containers 0.6.5.1 → 0.8
raw patch · 41 files changed
Files
- changelog.md +336/−7
- containers.cabal +21/−17
- include/containers.h +9/−20
- mkappend.hs +96/−0
- src/Data/Graph.hs +256/−164
- src/Data/IntMap.hs +66/−65
- src/Data/IntMap/Internal.hs +3883/−3577
- src/Data/IntMap/Internal/DeprecatedDebug.hs +0/−17
- src/Data/IntMap/Lazy.hs +57/−32
- src/Data/IntMap/Merge/Lazy.hs +1/−14
- src/Data/IntMap/Merge/Strict.hs +1/−16
- src/Data/IntMap/Strict.hs +54/−27
- src/Data/IntMap/Strict/Internal.hs +248/−228
- src/Data/IntSet.hs +60/−39
- src/Data/IntSet/Internal.hs +1998/−1648
- src/Data/IntSet/Internal/IntTreeCommons.hs +182/−0
- src/Data/Map.hs +62/−72
- src/Data/Map/Internal.hs +4546/−4355
- src/Data/Map/Internal/Debug.hs +4/−4
- src/Data/Map/Internal/DeprecatedShowTree.hs +0/−29
- src/Data/Map/Lazy.hs +35/−20
- src/Data/Map/Merge/Lazy.hs +1/−14
- src/Data/Map/Merge/Strict.hs +1/−14
- src/Data/Map/Strict.hs +34/−20
- src/Data/Map/Strict/Internal.hs +265/−297
- src/Data/Sequence.hs +4/−5
- src/Data/Sequence/Internal.hs +245/−187
- src/Data/Sequence/Internal/Sorting.hs +8/−7
- src/Data/Set.hs +36/−26
- src/Data/Set/Internal.hs +543/−292
- src/Data/Tree.hs +501/−49
- src/Utils/Containers/Internal/BitQueue.hs +1/−14
- src/Utils/Containers/Internal/BitUtil.hs +17/−64
- src/Utils/Containers/Internal/Coercions.hs +0/−44
- src/Utils/Containers/Internal/EqOrdUtil.hs +38/−0
- src/Utils/Containers/Internal/Prelude.hs +24/−0
- src/Utils/Containers/Internal/PtrEquality.hs +2/−24
- src/Utils/Containers/Internal/State.hs +7/−10
- src/Utils/Containers/Internal/StrictMaybe.hs +2/−4
- src/Utils/Containers/Internal/StrictPair.hs +1/−1
- src/Utils/Containers/Internal/TypeError.hs +0/−52
changelog.md view
@@ -1,5 +1,334 @@ # Changelog for [`containers` package](http://github.com/haskell/containers) +## 0.8 *March 2025*++### Breaking changes++* `Data.IntMap.Lazy.split`, `Data.IntMap.Strict.split`,+ `Data.IntMap.Lazy.splitLookup`, `Data.IntMap.Strict.splitLookup` and+ `Data.IntSet.splitMember` are now strict in the key. Previously, the key was+ ignored for an empty map or set. (Soumik Sarkar)+ ([#982](https://github.com/haskell/containers/pull/982),+ [#983](https://github.com/haskell/containers/pull/983))++* These functions have been updated to match the strictness of their+ `fromList` counterparts:++ * `Data.Map.Strict`: `fromAscList`, `fromAscListWith`, `fromAscListWithKey`+ `fromDescList`, `fromDescListWith`, `fromDescListWithKey`+ * `Data.IntMap.Strict`: `fromAscList`, `fromAscListWith`, `fromAscListWithKey`++ Previously they were lazier and did not force the first value in runs of at+ least 2 entries with equal keys. (Soumik Sarkar)+ ([#1023](https://github.com/haskell/containers/pull/1023))++* `Data.Set.fold` and `Data.IntSet.fold` are deprecated. One should instead use+ `Data.Set.foldr` and `Data.IntSet.foldr`. (Soumik Sarkar)+ ([#1049](https://github.com/haskell/containers/pull/1049))++* For `Data.IntMap.{Lazy,Strict}`, `updateMin`, `updateMax`, `updateMinWithKey`,+ `updateMaxWithKey` now return an empty map for an input empty map instead of+ calling `error`. This matches the behavior of `Data.Map`. (Kushagra Gupta)+ ([#1065](https://github.com/haskell/containers/pull/1065))++* `foldl'` and `foldr'` for `Seq` are now strict in the initial value. This+ matches the behavior of the default implementations and of other structures in+ the library. (Soumik Sarkar)+ ([#1077](https://github.com/haskell/containers/pull/1077))++* Some long deprecated functions, whose definitions currently cause type errors,+ have been removed. (Soumik Sarkar)+ ([#1046](https://github.com/haskell/containers/pull/1046))++### Bug fixes++* Make the package compile with [MicroHs](https://github.com/augustss/MicroHs).+ (Lennart Augustsson)+ ([#1043](https://github.com/haskell/containers/pull/1043),+ [#1081](https://github.com/haskell/containers/pull/1081))++* Fix a strictness bug in `Data.Map.Strict.fromDistinctAscList` and+ `Data.Map.Strict.fromDistinctDescList` where all values were not forced to+ WHNF. This bug affects versions 0.6.8 and 0.7. (Neil Mayhew)+ ([#996](https://github.com/haskell/containers/pull/996))++* Fix a bug in `Data.IntMap`'s `isProperSubmapOfBy` where it could incorrectly+ return `False`. (Soumik Sarkar)+ ([#1008](https://github.com/haskell/containers/pull/1008))++* Make `Data.Map.Merge.{Lazy,Strict}.filterAMissing` sequence effects in the+ correct order. (j6carey)+ ([#1005](https://github.com/haskell/containers/pull/1005))++* `Data.Map.Strict.mergeWithKey` now forces the result of the combining function+ to WHNF. (Soumik Sarkar)+ ([#1024](https://github.com/haskell/containers/pull/1024))++* Fix an issue where `Data.Map.mergeWithKey`, `Data.Map.Strict.mergeWithKey`,+ `Data.IntMap.mergeWithKey`, `Data.IntMap.Strict.mergeWithKey` could call the+ provided `only2` function with empty maps, contrary to documentation.+ (Soumik Sarkar) ([#1025](https://github.com/haskell/containers/pull/1025))++### Additions++* Add `Data.Graph.flattenSCC1`. (Andreas Abel)+ ([#987](https://github.com/haskell/containers/pull/987))++* Add `symmetricDifference` for `Set`, `Map`, `IntSet`, `IntMap`.+ (Soumik Sarkar) ([#1009](https://github.com/haskell/containers/pull/1009))++* Add `lookupMin` and `lookupMax` for `Data.IntSet`. (Soumik Sarkar)+ ([#976](https://github.com/haskell/containers/pull/976))++* Add `Intersection` and `intersections` for `Data.Set` and `Data.IntSet`.+ (Reed Mullanix, Soumik Sarkar)+ ([#756](https://github.com/haskell/containers/pull/756),+ [#1040](https://github.com/haskell/containers/pull/1040),+ [#1052](https://github.com/haskell/containers/pull/1052),+ [#1080](https://github.com/haskell/containers/pull/1080))++* Add `foldMap` for `Data.IntSet`. (Soumik Sarkar)+ ([#1048](https://github.com/haskell/containers/pull/1048))++* Add `filterKeys` for `Data.Map` and `Data.IntMap`. (flip111)+ ([#972](https://github.com/haskell/containers/pull/972))++* `NFData1`, `NFData2` instances for `SCC`, `IntMap`, `Map`, `Sequence`, `Set`,+ `Tree` and relevant internal dependencies (David Beacham)+ ([#992](https://github.com/haskell/containers/pull/992))++* Add `leaves`, `edges`, `pathsToRoot`, `pathsFromRoot`, `PostOrder` to+ `Data.Tree`. (Soumik Sarkar)+ ([#1109](https://github.com/haskell/containers/pull/1109))++### Performance improvements++* The internal representations of `IntMap` and `IntSet` have been changed+ to be a little more memory efficient. Consequently, many functions on+ `IntMap`s and `IntSet`s are a little faster now. (Soumik Sarkar)+ ([#995](https://github.com/haskell/containers/pull/995),+ [#998](https://github.com/haskell/containers/pull/998))++* Improved performance for `Data.Map`'s `minView`, `maxView`, `difference`.+ (Soumik Sarkar) ([#1001](https://github.com/haskell/containers/pull/1001))++* For `Data.Graph.SCC`, `Foldable.toList` and `Foldable1.toNonEmpty` now+ do not perform an unnecessary copy. (Soumik Sarkar)+ ([#1057](https://github.com/haskell/containers/pull/1057))++* Improved performance for `Data.Intset`'s `foldr`, `foldl'`, `foldl`, `foldr'`.+ (Soumik Sarkar) ([#1079](https://github.com/haskell/containers/pull/1079))++* Improved performance for `Data.Set` and `Data.Map`'s `fromAscList*` and+ `fromDescList*` functions. (Soumik Sarkar)+ ([#1083](https://github.com/haskell/containers/pull/1083))++* Improved performance for `Data.Set`'s `fromList`, `map` and `Data.Map`'s+ `fromList`, `fromListWith`, `fromListWithKey`, `mapKeys`, `mapKeysWith`.+ (Soumik Sarkar) ([#1042](https://github.com/haskell/containers/pull/1042))++* Improved performance for many `Set` and `Map` modification operations,+ including `insert` and `delete`, by inlining part of the balancing+ routine. (Soumik Sarkar)+ ([#1056](https://github.com/haskell/containers/pull/1056))++* Improved performance for `Eq` and `Ord` instances of `Set`, `Map`, `IntSet`,+ `IntMap`, `Seq`. (Soumik Sarkar)+ ([#1028](https://github.com/haskell/containers/pull/1028),+ [#1017](https://github.com/haskell/containers/pull/1017),+ [#1035](https://github.com/haskell/containers/pull/1035),+ [#1086](https://github.com/haskell/containers/pull/1086),+ [#1112](https://github.com/haskell/containers/pull/1112))++### Documentation++* Add and improve documentation (Bodigrim, konsumlamm, Toni Dietze, alexfmpe,+ Soumik Sarkar, Jonathan Knowles, Xavier Góngora, Xia Li-yao, eyelash)+ ([#957](https://github.com/haskell/containers/pull/957),+ [#1006](https://github.com/haskell/containers/pull/1006),+ [#877](https://github.com/haskell/containers/pull/877),+ [#960](https://github.com/haskell/containers/pull/960),+ [#1033](https://github.com/haskell/containers/pull/1033),+ [#1041](https://github.com/haskell/containers/pull/1041),+ [#1039](https://github.com/haskell/containers/pull/1039),+ [#1050](https://github.com/haskell/containers/pull/1050),+ [#1088](https://github.com/haskell/containers/pull/1088),+ [#1087](https://github.com/haskell/containers/pull/1087),+ [#1098](https://github.com/haskell/containers/pull/1098),+ [#1106](https://github.com/haskell/containers/pull/1106),+ [#1104](https://github.com/haskell/containers/pull/1104),+ [#1105](https://github.com/haskell/containers/pull/1105),+ [#1111](https://github.com/haskell/containers/pull/1111),+ [#1110](https://github.com/haskell/containers/pull/1110),+ [#1114](https://github.com/haskell/containers/pull/1114),+ [#1115](https://github.com/haskell/containers/pull/1115))++### Miscellaneous/internal++* Internal modules `Utils.Containers.Internal.BitUtil`,+ `Utils.Containers.Internal.BitQueue`, `Utils.Containers.Internal.StrictPair`+ are no longer exposed. (Soumik Sarkar)+ ([#1101](https://github.com/haskell/containers/pull/1101))++* Test and CI maintenance. (Andreas Abel, Soumik Sarkar)+ ([#986](https://github.com/haskell/containers/pull/986),+ [#1015](https://github.com/haskell/containers/pull/1015),+ [#1030](https://github.com/haskell/containers/pull/1030),+ [#1055](https://github.com/haskell/containers/pull/1055),+ [#1067](https://github.com/haskell/containers/pull/1067))++* Internal cleanups and improvements. (Soumik Sarkar, alexfmpe)+ ([#1000](https://github.com/haskell/containers/pull/1000),+ [#959](https://github.com/haskell/containers/pull/959),+ [#1020](https://github.com/haskell/containers/pull/1020),+ [#1029](https://github.com/haskell/containers/pull/1029),+ [#1031](https://github.com/haskell/containers/pull/1031),+ [#1037](https://github.com/haskell/containers/pull/1037),+ [#1058](https://github.com/haskell/containers/pull/1058),+ [#1076](https://github.com/haskell/containers/pull/1076),+ [#1084](https://github.com/haskell/containers/pull/1084),+ [#1085](https://github.com/haskell/containers/pull/1085),+ [#1093](https://github.com/haskell/containers/pull/1093),+ [#1094](https://github.com/haskell/containers/pull/1094),+ [#1095](https://github.com/haskell/containers/pull/1095),+ [#1097](https://github.com/haskell/containers/pull/1097),+ [#1103](https://github.com/haskell/containers/pull/1103),+ [#1117](https://github.com/haskell/containers/pull/1117))++* Add new tests and benchmarks (Soumik Sarkar)+ ([#962](https://github.com/haskell/containers/pull/962),+ [#1021](https://github.com/haskell/containers/pull/1021),+ [#1063](https://github.com/haskell/containers/pull/1063),+ [#1068](https://github.com/haskell/containers/pull/1068),+ [#1071](https://github.com/haskell/containers/pull/1071),+ [#1075](https://github.com/haskell/containers/pull/1075),+ [#1082](https://github.com/haskell/containers/pull/1082))++* Fix the Read the Docs tutorial (Soumik Sarkar)+ ([#1091](https://github.com/haskell/containers/pull/1091),+ [#1099](https://github.com/haskell/containers/pull/1099))++## 0.7++### Breaking changes++* Breaking changes to `Data.Graph.SCC v` (bodʲɪˈɡrʲim):+ * `CyclicSCC [v]` is now not a constructor,+ but a bundled pattern synonym for backward compatibility.+ * `NECyclicSCC (NonEmpty v)` is a new constructor, maintaining an invariant+ that a set of mutually reachable vertices is non-empty.++## 0.6.8++### Additions++* Add `Data.IntSet.fromRange`. (Soumik Sarkar)++### Improvements++* Speed up conversion from monotonic lists to `Set`s and+ `Map`s. (Soumik Sarkar)++### Documentation and other++* Add, improve, and correct documentation. (Niklas Hambüchen, Soumik Sarkar,+ tomjaguarpaw, Alice Rixte, Tom Smeding)++### Other/internal++* Remove the `stack.yaml` file. It was extremely stale, and its utility was a+ bit dubious in a GHC boot package. Closes #938.++* Add a bunch of new tests and benchmarks. (Soumik Sarkar)++* Future-proof test suite against export of `foldl'` from `Prelude`.+ (Teo Camarasu)++## 0.6.7++### Additions++* Add `takeWhileAntitone`, `dropWhileAntitone`, and `spanAntitone` for `IntMap`+ and `IntSet`. (Soumik Sarkar)++* Add a `Foldable1` instance for `Data.Tree`.++### Improvements++* Speed up splitting functions for `IntSet` and `IntMap`. (Soumik Sarkar)++* Speed up `Foldable` methods for `Data.Tree`. (Soumik Sarkar)++* Speed up `Data.Graph.dfs` (Soumik Sarkar)++* Inline a few functions in `Data.Graph` to enable list fusion. This+ immediately improves the performance of the `transposeG` and `scc` functions.+ Mark several others `INLINABLE` to allow specialization. (Soumik Sarkar)++* Optimize `Data.Graph.bcc`, most notably replacing lists by difference lists+ to avoid quadratic complexity. (Soumik Sarkar)++### Documentation++* Improve various documentation and documentation formatting (Joseph C. Sible,+ konsumlamm, Soumik Sarkar, Alberto Fanton)++* Add and correct time complexity documentation. (Soumik Sarkar)++* Update `CONTRIBUTING.md` instructions for building with `stack` and `cabal`,+ and add a note about how to avoid unnecessary recompilations. (Melanie+ Phoenix)++### Miscellaneous/internal++* Remove now-redundant CPP. (Alexandre Esteves)+* Avoid `head` and `tail`. (Bodigrim)+* Fix build paths in `gitignore`. (Alexandre Esteves)+* Add extra implicit dependencies for `DeriveLift`. (Matthew Pickering)+* Work around `Prelude` changes for `liftA2`. (David Feuer)+* Add several property tests and too many benchmarks to count. (Soumik Sarkar)+* Add benchmarks for `Data.Set.powerSet`. (jwaldmann)+* Improve `Data.Set.powerSet` property test. (David Feuer)+* Fix test name. (Marcin Szamotulski)+* Fix error messages in internal `Data.Set` functions. (Erik de Castro Lopo)++## 0.6.6++### Additions++* Add `Lift` instances for use with Template Haskell. Specifically:+ `Seq`, `ViewL`, and `ViewR` (in `Data.Sequence`), `Map`, `Set`,+ `IntMap`, `IntSet`, `Tree`, and `SCC` (in `Data.Graph`). (David Feuer)++* Add `argSet` and `fromArgSet` for `Data.Map`. (Joseph C. Sible)++### Performance improvements++* Remove short-circuiting from certain `IntMap` functions to improve+ performance for successful lookups. (Callan McGill)++### Other changes++* Drop support for GHC versions before 8.0.2. (David Feuer)++* Various documentation improvements. (Will Hawkins, Eric Lindblad, konsumlamm,+ Joseph C. Sible)++### Miscellaneous/internal++* Bump Cabal version for tests, and use `common` clauses to reduce+ duplication. (David Feuer)++* Migrate from test-framework to tasty. (Bodigrim)++* Migrate from gauge to tasty-bench. (Bodigrim)++* Enable `TypeOperators` to address a future GHC requirement.+ (Vladislav Zavialov)++* Work around an issue with unboxed arrays on big-endian systems.+ (Peter Trommler)+ ## 0.6.5.1 ### Bug fixes@@ -8,7 +337,7 @@ should be, and we have detailed tests to make sure they stay that way. (Thanks, coot.) -* The `Ord IntSet` instance, which was broken in the last version, has been+* The `Ord IntSet` instance, which was broken in 0.6.3.1, has been repaired. ### New instance@@ -223,13 +552,13 @@ * Rewrite the `IsString` instance head for sequences, improving compatibility with the list instance and also improving type inference. We used to have- + ```haskell instance IsString (Seq Char) ```- + Now we commit more eagerly with- + ```haskell instance a ~ Char => IsString (Seq a) ```@@ -303,7 +632,7 @@ * Fix completely incorrect implementations of `Data.IntMap.restrictKeys` and `Data.IntMap.withoutKeys`. Make the tests for these actually run. (Thanks to Tom Smalley for reporting this.)- + * Fix a minor bug in the `Show1` instance of `Data.Tree`. This produced valid output, but with fewer parentheses than `Show`. (Thanks, Ryan Scott.) @@ -358,7 +687,7 @@ before 7.0. * Integrate benchmarks with Cabal. (Thanks, Gabriel Gonzalez!)- + * Make Cabal report required extensions properly, and stop using default extensions. Note that we do *not* report extensions conditionally enabled based on GHC version, as doing so would lead to a maintenance nightmare@@ -408,7 +737,7 @@ it returned a lazy pair. * Fix completely erroneous definition of `length` for `Data.Sequence.ViewR`.- + * Make `Data.Map.Strict.traverseWithKey` force result values before installing them in the new map.
containers.cabal view
@@ -1,8 +1,10 @@+cabal-version: 2.2 name: containers-version: 0.6.5.1-license: BSD3+version: 0.8+license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org+homepage: https://github.com/haskell/containers bug-reports: https://github.com/haskell/containers/issues synopsis: Assorted concrete container types category: Data Structures@@ -20,22 +22,27 @@ remains valid even if structures are shared. build-type: Simple-cabal-version: >=1.10+extra-doc-files:+ changelog.md extra-source-files: include/containers.h- changelog.md+ mkappend.hs -tested-with: GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3+tested-with:+ GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 ||+ ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 source-repository head type: git- location: http://github.com/haskell/containers.git+ location: https://github.com/haskell/containers Library default-language: Haskell2010- build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5+ build-depends: base >= 4.10 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.6+ if impl(ghc)+ build-depends: template-haskell hs-source-dirs: src- ghc-options: -O2 -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+ ghc-options: -O2 -Wall other-extensions: CPP, BangPatterns @@ -50,6 +57,7 @@ Data.IntMap.Merge.Lazy Data.IntMap.Merge.Strict Data.IntSet.Internal+ Data.IntSet.Internal.IntTreeCommons Data.IntSet Data.Map Data.Map.Lazy@@ -66,19 +74,15 @@ Data.Sequence.Internal Data.Sequence.Internal.Sorting Data.Tree- Utils.Containers.Internal.BitUtil- Utils.Containers.Internal.BitQueue- Utils.Containers.Internal.StrictPair other-modules:+ Utils.Containers.Internal.Prelude Utils.Containers.Internal.State Utils.Containers.Internal.StrictMaybe Utils.Containers.Internal.PtrEquality- Utils.Containers.Internal.Coercions- if impl(ghc)- other-modules:- Utils.Containers.Internal.TypeError- Data.Map.Internal.DeprecatedShowTree- Data.IntMap.Internal.DeprecatedDebug+ Utils.Containers.Internal.EqOrdUtil+ Utils.Containers.Internal.BitUtil+ Utils.Containers.Internal.BitQueue+ Utils.Containers.Internal.StrictPair include-dirs: include
include/containers.h view
@@ -6,36 +6,25 @@ #define HASKELL_CONTAINERS_H /*- * On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.+ * On GHC and MicroHs, include MachDeps.h to get WORD_SIZE_IN_BITS macro. */-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) #include "MachDeps.h" #endif -/*- * Define INSTANCE_TYPEABLE[0-2]- */-#if __GLASGOW_HASKELL__ >= 707-#define INSTANCE_TYPEABLE0(tycon) deriving instance Typeable tycon-#define INSTANCE_TYPEABLE1(tycon) deriving instance Typeable tycon-#define INSTANCE_TYPEABLE2(tycon) deriving instance Typeable tycon-#elif defined(__GLASGOW_HASKELL__)-#define INSTANCE_TYPEABLE0(tycon) deriving instance Typeable tycon-#define INSTANCE_TYPEABLE1(tycon) deriving instance Typeable1 tycon-#define INSTANCE_TYPEABLE2(tycon) deriving instance Typeable2 tycon-#else-#define INSTANCE_TYPEABLE0(tycon)-#define INSTANCE_TYPEABLE1(tycon)-#define INSTANCE_TYPEABLE2(tycon)-#endif--#if __GLASGOW_HASKELL__ >= 800+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) #define DEFINE_PATTERN_SYNONYMS 1 #endif #ifdef __GLASGOW_HASKELL__ # define USE_ST_MONAD 1+#ifndef WORDS_BIGENDIAN+/*+ * Unboxed arrays are broken on big-endian architectures.+ * See https://gitlab.haskell.org/ghc/ghc/-/issues/16998+ */ # define USE_UNBOXED_ARRAYS 1+#endif #endif #endif
+ mkappend.hs view
@@ -0,0 +1,96 @@+-- Generate appendTree<0..4> and addDigits<1..4> for Data.Sequence+module Main where++main :: IO ()+main = putStr (compose [showAppend n | n <- [0..4]] "")++showAppend :: Int -> ShowS+showAppend n =+ showChar '\n' .+ showString "appendTree" . shows n . showString " :: " .+ showFunType+ ([fingertree] ++ replicate n tyarg ++ [fingertree]) fingertree .+ showString "\n" .+ appendTreeClause "EmptyT" "xs" (showCons (args n) (showString "xs")) .+ appendTreeClause "xs" "EmptyT" (showSnoc (showString "xs") (args n)) .+ appendTreeClause "(Single x)" "xs"+ (showCons ('x':args n) (showString "xs")) .+ appendTreeClause "xs" "(Single x)"+ (showSnoc (showString "xs") (args n++"x")) .+ appendTreeClause "(Deep s1 pr1 m1 sf1)" "(Deep s2 pr2 m2 sf2)"+ (showString "Deep (s1" .+ compose [showString " + size " . showChar v | v <- args n] .+ showString " + s2) pr1 (addDigits" . shows n .+ showString " m1 sf1" . showArgList (args n) .+ showString " pr2 m2) sf2") .+ showChar '\n' .+ showString "addDigits" . shows n . showString " :: " .+ showFunType+ ([fingertree_node, digit] ++ replicate n tyarg ++ [digit, fingertree_node])+ fingertree_node .+ showString "\n" .+ compose [addDigitsClause n1 n2 | n1 <- [1..4], n2 <- [1..4]]+ where+ fingertree = tyapp "FingerTree" tyarg+ digit = tyapp "Digit" tyarg+ fingertree_node = tyapp "FingerTree" (tyapp "Node" tyarg)+ showFunType ts tr =+ compose [showString t . showString " -> " | t <- ts] . showString tr+ tyapp tc t = tc ++ " (" ++ t ++ ")"+ tyarg+ | n == 0 = "Elem a"+ | otherwise = "Node a"+ appendTreeClause t1 t2 rhs =+ showString "appendTree" . shows n .+ showChar ' ' . showString t1 . showArgList (args n) .+ showChar ' ' . showString t2 .+ showString " =\n " . rhs . showChar '\n'+ addDigitsClause n1 n2 =+ showString "addDigits" . shows n .+ showString " m1 (" . showDigit vs1 . showChar ')' .+ showArgList vsm .+ showString " (" . showDigit vs2 . showString ") m2" .+ showString " =\n " .+ showString "appendTree" . shows (length ns) .+ showString " m1" .+ compose [showString " (" . showNode node . showChar ')' |+ node <- ns] .+ showString " m2" . showChar '\n'+ where+ vs = args (n1+n+n2)+ vs1 = take n1 vs+ vsm = take n (drop n1 vs)+ vs2 = drop (n1+n) vs+ ns = nodes vs++data Node a = Node2 a a | Node3 a a a++nodes :: [a] -> [Node a]+nodes [a, b] = [Node2 a b]+nodes [a, b, c] = [Node3 a b c]+nodes [a, b, c, d] = [Node2 a b, Node2 c d]+nodes (a:b:c:xs) = Node3 a b c : nodes xs++showNode (Node2 a b) =+ showString "node2 " . showChar a . showChar ' ' . showChar b+showNode (Node3 a b c) =+ showString "node3 " . showChar a . showChar ' ' . showChar b .+ showChar ' ' . showChar c++showDigit vs =+ showString (["One", "Two", "Three", "Four"]!!(length vs-1)) .+ showArgList vs++showArgList :: [Char] -> ShowS+showArgList vs = compose [showChar ' ' . showChar c | c <- vs]++args :: Int -> [Char]+args n = take n ['a'..]++showCons xs sf =+ compose [showChar x . showString " `consTree` " | x <- xs] . sf+showSnoc sf xs =+ sf . compose [showString " `snocTree` " . showChar x | x <- xs]++compose :: [a -> a] -> a -> a+compose = flip (foldr id)
src/Data/Graph.hs view
@@ -1,17 +1,21 @@ {-# LANGUAGE CPP #-}+#include "containers.h"+{-# LANGUAGE BangPatterns #-} #if __GLASGOW_HASKELL__-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-}-# if __GLASGOW_HASKELL__ >= 710 {-# LANGUAGE Safe #-}-# else-{-# LANGUAGE Trustworthy #-}-# endif+{-# LANGUAGE TemplateHaskellQuotes #-} #endif--#include "containers.h"+#ifdef DEFINE_PATTERN_SYNONYMS+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+#endif+#ifdef USE_ST_MONAD+{-# LANGUAGE RankNTypes #-}+#endif ----------------------------------------------------------------------------- -- |@@ -35,8 +39,11 @@ -- -- The implementation is based on ----- * /Structuring Depth-First Search Algorithms in Haskell/,--- by David King and John Launchbury, <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.52.6526>+-- * David King and John Launchbury,+-- \"/Structuring Depth-First Search Algorithms in Haskell/\",+-- Proceedings of the 22nd ACM SIGPLAN-SIGACT Symposium on Principles of+-- Programming Languages, 344-354, 1995,+-- <https://doi.org/10.1145/199448.199530>. -- ----------------------------------------------------------------------------- @@ -76,7 +83,11 @@ -- * Strongly Connected Components- , SCC(..)+ , SCC(..+#ifdef DEFINE_PATTERN_SYNONYMS+ , CyclicSCC+#endif+ ) -- ** Construction , stronglyConnComp@@ -84,6 +95,7 @@ -- ** Conversion , flattenSCC+ , flattenSCC1 , flattenSCCs -- * Trees@@ -91,6 +103,8 @@ ) where +import Utils.Containers.Internal.Prelude+import Prelude () #if USE_ST_MONAD import Control.Monad.ST import Data.Array.ST.Safe (newArray, readArray, writeArray)@@ -106,14 +120,11 @@ import Data.Tree (Tree(Node), Forest) -- std interfaces-import Control.Applicative-#if !MIN_VERSION_base(4,8,0)-import qualified Data.Foldable as F-import Data.Traversable-#else import Data.Foldable as F+#if MIN_VERSION_base(4,18,0)+import qualified Data.Foldable1 as F1 #endif-import Control.DeepSeq (NFData(rnf))+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf)) import Data.Maybe import Data.Array #if USE_UNBOXED_ARRAYS@@ -123,16 +134,18 @@ import qualified Data.Array as UA #endif import qualified Data.List as L-#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE import Data.Functor.Classes-#endif-#if (!MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup (..)) #endif #ifdef __GLASGOW_HASKELL__ import GHC.Generics (Generic, Generic1) import Data.Data (Data)-import Data.Typeable+import Language.Haskell.TH.Syntax (Lift(..))+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH () #endif -- Make sure we don't use Integer by mistake.@@ -145,21 +158,28 @@ ------------------------------------------------------------------------- -- | Strongly connected component.-data SCC vertex = AcyclicSCC vertex -- ^ A single vertex that is not- -- in any cycle.- | CyclicSCC [vertex] -- ^ A maximal set of mutually- -- reachable vertices.-#if __GLASGOW_HASKELL__ >= 802+data SCC vertex+ = AcyclicSCC vertex+ -- ^ A single vertex that is not in any cycle.+ | NECyclicSCC {-# UNPACK #-} !(NonEmpty vertex)+ -- ^ A maximal set of mutually reachable vertices.+ --+ -- @since 0.7 deriving ( Eq -- ^ @since 0.5.9 , Show -- ^ @since 0.5.9 , Read -- ^ @since 0.5.9 )-#else- deriving (Eq, Show, Read)-#endif -INSTANCE_TYPEABLE1(SCC)+#ifdef DEFINE_PATTERN_SYNONYMS+-- | Partial pattern synonym for backward compatibility with @containers < 0.7@.+pattern CyclicSCC :: [vertex] -> SCC vertex+pattern CyclicSCC xs <- NECyclicSCC (NE.toList -> xs) where+ CyclicSCC [] = error "CyclicSCC: an argument cannot be an empty list"+ CyclicSCC (x : xs) = NECyclicSCC (x :| xs) +{-# COMPLETE AcyclicSCC, CyclicSCC #-}+#endif+ #ifdef __GLASGOW_HASKELL__ -- | @since 0.5.9 deriving instance Data vertex => Data (SCC vertex)@@ -169,60 +189,104 @@ -- | @since 0.5.9 deriving instance Generic (SCC vertex)++-- There is no instance Lift (NonEmpty v) before template-haskell-2.15.+#if MIN_VERSION_template_haskell(2,15,0)+-- | @since 0.6.6+deriving instance Lift vertex => Lift (SCC vertex)+#else+instance Lift vertex => Lift (SCC vertex) where+ lift (AcyclicSCC v) = [| AcyclicSCC v |]+ lift (NECyclicSCC (v :| vs)) = [| NECyclicSCC (v :| vs) |] #endif -#if MIN_VERSION_base(4,9,0)+#endif+ -- | @since 0.5.9 instance Eq1 SCC where liftEq eq (AcyclicSCC v1) (AcyclicSCC v2) = eq v1 v2- liftEq eq (CyclicSCC vs1) (CyclicSCC vs2) = liftEq eq vs1 vs2+ liftEq eq (NECyclicSCC vs1) (NECyclicSCC vs2) = liftEq eq vs1 vs2 liftEq _ _ _ = False -- | @since 0.5.9 instance Show1 SCC where liftShowsPrec sp _sl d (AcyclicSCC v) = showsUnaryWith sp "AcyclicSCC" d v- liftShowsPrec _sp sl d (CyclicSCC vs) = showsUnaryWith (const sl) "CyclicSCC" d vs+ liftShowsPrec sp sl d (NECyclicSCC vs) = showsUnaryWith (liftShowsPrec sp sl) "NECyclicSCC" d vs -- | @since 0.5.9 instance Read1 SCC where liftReadsPrec rp rl = readsData $ readsUnaryWith rp "AcyclicSCC" AcyclicSCC <>- readsUnaryWith (const rl) "CyclicSCC" CyclicSCC+ readsUnaryWith (liftReadsPrec rp rl) "NECyclicSCC" NECyclicSCC+#ifdef __GLASGOW_HASKELL__+ <> readsUnaryWith (const rl) "CyclicSCC" CyclicSCC #endif -- | @since 0.5.9 instance F.Foldable SCC where foldr c n (AcyclicSCC v) = c v n- foldr c n (CyclicSCC vs) = foldr c n vs+ foldr c n (NECyclicSCC vs) = foldr c n vs + toList = flattenSCC++#if MIN_VERSION_base(4,18,0)+-- | @since 0.7+instance F1.Foldable1 SCC where+ foldMap1 f (AcyclicSCC v) = f v+ foldMap1 f (NECyclicSCC vs) = F1.foldMap1 f vs++ toNonEmpty = flattenSCC1++ -- TODO define more methods+#endif+ -- | @since 0.5.9 instance Traversable SCC where- -- We treat the non-empty cyclic case specially to cut one- -- fmap application. traverse f (AcyclicSCC vertex) = AcyclicSCC <$> f vertex- traverse _f (CyclicSCC []) = pure (CyclicSCC [])- traverse f (CyclicSCC (x : xs)) =- liftA2 (\x' xs' -> CyclicSCC (x' : xs')) (f x) (traverse f xs)+ -- Avoid traverse from instance Traversable NonEmpty,+ -- it is redundantly lazy.+ traverse f (NECyclicSCC (x :| xs)) =+ liftA2 (\x' xs' -> NECyclicSCC (x' :| xs')) (f x) (traverse f xs) instance NFData a => NFData (SCC a) where rnf (AcyclicSCC v) = rnf v- rnf (CyclicSCC vs) = rnf vs+ rnf (NECyclicSCC vs) = rnf vs +-- | @since 0.8+instance NFData1 SCC where+ liftRnf rnfx (AcyclicSCC v) = rnfx v+ liftRnf rnfx (NECyclicSCC vs) = liftRnf rnfx vs+ -- | @since 0.5.4 instance Functor SCC where fmap f (AcyclicSCC v) = AcyclicSCC (f v)- fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)+ -- Avoid fmap from instance Functor NonEmpty,+ -- it is redundantly lazy.+ fmap f (NECyclicSCC (x :| xs)) = NECyclicSCC (f x :| map f xs) -- | The vertices of a list of strongly connected components. flattenSCCs :: [SCC a] -> [a] flattenSCCs = concatMap flattenSCC -- | The vertices of a strongly connected component.+--+-- @flattenSCC = 'Data.List.NonEmpty.toList' . 'flattenSCC1'@.+--+-- This function is retained for backward compatibility,+-- 'flattenSCC1' has the more precise type. flattenSCC :: SCC vertex -> [vertex] flattenSCC (AcyclicSCC v) = [v]-flattenSCC (CyclicSCC vs) = vs+flattenSCC (NECyclicSCC (v :| vs)) = v : vs+-- Note: Best to avoid NE.toList, it is too lazy. --- | The strongly connected components of a directed graph, reverse topologically--- sorted.+-- | The vertices of a strongly connected component. --+-- @since 0.8+flattenSCC1 :: SCC vertex -> NonEmpty vertex+flattenSCC1 (AcyclicSCC v) = v :| []+flattenSCC1 (NECyclicSCC vs) = vs++-- | \(O((V+E) \log V)\). The strongly connected components of a directed graph,+-- reverse topologically sorted.+-- -- ==== __Examples__ -- -- > stronglyConnComp [("a",0,[1]),("b",1,[2,3]),("c",2,[1]),("d",3,[3])]@@ -240,11 +304,13 @@ = map get_node (stronglyConnCompR edges0) where get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n- get_node (CyclicSCC triples) = CyclicSCC [n | (n,_,_) <- triples]+ get_node (NECyclicSCC ((n0, _, _) :| triples)) =+ NECyclicSCC (n0 :| [n | (n, _, _) <- triples])+{-# INLINABLE stronglyConnComp #-} --- | The strongly connected components of a directed graph, reverse topologically--- sorted. The function is the same as 'stronglyConnComp', except that--- all the information about each node retained.+-- | \(O((V+E) \log V)\). The strongly connected components of a directed graph,+-- reverse topologically sorted. The function is the same as+-- 'stronglyConnComp', except that all the information about each node retained. -- This interface is used when you expect to apply 'SCC' to -- (some of) the result of 'SCC', so you don't want to lose the -- dependency information.@@ -268,12 +334,14 @@ where (graph, vertex_fn,_) = graphFromEdges edges0 forest = scc graph- decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]++ decode (Node v []) | mentions_itself v = NECyclicSCC (vertex_fn v :| []) | otherwise = AcyclicSCC (vertex_fn v)- decode other = CyclicSCC (dec other [])- where- dec (Node v ts) vs = vertex_fn v : foldr dec vs ts+ decode (Node v ts) = NECyclicSCC (vertex_fn v :| foldr dec [] ts)++ dec (Node v ts) vs = vertex_fn v : foldr dec vs ts mentions_itself v = v `elem` (graph ! v)+{-# INLINABLE stronglyConnCompR #-} ------------------------------------------------------------------------- -- -@@ -299,7 +367,7 @@ type UArray i a = Array i a #endif --- | Returns the list of vertices in the graph.+-- | \(O(V)\). Returns the list of vertices in the graph. -- -- ==== __Examples__ --@@ -308,8 +376,10 @@ -- > vertices (buildG (0,2) [(0,1),(1,2)]) == [0,1,2] vertices :: Graph -> [Vertex] vertices = indices+-- See Note [Inline for fusion]+{-# INLINE vertices #-} --- | Returns the list of edges in the graph.+-- | \(O(V+E)\). Returns the list of edges in the graph. -- -- ==== __Examples__ --@@ -318,8 +388,10 @@ -- > edges (buildG (0,2) [(0,1),(1,2)]) == [(0,1),(1,2)] edges :: Graph -> [Edge] edges g = [ (v, w) | v <- vertices g, w <- g!v ]+-- See Note [Inline for fusion]+{-# INLINE edges #-} --- | Build a graph from a list of edges.+-- | \(O(V+E)\). Build a graph from a list of edges. -- -- Warning: This function will cause a runtime exception if a vertex in the edge -- list is not within the given @Bounds@.@@ -330,9 +402,11 @@ -- > buildG (0,2) [(0,1), (1,2)] == array (0,1) [(0,[1]),(1,[2])] -- > buildG (0,2) [(0,1), (0,2), (1,2)] == array (0,2) [(0,[2,1]),(1,[2]),(2,[])] buildG :: Bounds -> [Edge] -> Graph-buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0+buildG = accumArray (flip (:)) []+-- See Note [Inline for fusion]+{-# INLINE buildG #-} --- | The graph obtained by reversing all edges.+-- | \(O(V+E)\). The graph obtained by reversing all edges. -- -- ==== __Examples__ --@@ -342,8 +416,10 @@ reverseE :: Graph -> [Edge] reverseE g = [ (w, v) | (v, w) <- edges g ]+-- See Note [Inline for fusion]+{-# INLINE reverseE #-} --- | A table of the count of edges from each node.+-- | \(O(V+E)\). A table of the count of edges from each node. -- -- ==== __Examples__ --@@ -357,7 +433,7 @@ -- out. Note that we *can't* be so lazy with indegree. outdegree = fmap length --- | A table of the count of edges into each node.+-- | \(O(V+E)\). A table of the count of edges into each node. -- -- ==== __Examples__ --@@ -367,8 +443,8 @@ indegree :: Graph -> Array Vertex Int indegree g = accumArray (+) 0 (bounds g) [(v, 1) | (_, outs) <- assocs g, v <- outs] --- | Identical to 'graphFromEdges', except that the return value--- does not include the function which maps keys to vertices. This+-- | \(O((V+E) \log V)\). Identical to 'graphFromEdges', except that the return+-- value does not include the function which maps keys to vertices. This -- version of 'graphFromEdges' is for backwards compatibility. graphFromEdges' :: Ord key@@ -376,9 +452,10 @@ -> (Graph, Vertex -> (node, key, [key])) graphFromEdges' x = (a,b) where (a,b,_) = graphFromEdges x+{-# INLINABLE graphFromEdges' #-} --- | Build a graph from a list of nodes uniquely identified by keys,--- with a list of keys of nodes this node should have edges to.+-- | \(O((V+E) \log V)\). Build a graph from a list of nodes uniquely identified+-- by keys, with a list of keys of nodes this node should have edges to. -- -- This function takes an adjacency list representing a graph with vertices of -- type @key@ labeled by values of type @node@ and produces a @Graph@-based@@ -390,9 +467,11 @@ -- -- * @graph :: Graph@ is the raw, array based adjacency list for the graph. -- * @nodeFromVertex :: Vertex -> (node, key, [key])@ returns the node--- associated with the given 0-based @Int@ vertex; see /warning/ below.+-- associated with the given 0-based @Int@ vertex; see /warning/ below. This+-- runs in \(O(1)\) time. -- * @vertexFromKey :: key -> Maybe Vertex@ returns the @Int@ vertex for the--- key if it exists in the graph, @Nothing@ otherwise.+-- key if it exists in the graph, @Nothing@ otherwise. This runs in+-- \(O(\log V)\) time. -- -- To safely use this API you must either extract the list of vertices directly -- from the graph or first call @vertexFromKey k@ to check if a vertex@@ -463,6 +542,7 @@ GT -> findVertex (mid+1) b where mid = a + (b - a) `div` 2+{-# INLINABLE graphFromEdges #-} ------------------------------------------------------------------------- -- -@@ -470,103 +550,79 @@ -- - ------------------------------------------------------------------------- --- | A spanning forest of the graph, obtained from a depth-first search of--- the graph starting from each vertex in an unspecified order.-dff :: Graph -> Forest Vertex+-- | \(O(V+E)\). A spanning forest of the graph, obtained from a depth-first+-- search of the graph starting from each vertex in an unspecified order.+dff :: Graph -> [Tree Vertex] dff g = dfs g (vertices g) --- | A spanning forest of the part of the graph reachable from the listed--- vertices, obtained from a depth-first search of the graph starting at+-- | \(O(V+E)\). A spanning forest of the part of the graph reachable from the+-- listed vertices, obtained from a depth-first search of the graph starting at -- each of the listed vertices in order.-dfs :: Graph -> [Vertex] -> Forest Vertex-dfs g vs = prune (bounds g) (map (generate g) vs) -generate :: Graph -> Vertex -> Tree Vertex-generate g v = Node v (map (generate g) (g!v))--prune :: Bounds -> Forest Vertex -> Forest Vertex-prune bnds ts = run bnds (chop ts)--chop :: Forest Vertex -> SetM s (Forest Vertex)-chop [] = return []-chop (Node v ts : us)- = do- visited <- contains v- if visited then- chop us- else do- include v- as <- chop ts- bs <- chop us- return (Node v as : bs)+-- This function deviates from King and Launchbury's implementation by+-- bundling together the functions generate, prune, and chop for efficiency+-- reasons.+dfs :: Graph -> [Vertex] -> [Tree Vertex]+dfs !g vs0 = run (bounds g) $ \contains include ->+ let+ go [] = pure []+ go (v:vs) = do+ visited <- contains v+ if visited+ then go vs+ else do+ include v+ as <- go (g!v)+ bs <- go vs+ pure $ Node v as : bs+ in go vs0 --- A monad holding a set of vertices visited so far. #if USE_ST_MONAD -- Use the ST monad if available, for constant-time primitives. +newArrayBool+ :: Bounds #if USE_UNBOXED_ARRAYS-newtype SetM s a = SetM { runSetM :: STUArray s Vertex Bool -> ST s a }+ -> ST s (STUArray s Vertex Bool) #else-newtype SetM s a = SetM { runSetM :: STArray s Vertex Bool -> ST s a }+ -> ST s (STArray s Vertex Bool) #endif--instance Monad (SetM s) where- return = pure- {-# INLINE return #-}- SetM v >>= f = SetM $ \s -> do { x <- v s; runSetM (f x) s }- {-# INLINE (>>=) #-}--instance Functor (SetM s) where- f `fmap` SetM v = SetM $ \s -> f `fmap` v s- {-# INLINE fmap #-}--instance Applicative (SetM s) where- pure x = SetM $ const (return x)- {-# INLINE pure #-}- SetM f <*> SetM v = SetM $ \s -> f s >>= (`fmap` v s)- -- We could also use the following definition- -- SetM f <*> SetM v = SetM $ \s -> f s <*> v s- -- but Applicative (ST s) instance is present only in GHC 7.2+- {-# INLINE (<*>) #-}--run :: Bounds -> (forall s. SetM s a) -> a-run bnds act = runST (newArray bnds False >>= runSetM act)--contains :: Vertex -> SetM s Bool-contains v = SetM $ \ m -> readArray m v+newArrayBool bnds = newArray bnds False -include :: Vertex -> SetM s ()-include v = SetM $ \ m -> writeArray m v True+run+ :: Bounds+ -> (forall s. (Vertex -> ST s Bool) -> (Vertex -> ST s ()) -> ST s a)+ -> a+run bnds f = runST $ do+ m <- newArrayBool bnds+ f (readArray m) (\v -> writeArray m v True)+{-# INLINE run #-} #else /* !USE_ST_MONAD */ -- Portable implementation using IntSet. -newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }+newtype SetM a = SetM { runSetM :: IntSet -> (a, IntSet) } -instance Monad (SetM s) where- return x = SetM $ \s -> (x, s)+instance Monad SetM where SetM v >>= f = SetM $ \s -> case v s of (x, s') -> runSetM (f x) s' -instance Functor (SetM s) where+instance Functor SetM where f `fmap` SetM v = SetM $ \s -> case v s of (x, s') -> (f x, s') {-# INLINE fmap #-} -instance Applicative (SetM s) where+instance Applicative SetM where pure x = SetM $ \s -> (x, s) {-# INLINE pure #-} SetM f <*> SetM v = SetM $ \s -> case f s of (k, s') -> case v s' of (x, s'') -> (k x, s'') {-# INLINE (<*>) #-} -run :: Bounds -> SetM s a -> a-run _ act = fst (runSetM act Set.empty)--contains :: Vertex -> SetM s Bool-contains v = SetM $ \ m -> (Set.member v m, m)--include :: Vertex -> SetM s ()-include v = SetM $ \ m -> ((), Set.insert v m)+run :: Bounds -> ((Vertex -> SetM Bool) -> (Vertex -> SetM ()) -> SetM a) -> a+run _ f = fst (runSetM (f contains include) Set.empty)+ where+ contains v = SetM $ \m -> (Set.member v m, m)+ include v = SetM $ \m -> ((), Set.insert v m) #endif /* !USE_ST_MONAD */ @@ -583,10 +639,10 @@ preorder' :: Tree a -> [a] -> [a] preorder' (Node a ts) = (a :) . preorderF' ts -preorderF' :: Forest a -> [a] -> [a]+preorderF' :: [Tree a] -> [a] -> [a] preorderF' ts = foldr (.) id $ map preorder' ts -preorderF :: Forest a -> [a]+preorderF :: [Tree a] -> [a] preorderF ts = preorderF' ts [] tabulate :: Bounds -> [Vertex] -> UArray Vertex Int@@ -596,7 +652,7 @@ -- away, and these days that only happens when it's the first -- list argument. -preArr :: Bounds -> Forest Vertex -> UArray Vertex Int+preArr :: Bounds -> [Tree Vertex] -> UArray Vertex Int preArr bnds = tabulate bnds . preorderF ------------------------------------------------------------@@ -606,20 +662,26 @@ postorder :: Tree a -> [a] -> [a] postorder (Node a ts) = postorderF ts . (a :) -postorderF :: Forest a -> [a] -> [a]+postorderF :: [Tree a] -> [a] -> [a] postorderF ts = foldr (.) id $ map postorder ts postOrd :: Graph -> [Vertex] postOrd g = postorderF (dff g) [] --- | A topological sort of the graph.+-- | \(O(V+E)\). A topological sort of the graph. -- The order is partially specified by the condition that a vertex /i/ -- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.+--+-- Note: A topological sort exists only when there are no cycles in the graph.+-- If the graph has cycles, the output of this function will not be a+-- topological sort. In such a case consider using 'scc'. topSort :: Graph -> [Vertex] topSort = reverse . postOrd --- | Reverse ordering of `topSort`.+-- | \(O(V+E)\). Reverse ordering of `topSort`. --+-- See note in 'topSort'.+-- -- @since 0.6.4 reverseTopSort :: Graph -> [Vertex] reverseTopSort = postOrd@@ -628,10 +690,10 @@ -- Algorithm 3: connected components ------------------------------------------------------------ --- | The connected components of a graph.+-- | \(O(V+E)\). The connected components of a graph. -- Two vertices are connected if there is a path between them, traversing -- edges in either direction.-components :: Graph -> Forest Vertex+components :: Graph -> [Tree Vertex] components = dff . undirected undirected :: Graph -> Graph@@ -639,7 +701,8 @@ -- Algorithm 4: strongly connected components --- | The strongly connected components of a graph, in reverse topological order.+-- | \(O(V+E)\). The strongly connected components of a graph, in reverse+-- topological order. -- -- ==== __Examples__ --@@ -647,7 +710,7 @@ -- > == [Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []}]}]} -- > ,Node {rootLabel = 3, subForest = []}] -scc :: Graph -> Forest Vertex+scc :: Graph -> [Tree Vertex] scc g = dfs g (reverse (postOrd (transposeG g))) ------------------------------------------------------------@@ -682,7 +745,7 @@ -- Algorithm 6: Finding reachable vertices ------------------------------------------------------------ --- | Returns the list of vertices reachable from a given vertex.+-- | \(O(V+E)\). Returns the list of vertices reachable from a given vertex. -- -- ==== __Examples__ --@@ -692,7 +755,7 @@ reachable :: Graph -> Vertex -> [Vertex] reachable g v = preorderF (dfs g [v]) --- | Returns @True@ if the second vertex reachable from the first.+-- | \(O(V+E)\). Returns @True@ if the second vertex reachable from the first. -- -- ==== __Examples__ --@@ -708,27 +771,56 @@ -- Algorithm 7: Biconnected components ------------------------------------------------------------ --- | The biconnected components of a graph.+-- | \(O(V+E)\). The biconnected components of a graph. -- An undirected graph is biconnected if the deletion of any vertex -- leaves it connected.-bcc :: Graph -> Forest [Vertex]-bcc g = (concat . map bicomps . map (do_label g dnum)) forest- where forest = dff g- dnum = preArr (bounds g) forest+--+-- The input graph is expected to be undirected, i.e. for every edge in the+-- graph the reverse edge is also in the graph. If the graph is not undirected+-- the output is arbitrary.+bcc :: Graph -> [Tree [Vertex]]+bcc g = concatMap bicomps forest+ where+ -- The algorithm here is the same as given by King and Launchbury, which is+ -- an adaptation of Hopcroft and Tarjan's. The implementation, however, has+ -- been modified from King and Launchbury to make it efficient. -do_label :: Graph -> UArray Vertex Int -> Tree Vertex -> Tree (Vertex,Int,Int)-do_label g dnum (Node v ts) = Node (v, dnum UA.! v, lv) us- where us = map (do_label g dnum) ts- lv = minimum ([dnum UA.! v] ++ [dnum UA.! w | w <- g!v]- ++ [lu | Node (_,_,lu) _ <- us])+ forest = dff g -bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]-bicomps (Node (v,_,_) ts)- = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]+ -- dnum!v is the index of vertex v in the dfs preorder of vertices+ dnum = preArr (bounds g) forest -collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])-collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)- where collected = map collect ts- vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv]- cs = concat [ if lw<dv then us else [Node (v:ws) us]- | (lw, Node ws us) <- collected ]+ -- Wraps up the component of every child of the root+ bicomps :: Tree Vertex -> [Tree [Vertex]]+ bicomps (Node v tws) =+ [Node (v : curw []) (donew []) | (_, curw, donew) <- map collect tws]++ -- Returns a triple of+ -- * lowpoint of v+ -- * difference list of vertices in v's component+ -- * difference list of trees of components, whose root components are+ -- adjacent to v's component+ collect :: Tree Vertex+ -> (Int, [Vertex] -> [Vertex], [Tree [Vertex]] -> [Tree [Vertex]])+ collect (Node v tws) = (lowv, (v:) . curv, donev)+ where+ dv = dnum UA.! v+ accf (lowv', curv', donev') tw+ | loww < dv -- w's component extends through v+ = (lowv'', curv' . curw, donev' . donew)+ | otherwise -- w's component ends with v as an articulation point+ = (lowv'', curv', donev' . (Node (v : curw []) (donew []) :))+ where+ (loww, curw, donew) = collect tw+ !lowv'' = min lowv' loww+ !lowv0 = F.foldl' min dv [dnum UA.! w | w <- g!v]+ !(lowv, curv, donev) = F.foldl' accf (lowv0, id, id) tws++--------------------------------------------------------------------------------++-- Note [Inline for fusion]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We inline simple functions that produce or consume lists so that list fusion+-- can fire. transposeG is a function where this is particularly useful; it has+-- two intermediate lists in its definition which get fused away.
src/Data/IntMap.hs view
@@ -1,12 +1,6 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif #ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DataKinds, FlexibleContexts #-}-#endif-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE Safe #-} #endif #include "containers.h"@@ -20,81 +14,88 @@ -- Maintainer : libraries@haskell.org -- Portability : portable ----- An efficient implementation of maps from integer keys to values--- (dictionaries). ----- This module re-exports the value lazy "Data.IntMap.Lazy" API, plus--- several deprecated value strict functions. Please note that these functions--- have different strictness properties than those in "Data.IntMap.Strict":--- they only evaluate the result of the combining function. For example, the--- default value to 'insertWith'' is only evaluated if the combining function--- is called and uses it.+-- = Finite Int Maps (lazy interface) ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.+-- This module re-exports the value lazy "Data.IntMap.Lazy" API. ----- > import Data.IntMap (IntMap)--- > import qualified Data.IntMap as IntMap+-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @Int@ to values of type @v@. --+-- The functions in "Data.IntMap.Strict" are careful to force values before+-- installing them in an 'IntMap'. This is usually more efficient in cases where+-- laziness is not essential. The functions in this module do not do so.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- > import Data.IntMap.Lazy (IntMap)+-- > import qualified Data.IntMap.Lazy as IntMap+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Implementation+-- -- The implementation is based on /big-endian patricia trees/. This data -- structure performs especially well on binary operations like 'union'--- and 'intersection'. However, my benchmarks show that it is also+-- and 'intersection'. Additionally, benchmarks show that it is also -- (much) faster on insertions and deletions when compared to a generic -- size-balanced map implementation (see "Data.Map"). ----- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",+-- * Chris Okasaki and Andy Gill,+-- \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86,--- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+-- <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>. ----- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",--- Journal of the ACM, 15(4), October 1968, pages 514-534.+-- * D.R. Morrison,+-- \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+-- Journal of the ACM, 15(4), October 1968, pages 514-534,+-- <https://doi.org/10.1145/321479.321481>. --+--+-- == Performance information+-- -- Operation comments contain the operation time complexity in--- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.--- Many operations have a worst-case complexity of /O(min(n,W))/.--- This means that the operation can become linear in the number of--- elements with a maximum of /W/ -- the number of bits in an 'Int'--- (32 or 64).+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'lookup', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+-- the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+-- shared by all subelements, so there could not be more+-- than \(W\) levels.+--+-- If all \(n\) keys in the tree are between 0 and \(N\) (or, say, between \(-N\) and \(N\)),+-- the estimate can be refined to \(O(\min(n, \log N))\). If the set of keys+-- is sufficiently "dense", this becomes \(O(\min(n, \log n))\) or simply+-- the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntMap' are keys from a contiguous subset,+-- in which case the complexity is proportional to \(\log n\), capped by \(W\).+-- The worst scenario are exponentially growing keys \(1,2,4,\ldots,2^n\),+-- for which complexity grows as fast as \(n\) but again is capped by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+-- ----------------------------------------------------------------------------- module Data.IntMap ( module Data.IntMap.Lazy-#ifdef __GLASGOW_HASKELL__--- For GHC, we disable these, pending removal. For anything else,--- we just don't define them at all.- , insertWith'- , insertWithKey'- , fold- , foldWithKey-#endif ) where import Data.IntMap.Lazy--#ifdef __GLASGOW_HASKELL__-import Utils.Containers.Internal.TypeError---- | This function is being removed and is no longer usable.--- Use 'Data.IntMap.Strict.insertWith'-insertWith' :: Whoops "Data.IntMap.insertWith' is gone. Use Data.IntMap.Strict.insertWith."- => (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWith' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.IntMap.Strict.insertWithKey'.-insertWithKey' :: Whoops "Data.IntMap.insertWithKey' is gone. Use Data.IntMap.Strict.insertWithKey."- => (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWithKey' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.IntMap.Lazy.foldr'.-fold :: Whoops "Data.IntMap.fold' is gone. Use Data.IntMap.foldr or Prelude.foldr."- => (a -> b -> b) -> b -> IntMap a -> b-fold _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'foldrWithKey'.-foldWithKey :: Whoops "Data.IntMap.foldWithKey is gone. Use foldrWithKey."- => (Key -> a -> b -> b) -> b -> IntMap a -> b-foldWithKey _ _ _ = undefined-#endif
src/Data/IntMap/Internal.hs view
@@ -1,3580 +1,3886 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE TypeFamilies #-}-#endif--{-# OPTIONS_HADDOCK not-home #-}-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}--#include "containers.h"---------------------------------------------------------------------------------- |--- Module : Data.IntMap.Internal--- Copyright : (c) Daan Leijen 2002--- (c) Andriy Palamarchuk 2008--- (c) wren romano 2016--- License : BSD-style--- Maintainer : libraries@haskell.org--- Portability : portable------ = WARNING------ This module is considered __internal__.------ The Package Versioning Policy __does not apply__.------ The contents of this module may change __in any way whatsoever__--- and __without any warning__ between minor versions of this package.------ Authors importing this module are expected to track development--- closely.------ = Description------ This defines the data structures and core (hidden) manipulations--- on representations.------ @since 0.5.9---------------------------------------------------------------------------------- [Note: INLINE bit fiddling]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- It is essential that the bit fiddling functions like mask, zero, branchMask--- etc are inlined. If they do not, the memory allocation skyrockets. The GHC--- usually gets it right, but it is disastrous if it does not. Therefore we--- explicitly mark these functions INLINE.----- [Note: Local 'go' functions and capturing]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Care must be taken when using 'go' function which captures an argument.--- Sometimes (for example when the argument is passed to a data constructor,--- as in insert), GHC heap-allocates more than necessary. Therefore C-- code--- must be checked for increased allocation when creating and modifying such--- functions.----- [Note: Order of constructors]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The order of constructors of IntMap matters when considering performance.--- Currently in GHC 7.0, when type has 3 constructors, they are matched from--- the first to the last -- the best performance is achieved when the--- constructors are ordered by frequency.--- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil--- improves the benchmark by circa 10%.--module Data.IntMap.Internal (- -- * Map type- IntMap(..), Key -- instance Eq,Show-- -- * Operators- , (!), (!?), (\\)-- -- * Query- , null- , size- , member- , notMember- , lookup- , findWithDefault- , lookupLT- , lookupGT- , lookupLE- , lookupGE- , disjoint-- -- * Construction- , empty- , singleton-- -- ** Insertion- , insert- , insertWith- , insertWithKey- , insertLookupWithKey-- -- ** Delete\/Update- , delete- , adjust- , adjustWithKey- , update- , updateWithKey- , updateLookupWithKey- , alter- , alterF-- -- * Combine-- -- ** Union- , union- , unionWith- , unionWithKey- , unions- , unionsWith-- -- ** Difference- , difference- , differenceWith- , differenceWithKey-- -- ** Intersection- , intersection- , intersectionWith- , intersectionWithKey-- -- ** Compose- , compose-- -- ** General combining function- , SimpleWhenMissing- , SimpleWhenMatched- , runWhenMatched- , runWhenMissing- , merge- -- *** @WhenMatched@ tactics- , zipWithMaybeMatched- , zipWithMatched- -- *** @WhenMissing@ tactics- , mapMaybeMissing- , dropMissing- , preserveMissing- , mapMissing- , filterMissing-- -- ** Applicative general combining function- , WhenMissing (..)- , WhenMatched (..)- , mergeA- -- *** @WhenMatched@ tactics- -- | The tactics described for 'merge' work for- -- 'mergeA' as well. Furthermore, the following- -- are available.- , zipWithMaybeAMatched- , zipWithAMatched- -- *** @WhenMissing@ tactics- -- | The tactics described for 'merge' work for- -- 'mergeA' as well. Furthermore, the following- -- are available.- , traverseMaybeMissing- , traverseMissing- , filterAMissing-- -- ** Deprecated general combining function- , mergeWithKey- , mergeWithKey'-- -- * Traversal- -- ** Map- , map- , mapWithKey- , traverseWithKey- , traverseMaybeWithKey- , mapAccum- , mapAccumWithKey- , mapAccumRWithKey- , mapKeys- , mapKeysWith- , mapKeysMonotonic-- -- * Folds- , foldr- , foldl- , foldrWithKey- , foldlWithKey- , foldMapWithKey-- -- ** Strict folds- , foldr'- , foldl'- , foldrWithKey'- , foldlWithKey'-- -- * Conversion- , elems- , keys- , assocs- , keysSet- , fromSet-- -- ** Lists- , toList- , fromList- , fromListWith- , fromListWithKey-- -- ** Ordered lists- , toAscList- , toDescList- , fromAscList- , fromAscListWith- , fromAscListWithKey- , fromDistinctAscList-- -- * Filter- , filter- , filterWithKey- , restrictKeys- , withoutKeys- , partition- , partitionWithKey-- , mapMaybe- , mapMaybeWithKey- , mapEither- , mapEitherWithKey-- , split- , splitLookup- , splitRoot-- -- * Submap- , isSubmapOf, isSubmapOfBy- , isProperSubmapOf, isProperSubmapOfBy-- -- * Min\/Max- , lookupMin- , lookupMax- , findMin- , findMax- , deleteMin- , deleteMax- , deleteFindMin- , deleteFindMax- , updateMin- , updateMax- , updateMinWithKey- , updateMaxWithKey- , minView- , maxView- , minViewWithKey- , maxViewWithKey-- -- * Debugging- , showTree- , showTreeWith-- -- * Internal types- , Mask, Prefix, Nat-- -- * Utility- , natFromInt- , intFromNat- , link- , linkWithMask- , bin- , binCheckLeft- , binCheckRight- , zero- , nomatch- , match- , mask- , maskW- , shorter- , branchMask- , highestBitMask-- -- * Used by "IntMap.Merge.Lazy" and "IntMap.Merge.Strict"- , mapWhenMissing- , mapWhenMatched- , lmapWhenMissing- , contramapFirstWhenMatched- , contramapSecondWhenMatched- , mapGentlyWhenMissing- , mapGentlyWhenMatched- ) where--#if MIN_VERSION_base(4,8,0)-import Data.Functor.Identity (Identity (..))-import Control.Applicative (liftA2)-#else-import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2)-import Data.Monoid (Monoid(..))-import Data.Traversable (Traversable(traverse))-import Data.Word (Word)-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup(stimes))-#endif-#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>)))-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (stimesIdempotentMonoid)-import Data.Functor.Classes-#endif--import Control.DeepSeq (NFData(rnf))-import Data.Bits-import qualified Data.Foldable as Foldable-#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable())-#endif-import Data.Maybe (fromMaybe)-import Data.Typeable-import Prelude hiding (lookup, map, filter, foldr, foldl, null)--import Data.IntSet.Internal (Key)-import qualified Data.IntSet.Internal as IntSet-import Utils.Containers.Internal.BitUtil-import Utils.Containers.Internal.StrictPair--#if __GLASGOW_HASKELL__-import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),- DataType, mkDataType)-import GHC.Exts (build)-#if !MIN_VERSION_base(4,8,0)-import Data.Functor ((<$))-#endif-#if __GLASGOW_HASKELL__ >= 708-import qualified GHC.Exts as GHCExts-#endif-import Text.Read-#endif-import qualified Control.Category as Category-#if __GLASGOW_HASKELL__ >= 709-import Data.Coerce-#endif----- A "Nat" is a natural machine word (an unsigned Int)-type Nat = Word--natFromInt :: Key -> Nat-natFromInt = fromIntegral-{-# INLINE natFromInt #-}--intFromNat :: Nat -> Key-intFromNat = fromIntegral-{-# INLINE intFromNat #-}--{--------------------------------------------------------------------- Types---------------------------------------------------------------------}----- | A map of integers to values @a@.---- See Note: Order of constructors-data IntMap a = Bin {-# UNPACK #-} !Prefix- {-# UNPACK #-} !Mask- !(IntMap a)- !(IntMap a)--- Fields:--- prefix: The most significant bits shared by all keys in this Bin.--- mask: The switching bit to determine if a key should follow the left--- or right subtree of a 'Bin'.--- Invariant: Nil is never found as a child of Bin.--- Invariant: The Mask is a power of 2. It is the largest bit position at which--- two keys of the map differ.--- Invariant: Prefix is the common high-order bits that all elements share to--- the left of the Mask bit.--- Invariant: In (Bin prefix mask left right), left consists of the elements that--- don't have the mask bit set; right is all the elements that do.- | Tip {-# UNPACK #-} !Key a- | Nil--type Prefix = Int-type Mask = Int----- Some stuff from "Data.IntSet.Internal", for 'restrictKeys' and--- 'withoutKeys' to use.-type IntSetPrefix = Int-type IntSetBitMap = Word--bitmapOf :: Int -> IntSetBitMap-bitmapOf x = shiftLL 1 (x .&. IntSet.suffixBitMask)-{-# INLINE bitmapOf #-}--{--------------------------------------------------------------------- Operators---------------------------------------------------------------------}---- | /O(min(n,W))/. Find the value at a key.--- Calls 'error' when the element can not be found.------ > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map--- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'--(!) :: IntMap a -> Key -> a-(!) m k = find k m---- | /O(min(n,W))/. Find the value at a key.--- Returns 'Nothing' when the element can not be found.------ > fromList [(5,'a'), (3,'b')] !? 1 == Nothing--- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a'------ @since 0.5.11--(!?) :: IntMap a -> Key -> Maybe a-(!?) m k = lookup k m---- | Same as 'difference'.-(\\) :: IntMap a -> IntMap b -> IntMap a-m1 \\ m2 = difference m1 m2--infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}--{--------------------------------------------------------------------- Types---------------------------------------------------------------------}--instance Monoid (IntMap a) where- mempty = empty- mconcat = unions-#if !(MIN_VERSION_base(4,9,0))- mappend = union-#else- mappend = (<>)---- | @since 0.5.7-instance Semigroup (IntMap a) where- (<>) = union- stimes = stimesIdempotentMonoid-#endif---- | Folds in order of increasing key.-instance Foldable.Foldable IntMap where- fold = go- where go Nil = mempty- go (Tip _ v) = v- go (Bin _ m l r)- | m < 0 = go r `mappend` go l- | otherwise = go l `mappend` go r- {-# INLINABLE fold #-}- foldr = foldr- {-# INLINE foldr #-}- foldl = foldl- {-# INLINE foldl #-}- foldMap f t = go t- where go Nil = mempty- go (Tip _ v) = f v- go (Bin _ m l r)- | m < 0 = go r `mappend` go l- | otherwise = go l `mappend` go r- {-# INLINE foldMap #-}- foldl' = foldl'- {-# INLINE foldl' #-}- foldr' = foldr'- {-# INLINE foldr' #-}-#if MIN_VERSION_base(4,8,0)- length = size- {-# INLINE length #-}- null = null- {-# INLINE null #-}- toList = elems -- NB: Foldable.toList /= IntMap.toList- {-# INLINE toList #-}- elem = go- where go !_ Nil = False- go x (Tip _ y) = x == y- go x (Bin _ _ l r) = go x l || go x r- {-# INLINABLE elem #-}- maximum = start- where start Nil = error "Data.Foldable.maximum (for Data.IntMap): empty map"- start (Tip _ y) = y- start (Bin _ m l r)- | m < 0 = go (start r) l- | otherwise = go (start l) r-- go !m Nil = m- go m (Tip _ y) = max m y- go m (Bin _ _ l r) = go (go m l) r- {-# INLINABLE maximum #-}- minimum = start- where start Nil = error "Data.Foldable.minimum (for Data.IntMap): empty map"- start (Tip _ y) = y- start (Bin _ m l r)- | m < 0 = go (start r) l- | otherwise = go (start l) r-- go !m Nil = m- go m (Tip _ y) = min m y- go m (Bin _ _ l r) = go (go m l) r- {-# INLINABLE minimum #-}- sum = foldl' (+) 0- {-# INLINABLE sum #-}- product = foldl' (*) 1- {-# INLINABLE product #-}-#endif---- | Traverses in order of increasing key.-instance Traversable IntMap where- traverse f = traverseWithKey (\_ -> f)- {-# INLINE traverse #-}--instance NFData a => NFData (IntMap a) where- rnf Nil = ()- rnf (Tip _ v) = rnf v- rnf (Bin _ _ l r) = rnf l `seq` rnf r--#if __GLASGOW_HASKELL__--{--------------------------------------------------------------------- A Data instance---------------------------------------------------------------------}---- This instance preserves data abstraction at the cost of inefficiency.--- We provide limited reflection services for the sake of data abstraction.--instance Data a => Data (IntMap a) where- gfoldl f z im = z fromList `f` (toList im)- toConstr _ = fromListConstr- gunfold k z c = case constrIndex c of- 1 -> k (z fromList)- _ -> error "gunfold"- dataTypeOf _ = intMapDataType- dataCast1 f = gcast1 f--fromListConstr :: Constr-fromListConstr = mkConstr intMapDataType "fromList" [] Prefix--intMapDataType :: DataType-intMapDataType = mkDataType "Data.IntMap.Internal.IntMap" [fromListConstr]--#endif--{--------------------------------------------------------------------- Query---------------------------------------------------------------------}--- | /O(1)/. Is the map empty?------ > Data.IntMap.null (empty) == True--- > Data.IntMap.null (singleton 1 'a') == False--null :: IntMap a -> Bool-null Nil = True-null _ = False-{-# INLINE null #-}---- | /O(n)/. Number of elements in the map.------ > size empty == 0--- > size (singleton 1 'a') == 1--- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3-size :: IntMap a -> Int-size = go 0- where- go !acc (Bin _ _ l r) = go (go acc l) r- go acc (Tip _ _) = 1 + acc- go acc Nil = acc---- | /O(min(n,W))/. Is the key a member of the map?------ > member 5 (fromList [(5,'a'), (3,'b')]) == True--- > member 1 (fromList [(5,'a'), (3,'b')]) == False---- See Note: Local 'go' functions and capturing]-member :: Key -> IntMap a -> Bool-member !k = go- where- go (Bin p m l r) | nomatch k p m = False- | zero k m = go l- | otherwise = go r- go (Tip kx _) = k == kx- go Nil = False---- | /O(min(n,W))/. Is the key not a member of the map?------ > notMember 5 (fromList [(5,'a'), (3,'b')]) == False--- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True--notMember :: Key -> IntMap a -> Bool-notMember k m = not $ member k m---- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'.---- See Note: Local 'go' functions and capturing]-lookup :: Key -> IntMap a -> Maybe a-lookup !k = go- where- go (Bin p m l r) | nomatch k p m = Nothing- | zero k m = go l- | otherwise = go r- go (Tip kx x) | k == kx = Just x- | otherwise = Nothing- go Nil = Nothing----- See Note: Local 'go' functions and capturing]-find :: Key -> IntMap a -> a-find !k = go- where- go (Bin p m l r) | nomatch k p m = not_found- | zero k m = go l- | otherwise = go r- go (Tip kx x) | k == kx = x- | otherwise = not_found- go Nil = not_found-- not_found = error ("IntMap.!: key " ++ show k ++ " is not an element of the map")---- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@--- returns the value at key @k@ or returns @def@ when the key is not an--- element of the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'---- See Note: Local 'go' functions and capturing]-findWithDefault :: a -> Key -> IntMap a -> a-findWithDefault def !k = go- where- go (Bin p m l r) | nomatch k p m = def- | zero k m = go l- | otherwise = go r- go (Tip kx x) | k == kx = x- | otherwise = def- go Nil = def---- | /O(log n)/. Find largest key smaller than the given one and return the--- corresponding (key, value) pair.------ > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing--- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')---- See Note: Local 'go' functions and capturing.-lookupLT :: Key -> IntMap a -> Maybe (Key, a)-lookupLT !k t = case t of- Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r- _ -> go Nil t- where- go def (Bin p m l r)- | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r- | zero k m = go def l- | otherwise = go l r- go def (Tip ky y)- | k <= ky = unsafeFindMax def- | otherwise = Just (ky, y)- go def Nil = unsafeFindMax def---- | /O(log n)/. Find smallest key greater than the given one and return the--- corresponding (key, value) pair.------ > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')--- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGT :: Key -> IntMap a -> Maybe (Key, a)-lookupGT !k t = case t of- Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r- _ -> go Nil t- where- go def (Bin p m l r)- | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def- | zero k m = go r l- | otherwise = go def r- go def (Tip ky y)- | k >= ky = unsafeFindMin def- | otherwise = Just (ky, y)- go def Nil = unsafeFindMin def---- | /O(log n)/. Find largest key smaller or equal to the given one and return--- the corresponding (key, value) pair.------ > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing--- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')--- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')---- See Note: Local 'go' functions and capturing.-lookupLE :: Key -> IntMap a -> Maybe (Key, a)-lookupLE !k t = case t of- Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r- _ -> go Nil t- where- go def (Bin p m l r)- | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r- | zero k m = go def l- | otherwise = go l r- go def (Tip ky y)- | k < ky = unsafeFindMax def- | otherwise = Just (ky, y)- go def Nil = unsafeFindMax def---- | /O(log n)/. Find smallest key greater or equal to the given one and return--- the corresponding (key, value) pair.------ > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')--- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')--- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGE :: Key -> IntMap a -> Maybe (Key, a)-lookupGE !k t = case t of- Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r- _ -> go Nil t- where- go def (Bin p m l r)- | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def- | zero k m = go r l- | otherwise = go def r- go def (Tip ky y)- | k > ky = unsafeFindMin def- | otherwise = Just (ky, y)- go def Nil = unsafeFindMin def----- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMin :: IntMap a -> Maybe (Key, a)-unsafeFindMin Nil = Nothing-unsafeFindMin (Tip ky y) = Just (ky, y)-unsafeFindMin (Bin _ _ l _) = unsafeFindMin l---- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMax :: IntMap a -> Maybe (Key, a)-unsafeFindMax Nil = Nothing-unsafeFindMax (Tip ky y) = Just (ky, y)-unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r--{--------------------------------------------------------------------- Disjoint---------------------------------------------------------------------}--- | /O(n+m)/. Check whether the key sets of two maps are disjoint--- (i.e. their 'intersection' is empty).------ > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True--- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False--- > disjoint (fromList []) (fromList []) == True------ > disjoint a b == null (intersection a b)------ @since 0.6.2.1-disjoint :: IntMap a -> IntMap b -> Bool-disjoint Nil _ = True-disjoint _ Nil = True-disjoint (Tip kx _) ys = notMember kx ys-disjoint xs (Tip ky _) = notMember ky xs-disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)- | shorter m1 m2 = disjoint1- | shorter m2 m1 = disjoint2- | p1 == p2 = disjoint l1 l2 && disjoint r1 r2- | otherwise = True- where- disjoint1 | nomatch p2 p1 m1 = True- | zero p2 m1 = disjoint l1 t2- | otherwise = disjoint r1 t2- disjoint2 | nomatch p1 p2 m2 = True- | zero p1 m2 = disjoint t1 l2- | otherwise = disjoint t1 r2--{--------------------------------------------------------------------- Compose---------------------------------------------------------------------}--- | Relate the keys of one map to the values of--- the other, by using the values of the former as keys for lookups--- in the latter.------ Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument------ > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]------ @--- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')--- @------ __Note:__ Prior to v0.6.4, "Data.IntMap.Strict" exposed a version of--- 'compose' that forced the values of the output 'IntMap'. This version does--- not force these values.------ @since 0.6.3.1-compose :: IntMap c -> IntMap Int -> IntMap c-compose bc !ab- | null bc = empty- | otherwise = mapMaybe (bc !?) ab--{--------------------------------------------------------------------- Construction---------------------------------------------------------------------}--- | /O(1)/. The empty map.------ > empty == fromList []--- > size empty == 0--empty :: IntMap a-empty- = Nil-{-# INLINE empty #-}---- | /O(1)/. A map of one element.------ > singleton 1 'a' == fromList [(1, 'a')]--- > size (singleton 1 'a') == 1--singleton :: Key -> a -> IntMap a-singleton k x- = Tip k x-{-# INLINE singleton #-}--{--------------------------------------------------------------------- Insert---------------------------------------------------------------------}--- | /O(min(n,W))/. Insert a new key\/value pair in the map.--- If the key is already present in the map, the associated value is--- replaced with the supplied value, i.e. 'insert' is equivalent to--- @'insertWith' 'const'@.------ > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]--- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]--- > insert 5 'x' empty == singleton 5 'x'--insert :: Key -> a -> IntMap a -> IntMap a-insert !k x t@(Bin p m l r)- | nomatch k p m = link k (Tip k x) p t- | zero k m = Bin p m (insert k x l) r- | otherwise = Bin p m l (insert k x r)-insert k x t@(Tip ky _)- | k==ky = Tip k x- | otherwise = link k (Tip k x) ky t-insert k x Nil = Tip k x---- right-biased insertion, used by 'union'--- | /O(min(n,W))/. Insert with a combining function.--- @'insertWith' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert @f new_value old_value@.------ > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"--insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWith f k x t- = insertWithKey (\_ x' y' -> f x' y') k x t---- | /O(min(n,W))/. Insert with a combining function.--- @'insertWithKey' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert @f key new_value old_value@.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"--insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWithKey f !k x t@(Bin p m l r)- | nomatch k p m = link k (Tip k x) p t- | zero k m = Bin p m (insertWithKey f k x l) r- | otherwise = Bin p m l (insertWithKey f k x r)-insertWithKey f k x t@(Tip ky y)- | k == ky = Tip k (f k x y)- | otherwise = link k (Tip k x) ky t-insertWithKey _ k x Nil = Tip k x---- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)--- is a pair where the first element is equal to (@'lookup' k map@)--- and the second element equal to (@'insertWithKey' f k x map@).------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])--- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])--- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")------ This is how to define @insertLookup@ using @insertLookupWithKey@:------ > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t--- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])--- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])--insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)-insertLookupWithKey f !k x t@(Bin p m l r)- | nomatch k p m = (Nothing,link k (Tip k x) p t)- | zero k m = let (found,l') = insertLookupWithKey f k x l- in (found,Bin p m l' r)- | otherwise = let (found,r') = insertLookupWithKey f k x r- in (found,Bin p m l r')-insertLookupWithKey f k x t@(Tip ky y)- | k == ky = (Just y,Tip k (f k x y))- | otherwise = (Nothing,link k (Tip k x) ky t)-insertLookupWithKey _ k x Nil = (Nothing,Tip k x)---{--------------------------------------------------------------------- Deletion---------------------------------------------------------------------}--- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not--- a member of the map, the original map is returned.------ > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > delete 5 empty == empty--delete :: Key -> IntMap a -> IntMap a-delete !k t@(Bin p m l r)- | nomatch k p m = t- | zero k m = binCheckLeft p m (delete k l) r- | otherwise = binCheckRight p m l (delete k r)-delete k t@(Tip ky _)- | k == ky = Nil- | otherwise = t-delete _k Nil = Nil---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjust ("new " ++) 7 empty == empty--adjust :: (a -> a) -> Key -> IntMap a -> IntMap a-adjust f k m- = adjustWithKey (\_ x -> f x) k m---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > let f key x = (show key) ++ ":new " ++ x--- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjustWithKey f 7 empty == empty--adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a-adjustWithKey f !k t@(Bin p m l r)- | nomatch k p m = t- | zero k m = Bin p m (adjustWithKey f k l) r- | otherwise = Bin p m l (adjustWithKey f k r)-adjustWithKey f k t@(Tip ky y)- | k == ky = Tip ky (f k y)- | otherwise = t-adjustWithKey _ _ Nil = Nil----- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f x = if x == "a" then Just "new a" else Nothing--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a-update f- = updateWithKey (\_ x -> f x)---- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a-updateWithKey f !k t@(Bin p m l r)- | nomatch k p m = t- | zero k m = binCheckLeft p m (updateWithKey f k l) r- | otherwise = binCheckRight p m l (updateWithKey f k r)-updateWithKey f k t@(Tip ky y)- | k == ky = case (f k y) of- Just y' -> Tip ky y'- Nothing -> Nil- | otherwise = t-updateWithKey _ _ Nil = Nil---- | /O(min(n,W))/. Lookup and update.--- The function returns original value, if it is updated.--- This is different behavior than 'Data.Map.updateLookupWithKey'.--- Returns the original key value if the map entry is deleted.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])--- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])--- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")--updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)-updateLookupWithKey f !k t@(Bin p m l r)- | nomatch k p m = (Nothing,t)- | zero k m = let !(found,l') = updateLookupWithKey f k l- in (found,binCheckLeft p m l' r)- | otherwise = let !(found,r') = updateLookupWithKey f k r- in (found,binCheckRight p m l r')-updateLookupWithKey f k t@(Tip ky y)- | k==ky = case (f k y) of- Just y' -> (Just y,Tip ky y')- Nothing -> (Just y,Nil)- | otherwise = (Nothing,t)-updateLookupWithKey _ _ Nil = (Nothing,Nil)------ | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.--- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.-alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a-alter f !k t@(Bin p m l r)- | nomatch k p m = case f Nothing of- Nothing -> t- Just x -> link k (Tip k x) p t- | zero k m = binCheckLeft p m (alter f k l) r- | otherwise = binCheckRight p m l (alter f k r)-alter f k t@(Tip ky y)- | k==ky = case f (Just y) of- Just x -> Tip ky x- Nothing -> Nil- | otherwise = case f Nothing of- Just x -> link k (Tip k x) ky t- Nothing -> Tip ky y-alter f k Nil = case f Nothing of- Just x -> Tip k x- Nothing -> Nil---- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at--- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete,--- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f--- ('lookup' k m)@.------ Example:------ @--- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)--- interactiveAlter k m = alterF f k m where--- f Nothing = do--- putStrLn $ show k ++--- " was not found in the map. Would you like to add it?"--- getUserResponse1 :: IO (Maybe String)--- f (Just old) = do--- putStrLn $ "The key is currently bound to " ++ show old ++--- ". Would you like to change or delete it?"--- getUserResponse2 :: IO (Maybe String)--- @------ 'alterF' is the most general operation for working with an individual--- key that may or may not be in a given map.------ Note: 'alterF' is a flipped version of the @at@ combinator from--- @Control.Lens.At@.------ @since 0.5.8--alterF :: Functor f- => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)--- This implementation was stolen from 'Control.Lens.At'.-alterF f k m = (<$> f mv) $ \fres ->- case fres of- Nothing -> maybe m (const (delete k m)) mv- Just v' -> insert k v' m- where mv = lookup k m--{--------------------------------------------------------------------- Union---------------------------------------------------------------------}--- | The union of a list of maps.------ > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- > == fromList [(3, "b"), (5, "a"), (7, "C")]--- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]--- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]--unions :: Foldable f => f (IntMap a) -> IntMap a-unions xs- = Foldable.foldl' union empty xs---- | The union of a list of maps, with a combining operation.------ > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]--unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a-unionsWith f ts- = Foldable.foldl' (unionWith f) empty ts---- | /O(n+m)/. The (left-biased) union of two maps.--- It prefers the first map when duplicate keys are encountered,--- i.e. (@'union' == 'unionWith' 'const'@).------ > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]--union :: IntMap a -> IntMap a -> IntMap a-union m1 m2- = mergeWithKey' Bin const id id m1 m2---- | /O(n+m)/. The union with a combining function.------ > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]--unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a-unionWith f m1 m2- = unionWithKey (\_ x y -> f x y) m1 m2---- | /O(n+m)/. The union with a combining function.------ > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]--unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a-unionWithKey f m1 m2- = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2--{--------------------------------------------------------------------- Difference---------------------------------------------------------------------}--- | /O(n+m)/. Difference between two maps (based on keys).------ > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"--difference :: IntMap a -> IntMap b -> IntMap a-difference m1 m2- = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2---- | /O(n+m)/. Difference with a combining function.------ > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing--- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])--- > == singleton 3 "b:B"--differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a-differenceWith f m1 m2- = differenceWithKey (\_ x y -> f x y) m1 m2---- | /O(n+m)/. Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference).--- If it returns (@'Just' y@), the element is updated with a new value @y@.------ > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing--- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])--- > == singleton 3 "3:b|B"--differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a-differenceWithKey f m1 m2- = mergeWithKey f id (const Nil) m1 m2----- TODO(wrengr): re-verify that asymptotic bound--- | /O(n+m)/. Remove all the keys in a given set from a map.------ @--- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.notMember`` s) m--- @------ @since 0.5.8-withoutKeys :: IntMap a -> IntSet.IntSet -> IntMap a-withoutKeys t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)- | shorter m1 m2 = difference1- | shorter m2 m1 = difference2- | p1 == p2 = bin p1 m1 (withoutKeys l1 l2) (withoutKeys r1 r2)- | otherwise = t1- where- difference1- | nomatch p2 p1 m1 = t1- | zero p2 m1 = binCheckLeft p1 m1 (withoutKeys l1 t2) r1- | otherwise = binCheckRight p1 m1 l1 (withoutKeys r1 t2)- difference2- | nomatch p1 p2 m2 = t1- | zero p1 m2 = withoutKeys t1 l2- | otherwise = withoutKeys t1 r2-withoutKeys t1@(Bin p1 m1 _ _) (IntSet.Tip p2 bm2) =- let minbit = bitmapOf p1- lt_minbit = minbit - 1- maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))- gt_maxbit = (-maxbit) `xor` maxbit- -- TODO(wrengr): should we manually inline/unroll 'updatePrefix'- -- and 'withoutBM' here, in order to avoid redundant case analyses?- in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)-withoutKeys t1@(Bin _ _ _ _) IntSet.Nil = t1-withoutKeys t1@(Tip k1 _) t2- | k1 `IntSet.member` t2 = Nil- | otherwise = t1-withoutKeys Nil _ = Nil---updatePrefix- :: IntSetPrefix -> IntMap a -> (IntMap a -> IntMap a) -> IntMap a-updatePrefix !kp t@(Bin p m l r) f- | m .&. IntSet.suffixBitMask /= 0 =- if p .&. IntSet.prefixBitMask == kp then f t else t- | nomatch kp p m = t- | zero kp m = binCheckLeft p m (updatePrefix kp l f) r- | otherwise = binCheckRight p m l (updatePrefix kp r f)-updatePrefix kp t@(Tip kx _) f- | kx .&. IntSet.prefixBitMask == kp = f t- | otherwise = t-updatePrefix _ Nil _ = Nil---withoutBM :: IntSetBitMap -> IntMap a -> IntMap a-withoutBM 0 t = t-withoutBM bm (Bin p m l r) =- let leftBits = bitmapOf (p .|. m) - 1- bmL = bm .&. leftBits- bmR = bm `xor` bmL -- = (bm .&. complement leftBits)- in bin p m (withoutBM bmL l) (withoutBM bmR r)-withoutBM bm t@(Tip k _)- -- TODO(wrengr): need we manually inline 'IntSet.Member' here?- | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = Nil- | otherwise = t-withoutBM _ Nil = Nil---{--------------------------------------------------------------------- Intersection---------------------------------------------------------------------}--- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).------ > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"--intersection :: IntMap a -> IntMap b -> IntMap a-intersection m1 m2- = mergeWithKey' bin const (const Nil) (const Nil) m1 m2----- TODO(wrengr): re-verify that asymptotic bound--- | /O(n+m)/. The restriction of a map to the keys in a set.------ @--- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.member`` s) m--- @------ @since 0.5.8-restrictKeys :: IntMap a -> IntSet.IntSet -> IntMap a-restrictKeys t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)- | shorter m1 m2 = intersection1- | shorter m2 m1 = intersection2- | p1 == p2 = bin p1 m1 (restrictKeys l1 l2) (restrictKeys r1 r2)- | otherwise = Nil- where- intersection1- | nomatch p2 p1 m1 = Nil- | zero p2 m1 = restrictKeys l1 t2- | otherwise = restrictKeys r1 t2- intersection2- | nomatch p1 p2 m2 = Nil- | zero p1 m2 = restrictKeys t1 l2- | otherwise = restrictKeys t1 r2-restrictKeys t1@(Bin p1 m1 _ _) (IntSet.Tip p2 bm2) =- let minbit = bitmapOf p1- ge_minbit = complement (minbit - 1)- maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))- le_maxbit = maxbit .|. (maxbit - 1)- -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'- -- and 'restrictBM' here, in order to avoid redundant case analyses?- in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)-restrictKeys (Bin _ _ _ _) IntSet.Nil = Nil-restrictKeys t1@(Tip k1 _) t2- | k1 `IntSet.member` t2 = t1- | otherwise = Nil-restrictKeys Nil _ = Nil----- | /O(min(n,W))/. Restrict to the sub-map with all keys matching--- a key prefix.-lookupPrefix :: IntSetPrefix -> IntMap a -> IntMap a-lookupPrefix !kp t@(Bin p m l r)- | m .&. IntSet.suffixBitMask /= 0 =- if p .&. IntSet.prefixBitMask == kp then t else Nil- | nomatch kp p m = Nil- | zero kp m = lookupPrefix kp l- | otherwise = lookupPrefix kp r-lookupPrefix kp t@(Tip kx _)- | (kx .&. IntSet.prefixBitMask) == kp = t- | otherwise = Nil-lookupPrefix _ Nil = Nil---restrictBM :: IntSetBitMap -> IntMap a -> IntMap a-restrictBM 0 _ = Nil-restrictBM bm (Bin p m l r) =- let leftBits = bitmapOf (p .|. m) - 1- bmL = bm .&. leftBits- bmR = bm `xor` bmL -- = (bm .&. complement leftBits)- in bin p m (restrictBM bmL l) (restrictBM bmR r)-restrictBM bm t@(Tip k _)- -- TODO(wrengr): need we manually inline 'IntSet.Member' here?- | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = t- | otherwise = Nil-restrictBM _ Nil = Nil----- | /O(n+m)/. The intersection with a combining function.------ > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"--intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c-intersectionWith f m1 m2- = intersectionWithKey (\_ x y -> f x y) m1 m2---- | /O(n+m)/. The intersection with a combining function.------ > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar--- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"--intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c-intersectionWithKey f m1 m2- = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2--{--------------------------------------------------------------------- MergeWithKey---------------------------------------------------------------------}---- | /O(n+m)/. A high-performance universal combining function. Using--- 'mergeWithKey', all combining functions can be defined without any loss of--- efficiency (with exception of 'union', 'difference' and 'intersection',--- where sharing of some nodes is lost with 'mergeWithKey').------ Please make sure you know what is going on when using 'mergeWithKey',--- otherwise you can be surprised by unexpected code growth or even--- corruption of the data structure.------ When 'mergeWithKey' is given three arguments, it is inlined to the call--- site. You should therefore use 'mergeWithKey' only to define your custom--- combining functions. For example, you could define 'unionWithKey',--- 'differenceWithKey' and 'intersectionWithKey' as------ > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2--- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2--- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2------ When calling @'mergeWithKey' combine only1 only2@, a function combining two--- 'IntMap's is created, such that------ * if a key is present in both maps, it is passed with both corresponding--- values to the @combine@ function. Depending on the result, the key is either--- present in the result with specified value, or is left out;------ * a nonempty subtree present only in the first map is passed to @only1@ and--- the output is added to the result;------ * a nonempty subtree present only in the second map is passed to @only2@ and--- the output is added to the result.------ The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.--- The values can be modified arbitrarily. Most common variants of @only1@ and--- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or--- @'filterWithKey' f@ could be used for any @f@.--mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)- -> IntMap a -> IntMap b -> IntMap c-mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2- where -- We use the lambda form to avoid non-exhaustive pattern matches warning.- combine = \(Tip k1 x1) (Tip _k2 x2) ->- case f k1 x1 x2 of- Nothing -> Nil- Just x -> Tip k1 x- {-# INLINE combine #-}-{-# INLINE mergeWithKey #-}---- Slightly more general version of mergeWithKey. It differs in the following:------ * the combining function operates on maps instead of keys and values. The--- reason is to enable sharing in union, difference and intersection.------ * mergeWithKey' is given an equivalent of bin. The reason is that in union*,--- Bin constructor can be used, because we know both subtrees are nonempty.--mergeWithKey' :: (Prefix -> Mask -> IntMap c -> IntMap c -> IntMap c)- -> (IntMap a -> IntMap b -> IntMap c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)- -> IntMap a -> IntMap b -> IntMap c-mergeWithKey' bin' f g1 g2 = go- where- go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)- | shorter m1 m2 = merge1- | shorter m2 m1 = merge2- | p1 == p2 = bin' p1 m1 (go l1 l2) (go r1 r2)- | otherwise = maybe_link p1 (g1 t1) p2 (g2 t2)- where- merge1 | nomatch p2 p1 m1 = maybe_link p1 (g1 t1) p2 (g2 t2)- | zero p2 m1 = bin' p1 m1 (go l1 t2) (g1 r1)- | otherwise = bin' p1 m1 (g1 l1) (go r1 t2)- merge2 | nomatch p1 p2 m2 = maybe_link p1 (g1 t1) p2 (g2 t2)- | zero p1 m2 = bin' p2 m2 (go t1 l2) (g2 r2)- | otherwise = bin' p2 m2 (g2 l2) (go t1 r2)-- go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1'- where- merge0 t2 k2 t1@(Bin p1 m1 l1 r1)- | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2)- | zero k2 m1 = bin' p1 m1 (merge0 t2 k2 l1) (g1 r1)- | otherwise = bin' p1 m1 (g1 l1) (merge0 t2 k2 r1)- merge0 t2 k2 t1@(Tip k1 _)- | k1 == k2 = f t1 t2- | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)- merge0 t2 _ Nil = g2 t2-- go t1@(Bin _ _ _ _) Nil = g1 t1-- go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'- where- merge0 t1 k1 t2@(Bin p2 m2 l2 r2)- | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2)- | zero k1 m2 = bin' p2 m2 (merge0 t1 k1 l2) (g2 r2)- | otherwise = bin' p2 m2 (g2 l2) (merge0 t1 k1 r2)- merge0 t1 k1 t2@(Tip k2 _)- | k1 == k2 = f t1 t2- | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)- merge0 t1 _ Nil = g1 t1-- go Nil t2 = g2 t2-- maybe_link _ Nil _ t2 = t2- maybe_link _ t1 _ Nil = t1- maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2- {-# INLINE maybe_link #-}-{-# INLINE mergeWithKey' #-}---{--------------------------------------------------------------------- mergeA---------------------------------------------------------------------}---- | A tactic for dealing with keys present in one map but not the--- other in 'merge' or 'mergeA'.------ A tactic of type @WhenMissing f k x z@ is an abstract representation--- of a function of type @Key -> x -> f (Maybe z)@.------ @since 0.5.9--data WhenMissing f x y = WhenMissing- { missingSubtree :: IntMap x -> f (IntMap y)- , missingKey :: Key -> x -> f (Maybe y)}---- | @since 0.5.9-instance (Applicative f, Monad f) => Functor (WhenMissing f x) where- fmap = mapWhenMissing- {-# INLINE fmap #-}----- | @since 0.5.9-instance (Applicative f, Monad f) => Category.Category (WhenMissing f)- where- id = preserveMissing- f . g =- traverseMaybeMissing $ \ k x -> do- y <- missingKey g k x- case y of- Nothing -> pure Nothing- Just q -> missingKey f k q- {-# INLINE id #-}- {-# INLINE (.) #-}----- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.------ @since 0.5.9-instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where- pure x = mapMissing (\ _ _ -> x)- f <*> g =- traverseMaybeMissing $ \k x -> do- res1 <- missingKey f k x- case res1 of- Nothing -> pure Nothing- Just r -> (pure $!) . fmap r =<< missingKey g k x- {-# INLINE pure #-}- {-# INLINE (<*>) #-}----- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.------ @since 0.5.9-instance (Applicative f, Monad f) => Monad (WhenMissing f x) where-#if !MIN_VERSION_base(4,8,0)- return = pure-#endif- m >>= f =- traverseMaybeMissing $ \k x -> do- res1 <- missingKey m k x- case res1 of- Nothing -> pure Nothing- Just r -> missingKey (f r) k x- {-# INLINE (>>=) #-}----- | Map covariantly over a @'WhenMissing' f x@.------ @since 0.5.9-mapWhenMissing- :: (Applicative f, Monad f)- => (a -> b)- -> WhenMissing f x a- -> WhenMissing f x b-mapWhenMissing f t = WhenMissing- { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'- , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }-{-# INLINE mapWhenMissing #-}----- | Map covariantly over a @'WhenMissing' f x@, using only a--- 'Functor f' constraint.-mapGentlyWhenMissing- :: Functor f- => (a -> b)- -> WhenMissing f x a- -> WhenMissing f x b-mapGentlyWhenMissing f t = WhenMissing- { missingSubtree = \m -> fmap f <$> missingSubtree t m- , missingKey = \k x -> fmap f <$> missingKey t k x }-{-# INLINE mapGentlyWhenMissing #-}----- | Map covariantly over a @'WhenMatched' f k x@, using only a--- 'Functor f' constraint.-mapGentlyWhenMatched- :: Functor f- => (a -> b)- -> WhenMatched f x y a- -> WhenMatched f x y b-mapGentlyWhenMatched f t =- zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y-{-# INLINE mapGentlyWhenMatched #-}----- | Map contravariantly over a @'WhenMissing' f _ x@.------ @since 0.5.9-lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x-lmapWhenMissing f t = WhenMissing- { missingSubtree = \m -> missingSubtree t (fmap f m)- , missingKey = \k x -> missingKey t k (f x) }-{-# INLINE lmapWhenMissing #-}----- | Map contravariantly over a @'WhenMatched' f _ y z@.------ @since 0.5.9-contramapFirstWhenMatched- :: (b -> a)- -> WhenMatched f a y z- -> WhenMatched f b y z-contramapFirstWhenMatched f t =- WhenMatched $ \k x y -> runWhenMatched t k (f x) y-{-# INLINE contramapFirstWhenMatched #-}----- | Map contravariantly over a @'WhenMatched' f x _ z@.------ @since 0.5.9-contramapSecondWhenMatched- :: (b -> a)- -> WhenMatched f x a z- -> WhenMatched f x b z-contramapSecondWhenMatched f t =- WhenMatched $ \k x y -> runWhenMatched t k x (f y)-{-# INLINE contramapSecondWhenMatched #-}---#if !MIN_VERSION_base(4,8,0)-newtype Identity a = Identity {runIdentity :: a}--instance Functor Identity where- fmap f (Identity x) = Identity (f x)--instance Applicative Identity where- pure = Identity- Identity f <*> Identity x = Identity (f x)-#endif---- | A tactic for dealing with keys present in one map but not the--- other in 'merge'.------ A tactic of type @SimpleWhenMissing x z@ is an abstract--- representation of a function of type @Key -> x -> Maybe z@.------ @since 0.5.9-type SimpleWhenMissing = WhenMissing Identity----- | A tactic for dealing with keys present in both maps in 'merge'--- or 'mergeA'.------ A tactic of type @WhenMatched f x y z@ is an abstract representation--- of a function of type @Key -> x -> y -> f (Maybe z)@.------ @since 0.5.9-newtype WhenMatched f x y z = WhenMatched- { matchedKey :: Key -> x -> y -> f (Maybe z) }----- | Along with zipWithMaybeAMatched, witnesses the isomorphism--- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@.------ @since 0.5.9-runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z)-runWhenMatched = matchedKey-{-# INLINE runWhenMatched #-}----- | Along with traverseMaybeMissing, witnesses the isomorphism--- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@.------ @since 0.5.9-runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y)-runWhenMissing = missingKey-{-# INLINE runWhenMissing #-}----- | @since 0.5.9-instance Functor f => Functor (WhenMatched f x y) where- fmap = mapWhenMatched- {-# INLINE fmap #-}----- | @since 0.5.9-instance (Monad f, Applicative f) => Category.Category (WhenMatched f x)- where- id = zipWithMatched (\_ _ y -> y)- f . g =- zipWithMaybeAMatched $ \k x y -> do- res <- runWhenMatched g k x y- case res of- Nothing -> pure Nothing- Just r -> runWhenMatched f k x r- {-# INLINE id #-}- {-# INLINE (.) #-}----- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@------ @since 0.5.9-instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where- pure x = zipWithMatched (\_ _ _ -> x)- fs <*> xs =- zipWithMaybeAMatched $ \k x y -> do- res <- runWhenMatched fs k x y- case res of- Nothing -> pure Nothing- Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y- {-# INLINE pure #-}- {-# INLINE (<*>) #-}----- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@------ @since 0.5.9-instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where-#if !MIN_VERSION_base(4,8,0)- return = pure-#endif- m >>= f =- zipWithMaybeAMatched $ \k x y -> do- res <- runWhenMatched m k x y- case res of- Nothing -> pure Nothing- Just r -> runWhenMatched (f r) k x y- {-# INLINE (>>=) #-}----- | Map covariantly over a @'WhenMatched' f x y@.------ @since 0.5.9-mapWhenMatched- :: Functor f- => (a -> b)- -> WhenMatched f x y a- -> WhenMatched f x y b-mapWhenMatched f (WhenMatched g) =- WhenMatched $ \k x y -> fmap (fmap f) (g k x y)-{-# INLINE mapWhenMatched #-}----- | A tactic for dealing with keys present in both maps in 'merge'.------ A tactic of type @SimpleWhenMatched x y z@ is an abstract--- representation of a function of type @Key -> x -> y -> Maybe z@.------ @since 0.5.9-type SimpleWhenMatched = WhenMatched Identity----- | When a key is found in both maps, apply a function to the key--- and values and use the result in the merged map.------ > zipWithMatched--- > :: (Key -> x -> y -> z)--- > -> SimpleWhenMatched x y z------ @since 0.5.9-zipWithMatched- :: Applicative f- => (Key -> x -> y -> z)- -> WhenMatched f x y z-zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y-{-# INLINE zipWithMatched #-}----- | When a key is found in both maps, apply a function to the key--- and values to produce an action and use its result in the merged--- map.------ @since 0.5.9-zipWithAMatched- :: Applicative f- => (Key -> x -> y -> f z)- -> WhenMatched f x y z-zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y-{-# INLINE zipWithAMatched #-}----- | When a key is found in both maps, apply a function to the key--- and values and maybe use the result in the merged map.------ > zipWithMaybeMatched--- > :: (Key -> x -> y -> Maybe z)--- > -> SimpleWhenMatched x y z------ @since 0.5.9-zipWithMaybeMatched- :: Applicative f- => (Key -> x -> y -> Maybe z)- -> WhenMatched f x y z-zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y-{-# INLINE zipWithMaybeMatched #-}----- | When a key is found in both maps, apply a function to the key--- and values, perform the resulting action, and maybe use the--- result in the merged map.------ This is the fundamental 'WhenMatched' tactic.------ @since 0.5.9-zipWithMaybeAMatched- :: (Key -> x -> y -> f (Maybe z))- -> WhenMatched f x y z-zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y-{-# INLINE zipWithMaybeAMatched #-}----- | Drop all the entries whose keys are missing from the other--- map.------ > dropMissing :: SimpleWhenMissing x y------ prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)------ but @dropMissing@ is much faster.------ @since 0.5.9-dropMissing :: Applicative f => WhenMissing f x y-dropMissing = WhenMissing- { missingSubtree = const (pure Nil)- , missingKey = \_ _ -> pure Nothing }-{-# INLINE dropMissing #-}----- | Preserve, unchanged, the entries whose keys are missing from--- the other map.------ > preserveMissing :: SimpleWhenMissing x x------ prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)------ but @preserveMissing@ is much faster.------ @since 0.5.9-preserveMissing :: Applicative f => WhenMissing f x x-preserveMissing = WhenMissing- { missingSubtree = pure- , missingKey = \_ v -> pure (Just v) }-{-# INLINE preserveMissing #-}----- | Map over the entries whose keys are missing from the other map.------ > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y------ prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)------ but @mapMissing@ is somewhat faster.------ @since 0.5.9-mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y-mapMissing f = WhenMissing- { missingSubtree = \m -> pure $! mapWithKey f m- , missingKey = \k x -> pure $ Just (f k x) }-{-# INLINE mapMissing #-}----- | Map over the entries whose keys are missing from the other--- map, optionally removing some. This is the most powerful--- 'SimpleWhenMissing' tactic, but others are usually more efficient.------ > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y------ prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))------ but @mapMaybeMissing@ uses fewer unnecessary 'Applicative'--- operations.------ @since 0.5.9-mapMaybeMissing- :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y-mapMaybeMissing f = WhenMissing- { missingSubtree = \m -> pure $! mapMaybeWithKey f m- , missingKey = \k x -> pure $! f k x }-{-# INLINE mapMaybeMissing #-}----- | Filter the entries whose keys are missing from the other map.------ > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x------ prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x------ but this should be a little faster.------ @since 0.5.9-filterMissing- :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x-filterMissing f = WhenMissing- { missingSubtree = \m -> pure $! filterWithKey f m- , missingKey = \k x -> pure $! if f k x then Just x else Nothing }-{-# INLINE filterMissing #-}----- | Filter the entries whose keys are missing from the other map--- using some 'Applicative' action.------ > filterAMissing f = Merge.Lazy.traverseMaybeMissing $--- > \k x -> (\b -> guard b *> Just x) <$> f k x------ but this should be a little faster.------ @since 0.5.9-filterAMissing- :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x-filterAMissing f = WhenMissing- { missingSubtree = \m -> filterWithKeyA f m- , missingKey = \k x -> bool Nothing (Just x) <$> f k x }-{-# INLINE filterAMissing #-}----- | /O(n)/. Filter keys and values using an 'Applicative' predicate.-filterWithKeyA- :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a)-filterWithKeyA _ Nil = pure Nil-filterWithKeyA f t@(Tip k x) = (\b -> if b then t else Nil) <$> f k x-filterWithKeyA f (Bin p m l r)- | m < 0 = liftA2 (flip (bin p m)) (filterWithKeyA f r) (filterWithKeyA f l)- | otherwise = liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r)---- | This wasn't in Data.Bool until 4.7.0, so we define it here-bool :: a -> a -> Bool -> a-bool f _ False = f-bool _ t True = t----- | Traverse over the entries whose keys are missing from the other--- map.------ @since 0.5.9-traverseMissing- :: Applicative f => (Key -> x -> f y) -> WhenMissing f x y-traverseMissing f = WhenMissing- { missingSubtree = traverseWithKey f- , missingKey = \k x -> Just <$> f k x }-{-# INLINE traverseMissing #-}----- | Traverse over the entries whose keys are missing from the other--- map, optionally producing values to put in the result. This is--- the most powerful 'WhenMissing' tactic, but others are usually--- more efficient.------ @since 0.5.9-traverseMaybeMissing- :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y-traverseMaybeMissing f = WhenMissing- { missingSubtree = traverseMaybeWithKey f- , missingKey = f }-{-# INLINE traverseMaybeMissing #-}----- | /O(n)/. Traverse keys\/values and collect the 'Just' results.------ @since 0.6.4-traverseMaybeWithKey- :: Applicative f => (Key -> a -> f (Maybe b)) -> IntMap a -> f (IntMap b)-traverseMaybeWithKey f = go- where- go Nil = pure Nil- go (Tip k x) = maybe Nil (Tip k) <$> f k x- go (Bin p m l r)- | m < 0 = liftA2 (flip (bin p m)) (go r) (go l)- | otherwise = liftA2 (bin p m) (go l) (go r)----- | Merge two maps.------ 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic--- and two maps. It uses the tactics to merge the maps. Its behavior--- is best understood via its fundamental tactics, 'mapMaybeMissing'--- and 'zipWithMaybeMatched'.------ Consider------ @--- merge (mapMaybeMissing g1)--- (mapMaybeMissing g2)--- (zipWithMaybeMatched f)--- m1 m2--- @------ Take, for example,------ @--- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ 'merge' will first \"align\" these maps by key:------ @--- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ It will then pass the individual entries and pairs of entries--- to @g1@, @g2@, or @f@ as appropriate:------ @--- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]--- @------ This produces a 'Maybe' for each key:------ @--- keys = 0 1 2 3 4--- results = [Nothing, Just True, Just False, Nothing, Just True]--- @------ Finally, the @Just@ results are collected into a map:------ @--- return value = [(1, True), (2, False), (4, True)]--- @------ The other tactics below are optimizations or simplifications of--- 'mapMaybeMissing' for special cases. Most importantly,------ * 'dropMissing' drops all the keys.--- * 'preserveMissing' leaves all the entries alone.------ When 'merge' is given three arguments, it is inlined at the call--- site. To prevent excessive inlining, you should typically use--- 'merge' to define your custom combining functions.--------- Examples:------ prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)--- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)--- prop> differenceWith f = merge diffPreserve diffDrop f--- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)--- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)------ @since 0.5.9-merge- :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@- -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@- -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@- -> IntMap a -- ^ Map @m1@- -> IntMap b -- ^ Map @m2@- -> IntMap c-merge g1 g2 f m1 m2 =- runIdentity $ mergeA g1 g2 f m1 m2-{-# INLINE merge #-}----- | An applicative version of 'merge'.------ 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'--- tactic and two maps. It uses the tactics to merge the maps.--- Its behavior is best understood via its fundamental tactics,--- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.------ Consider------ @--- mergeA (traverseMaybeMissing g1)--- (traverseMaybeMissing g2)--- (zipWithMaybeAMatched f)--- m1 m2--- @------ Take, for example,------ @--- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ 'mergeA' will first \"align\" these maps by key:------ @--- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ It will then pass the individual entries and pairs of entries--- to @g1@, @g2@, or @f@ as appropriate:------ @--- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]--- @------ Next, it will perform the actions in the @actions@ list in order from--- left to right.------ @--- keys = 0 1 2 3 4--- results = [Nothing, Just True, Just False, Nothing, Just True]--- @------ Finally, the @Just@ results are collected into a map:------ @--- return value = [(1, True), (2, False), (4, True)]--- @------ The other tactics below are optimizations or simplifications of--- 'traverseMaybeMissing' for special cases. Most importantly,------ * 'dropMissing' drops all the keys.--- * 'preserveMissing' leaves all the entries alone.--- * 'mapMaybeMissing' does not use the 'Applicative' context.------ When 'mergeA' is given three arguments, it is inlined at the call--- site. To prevent excessive inlining, you should generally only use--- 'mergeA' to define custom combining functions.------ @since 0.5.9-mergeA- :: (Applicative f)- => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@- -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@- -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@- -> IntMap a -- ^ Map @m1@- -> IntMap b -- ^ Map @m2@- -> f (IntMap c)-mergeA- WhenMissing{missingSubtree = g1t, missingKey = g1k}- WhenMissing{missingSubtree = g2t, missingKey = g2k}- WhenMatched{matchedKey = f}- = go- where- go t1 Nil = g1t t1- go Nil t2 = g2t t2-- -- This case is already covered below.- -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2-- go (Tip k1 x1) t2' = merge2 t2'- where- merge2 t2@(Bin p2 m2 l2 r2)- | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2)- | zero k1 m2 = binA p2 m2 (merge2 l2) (g2t r2)- | otherwise = binA p2 m2 (g2t l2) (merge2 r2)- merge2 (Tip k2 x2) = mergeTips k1 x1 k2 x2- merge2 Nil = subsingletonBy g1k k1 x1-- go t1' (Tip k2 x2) = merge1 t1'- where- merge1 t1@(Bin p1 m1 l1 r1)- | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2)- | zero k2 m1 = binA p1 m1 (merge1 l1) (g1t r1)- | otherwise = binA p1 m1 (g1t l1) (merge1 r1)- merge1 (Tip k1 x1) = mergeTips k1 x1 k2 x2- merge1 Nil = subsingletonBy g2k k2 x2-- go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)- | shorter m1 m2 = merge1- | shorter m2 m1 = merge2- | p1 == p2 = binA p1 m1 (go l1 l2) (go r1 r2)- | otherwise = linkA p1 (g1t t1) p2 (g2t t2)- where- merge1 | nomatch p2 p1 m1 = linkA p1 (g1t t1) p2 (g2t t2)- | zero p2 m1 = binA p1 m1 (go l1 t2) (g1t r1)- | otherwise = binA p1 m1 (g1t l1) (go r1 t2)- merge2 | nomatch p1 p2 m2 = linkA p1 (g1t t1) p2 (g2t t2)- | zero p1 m2 = binA p2 m2 (go t1 l2) (g2t r2)- | otherwise = binA p2 m2 (g2t l2) (go t1 r2)-- subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x- {-# INLINE subsingletonBy #-}-- mergeTips k1 x1 k2 x2- | k1 == k2 = maybe Nil (Tip k1) <$> f k1 x1 x2- | k1 < k2 = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2)- {-- = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2- -}- | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1)- {-# INLINE mergeTips #-}-- subdoubleton _ _ Nothing Nothing = Nil- subdoubleton _ k2 Nothing (Just y2) = Tip k2 y2- subdoubleton k1 _ (Just y1) Nothing = Tip k1 y1- subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2)- {-# INLINE subdoubleton #-}-- -- | A variant of 'link_' which makes sure to execute side-effects- -- in the right order.- linkA- :: Applicative f- => Prefix -> f (IntMap a)- -> Prefix -> f (IntMap a)- -> f (IntMap a)- linkA p1 t1 p2 t2- | zero p1 m = binA p m t1 t2- | otherwise = binA p m t2 t1- where- m = branchMask p1 p2- p = mask p1 m- {-# INLINE linkA #-}-- -- A variant of 'bin' that ensures that effects for negative keys are executed- -- first.- binA- :: Applicative f- => Prefix- -> Mask- -> f (IntMap a)- -> f (IntMap a)- -> f (IntMap a)- binA p m a b- | m < 0 = liftA2 (flip (bin p m)) b a- | otherwise = liftA2 (bin p m) a b- {-# INLINE binA #-}-{-# INLINE mergeA #-}---{--------------------------------------------------------------------- Min\/Max---------------------------------------------------------------------}---- | /O(min(n,W))/. Update the value at the minimal key.------ > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]--- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a-updateMinWithKey f t =- case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)- _ -> go f t- where- go f' (Bin p m l r) = binCheckLeft p m (go f' l) r- go f' (Tip k y) = case f' k y of- Just y' -> Tip k y'- Nothing -> Nil- go _ Nil = error "updateMinWithKey Nil"---- | /O(min(n,W))/. Update the value at the maximal key.------ > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]--- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a-updateMaxWithKey f t =- case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r- _ -> go f t- where- go f' (Bin p m l r) = binCheckRight p m l (go f' r)- go f' (Tip k y) = case f' k y of- Just y' -> Tip k y'- Nothing -> Nil- go _ Nil = error "updateMaxWithKey Nil"---data View a = View {-# UNPACK #-} !Key a !(IntMap a)---- | /O(min(n,W))/. Retrieves the maximal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")--- > maxViewWithKey empty == Nothing--maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)-maxViewWithKey t = case t of- Nil -> Nothing- _ -> Just $ case maxViewWithKeySure t of- View k v t' -> ((k, v), t')-{-# INLINE maxViewWithKey #-}--maxViewWithKeySure :: IntMap a -> View a-maxViewWithKeySure t =- case t of- Nil -> error "maxViewWithKeySure Nil"- Bin p m l r | m < 0 ->- case go l of View k a l' -> View k a (binCheckLeft p m l' r)- _ -> go t- where- go (Bin p m l r) =- case go r of View k a r' -> View k a (binCheckRight p m l r')- go (Tip k y) = View k y Nil- go Nil = error "maxViewWithKey_go Nil"--- See note on NOINLINE at minViewWithKeySure-{-# NOINLINE maxViewWithKeySure #-}---- | /O(min(n,W))/. Retrieves the minimal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")--- > minViewWithKey empty == Nothing--minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)-minViewWithKey t =- case t of- Nil -> Nothing- _ -> Just $ case minViewWithKeySure t of- View k v t' -> ((k, v), t')--- We inline this to give GHC the best possible chance of--- getting rid of the Maybe, pair, and Int constructors, as--- well as a thunk under the Just. That is, we really want to--- be certain this inlines!-{-# INLINE minViewWithKey #-}--minViewWithKeySure :: IntMap a -> View a-minViewWithKeySure t =- case t of- Nil -> error "minViewWithKeySure Nil"- Bin p m l r | m < 0 ->- case go r of- View k a r' -> View k a (binCheckRight p m l r')- _ -> go t- where- go (Bin p m l r) =- case go l of View k a l' -> View k a (binCheckLeft p m l' r)- go (Tip k y) = View k y Nil- go Nil = error "minViewWithKey_go Nil"--- There's never anything significant to be gained by inlining--- this. Sufficiently recent GHC versions will inline the wrapper--- anyway, which should be good enough.-{-# NOINLINE minViewWithKeySure #-}---- | /O(min(n,W))/. Update the value at the maximal key.------ > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]--- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a-updateMax f = updateMaxWithKey (const f)---- | /O(min(n,W))/. Update the value at the minimal key.------ > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]--- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a-updateMin f = updateMinWithKey (const f)---- | /O(min(n,W))/. Retrieves the maximal key of the map, and the map--- stripped of that element, or 'Nothing' if passed an empty map.-maxView :: IntMap a -> Maybe (a, IntMap a)-maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t)---- | /O(min(n,W))/. Retrieves the minimal key of the map, and the map--- stripped of that element, or 'Nothing' if passed an empty map.-minView :: IntMap a -> Maybe (a, IntMap a)-minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t)---- | /O(min(n,W))/. Delete and find the maximal element.--- This function throws an error if the map is empty. Use 'maxViewWithKey'--- if the map may be empty.-deleteFindMax :: IntMap a -> ((Key, a), IntMap a)-deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey---- | /O(min(n,W))/. Delete and find the minimal element.--- This function throws an error if the map is empty. Use 'minViewWithKey'--- if the map may be empty.-deleteFindMin :: IntMap a -> ((Key, a), IntMap a)-deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey---- | /O(min(n,W))/. The minimal key of the map. Returns 'Nothing' if the map is empty.-lookupMin :: IntMap a -> Maybe (Key, a)-lookupMin Nil = Nothing-lookupMin (Tip k v) = Just (k,v)-lookupMin (Bin _ m l r)- | m < 0 = go r- | otherwise = go l- where go (Tip k v) = Just (k,v)- go (Bin _ _ l' _) = go l'- go Nil = Nothing---- | /O(min(n,W))/. The minimal key of the map. Calls 'error' if the map is empty.--- Use 'minViewWithKey' if the map may be empty.-findMin :: IntMap a -> (Key, a)-findMin t- | Just r <- lookupMin t = r- | otherwise = error "findMin: empty map has no minimal element"---- | /O(min(n,W))/. The maximal key of the map. Returns 'Nothing' if the map is empty.-lookupMax :: IntMap a -> Maybe (Key, a)-lookupMax Nil = Nothing-lookupMax (Tip k v) = Just (k,v)-lookupMax (Bin _ m l r)- | m < 0 = go l- | otherwise = go r- where go (Tip k v) = Just (k,v)- go (Bin _ _ _ r') = go r'- go Nil = Nothing---- | /O(min(n,W))/. The maximal key of the map. Calls 'error' if the map is empty.--- Use 'maxViewWithKey' if the map may be empty.-findMax :: IntMap a -> (Key, a)-findMax t- | Just r <- lookupMax t = r- | otherwise = error "findMax: empty map has no maximal element"---- | /O(min(n,W))/. Delete the minimal key. Returns an empty map if the map is empty.------ Note that this is a change of behaviour for consistency with 'Data.Map.Map' –--- versions prior to 0.5 threw an error if the 'IntMap' was already empty.-deleteMin :: IntMap a -> IntMap a-deleteMin = maybe Nil snd . minView---- | /O(min(n,W))/. Delete the maximal key. Returns an empty map if the map is empty.------ Note that this is a change of behaviour for consistency with 'Data.Map.Map' –--- versions prior to 0.5 threw an error if the 'IntMap' was already empty.-deleteMax :: IntMap a -> IntMap a-deleteMax = maybe Nil snd . maxView---{--------------------------------------------------------------------- Submap---------------------------------------------------------------------}--- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).--- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).-isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool-isProperSubmapOf m1 m2- = isProperSubmapOfBy (==) m1 m2--{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when- @keys m1@ and @keys m2@ are not equal,- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following- expressions are all 'True':-- > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])- > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-- But the following are all 'False':-- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])- > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])--}-isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool-isProperSubmapOfBy predicate t1 t2- = case submapCmp predicate t1 t2 of- LT -> True- _ -> False--submapCmp :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Ordering-submapCmp predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- | shorter m1 m2 = GT- | shorter m2 m1 = submapCmpLt- | p1 == p2 = submapCmpEq- | otherwise = GT -- disjoint- where- submapCmpLt | nomatch p1 p2 m2 = GT- | zero p1 m2 = submapCmp predicate t1 l2- | otherwise = submapCmp predicate t1 r2- submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of- (GT,_ ) -> GT- (_ ,GT) -> GT- (EQ,EQ) -> EQ- _ -> LT--submapCmp _ (Bin _ _ _ _) _ = GT-submapCmp predicate (Tip kx x) (Tip ky y)- | (kx == ky) && predicate x y = EQ- | otherwise = GT -- disjoint-submapCmp predicate (Tip k x) t- = case lookup k t of- Just y | predicate x y -> LT- _ -> GT -- disjoint-submapCmp _ Nil Nil = EQ-submapCmp _ Nil _ = LT---- | /O(n+m)/. Is this a submap?--- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).-isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool-isSubmapOf m1 m2- = isSubmapOfBy (==) m1 m2--{- | /O(n+m)/.- The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following- expressions are all 'True':-- > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])- > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])- > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])-- But the following are all 'False':-- > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])- > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])- > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])--}-isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool-isSubmapOfBy predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- | shorter m1 m2 = False- | shorter m2 m1 = match p1 p2 m2 &&- if zero p1 m2- then isSubmapOfBy predicate t1 l2- else isSubmapOfBy predicate t1 r2- | otherwise = (p1==p2) && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2-isSubmapOfBy _ (Bin _ _ _ _) _ = False-isSubmapOfBy predicate (Tip k x) t = case lookup k t of- Just y -> predicate x y- Nothing -> False-isSubmapOfBy _ Nil _ = True--{--------------------------------------------------------------------- Mapping---------------------------------------------------------------------}--- | /O(n)/. Map a function over all values in the map.------ > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]--map :: (a -> b) -> IntMap a -> IntMap b-map f = go- where- go (Bin p m l r) = Bin p m (go l) (go r)- go (Tip k x) = Tip k (f x)- go Nil = Nil--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] map #-}-{-# RULES-"map/map" forall f g xs . map f (map g xs) = map (f . g) xs- #-}-#endif-#if __GLASGOW_HASKELL__ >= 709--- Safe coercions were introduced in 7.8, but did not play well with RULES yet.-{-# RULES-"map/coerce" map coerce = coerce- #-}-#endif---- | /O(n)/. Map a function over all values in the map.------ > let f key x = (show key) ++ ":" ++ x--- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]--mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b-mapWithKey f t- = case t of- Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)- Tip k x -> Tip k (f k x)- Nil -> Nil--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] mapWithKey #-}-{-# RULES-"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =- mapWithKey (\k a -> f k (g k a)) xs-"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =- mapWithKey (\k a -> f k (g a)) xs-"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =- mapWithKey (\k a -> f (g k a)) xs- #-}-#endif---- | /O(n)/.--- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@--- That is, behaves exactly like a regular 'traverse' except that the traversing--- function also has access to the key associated with a value.------ > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])--- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing-traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b)-traverseWithKey f = go- where- go Nil = pure Nil- go (Tip k v) = Tip k <$> f k v- go (Bin p m l r)- | m < 0 = liftA2 (flip (Bin p m)) (go r) (go l)- | otherwise = liftA2 (Bin p m) (go l) (go r)-{-# INLINE traverseWithKey #-}---- | /O(n)/. The function @'mapAccum'@ threads an accumulating--- argument through the map in ascending order of keys.------ > let f a b = (a ++ b, b ++ "X")--- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])--mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)---- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating--- argument through the map in ascending order of keys.------ > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])--mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccumWithKey f a t- = mapAccumL f a t---- | /O(n)/. The function @'mapAccumL'@ threads an accumulating--- argument through the map in ascending order of keys.-mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccumL f a t- = case t of- Bin p m l r- | m < 0 ->- let (a1,r') = mapAccumL f a r- (a2,l') = mapAccumL f a1 l- in (a2,Bin p m l' r')- | otherwise ->- let (a1,l') = mapAccumL f a l- (a2,r') = mapAccumL f a1 r- in (a2,Bin p m l' r')- Tip k x -> let (a',x') = f a k x in (a',Tip k x')- Nil -> (a,Nil)---- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating--- argument through the map in descending order of keys.-mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccumRWithKey f a t- = case t of- Bin p m l r- | m < 0 ->- let (a1,l') = mapAccumRWithKey f a l- (a2,r') = mapAccumRWithKey f a1 r- in (a2,Bin p m l' r')- | otherwise ->- let (a1,r') = mapAccumRWithKey f a r- (a2,l') = mapAccumRWithKey f a1 l- in (a2,Bin p m l' r')- Tip k x -> let (a',x') = f a k x in (a',Tip k x')- Nil -> (a,Nil)---- | /O(n*min(n,W))/.--- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key. In this case the value at the greatest of the--- original keys is retained.------ > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]--- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"--- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"--mapKeys :: (Key->Key) -> IntMap a -> IntMap a-mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []---- | /O(n*min(n,W))/.--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key. In this case the associated values will be--- combined using @c@.------ > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"--mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a-mapKeysWith c f- = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []---- | /O(n*min(n,W))/.--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@--- is strictly monotonic.--- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.--- /The precondition is not checked./--- Semi-formally, we have:------ > and [x < y ==> f x < f y | x <- ls, y <- ls]--- > ==> mapKeysMonotonic f s == mapKeys f s--- > where ls = keys s------ This means that @f@ maps distinct original keys to distinct resulting keys.--- This function has slightly better performance than 'mapKeys'.------ > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]--mapKeysMonotonic :: (Key->Key) -> IntMap a -> IntMap a-mapKeysMonotonic f- = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) []--{--------------------------------------------------------------------- Filter---------------------------------------------------------------------}--- | /O(n)/. Filter all values that satisfy some predicate.------ > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty--- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty--filter :: (a -> Bool) -> IntMap a -> IntMap a-filter p m- = filterWithKey (\_ x -> p x) m---- | /O(n)/. Filter all keys\/values that satisfy some predicate.------ > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a-filterWithKey predicate = go- where- go Nil = Nil- go t@(Tip k x) = if predicate k x then t else Nil- go (Bin p m l r) = bin p m (go l) (go r)---- | /O(n)/. Partition the map according to some predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)-partition p m- = partitionWithKey (\_ x -> p x) m---- | /O(n)/. Partition the map according to some predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")--- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)-partitionWithKey predicate0 t0 = toPair $ go predicate0 t0- where- go predicate t =- case t of- Bin p m l r ->- let (l1 :*: l2) = go predicate l- (r1 :*: r2) = go predicate r- in bin p m l1 r1 :*: bin p m l2 r2- Tip k x- | predicate k x -> (t :*: Nil)- | otherwise -> (Nil :*: t)- Nil -> (Nil :*: Nil)---- | /O(n)/. Map values and collect the 'Just' results.------ > let f x = if x == "a" then Just "new a" else Nothing--- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"--mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b-mapMaybe f = mapMaybeWithKey (\_ x -> f x)---- | /O(n)/. Map keys\/values and collect the 'Just' results.------ > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing--- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"--mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b-mapMaybeWithKey f (Bin p m l r)- = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)-mapMaybeWithKey f (Tip k x) = case f k x of- Just y -> Tip k y- Nothing -> Nil-mapMaybeWithKey _ Nil = Nil---- | /O(n)/. Map values and separate the 'Left' and 'Right' results.------ > let f a = if a < "c" then Left a else Right a--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])--- >--- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)-mapEither f m- = mapEitherWithKey (\_ x -> f x) m---- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.------ > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])--- >--- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])--mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)-mapEitherWithKey f0 t0 = toPair $ go f0 t0- where- go f (Bin p m l r) =- bin p m l1 r1 :*: bin p m l2 r2- where- (l1 :*: l2) = go f l- (r1 :*: r2) = go f r- go f (Tip k x) = case f k x of- Left y -> (Tip k y :*: Nil)- Right z -> (Nil :*: Tip k z)- go _ Nil = (Nil :*: Nil)---- | /O(min(n,W))/. The expression (@'split' k map@) is a pair @(map1,map2)@--- where all keys in @map1@ are lower than @k@ and all keys in--- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.------ > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])--- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")--- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)--- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)--split :: Key -> IntMap a -> (IntMap a, IntMap a)-split k t =- case t of- Bin _ m l r- | m < 0 ->- if k >= 0 -- handle negative numbers.- then- case go k l of- (lt :*: gt) ->- let !lt' = union r lt- in (lt', gt)- else- case go k r of- (lt :*: gt) ->- let !gt' = union gt l- in (lt, gt')- _ -> case go k t of- (lt :*: gt) -> (lt, gt)- where- go k' t'@(Bin p m l r)- | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t'- | zero k' m = case go k' l of (lt :*: gt) -> lt :*: union gt r- | otherwise = case go k' r of (lt :*: gt) -> union l lt :*: gt- go k' t'@(Tip ky _)- | k' > ky = (t' :*: Nil)- | k' < ky = (Nil :*: t')- | otherwise = (Nil :*: Nil)- go _ Nil = (Nil :*: Nil)---data SplitLookup a = SplitLookup !(IntMap a) !(Maybe a) !(IntMap a)--mapLT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a-mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt-{-# INLINE mapLT #-}--mapGT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a-mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt)-{-# INLINE mapGT #-}---- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot--- key was found in the original map.------ > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])--- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")--- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")--- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)--- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)--splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a)-splitLookup k t =- case- case t of- Bin _ m l r- | m < 0 ->- if k >= 0 -- handle negative numbers.- then mapLT (union r) (go k l)- else mapGT (`union` l) (go k r)- _ -> go k t- of SplitLookup lt fnd gt -> (lt, fnd, gt)- where- go k' t'@(Bin p m l r)- | nomatch k' p m =- if k' > p- then SplitLookup t' Nothing Nil- else SplitLookup Nil Nothing t'- | zero k' m = mapGT (`union` r) (go k' l)- | otherwise = mapLT (union l) (go k' r)- go k' t'@(Tip ky y)- | k' > ky = SplitLookup t' Nothing Nil- | k' < ky = SplitLookup Nil Nothing t'- | otherwise = SplitLookup Nil (Just y) Nil- go _ Nil = SplitLookup Nil Nothing Nil--{--------------------------------------------------------------------- Fold---------------------------------------------------------------------}--- | /O(n)/. Fold the values in the map using the given right-associative--- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.------ For example,------ > elems map = foldr (:) [] map------ > let f a len = len + (length a)--- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-foldr :: (a -> b -> b) -> b -> IntMap a -> b-foldr f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of- Bin _ m l r- | m < 0 -> go (go z l) r -- put negative numbers before- | otherwise -> go (go z r) l- _ -> go z t- where- go z' Nil = z'- go z' (Tip _ x) = f x z'- go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr #-}---- | /O(n)/. A strict version of 'foldr'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldr' :: (a -> b -> b) -> b -> IntMap a -> b-foldr' f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of- Bin _ m l r- | m < 0 -> go (go z l) r -- put negative numbers before- | otherwise -> go (go z r) l- _ -> go z t- where- go !z' Nil = z'- go z' (Tip _ x) = f x z'- go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr' #-}---- | /O(n)/. Fold the values in the map using the given left-associative--- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.------ For example,------ > elems = reverse . foldl (flip (:)) []------ > let f len a = len + (length a)--- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-foldl :: (a -> b -> a) -> a -> IntMap b -> a-foldl f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of- Bin _ m l r- | m < 0 -> go (go z r) l -- put negative numbers before- | otherwise -> go (go z l) r- _ -> go z t- where- go z' Nil = z'- go z' (Tip _ x) = f z' x- go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl #-}---- | /O(n)/. A strict version of 'foldl'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldl' :: (a -> b -> a) -> a -> IntMap b -> a-foldl' f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of- Bin _ m l r- | m < 0 -> go (go z r) l -- put negative numbers before- | otherwise -> go (go z l) r- _ -> go z t- where- go !z' Nil = z'- go z' (Tip _ x) = f z' x- go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl' #-}---- | /O(n)/. Fold the keys and values in the map using the given right-associative--- binary operator, such that--- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.------ For example,------ > keys map = foldrWithKey (\k x ks -> k:ks) [] map------ > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"-foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b-foldrWithKey f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of- Bin _ m l r- | m < 0 -> go (go z l) r -- put negative numbers before- | otherwise -> go (go z r) l- _ -> go z t- where- go z' Nil = z'- go z' (Tip kx x) = f kx x z'- go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldrWithKey #-}---- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b-foldrWithKey' f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of- Bin _ m l r- | m < 0 -> go (go z l) r -- put negative numbers before- | otherwise -> go (go z r) l- _ -> go z t- where- go !z' Nil = z'- go z' (Tip kx x) = f kx x z'- go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldrWithKey' #-}---- | /O(n)/. Fold the keys and values in the map using the given left-associative--- binary operator, such that--- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.------ For example,------ > keys = reverse . foldlWithKey (\ks k x -> k:ks) []------ > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"-foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a-foldlWithKey f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of- Bin _ m l r- | m < 0 -> go (go z r) l -- put negative numbers before- | otherwise -> go (go z l) r- _ -> go z t- where- go z' Nil = z'- go z' (Tip kx x) = f z' kx x- go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldlWithKey #-}---- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a-foldlWithKey' f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of- Bin _ m l r- | m < 0 -> go (go z r) l -- put negative numbers before- | otherwise -> go (go z l) r- _ -> go z t- where- go !z' Nil = z'- go z' (Tip kx x) = f z' kx x- go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldlWithKey' #-}---- | /O(n)/. Fold the keys and values in the map using the given monoid, such that------ @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@------ This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.------ @since 0.5.4-foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m-foldMapWithKey f = go- where- go Nil = mempty- go (Tip kx x) = f kx x- go (Bin _ m l r)- | m < 0 = go r `mappend` go l- | otherwise = go l `mappend` go r-{-# INLINE foldMapWithKey #-}--{--------------------------------------------------------------------- List variations---------------------------------------------------------------------}--- | /O(n)/.--- Return all elements of the map in the ascending order of their keys.--- Subject to list fusion.------ > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]--- > elems empty == []--elems :: IntMap a -> [a]-elems = foldr (:) []---- | /O(n)/. Return all keys of the map in ascending order. Subject to list--- fusion.------ > keys (fromList [(5,"a"), (3,"b")]) == [3,5]--- > keys empty == []--keys :: IntMap a -> [Key]-keys = foldrWithKey (\k _ ks -> k : ks) []---- | /O(n)/. An alias for 'toAscList'. Returns all key\/value pairs in the--- map in ascending key order. Subject to list fusion.------ > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > assocs empty == []--assocs :: IntMap a -> [(Key,a)]-assocs = toAscList---- | /O(n*min(n,W))/. The set of all keys of the map.------ > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]--- > keysSet empty == Data.IntSet.empty--keysSet :: IntMap a -> IntSet.IntSet-keysSet Nil = IntSet.Nil-keysSet (Tip kx _) = IntSet.singleton kx-keysSet (Bin p m l r)- | m .&. IntSet.suffixBitMask == 0 = IntSet.Bin p m (keysSet l) (keysSet r)- | otherwise = IntSet.Tip (p .&. IntSet.prefixBitMask) (computeBm (computeBm 0 l) r)- where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'- computeBm acc (Tip kx _) = acc .|. IntSet.bitmapOf kx- computeBm _ Nil = error "Data.IntSet.keysSet: Nil"---- | /O(n)/. Build a map from a set of keys and a function which for each key--- computes its value.------ > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]--- > fromSet undefined Data.IntSet.empty == empty--fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a-fromSet _ IntSet.Nil = Nil-fromSet f (IntSet.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)-fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)- where- -- This is slightly complicated, as we to convert the dense- -- representation of IntSet into tree representation of IntMap.- --- -- We are given a nonzero bit mask 'bmask' of 'bits' bits with- -- prefix 'prefix'. We split bmask into halves corresponding- -- to left and right subtree. If they are both nonempty, we- -- create a Bin node, otherwise exactly one of them is nonempty- -- and we construct the IntMap from that half.- buildTree g !prefix !bmask bits = case bits of- 0 -> Tip prefix (g prefix)- _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of- bits2- | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->- buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2- | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->- buildTree g prefix bmask bits2- | otherwise ->- Bin prefix bits2- (buildTree g prefix bmask bits2)- (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)--{--------------------------------------------------------------------- Lists---------------------------------------------------------------------}-#if __GLASGOW_HASKELL__ >= 708--- | @since 0.5.6.2-instance GHCExts.IsList (IntMap a) where- type Item (IntMap a) = (Key,a)- fromList = fromList- toList = toList-#endif---- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list--- fusion.------ > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > toList empty == []--toList :: IntMap a -> [(Key,a)]-toList = toAscList---- | /O(n)/. Convert the map to a list of key\/value pairs where the--- keys are in ascending order. Subject to list fusion.------ > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--toAscList :: IntMap a -> [(Key,a)]-toAscList = foldrWithKey (\k x xs -> (k,x):xs) []---- | /O(n)/. Convert the map to a list of key\/value pairs where the keys--- are in descending order. Subject to list fusion.------ > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]--toDescList :: IntMap a -> [(Key,a)]-toDescList = foldlWithKey (\xs k x -> (k,x):xs) []---- List fusion for the list generating functions.-#if __GLASGOW_HASKELL__--- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.--- They are important to convert unfused methods back, see mapFB in prelude.-foldrFB :: (Key -> a -> b -> b) -> b -> IntMap a -> b-foldrFB = foldrWithKey-{-# INLINE[0] foldrFB #-}-foldlFB :: (a -> Key -> b -> a) -> a -> IntMap b -> a-foldlFB = foldlWithKey-{-# INLINE[0] foldlFB #-}---- Inline assocs and toList, so that we need to fuse only toAscList.-{-# INLINE assocs #-}-{-# INLINE toList #-}---- The fusion is enabled up to phase 2 included. If it does not succeed,--- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to--- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were--- used in a list fusion, otherwise it would go away in phase 1), and let compiler--- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to--- inline it before phase 0, otherwise the fusion rules would not fire at all.-{-# NOINLINE[0] elems #-}-{-# NOINLINE[0] keys #-}-{-# NOINLINE[0] toAscList #-}-{-# NOINLINE[0] toDescList #-}-{-# RULES "IntMap.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}-{-# RULES "IntMap.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}-{-# RULES "IntMap.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}-{-# RULES "IntMap.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}-{-# RULES "IntMap.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}-{-# RULES "IntMap.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}-{-# RULES "IntMap.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}-{-# RULES "IntMap.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}-#endif----- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.------ > fromList [] == empty--- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]--- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]--fromList :: [(Key,a)] -> IntMap a-fromList xs- = Foldable.foldl' ins empty xs- where- ins t (k,x) = insert k x t---- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.------ > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")]--- > fromListWith (++) [] == empty--fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a-fromListWith f xs- = fromListWithKey (\_ x y -> f x y) xs---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]--- > fromListWithKey f [] == empty--fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a-fromListWithKey f xs- = Foldable.foldl' ins empty xs- where- ins t (k,x) = insertWithKey f k x t---- | /O(n)/. Build a map from a list of key\/value pairs where--- the keys are in ascending order.------ > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]--fromAscList :: [(Key,a)] -> IntMap a-fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)-{-# NOINLINE fromAscList #-}---- | /O(n)/. Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./------ > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]--fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a-fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)-{-# NOINLINE fromAscListWith #-}---- | /O(n)/. Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")]--fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a-fromAscListWithKey f = fromMonoListWithKey Nondistinct f-{-# NOINLINE fromAscListWithKey #-}---- | /O(n)/. Build a map from a list of key\/value pairs where--- the keys are in ascending order and all distinct.--- /The precondition (input list is strictly ascending) is not checked./------ > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]--fromDistinctAscList :: [(Key,a)] -> IntMap a-fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)-{-# NOINLINE fromDistinctAscList #-}---- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys--- and a combining function.------ The precise conditions under which this function works are subtle:--- For any branch mask, keys with the same prefix w.r.t. the branch--- mask must occur consecutively in the list.--fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a-fromMonoListWithKey distinct f = go- where- go [] = Nil- go ((kx,vx) : zs1) = addAll' kx vx zs1-- -- `addAll'` collects all keys equal to `kx` into a single value,- -- and then proceeds with `addAll`.- addAll' !kx vx []- = Tip kx vx- addAll' !kx vx ((ky,vy) : zs)- | Nondistinct <- distinct, kx == ky- = let v = f kx vy vx in addAll' ky v zs- -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)- | m <- branchMask kx ky- , Inserted ty zs' <- addMany' m ky vy zs- = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx vx)) zs'-- -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`- -- `addAll` consumes the rest of the list, adding to the tree `tx`- addAll !_kx !tx []- = tx- addAll !kx !tx ((ky,vy) : zs)- | m <- branchMask kx ky- , Inserted ty zs' <- addMany' m ky vy zs- = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'-- -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.- addMany' !_m !kx vx []- = Inserted (Tip kx vx) []- addMany' !m !kx vx zs0@((ky,vy) : zs)- | Nondistinct <- distinct, kx == ky- = let v = f kx vy vx in addMany' m ky v zs- -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)- | mask kx m /= mask ky m- = Inserted (Tip kx vx) zs0- | mxy <- branchMask kx ky- , Inserted ty zs' <- addMany' mxy ky vy zs- = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx vx)) zs'-- -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.- addMany !_m !_kx tx []- = Inserted tx []- addMany !m !kx tx zs0@((ky,vy) : zs)- | mask kx m /= mask ky m- = Inserted tx zs0- | mxy <- branchMask kx ky- , Inserted ty zs' <- addMany' mxy ky vy zs- = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'-{-# INLINE fromMonoListWithKey #-}--data Inserted a = Inserted !(IntMap a) ![(Key,a)]--data Distinct = Distinct | Nondistinct--{--------------------------------------------------------------------- Eq---------------------------------------------------------------------}-instance Eq a => Eq (IntMap a) where- t1 == t2 = equal t1 t2- t1 /= t2 = nequal t1 t2--equal :: Eq a => IntMap a -> IntMap a -> Bool-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)-equal (Tip kx x) (Tip ky y)- = (kx == ky) && (x==y)-equal Nil Nil = True-equal _ _ = False--nequal :: Eq a => IntMap a -> IntMap a -> Bool-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)-nequal (Tip kx x) (Tip ky y)- = (kx /= ky) || (x/=y)-nequal Nil Nil = False-nequal _ _ = True--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Eq1 IntMap where- liftEq eq (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- = (m1 == m2) && (p1 == p2) && (liftEq eq l1 l2) && (liftEq eq r1 r2)- liftEq eq (Tip kx x) (Tip ky y)- = (kx == ky) && (eq x y)- liftEq _eq Nil Nil = True- liftEq _eq _ _ = False-#endif--{--------------------------------------------------------------------- Ord---------------------------------------------------------------------}--instance Ord a => Ord (IntMap a) where- compare m1 m2 = compare (toList m1) (toList m2)--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Ord1 IntMap where- liftCompare cmp m n =- liftCompare (liftCompare cmp) (toList m) (toList n)-#endif--{--------------------------------------------------------------------- Functor---------------------------------------------------------------------}--instance Functor IntMap where- fmap = map--#ifdef __GLASGOW_HASKELL__- a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r)- a <$ Tip k _ = Tip k a- _ <$ Nil = Nil-#endif--{--------------------------------------------------------------------- Show---------------------------------------------------------------------}--instance Show a => Show (IntMap a) where- showsPrec d m = showParen (d > 10) $- showString "fromList " . shows (toList m)--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Show1 IntMap where- liftShowsPrec sp sl d m =- showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)- where- sp' = liftShowsPrec sp sl- sl' = liftShowList sp sl-#endif--{--------------------------------------------------------------------- Read---------------------------------------------------------------------}-instance (Read e) => Read (IntMap e) where-#ifdef __GLASGOW_HASKELL__- readPrec = parens $ prec 10 $ do- Ident "fromList" <- lexP- xs <- readPrec- return (fromList xs)-- readListPrec = readListPrecDefault-#else- readsPrec p = readParen (p > 10) $ \ r -> do- ("fromList",s) <- lex r- (xs,t) <- reads s- return (fromList xs,t)-#endif--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Read1 IntMap where- liftReadsPrec rp rl = readsData $- readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList- where- rp' = liftReadsPrec rp rl- rl' = liftReadList rp rl-#endif--{--------------------------------------------------------------------- Typeable---------------------------------------------------------------------}--INSTANCE_TYPEABLE1(IntMap)--{--------------------------------------------------------------------- Helpers---------------------------------------------------------------------}-{--------------------------------------------------------------------- Link---------------------------------------------------------------------}-link :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a-link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2-{-# INLINE link #-}---- `linkWithMask` is useful when the `branchMask` has already been computed-linkWithMask :: Mask -> Prefix -> IntMap a -> IntMap a -> IntMap a-linkWithMask m p1 t1 {-p2-} t2- | zero p1 m = Bin p m t1 t2- | otherwise = Bin p m t2 t1- where- p = mask p1 m-{-# INLINE linkWithMask #-}--{--------------------------------------------------------------------- @bin@ assures that we never have empty trees within a tree.---------------------------------------------------------------------}-bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a-bin _ _ l Nil = l-bin _ _ Nil r = r-bin p m l r = Bin p m l r-{-# INLINE bin #-}---- binCheckLeft only checks that the left subtree is non-empty-binCheckLeft :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a-binCheckLeft _ _ Nil r = r-binCheckLeft p m l r = Bin p m l r-{-# INLINE binCheckLeft #-}---- binCheckRight only checks that the right subtree is non-empty-binCheckRight :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a-binCheckRight _ _ l Nil = l-binCheckRight p m l r = Bin p m l r-{-# INLINE binCheckRight #-}--{--------------------------------------------------------------------- Endian independent bit twiddling---------------------------------------------------------------------}---- | Should this key follow the left subtree of a 'Bin' with switching--- bit @m@? N.B., the answer is only valid when @match i p m@ is true.-zero :: Key -> Mask -> Bool-zero i m- = (natFromInt i) .&. (natFromInt m) == 0-{-# INLINE zero #-}--nomatch,match :: Key -> Prefix -> Mask -> Bool---- | Does the key @i@ differ from the prefix @p@ before getting to--- the switching bit @m@?-nomatch i p m- = (mask i m) /= p-{-# INLINE nomatch #-}---- | Does the key @i@ match the prefix @p@ (up to but not including--- bit @m@)?-match i p m- = (mask i m) == p-{-# INLINE match #-}----- | The prefix of key @i@ up to (but not including) the switching--- bit @m@.-mask :: Key -> Mask -> Prefix-mask i m- = maskW (natFromInt i) (natFromInt m)-{-# INLINE mask #-}---{--------------------------------------------------------------------- Big endian operations---------------------------------------------------------------------}---- | The prefix of key @i@ up to (but not including) the switching--- bit @m@.-maskW :: Nat -> Nat -> Prefix-maskW i m- = intFromNat (i .&. ((-m) `xor` m))-{-# INLINE maskW #-}---- | Does the left switching bit specify a shorter prefix?-shorter :: Mask -> Mask -> Bool-shorter m1 m2- = (natFromInt m1) > (natFromInt m2)-{-# INLINE shorter #-}---- | The first switching bit where the two prefixes disagree.-branchMask :: Prefix -> Prefix -> Mask-branchMask p1 p2- = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))-{-# INLINE branchMask #-}--{--------------------------------------------------------------------- Utilities---------------------------------------------------------------------}---- | /O(1)/. Decompose a map into pieces based on the structure--- of the underlying tree. This function is useful for consuming a--- map in parallel.------ No guarantee is made as to the sizes of the pieces; an internal, but--- deterministic process determines this. However, it is guaranteed that the--- pieces returned will be in ascending order (all elements in the first submap--- less than all elements in the second, and so on).------ Examples:------ > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==--- > [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]------ > splitRoot empty == []------ Note that the current implementation does not return more than two submaps,--- but you should not depend on this behaviour because it can change in the--- future without notice.-splitRoot :: IntMap a -> [IntMap a]-splitRoot orig =- case orig of- Nil -> []- x@(Tip _ _) -> [x]- Bin _ m l r | m < 0 -> [r, l]- | otherwise -> [l, r]-{-# INLINE splitRoot #-}---{--------------------------------------------------------------------- Debugging---------------------------------------------------------------------}---- | /O(n)/. Show the tree that implements the map. The tree is shown--- in a compressed, hanging format.-showTree :: Show a => IntMap a -> String-showTree s- = showTreeWith True False s---{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows- the tree that implements the map. If @hang@ is- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If- @wide@ is 'True', an extra wide version is shown.--}-showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String-showTreeWith hang wide t- | hang = (showsTreeHang wide [] t) ""- | otherwise = (showsTree wide [] [] t) ""--showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS-showsTree wide lbars rbars t = case t of- Bin p m l r ->- showsTree wide (withBar rbars) (withEmpty rbars) r .- showWide wide rbars .- showsBars lbars . showString (showBin p m) . showString "\n" .- showWide wide lbars .- showsTree wide (withEmpty lbars) (withBar lbars) l- Tip k x ->- showsBars lbars .- showString " " . shows k . showString ":=" . shows x . showString "\n"- Nil -> showsBars lbars . showString "|\n"--showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS-showsTreeHang wide bars t = case t of- Bin p m l r ->- showsBars bars . showString (showBin p m) . showString "\n" .- showWide wide bars .- showsTreeHang wide (withBar bars) l .- showWide wide bars .- showsTreeHang wide (withEmpty bars) r- Tip k x ->- showsBars bars .- showString " " . shows k . showString ":=" . shows x . showString "\n"- Nil -> showsBars bars . showString "|\n"--showBin :: Prefix -> Mask -> String-showBin _ _- = "*" -- ++ show (p,m)--showWide :: Bool -> [String] -> String -> String-showWide wide bars- | wide = showString (concat (reverse bars)) . showString "|\n"- | otherwise = id--showsBars :: [String] -> ShowS-showsBars bars- = case bars of- [] -> id- _ -> showString (concat (reverse (tail bars))) . showString node--node :: String-node = "+--"--withBar, withEmpty :: [String] -> [String]-withBar bars = "| ":bars-withEmpty bars = " ":bars+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module : Data.IntMap.Internal+-- Copyright : (c) Daan Leijen 2002+-- (c) Andriy Palamarchuk 2008+-- (c) wren romano 2016+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Portability : portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Int Maps (lazy interface internals)+--+-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @Int@ to values of type @v@.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/. This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. Additionally, benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced map implementation (see "Data.Map").+--+-- * Chris Okasaki and Andy Gill,+-- \"/Fast Mergeable Integer Maps/\",+-- Workshop on ML, September 1998, pages 77-86,+-- <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+-- * D.R. Morrison,+-- \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+-- Journal of the ACM, 15(4), October 1968, pages 514-534,+-- <https://doi.org/10.1145/321479.321481>.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of IntMap matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.+--++module Data.IntMap.Internal (+ -- * Map type+ IntMap(..) -- instance Eq,Show+ , Key++ -- * Operators+ , (!), (!?), (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault+ , lookupLT+ , lookupGT+ , lookupLE+ , lookupGE+ , disjoint++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWithKey+ , insertLookupWithKey++ -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter+ , alterF++ -- * Combine++ -- ** Union+ , union+ , unionWith+ , unionWithKey+ , unions+ , unionsWith++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey++ -- ** Intersection+ , intersection+ , intersectionWith+ , intersectionWithKey++ -- ** Symmetric difference+ , symmetricDifference++ -- ** Compose+ , compose++ -- ** General combining function+ , SimpleWhenMissing+ , SimpleWhenMatched+ , runWhenMatched+ , runWhenMissing+ , merge+ -- *** @WhenMatched@ tactics+ , zipWithMaybeMatched+ , zipWithMatched+ -- *** @WhenMissing@ tactics+ , mapMaybeMissing+ , dropMissing+ , preserveMissing+ , mapMissing+ , filterMissing++ -- ** Applicative general combining function+ , WhenMissing (..)+ , WhenMatched (..)+ , mergeA+ -- *** @WhenMatched@ tactics+ -- | The tactics described for 'merge' work for+ -- 'mergeA' as well. Furthermore, the following+ -- are available.+ , zipWithMaybeAMatched+ , zipWithAMatched+ -- *** @WhenMissing@ tactics+ -- | The tactics described for 'merge' work for+ -- 'mergeA' as well. Furthermore, the following+ -- are available.+ , traverseMaybeMissing+ , traverseMissing+ , filterAMissing++ -- ** Deprecated general combining function+ , mergeWithKey+ , mergeWithKey'++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , traverseWithKey+ , traverseMaybeWithKey+ , mapAccum+ , mapAccumWithKey+ , mapAccumRWithKey+ , mapKeys+ , mapKeysWith+ , mapKeysMonotonic++ -- * Folds+ , foldr+ , foldl+ , foldrWithKey+ , foldlWithKey+ , foldMapWithKey++ -- ** Strict folds+ , foldr'+ , foldl'+ , foldrWithKey'+ , foldlWithKey'++ -- * Conversion+ , elems+ , keys+ , assocs+ , keysSet+ , fromSet++ -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Ordered lists+ , toAscList+ , toDescList+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList++ -- * Filter+ , filter+ , filterKeys+ , filterWithKey+ , restrictKeys+ , withoutKeys+ , partition+ , partitionWithKey++ , takeWhileAntitone+ , dropWhileAntitone+ , spanAntitone++ , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey++ , split+ , splitLookup+ , splitRoot++ -- * Submap+ , isSubmapOf, isSubmapOfBy+ , isProperSubmapOf, isProperSubmapOfBy++ -- * Min\/Max+ , lookupMin+ , lookupMax+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey+ , minView+ , maxView+ , minViewWithKey+ , maxViewWithKey++ -- * Debugging+ , showTree+ , showTreeWith++ -- * Utility+ , link+ , linkKey+ , linkWithMask+ , bin+ , binCheckLeft+ , binCheckRight++ -- * Used by "IntMap.Merge.Lazy" and "IntMap.Merge.Strict"+ , mapWhenMissing+ , mapWhenMatched+ , lmapWhenMissing+ , contramapFirstWhenMatched+ , contramapSecondWhenMatched+ , mapGentlyWhenMissing+ , mapGentlyWhenMatched+ ) where++import Data.Functor.Identity (Identity (..))+import Data.Semigroup (Semigroup(stimes))+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+import Data.Semigroup (stimesIdempotentMonoid)+import Data.Functor.Classes++import Control.DeepSeq (NFData(rnf),NFData1(liftRnf))+import Data.Bits+import qualified Data.Foldable as Foldable+import Data.Maybe (fromMaybe)+import Utils.Containers.Internal.Prelude hiding+ (lookup, map, filter, foldr, foldl, foldl', null)+import Prelude ()++import qualified Data.IntSet.Internal as IntSet+import Data.IntSet.Internal.IntTreeCommons+ ( Key+ , Prefix(..)+ , nomatch+ , left+ , signBranch+ , mask+ , branchMask+ , TreeTreeBranch(..)+ , treeTreeBranch+ , i2w+ , Order(..)+ )+import Utils.Containers.Internal.BitUtil (shiftLL, shiftRL, iShiftRL)+import Utils.Containers.Internal.StrictPair++#ifdef __GLASGOW_HASKELL__+import Data.Coerce+import Data.Data (Data(..), Constr, mkConstr, constrIndex,+ DataType, mkDataType, gcast1)+import qualified Data.Data as Data+import GHC.Exts (build)+import qualified GHC.Exts as GHCExts+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+import Text.Read+#endif+import qualified Control.Category as Category+++{--------------------------------------------------------------------+ Types+--------------------------------------------------------------------}+++-- | A map of integers to values @a@.++-- See Note: Order of constructors+data IntMap a = Bin {-# UNPACK #-} !Prefix+ !(IntMap a)+ !(IntMap a)+ | Tip {-# UNPACK #-} !Key a+ | Nil++--+-- Note [IntMap structure and invariants]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- * Nil is never found as a child of Bin.+--+-- * The Prefix of a Bin indicates the common high-order bits that all keys in+-- the Bin share.+--+-- * The least significant set bit of the Int value of a Prefix is called the+-- mask bit.+--+-- * All the bits to the left of the mask bit are called the shared prefix. All+-- keys stored in the Bin begin with the shared prefix.+--+-- * All keys in the left child of the Bin have the mask bit unset, and all keys+-- in the right child have the mask bit set. It follows that+--+-- 1. The Int value of the Prefix of a Bin is the smallest key that can be+-- present in the right child of the Bin.+--+-- 2. All keys in the right child of a Bin are greater than keys in the+-- left child, with one exceptional situation. If the Bin separates+-- negative and non-negative keys, the mask bit is the sign bit and the+-- left child stores the non-negative keys while the right child stores the+-- negative keys.+--+-- * All bits to the right of the mask bit are set to 0 in a Prefix.+--++-- See Note [Okasaki-Gill] for how the implementation here relates to the one in+-- Okasaki and Gill's paper.++-- Some stuff from "Data.IntSet.Internal", for 'restrictKeys' and+-- 'withoutKeys' to use.+type IntSetPrefix = Int+type IntSetBitMap = Word++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+deriving instance Lift a => Lift (IntMap a)+#endif++bitmapOf :: Int -> IntSetBitMap+bitmapOf x = shiftLL 1 (x .&. IntSet.suffixBitMask)+{-# INLINE bitmapOf #-}++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: IntMap a -> Key -> a+(!) m k = find k m++-- | \(O(\min(n,W))\). Find the value at a key.+-- Returns 'Nothing' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing+-- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a'+--+-- @since 0.5.11++(!?) :: IntMap a -> Key -> Maybe a+(!?) m k = lookup k m++-- | Same as 'difference'.+(\\) :: IntMap a -> IntMap b -> IntMap a+m1 \\ m2 = difference m1 m2++infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}++{--------------------------------------------------------------------+ Types+--------------------------------------------------------------------}++-- | @mempty@ = 'empty'+instance Monoid (IntMap a) where+ mempty = empty+ mconcat = unions+ mappend = (<>)++-- | @(<>)@ = 'union'+--+-- @since 0.5.7+instance Semigroup (IntMap a) where+ (<>) = union+ stimes = stimesIdempotentMonoid++-- | Folds in order of increasing key.+instance Foldable.Foldable IntMap where+ fold = go+ where go Nil = mempty+ go (Tip _ v) = v+ go (Bin p l r)+ | signBranch p = go r `mappend` go l+ | otherwise = go l `mappend` go r+ {-# INLINABLE fold #-}+ foldr = foldr+ {-# INLINE foldr #-}+ foldl = foldl+ {-# INLINE foldl #-}+ foldMap f t = go t+ where go Nil = mempty+ go (Tip _ v) = f v+ go (Bin p l r)+ | signBranch p = go r `mappend` go l+ | otherwise = go l `mappend` go r+ {-# INLINE foldMap #-}+ foldl' = foldl'+ {-# INLINE foldl' #-}+ foldr' = foldr'+ {-# INLINE foldr' #-}+ length = size+ {-# INLINE length #-}+ null = null+ {-# INLINE null #-}+ toList = elems -- NB: Foldable.toList /= IntMap.toList+ {-# INLINE toList #-}+ elem = go+ where go !_ Nil = False+ go x (Tip _ y) = x == y+ go x (Bin _ l r) = go x l || go x r+ {-# INLINABLE elem #-}+ maximum = start+ where start Nil = error "Data.Foldable.maximum (for Data.IntMap): empty map"+ start (Tip _ y) = y+ start (Bin p l r)+ | signBranch p = go (start r) l+ | otherwise = go (start l) r++ go !m Nil = m+ go m (Tip _ y) = max m y+ go m (Bin _ l r) = go (go m l) r+ {-# INLINABLE maximum #-}+ minimum = start+ where start Nil = error "Data.Foldable.minimum (for Data.IntMap): empty map"+ start (Tip _ y) = y+ start (Bin p l r)+ | signBranch p = go (start r) l+ | otherwise = go (start l) r++ go !m Nil = m+ go m (Tip _ y) = min m y+ go m (Bin _ l r) = go (go m l) r+ {-# INLINABLE minimum #-}+ sum = foldl' (+) 0+ {-# INLINABLE sum #-}+ product = foldl' (*) 1+ {-# INLINABLE product #-}++-- | Traverses in order of increasing key.+instance Traversable IntMap where+ traverse f = traverseWithKey (\_ -> f)+ {-# INLINE traverse #-}++instance NFData a => NFData (IntMap a) where+ rnf Nil = ()+ rnf (Tip _ v) = rnf v+ rnf (Bin _ l r) = rnf l `seq` rnf r++-- | @since 0.8+instance NFData1 IntMap where+ liftRnf rnfx = go+ where+ go Nil = ()+ go (Tip _ v) = rnfx v+ go (Bin _ l r) = go l `seq` go r++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+ A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data a => Data (IntMap a) where+ gfoldl f z im = z fromList `f` (toList im)+ toConstr _ = fromListConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z fromList)+ _ -> error "gunfold"+ dataTypeOf _ = intMapDataType+ dataCast1 f = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr intMapDataType "fromList" [] Data.Prefix++intMapDataType :: DataType+intMapDataType = mkDataType "Data.IntMap.Internal.IntMap" [fromListConstr]++#endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the map empty?+--+-- > Data.IntMap.null (empty) == True+-- > Data.IntMap.null (singleton 1 'a') == False++null :: IntMap a -> Bool+null Nil = True+null _ = False+{-# INLINE null #-}++-- | \(O(n)\). Number of elements in the map.+--+-- > size empty == 0+-- > size (singleton 1 'a') == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3+size :: IntMap a -> Int+size = go 0+ where+ go !acc (Bin _ l r) = go (go acc l) r+ go acc (Tip _ _) = 1 + acc+ go acc Nil = acc++-- | \(O(\min(n,W))\). Is the key a member of the map?+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False++-- See Note: Local 'go' functions and capturing]+member :: Key -> IntMap a -> Bool+member !k = go+ where+ go (Bin p l r)+ | nomatch k p = False+ | left k p = go l+ | otherwise = go r+ go (Tip kx _) = k == kx+ go Nil = False++-- | \(O(\min(n,W))\). Is the key not a member of the map?+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Key -> IntMap a -> Bool+notMember k m = not $ member k m++-- | \(O(\min(n,W))\). Look up the value at a key in the map. See also 'Data.Map.lookup'.++-- See Note: Local 'go' functions and capturing+lookup :: Key -> IntMap a -> Maybe a+lookup !k = go+ where+ go (Bin p l r) | left k p = go l+ | otherwise = go r+ go (Tip kx x) | k == kx = Just x+ | otherwise = Nothing+ go Nil = Nothing++-- See Note: Local 'go' functions and capturing]+find :: Key -> IntMap a -> a+find !k = go+ where+ go (Bin p l r) | left k p = go l+ | otherwise = go r+ go (Tip kx x) | k == kx = x+ | otherwise = not_found+ go Nil = not_found++ not_found = error ("IntMap.!: key " ++ show k ++ " is not an element of the map")++-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See Note: Local 'go' functions and capturing]+findWithDefault :: a -> Key -> IntMap a -> a+findWithDefault def !k = go+ where+ go (Bin p l r) | nomatch k p = def+ | left k p = go l+ | otherwise = go r+ go (Tip kx x) | k == kx = x+ | otherwise = def+ go Nil = def++-- | \(O(\min(n,W))\). Find largest key smaller than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> IntMap a -> Maybe (Key, a)+lookupLT !k t = case t of+ Bin p l r | signBranch p -> if k >= 0 then go r l else go Nil r+ _ -> go Nil t+ where+ go def (Bin p l r)+ | nomatch k p = if k < unPrefix p then unsafeFindMax def else unsafeFindMax r+ | left k p = go def l+ | otherwise = go l r+ go def (Tip ky y)+ | k <= ky = unsafeFindMax def+ | otherwise = Just (ky, y)+ go def Nil = unsafeFindMax def++-- | \(O(\min(n,W))\). Find smallest key greater than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> IntMap a -> Maybe (Key, a)+lookupGT !k t = case t of+ Bin p l r | signBranch p -> if k >= 0 then go Nil l else go l r+ _ -> go Nil t+ where+ go def (Bin p l r)+ | nomatch k p = if k < unPrefix p then unsafeFindMin l else unsafeFindMin def+ | left k p = go r l+ | otherwise = go def r+ go def (Tip ky y)+ | k >= ky = unsafeFindMin def+ | otherwise = Just (ky, y)+ go def Nil = unsafeFindMin def++-- | \(O(\min(n,W))\). Find largest key smaller or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> IntMap a -> Maybe (Key, a)+lookupLE !k t = case t of+ Bin p l r | signBranch p -> if k >= 0 then go r l else go Nil r+ _ -> go Nil t+ where+ go def (Bin p l r)+ | nomatch k p = if k < unPrefix p then unsafeFindMax def else unsafeFindMax r+ | left k p = go def l+ | otherwise = go l r+ go def (Tip ky y)+ | k < ky = unsafeFindMax def+ | otherwise = Just (ky, y)+ go def Nil = unsafeFindMax def++-- | \(O(\min(n,W))\). Find smallest key greater or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> IntMap a -> Maybe (Key, a)+lookupGE !k t = case t of+ Bin p l r | signBranch p -> if k >= 0 then go Nil l else go l r+ _ -> go Nil t+ where+ go def (Bin p l r)+ | nomatch k p = if k < unPrefix p then unsafeFindMin l else unsafeFindMin def+ | left k p = go r l+ | otherwise = go def r+ go def (Tip ky y)+ | k > ky = unsafeFindMin def+ | otherwise = Just (ky, y)+ go def Nil = unsafeFindMin def+++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: IntMap a -> Maybe (Key, a)+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip ky y) = Just (ky, y)+unsafeFindMin (Bin _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: IntMap a -> Maybe (Key, a)+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip ky y) = Just (ky, y)+unsafeFindMax (Bin _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+ Disjoint+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Check whether the key sets of two maps are disjoint+-- (i.e. their 'intersection' is empty).+--+-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True+-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False+-- > disjoint (fromList []) (fromList []) == True+--+-- > disjoint a b == null (intersection a b)+--+-- @since 0.6.2.1+disjoint :: IntMap a -> IntMap b -> Bool+disjoint Nil _ = True+disjoint _ Nil = True+disjoint (Tip kx _) ys = notMember kx ys+disjoint xs (Tip ky _) = notMember ky xs+disjoint t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> disjoint l1 t2+ ABR -> disjoint r1 t2+ BAL -> disjoint t1 l2+ BAR -> disjoint t1 r2+ EQL -> disjoint l1 l2 && disjoint r1 r2+ NOM -> True++{--------------------------------------------------------------------+ Compose+--------------------------------------------------------------------}+-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument+--+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- __Note:__ Prior to v0.6.4, "Data.IntMap.Strict" exposed a version of+-- 'compose' that forced the values of the output 'IntMap'. This version does+-- not force these values.+--+-- @since 0.6.3.1+compose :: IntMap c -> IntMap Int -> IntMap c+compose bc !ab+ | null bc = empty+ | otherwise = mapMaybe (bc !?) ab++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty map.+--+-- > empty == fromList []+-- > size empty == 0++empty :: IntMap a+empty+ = Nil+{-# INLINE empty #-}++-- | \(O(1)\). A map of one element.+--+-- > singleton 1 'a' == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: Key -> a -> IntMap a+singleton k x+ = Tip k x+{-# INLINE singleton #-}++{--------------------------------------------------------------------+ Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty == singleton 5 'x'++insert :: Key -> a -> IntMap a -> IntMap a+insert !k x t@(Bin p l r)+ | nomatch k p = linkKey k (Tip k x) p t+ | left k p = Bin p (insert k x l) r+ | otherwise = Bin p l (insert k x r)+insert k x t@(Tip ky _)+ | k==ky = Tip k x+ | otherwise = link k (Tip k x) ky t+insert k x Nil = Tip k x++-- right-biased insertion, used by 'union'+-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWith f k x t+ = insertWithKey (\_ x' y' -> f x' y') k x t++-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithKey f !k x t@(Bin p l r)+ | nomatch k p = linkKey k (Tip k x) p t+ | left k p = Bin p (insertWithKey f k x l) r+ | otherwise = Bin p l (insertWithKey f k x r)+insertWithKey f k x t@(Tip ky y)+ | k == ky = Tip k (f k x y)+ | otherwise = link k (Tip k x) ky t+insertWithKey _ k x Nil = Tip k x++-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])+--+-- Also see the performance note on 'fromListWith'.++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)+insertLookupWithKey f !k x t@(Bin p l r)+ | nomatch k p = (Nothing,linkKey k (Tip k x) p t)+ | left k p = let (found,l') = insertLookupWithKey f k x l+ in (found,Bin p l' r)+ | otherwise = let (found,r') = insertLookupWithKey f k x r+ in (found,Bin p l r')+insertLookupWithKey f k x t@(Tip ky y)+ | k == ky = (Just y,Tip k (f k x y))+ | otherwise = (Nothing,link k (Tip k x) ky t)+insertLookupWithKey _ k x Nil = (Nothing,Tip k x)+++{--------------------------------------------------------------------+ Deletion+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > delete 5 empty == empty++delete :: Key -> IntMap a -> IntMap a+delete !k t@(Bin p l r)+ | nomatch k p = t+ | left k p = binCheckLeft p (delete k l) r+ | otherwise = binCheckRight p l (delete k r)+delete k t@(Tip ky _)+ | k == ky = Nil+ | otherwise = t+delete _k Nil = Nil++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty == empty++adjust :: (a -> a) -> Key -> IntMap a -> IntMap a+adjust f k m+ = adjustWithKey (\_ x -> f x) k m++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty == empty++adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a+adjustWithKey f !k (Bin p l r)+ | left k p = Bin p (adjustWithKey f k l) r+ | otherwise = Bin p l (adjustWithKey f k r)+adjustWithKey f k t@(Tip ky y)+ | k == ky = Tip ky (f k y)+ | otherwise = t+adjustWithKey _ _ Nil = Nil+++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a+update f+ = updateWithKey (\_ x -> f x)++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a+updateWithKey f !k (Bin p l r)+ | left k p = binCheckLeft p (updateWithKey f k l) r+ | otherwise = binCheckRight p l (updateWithKey f k r)+updateWithKey f k t@(Tip ky y)+ | k == ky = case (f k y) of+ Just y' -> Tip ky y'+ Nothing -> Nil+ | otherwise = t+updateWithKey _ _ Nil = Nil++-- | \(O(\min(n,W))\). Look up and update.+-- This function returns the original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)+updateLookupWithKey f !k (Bin p l r)+ | left k p = let !(found,l') = updateLookupWithKey f k l+ in (found,binCheckLeft p l' r)+ | otherwise = let !(found,r') = updateLookupWithKey f k r+ in (found,binCheckRight p l r')+updateLookupWithKey f k t@(Tip ky y)+ | k==ky = case (f k y) of+ Just y' -> (Just y,Tip ky y')+ Nothing -> (Just y,Nil)+ | otherwise = (Nothing,t)+updateLookupWithKey _ _ Nil = (Nothing,Nil)++++-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a+alter f !k t@(Bin p l r)+ | nomatch k p = case f Nothing of+ Nothing -> t+ Just x -> linkKey k (Tip k x) p t+ | left k p = binCheckLeft p (alter f k l) r+ | otherwise = binCheckRight p l (alter f k r)+alter f k t@(Tip ky y)+ | k==ky = case f (Just y) of+ Just x -> Tip ky x+ Nothing -> Nil+ | otherwise = case f Nothing of+ Just x -> link k (Tip k x) ky t+ Nothing -> Tip ky y+alter f k Nil = case f Nothing of+ Just x -> Tip k x+ Nothing -> Nil++-- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete,+-- or update a value in an 'IntMap'. In short : @'lookup' k \<$\> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)+-- interactiveAlter k m = alterF f k m where+-- f Nothing = do+-- putStrLn $ show k +++-- " was not found in the map. Would you like to add it?"+-- getUserResponse1 :: IO (Maybe String)+-- f (Just old) = do+-- putStrLn $ "The key is currently bound to " ++ show old +++-- ". Would you like to change or delete it?"+-- getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map.+--+-- Note: 'alterF' is a flipped version of the @at@ combinator from+-- @Control.Lens.At@.+--+-- @since 0.5.8++alterF :: Functor f+ => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)+-- This implementation was stolen from 'Control.Lens.At'.+alterF f k m = (<$> f mv) $ \fres ->+ case fres of+ Nothing -> maybe m (const (delete k m)) mv+ Just v' -> insert k v' m+ where mv = lookup k m++{--------------------------------------------------------------------+ Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+--+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "b"), (5, "a"), (7, "C")]+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]+-- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]++unions :: Foldable f => f (IntMap a) -> IntMap a+unions xs+ = Foldable.foldl' union empty xs++-- | The union of a list of maps, with a combining operation.+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a+unionsWith f ts+ = Foldable.foldl' (unionWith f) empty ts++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The (left-biased) union of two maps.+-- It prefers the first map when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: IntMap a -> IntMap a -> IntMap a+union m1 m2+ = mergeWithKey' Bin const id id m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWith f m1 m2+ = unionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWithKey f m1 m2+ = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference between two maps (based on keys).+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: IntMap a -> IntMap b -> IntMap a+difference m1 m2+ = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- > == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWith f m1 m2+ = differenceWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- > == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWithKey f m1 m2+ = mergeWithKey f id (const Nil) m1 m2+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Remove all the keys in a given set from a map.+--+-- @+-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``IntSet.notMember`` s) m+-- @+--+-- @since 0.5.8+withoutKeys :: IntMap a -> IntSet.IntSet -> IntMap a+withoutKeys t1@(Bin p1 l1 r1) t2@(IntSet.Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> binCheckLeft p1 (withoutKeys l1 t2) r1+ ABR -> binCheckRight p1 l1 (withoutKeys r1 t2)+ BAL -> withoutKeys t1 l2+ BAR -> withoutKeys t1 r2+ EQL -> bin p1 (withoutKeys l1 l2) (withoutKeys r1 r2)+ NOM -> t1+ where+withoutKeys t1@(Bin p1 _ _) (IntSet.Tip p2 bm2) =+ let px1 = unPrefix p1+ minbit = bitmapOf (px1 .&. (px1-1))+ lt_minbit = minbit - 1+ maxbit = bitmapOf (px1 .|. (px1-1))+ gt_maxbit = (-maxbit) `xor` maxbit+ -- TODO(wrengr): should we manually inline/unroll 'updatePrefix'+ -- and 'withoutBM' here, in order to avoid redundant case analyses?+ in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)+withoutKeys t1@(Bin _ _ _) IntSet.Nil = t1+withoutKeys t1@(Tip k1 _) t2+ | k1 `IntSet.member` t2 = Nil+ | otherwise = t1+withoutKeys Nil _ = Nil+++updatePrefix+ :: IntSetPrefix -> IntMap a -> (IntMap a -> IntMap a) -> IntMap a+updatePrefix !kp t@(Bin p l r) f+ | unPrefix p .&. IntSet.suffixBitMask /= 0 =+ if unPrefix p .&. IntSet.prefixBitMask == kp then f t else t+ | nomatch kp p = t+ | left kp p = binCheckLeft p (updatePrefix kp l f) r+ | otherwise = binCheckRight p l (updatePrefix kp r f)+updatePrefix kp t@(Tip kx _) f+ | kx .&. IntSet.prefixBitMask == kp = f t+ | otherwise = t+updatePrefix _ Nil _ = Nil+++withoutBM :: IntSetBitMap -> IntMap a -> IntMap a+withoutBM 0 t = t+withoutBM bm (Bin p l r) =+ let leftBits = bitmapOf (unPrefix p) - 1+ bmL = bm .&. leftBits+ bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+ in bin p (withoutBM bmL l) (withoutBM bmR r)+withoutBM bm t@(Tip k _)+ -- TODO(wrengr): need we manually inline 'IntSet.Member' here?+ | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = Nil+ | otherwise = t+withoutBM _ Nil = Nil+++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The (left-biased) intersection of two maps (based on keys).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: IntMap a -> IntMap b -> IntMap a+intersection m1 m2+ = mergeWithKey' bin const (const Nil) (const Nil) m1 m2+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The restriction of a map to the keys in a set.+--+-- @+-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``IntSet.member`` s) m+-- @+--+-- @since 0.5.8+restrictKeys :: IntMap a -> IntSet.IntSet -> IntMap a+restrictKeys t1@(Bin p1 l1 r1) t2@(IntSet.Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> restrictKeys l1 t2+ ABR -> restrictKeys r1 t2+ BAL -> restrictKeys t1 l2+ BAR -> restrictKeys t1 r2+ EQL -> bin p1 (restrictKeys l1 l2) (restrictKeys r1 r2)+ NOM -> Nil+restrictKeys t1@(Bin p1 _ _) (IntSet.Tip p2 bm2) =+ let px1 = unPrefix p1+ minbit = bitmapOf (px1 .&. (px1-1))+ ge_minbit = complement (minbit - 1)+ maxbit = bitmapOf (px1 .|. (px1-1))+ le_maxbit = maxbit .|. (maxbit - 1)+ -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'+ -- and 'restrictBM' here, in order to avoid redundant case analyses?+ in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)+restrictKeys (Bin _ _ _) IntSet.Nil = Nil+restrictKeys t1@(Tip k1 _) t2+ | k1 `IntSet.member` t2 = t1+ | otherwise = Nil+restrictKeys Nil _ = Nil+++-- | \(O(\min(n,W))\). Restrict to the sub-map with all keys matching+-- a key prefix.+lookupPrefix :: IntSetPrefix -> IntMap a -> IntMap a+lookupPrefix !kp t@(Bin p l r)+ | unPrefix p .&. IntSet.suffixBitMask /= 0 =+ if unPrefix p .&. IntSet.prefixBitMask == kp then t else Nil+ | nomatch kp p = Nil+ | left kp p = lookupPrefix kp l+ | otherwise = lookupPrefix kp r+lookupPrefix kp t@(Tip kx _)+ | (kx .&. IntSet.prefixBitMask) == kp = t+ | otherwise = Nil+lookupPrefix _ Nil = Nil+++restrictBM :: IntSetBitMap -> IntMap a -> IntMap a+restrictBM 0 _ = Nil+restrictBM bm (Bin p l r) =+ let leftBits = bitmapOf (unPrefix p) - 1+ bmL = bm .&. leftBits+ bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+ in bin p (restrictBM bmL l) (restrictBM bmR r)+restrictBM bm t@(Tip k _)+ -- TODO(wrengr): need we manually inline 'IntSet.Member' here?+ | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = t+ | otherwise = Nil+restrictBM _ Nil = Nil+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWith f m1 m2+ = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWithKey f m1 m2+ = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2++{--------------------------------------------------------------------+ Symmetric difference+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The symmetric difference of two maps.+--+-- The result contains entries whose keys appear in exactly one of the two maps.+--+-- @+-- symmetricDifference+-- (fromList [(0,\'q\'),(2,\'b\'),(4,\'w\'),(6,\'o\')])+-- (fromList [(0,\'e\'),(3,\'r\'),(6,\'t\'),(9,\'s\')])+-- ==+-- fromList [(2,\'b\'),(3,\'r\'),(4,\'w\'),(9,\'s\')]+-- @+--+-- @since 0.8+symmetricDifference :: IntMap a -> IntMap a -> IntMap a+symmetricDifference t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) =+ case treeTreeBranch p1 p2 of+ ABL -> bin p1 (symmetricDifference l1 t2) r1+ ABR -> bin p1 l1 (symmetricDifference r1 t2)+ BAL -> bin p2 (symmetricDifference t1 l2) r2+ BAR -> bin p2 l2 (symmetricDifference t1 r2)+ EQL -> bin p1 (symmetricDifference l1 l2) (symmetricDifference r1 r2)+ NOM -> link (unPrefix p1) t1 (unPrefix p2) t2+symmetricDifference t1@(Bin _ _ _) t2@(Tip k2 _) = symDiffTip t2 k2 t1+symmetricDifference t1@(Bin _ _ _) Nil = t1+symmetricDifference t1@(Tip k1 _) t2 = symDiffTip t1 k1 t2+symmetricDifference Nil t2 = t2++symDiffTip :: IntMap a -> Int -> IntMap a -> IntMap a+symDiffTip !t1 !k1 = go+ where+ go t2@(Bin p2 l2 r2)+ | nomatch k1 p2 = linkKey k1 t1 p2 t2+ | left k1 p2 = bin p2 (go l2) r2+ | otherwise = bin p2 l2 (go r2)+ go t2@(Tip k2 _)+ | k1 == k2 = Nil+ | otherwise = link k1 t1 k2 t2+ go Nil = t1++{--------------------------------------------------------------------+ MergeWithKey+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- A high-performance universal combining function. Using+-- 'mergeWithKey', all combining functions can be defined without any loss of+-- efficiency (with exception of 'union', 'difference' and 'intersection',+-- where sharing of some nodes is lost with 'mergeWithKey').+--+-- __Warning__: Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'IntMap's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+-- values to the @combine@ function. Depending on the result, the key is either+-- present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+-- the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+-- the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++-- See Note [IntMap merge complexity]+mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)+ -> IntMap a -> IntMap b -> IntMap c+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2+ where -- We use the lambda form to avoid non-exhaustive pattern matches warning.+ combine = \(Tip k1 x1) (Tip _k2 x2) ->+ case f k1 x1 x2 of+ Nothing -> Nil+ Just x -> Tip k1 x+ {-# INLINE combine #-}+{-# INLINE mergeWithKey #-}++-- Slightly more general version of mergeWithKey. It differs in the following:+--+-- * the combining function operates on maps instead of keys and values. The+-- reason is to enable sharing in union, difference and intersection.+--+-- * mergeWithKey' is given an equivalent of bin. The reason is that in union*,+-- Bin constructor can be used, because we know both subtrees are nonempty.++mergeWithKey' :: (Prefix -> IntMap c -> IntMap c -> IntMap c)+ -> (IntMap a -> IntMap b -> IntMap c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)+ -> IntMap a -> IntMap b -> IntMap c+mergeWithKey' bin' f g1 g2 = go+ where+ go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> bin' p1 (go l1 t2) (g1 r1)+ ABR -> bin' p1 (g1 l1) (go r1 t2)+ BAL -> bin' p2 (go t1 l2) (g2 r2)+ BAR -> bin' p2 (g2 l2) (go t1 r2)+ EQL -> bin' p1 (go l1 l2) (go r1 r2)+ NOM -> maybe_link (unPrefix p1) (g1 t1) (unPrefix p2) (g2 t2)++ go t1'@(Bin _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1'+ where+ merge0 t2 k2 t1@(Bin p1 l1 r1)+ | nomatch k2 p1 = maybe_link (unPrefix p1) (g1 t1) k2 (g2 t2)+ | left k2 p1 = bin' p1 (merge0 t2 k2 l1) (g1 r1)+ | otherwise = bin' p1 (g1 l1) (merge0 t2 k2 r1)+ merge0 t2 k2 t1@(Tip k1 _)+ | k1 == k2 = f t1 t2+ | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+ merge0 t2 _ Nil = g2 t2++ go t1@(Bin _ _ _) Nil = g1 t1++ go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'+ where+ merge0 t1 k1 t2@(Bin p2 l2 r2)+ | nomatch k1 p2 = maybe_link k1 (g1 t1) (unPrefix p2) (g2 t2)+ | left k1 p2 = bin' p2 (merge0 t1 k1 l2) (g2 r2)+ | otherwise = bin' p2 (g2 l2) (merge0 t1 k1 r2)+ merge0 t1 k1 t2@(Tip k2 _)+ | k1 == k2 = f t1 t2+ | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+ merge0 t1 _ Nil = g1 t1++ go Nil Nil = Nil++ go Nil t2 = g2 t2++ maybe_link _ Nil _ t2 = t2+ maybe_link _ t1 _ Nil = t1+ maybe_link k1 t1 k2 t2 = link k1 t1 k2 t2+ {-# INLINE maybe_link #-}+{-# INLINE mergeWithKey' #-}+++{--------------------------------------------------------------------+ mergeA+--------------------------------------------------------------------}++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge' or 'mergeA'.+--+-- A tactic of type @WhenMissing f k x z@ is an abstract representation+-- of a function of type @Key -> x -> f (Maybe z)@.+--+-- @since 0.5.9++data WhenMissing f x y = WhenMissing+ { missingSubtree :: IntMap x -> f (IntMap y)+ , missingKey :: Key -> x -> f (Maybe y)}++-- | @since 0.5.9+instance (Applicative f, Monad f) => Functor (WhenMissing f x) where+ fmap = mapWhenMissing+ {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Applicative f, Monad f) => Category.Category (WhenMissing f)+ where+ id = preserveMissing+ f . g =+ traverseMaybeMissing $ \ k x -> do+ y <- missingKey g k x+ case y of+ Nothing -> pure Nothing+ Just q -> missingKey f k q+ {-# INLINE id #-}+ {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where+ pure x = mapMissing (\ _ _ -> x)+ f <*> g =+ traverseMaybeMissing $ \k x -> do+ res1 <- missingKey f k x+ case res1 of+ Nothing -> pure Nothing+ Just r -> (pure $!) . fmap r =<< missingKey g k x+ {-# INLINE pure #-}+ {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Monad (WhenMissing f x) where+ m >>= f =+ traverseMaybeMissing $ \k x -> do+ res1 <- missingKey m k x+ case res1 of+ Nothing -> pure Nothing+ Just r -> missingKey (f r) k x+ {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMissing' f x@.+--+-- @since 0.5.9+mapWhenMissing+ :: (Applicative f, Monad f)+ => (a -> b)+ -> WhenMissing f x a+ -> WhenMissing f x b+mapWhenMissing f t = WhenMissing+ { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'+ , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }+{-# INLINE mapWhenMissing #-}+++-- | Map covariantly over a @'WhenMissing' f x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMissing+ :: Functor f+ => (a -> b)+ -> WhenMissing f x a+ -> WhenMissing f x b+mapGentlyWhenMissing f t = WhenMissing+ { missingSubtree = \m -> fmap f <$> missingSubtree t m+ , missingKey = \k x -> fmap f <$> missingKey t k x }+{-# INLINE mapGentlyWhenMissing #-}+++-- | Map covariantly over a @'WhenMatched' f k x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMatched+ :: Functor f+ => (a -> b)+ -> WhenMatched f x y a+ -> WhenMatched f x y b+mapGentlyWhenMatched f t =+ zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y+{-# INLINE mapGentlyWhenMatched #-}+++-- | Map contravariantly over a @'WhenMissing' f _ x@.+--+-- @since 0.5.9+lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x+lmapWhenMissing f t = WhenMissing+ { missingSubtree = \m -> missingSubtree t (fmap f m)+ , missingKey = \k x -> missingKey t k (f x) }+{-# INLINE lmapWhenMissing #-}+++-- | Map contravariantly over a @'WhenMatched' f _ y z@.+--+-- @since 0.5.9+contramapFirstWhenMatched+ :: (b -> a)+ -> WhenMatched f a y z+ -> WhenMatched f b y z+contramapFirstWhenMatched f t =+ WhenMatched $ \k x y -> runWhenMatched t k (f x) y+{-# INLINE contramapFirstWhenMatched #-}+++-- | Map contravariantly over a @'WhenMatched' f x _ z@.+--+-- @since 0.5.9+contramapSecondWhenMatched+ :: (b -> a)+ -> WhenMatched f x a z+ -> WhenMatched f x b z+contramapSecondWhenMatched f t =+ WhenMatched $ \k x y -> runWhenMatched t k x (f y)+{-# INLINE contramapSecondWhenMatched #-}+++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge'.+--+-- A tactic of type @SimpleWhenMissing x z@ is an abstract+-- representation of a function of type @Key -> x -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMissing = WhenMissing Identity+++-- | A tactic for dealing with keys present in both maps in 'merge'+-- or 'mergeA'.+--+-- A tactic of type @WhenMatched f x y z@ is an abstract representation+-- of a function of type @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+newtype WhenMatched f x y z = WhenMatched+ { matchedKey :: Key -> x -> y -> f (Maybe z) }+++-- | Along with zipWithMaybeAMatched, witnesses the isomorphism+-- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z)+runWhenMatched = matchedKey+{-# INLINE runWhenMatched #-}+++-- | Along with traverseMaybeMissing, witnesses the isomorphism+-- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@.+--+-- @since 0.5.9+runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y)+runWhenMissing = missingKey+{-# INLINE runWhenMissing #-}+++-- | @since 0.5.9+instance Functor f => Functor (WhenMatched f x y) where+ fmap = mapWhenMatched+ {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Monad f, Applicative f) => Category.Category (WhenMatched f x)+ where+ id = zipWithMatched (\_ _ y -> y)+ f . g =+ zipWithMaybeAMatched $ \k x y -> do+ res <- runWhenMatched g k x y+ case res of+ Nothing -> pure Nothing+ Just r -> runWhenMatched f k x r+ {-# INLINE id #-}+ {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where+ pure x = zipWithMatched (\_ _ _ -> x)+ fs <*> xs =+ zipWithMaybeAMatched $ \k x y -> do+ res <- runWhenMatched fs k x y+ case res of+ Nothing -> pure Nothing+ Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y+ {-# INLINE pure #-}+ {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where+ m >>= f =+ zipWithMaybeAMatched $ \k x y -> do+ res <- runWhenMatched m k x y+ case res of+ Nothing -> pure Nothing+ Just r -> runWhenMatched (f r) k x y+ {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMatched' f x y@.+--+-- @since 0.5.9+mapWhenMatched+ :: Functor f+ => (a -> b)+ -> WhenMatched f x y a+ -> WhenMatched f x y b+mapWhenMatched f (WhenMatched g) =+ WhenMatched $ \k x y -> fmap (fmap f) (g k x y)+{-# INLINE mapWhenMatched #-}+++-- | A tactic for dealing with keys present in both maps in 'merge'.+--+-- A tactic of type @SimpleWhenMatched x y z@ is an abstract+-- representation of a function of type @Key -> x -> y -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMatched = WhenMatched Identity+++-- | When a key is found in both maps, apply a function to the key+-- and values and use the result in the merged map.+--+-- > zipWithMatched+-- > :: (Key -> x -> y -> z)+-- > -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMatched+ :: Applicative f+ => (Key -> x -> y -> z)+ -> WhenMatched f x y z+zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y+{-# INLINE zipWithMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values to produce an action and use its result in the merged+-- map.+--+-- @since 0.5.9+zipWithAMatched+ :: Applicative f+ => (Key -> x -> y -> f z)+ -> WhenMatched f x y z+zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y+{-# INLINE zipWithAMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values and maybe use the result in the merged map.+--+-- > zipWithMaybeMatched+-- > :: (Key -> x -> y -> Maybe z)+-- > -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMaybeMatched+ :: Applicative f+ => (Key -> x -> y -> Maybe z)+ -> WhenMatched f x y z+zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y+{-# INLINE zipWithMaybeMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values, perform the resulting action, and maybe use the+-- result in the merged map.+--+-- This is the fundamental 'WhenMatched' tactic.+--+-- @since 0.5.9+zipWithMaybeAMatched+ :: (Key -> x -> y -> f (Maybe z))+ -> WhenMatched f x y z+zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y+{-# INLINE zipWithMaybeAMatched #-}+++-- | Drop all the entries whose keys are missing from the other+-- map.+--+-- > dropMissing :: SimpleWhenMissing x y+--+-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)+--+-- but @dropMissing@ is much faster.+--+-- @since 0.5.9+dropMissing :: Applicative f => WhenMissing f x y+dropMissing = WhenMissing+ { missingSubtree = const (pure Nil)+ , missingKey = \_ _ -> pure Nothing }+{-# INLINE dropMissing #-}+++-- | Preserve, unchanged, the entries whose keys are missing from+-- the other map.+--+-- > preserveMissing :: SimpleWhenMissing x x+--+-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)+--+-- but @preserveMissing@ is much faster.+--+-- @since 0.5.9+preserveMissing :: Applicative f => WhenMissing f x x+preserveMissing = WhenMissing+ { missingSubtree = pure+ , missingKey = \_ v -> pure (Just v) }+{-# INLINE preserveMissing #-}+++-- | Map over the entries whose keys are missing from the other map.+--+-- > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+--+-- @since 0.5.9+mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y+mapMissing f = WhenMissing+ { missingSubtree = \m -> pure $! mapWithKey f m+ , missingKey = \k x -> pure $ Just (f k x) }+{-# INLINE mapMissing #-}+++-- | Map over the entries whose keys are missing from the other+-- map, optionally removing some. This is the most powerful+-- 'SimpleWhenMissing' tactic, but others are usually more efficient.+--+-- > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y+--+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))+--+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative'+-- operations.+--+-- @since 0.5.9+mapMaybeMissing+ :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y+mapMaybeMissing f = WhenMissing+ { missingSubtree = \m -> pure $! mapMaybeWithKey f m+ , missingKey = \k x -> pure $! f k x }+{-# INLINE mapMaybeMissing #-}+++-- | Filter the entries whose keys are missing from the other map.+--+-- > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x+--+-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterMissing+ :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x+filterMissing f = WhenMissing+ { missingSubtree = \m -> pure $! filterWithKey f m+ , missingKey = \k x -> pure $! if f k x then Just x else Nothing }+{-# INLINE filterMissing #-}+++-- | Filter the entries whose keys are missing from the other map+-- using some 'Applicative' action.+--+-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $+-- > \k x -> (\b -> guard b *> Just x) <$> f k x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterAMissing+ :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x+filterAMissing f = WhenMissing+ { missingSubtree = \m -> filterWithKeyA f m+ , missingKey = \k x -> bool Nothing (Just x) <$> f k x }+{-# INLINE filterAMissing #-}+++-- | \(O(n)\). Filter keys and values using an 'Applicative' predicate.+filterWithKeyA+ :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a)+filterWithKeyA _ Nil = pure Nil+filterWithKeyA f t@(Tip k x) = (\b -> if b then t else Nil) <$> f k x+filterWithKeyA f (Bin p l r)+ | signBranch p = liftA2 (flip (bin p)) (filterWithKeyA f r) (filterWithKeyA f l)+ | otherwise = liftA2 (bin p) (filterWithKeyA f l) (filterWithKeyA f r)++-- | This wasn't in Data.Bool until 4.7.0, so we define it here+bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True = t+++-- | Traverse over the entries whose keys are missing from the other+-- map.+--+-- @since 0.5.9+traverseMissing+ :: Applicative f => (Key -> x -> f y) -> WhenMissing f x y+traverseMissing f = WhenMissing+ { missingSubtree = traverseWithKey f+ , missingKey = \k x -> Just <$> f k x }+{-# INLINE traverseMissing #-}+++-- | Traverse over the entries whose keys are missing from the other+-- map, optionally producing values to put in the result. This is+-- the most powerful 'WhenMissing' tactic, but others are usually+-- more efficient.+--+-- @since 0.5.9+traverseMaybeMissing+ :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y+traverseMaybeMissing f = WhenMissing+ { missingSubtree = traverseMaybeWithKey f+ , missingKey = f }+{-# INLINE traverseMaybeMissing #-}+++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.6.4+traverseMaybeWithKey+ :: Applicative f => (Key -> a -> f (Maybe b)) -> IntMap a -> f (IntMap b)+traverseMaybeWithKey f = go+ where+ go Nil = pure Nil+ go (Tip k x) = maybe Nil (Tip k) <$> f k x+ go (Bin p l r)+ | signBranch p = liftA2 (flip (bin p)) (go r) (go l)+ | otherwise = liftA2 (bin p) (go l) (go r)+++-- | Merge two maps.+--+-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic+-- and two maps. It uses the tactics to merge the maps. Its behavior+-- is best understood via its fundamental tactics, 'mapMaybeMissing'+-- and 'zipWithMaybeMatched'.+--+-- Consider+--+-- @+-- merge (mapMaybeMissing g1)+-- (mapMaybeMissing g2)+-- (zipWithMaybeMatched f)+-- m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'merge' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- This produces a 'Maybe' for each key:+--+-- @+-- keys = 0 1 2 3 4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'mapMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+--+-- When 'merge' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should typically use+-- 'merge' to define your custom combining functions.+--+--+-- Examples:+--+-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)+-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)+-- prop> differenceWith f = merge diffPreserve diffDrop f+-- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)+-- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)+--+-- @since 0.5.9+merge+ :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@+ -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@+ -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@+ -> IntMap a -- ^ Map @m1@+ -> IntMap b -- ^ Map @m2@+ -> IntMap c+merge g1 g2 f m1 m2 =+ runIdentity $ mergeA g1 g2 f m1 m2+{-# INLINE merge #-}+++-- | An applicative version of 'merge'.+--+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'+-- tactic and two maps. It uses the tactics to merge the maps.+-- Its behavior is best understood via its fundamental tactics,+-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+-- (traverseMaybeMissing g2)+-- (zipWithMaybeAMatched f)+-- m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'mergeA' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- Next, it will perform the actions in the @actions@ list in order from+-- left to right.+--+-- @+-- keys = 0 1 2 3 4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'traverseMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+-- * 'mapMaybeMissing' does not use the 'Applicative' context.+--+-- When 'mergeA' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should generally only use+-- 'mergeA' to define custom combining functions.+--+-- @since 0.5.9+mergeA+ :: (Applicative f)+ => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@+ -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@+ -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@+ -> IntMap a -- ^ Map @m1@+ -> IntMap b -- ^ Map @m2@+ -> f (IntMap c)+mergeA+ WhenMissing{missingSubtree = g1t, missingKey = g1k}+ WhenMissing{missingSubtree = g2t, missingKey = g2k}+ WhenMatched{matchedKey = f}+ = go+ where+ go t1 Nil = g1t t1+ go Nil t2 = g2t t2++ -- This case is already covered below.+ -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2++ go (Tip k1 x1) t2' = merge2 t2'+ where+ merge2 t2@(Bin p2 l2 r2)+ | nomatch k1 p2 = linkA k1 (subsingletonBy g1k k1 x1) (unPrefix p2) (g2t t2)+ | left k1 p2 = binA p2 (merge2 l2) (g2t r2)+ | otherwise = binA p2 (g2t l2) (merge2 r2)+ merge2 (Tip k2 x2) = mergeTips k1 x1 k2 x2+ merge2 Nil = subsingletonBy g1k k1 x1++ go t1' (Tip k2 x2) = merge1 t1'+ where+ merge1 t1@(Bin p1 l1 r1)+ | nomatch k2 p1 = linkA (unPrefix p1) (g1t t1) k2 (subsingletonBy g2k k2 x2)+ | left k2 p1 = binA p1 (merge1 l1) (g1t r1)+ | otherwise = binA p1 (g1t l1) (merge1 r1)+ merge1 (Tip k1 x1) = mergeTips k1 x1 k2 x2+ merge1 Nil = subsingletonBy g2k k2 x2++ go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> binA p1 (go l1 t2) (g1t r1)+ ABR -> binA p1 (g1t l1) (go r1 t2)+ BAL -> binA p2 (go t1 l2) (g2t r2)+ BAR -> binA p2 (g2t l2) (go t1 r2)+ EQL -> binA p1 (go l1 l2) (go r1 r2)+ NOM -> linkA (unPrefix p1) (g1t t1) (unPrefix p2) (g2t t2)++ subsingletonBy :: Functor f => (Key -> a -> f (Maybe c)) -> Key -> a -> f (IntMap c)+ subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x+ {-# INLINE subsingletonBy #-}++ mergeTips k1 x1 k2 x2+ | k1 == k2 = maybe Nil (Tip k1) <$> f k1 x1 x2+ | k1 < k2 = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2)+ {-+ = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2+ -}+ | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1)+ {-# INLINE mergeTips #-}++ subdoubleton _ _ Nothing Nothing = Nil+ subdoubleton _ k2 Nothing (Just y2) = Tip k2 y2+ subdoubleton k1 _ (Just y1) Nothing = Tip k1 y1+ subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2)+ {-# INLINE subdoubleton #-}++ -- | A variant of 'link_' which makes sure to execute side-effects+ -- in the right order.+ linkA+ :: Applicative f+ => Int -> f (IntMap a)+ -> Int -> f (IntMap a)+ -> f (IntMap a)+ linkA k1 t1 k2 t2+ | i2w k1 < i2w k2 = binA p t1 t2+ | otherwise = binA p t2 t1+ where+ m = branchMask k1 k2+ p = Prefix (mask k1 m .|. m)+ {-# INLINE linkA #-}++ -- A variant of 'bin' that ensures that effects for negative keys are executed+ -- first.+ binA+ :: Applicative f+ => Prefix+ -> f (IntMap a)+ -> f (IntMap a)+ -> f (IntMap a)+ binA p a b+ | signBranch p = liftA2 (flip (bin p)) b a+ | otherwise = liftA2 (bin p) a b+ {-# INLINE binA #-}+{-# INLINE mergeA #-}+++{--------------------------------------------------------------------+ Min\/Max+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMinWithKey f t =+ case t of Bin p l r | signBranch p -> binCheckRight p l (go f r)+ _ -> go f t+ where+ go f' (Bin p l r) = binCheckLeft p (go f' l) r+ go f' (Tip k y) = case f' k y of+ Just y' -> Tip k y'+ Nothing -> Nil+ go _ Nil = Nil++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMaxWithKey f t =+ case t of Bin p l r | signBranch p -> binCheckLeft p (go f l) r+ _ -> go f t+ where+ go f' (Bin p l r) = binCheckRight p l (go f' r)+ go f' (Tip k y) = case f' k y of+ Just y' -> Tip k y'+ Nothing -> Nil+ go _ Nil = Nil+++data View a = View {-# UNPACK #-} !Key a !(IntMap a)++-- | \(O(\min(n,W))\). Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)+maxViewWithKey t = case t of+ Nil -> Nothing+ _ -> Just $ case maxViewWithKeySure t of+ View k v t' -> ((k, v), t')+{-# INLINE maxViewWithKey #-}++maxViewWithKeySure :: IntMap a -> View a+maxViewWithKeySure t =+ case t of+ Nil -> error "maxViewWithKeySure Nil"+ Bin p l r | signBranch p ->+ case go l of View k a l' -> View k a (binCheckLeft p l' r)+ _ -> go t+ where+ go (Bin p l r) =+ case go r of View k a r' -> View k a (binCheckRight p l r')+ go (Tip k y) = View k y Nil+ go Nil = error "maxViewWithKey_go Nil"+-- See note on NOINLINE at minViewWithKeySure+{-# NOINLINE maxViewWithKeySure #-}++-- | \(O(\min(n,W))\). Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)+minViewWithKey t =+ case t of+ Nil -> Nothing+ _ -> Just $ case minViewWithKeySure t of+ View k v t' -> ((k, v), t')+-- We inline this to give GHC the best possible chance of+-- getting rid of the Maybe, pair, and Int constructors, as+-- well as a thunk under the Just. That is, we really want to+-- be certain this inlines!+{-# INLINE minViewWithKey #-}++minViewWithKeySure :: IntMap a -> View a+minViewWithKeySure t =+ case t of+ Nil -> error "minViewWithKeySure Nil"+ Bin p l r | signBranch p ->+ case go r of+ View k a r' -> View k a (binCheckRight p l r')+ _ -> go t+ where+ go (Bin p l r) =+ case go l of View k a l' -> View k a (binCheckLeft p l' r)+ go (Tip k y) = View k y Nil+ go Nil = error "minViewWithKey_go Nil"+-- There's never anything significant to be gained by inlining+-- this. Sufficiently recent GHC versions will inline the wrapper+-- anyway, which should be good enough.+{-# NOINLINE minViewWithKeySure #-}++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a+updateMax f = updateMaxWithKey (const f)++-- | \(O(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a+updateMin f = updateMinWithKey (const f)++-- | \(O(\min(n,W))\). Retrieves the maximal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+maxView :: IntMap a -> Maybe (a, IntMap a)+maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t)++-- | \(O(\min(n,W))\). Retrieves the minimal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+minView :: IntMap a -> Maybe (a, IntMap a)+minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t)++-- | \(O(\min(n,W))\). Delete and find the maximal element.+-- This function throws an error if the map is empty. Use 'maxViewWithKey'+-- if the map may be empty.+deleteFindMax :: IntMap a -> ((Key, a), IntMap a)+deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey++-- | \(O(\min(n,W))\). Delete and find the minimal element.+-- This function throws an error if the map is empty. Use 'minViewWithKey'+-- if the map may be empty.+deleteFindMin :: IntMap a -> ((Key, a), IntMap a)+deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey++-- The KeyValue type is used when returning a key-value pair and helps with+-- GHC optimizations.+--+-- For lookupMinSure, if the return type is (Int, a), GHC compiles it to a+-- worker $wlookupMinSure :: IntMap a -> (# Int, a #). If the return type is+-- KeyValue a instead, the worker does not box the int and returns+-- (# Int#, a #).+-- For a modern enough GHC (>=9.4), this measure turns out to be unnecessary in+-- this instance. We still use it for older GHCs and to make our intent clear.++data KeyValue a = KeyValue {-# UNPACK #-} !Key a++kvToTuple :: KeyValue a -> (Key, a)+kvToTuple (KeyValue k x) = (k, x)+{-# INLINE kvToTuple #-}++lookupMinSure :: IntMap a -> KeyValue a+lookupMinSure (Tip k v) = KeyValue k v+lookupMinSure (Bin _ l _) = lookupMinSure l+lookupMinSure Nil = error "lookupMinSure Nil"++-- | \(O(\min(n,W))\). The minimal key of the map. Returns 'Nothing' if the map is empty.+lookupMin :: IntMap a -> Maybe (Key, a)+lookupMin Nil = Nothing+lookupMin (Tip k v) = Just (k,v)+lookupMin (Bin p l r) =+ Just $! kvToTuple (lookupMinSure (if signBranch p then r else l))+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The minimal key of the map. Calls 'error' if the map is empty.+findMin :: IntMap a -> (Key, a)+findMin t+ | Just r <- lookupMin t = r+ | otherwise = error "findMin: empty map has no minimal element"++lookupMaxSure :: IntMap a -> KeyValue a+lookupMaxSure (Tip k v) = KeyValue k v+lookupMaxSure (Bin _ _ r) = lookupMaxSure r+lookupMaxSure Nil = error "lookupMaxSure Nil"++-- | \(O(\min(n,W))\). The maximal key of the map. Returns 'Nothing' if the map is empty.+lookupMax :: IntMap a -> Maybe (Key, a)+lookupMax Nil = Nothing+lookupMax (Tip k v) = Just (k,v)+lookupMax (Bin p l r) =+ Just $! kvToTuple (lookupMaxSure (if signBranch p then l else r))+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The maximal key of the map. Calls 'error' if the map is empty.+findMax :: IntMap a -> (Key, a)+findMax t+ | Just r <- lookupMax t = r+ | otherwise = error "findMax: empty map has no maximal element"++-- | \(O(\min(n,W))\). Delete the minimal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' –+-- versions prior to 0.5 threw an error if the 'IntMap' was already empty.+deleteMin :: IntMap a -> IntMap a+deleteMin = maybe Nil snd . minView++-- | \(O(\min(n,W))\). Delete the maximal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' –+-- versions prior to 0.5 threw an error if the 'IntMap' was already empty.+deleteMax :: IntMap a -> IntMap a+deleteMax = maybe Nil snd . maxView+++{--------------------------------------------------------------------+ Submap+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+isProperSubmapOf m1 m2+ = isProperSubmapOfBy (==) m1 m2++{- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+ Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @keys m1@ and @keys m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++ > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+-}+isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isProperSubmapOfBy predicate t1 t2+ = case submapCmp predicate t1 t2 of+ LT -> True+ _ -> False++submapCmp :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Ordering+submapCmp predicate t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> GT+ ABR -> GT+ BAL -> submapCmpLt l2+ BAR -> submapCmpLt r2+ EQL -> submapCmpEq+ NOM -> GT -- disjoint+ where+ submapCmpLt t = case submapCmp predicate t1 t of+ GT -> GT+ _ -> LT+ submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of+ (GT,_ ) -> GT+ (_ ,GT) -> GT+ (EQ,EQ) -> EQ+ _ -> LT++submapCmp _ (Bin _ _ _) _ = GT+submapCmp predicate (Tip kx x) (Tip ky y)+ | (kx == ky) && predicate x y = EQ+ | otherwise = GT -- disjoint+submapCmp predicate (Tip k x) t+ = case lookup k t of+ Just y | predicate x y -> LT+ _ -> GT -- disjoint+submapCmp _ Nil Nil = EQ+submapCmp _ Nil _ = LT++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Is this a submap?+-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+isSubmapOf m1 m2+ = isSubmapOfBy (==) m1 m2++{- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+ The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++ > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++ > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+-}+isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isSubmapOfBy predicate t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> False+ ABR -> False+ BAL -> isSubmapOfBy predicate t1 l2+ BAR -> isSubmapOfBy predicate t1 r2+ EQL -> isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2+ NOM -> False+isSubmapOfBy _ (Bin _ _ _) _ = False+isSubmapOfBy predicate (Tip k x) t = case lookup k t of+ Just y -> predicate x y+ Nothing -> False+isSubmapOfBy _ Nil _ = True++{--------------------------------------------------------------------+ Mapping+--------------------------------------------------------------------}+-- | \(O(n)\). Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> IntMap a -> IntMap b+map f = go+ where+ go (Bin p l r) = Bin p (go l) (go r)+ go (Tip k x) = Tip k (f x)+ go Nil = Nil++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+"map/coerce" map coerce = coerce+ #-}+#endif++-- | \(O(n)\). Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKey f t+ = case t of+ Bin p l r -> Bin p (mapWithKey f l) (mapWithKey f r)+ Tip k x -> Tip k (f k x)+ Nil -> Nil++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+ mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+ mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+ mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif++-- | \(O(n)\).+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing+traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b)+traverseWithKey f = go+ where+ go Nil = pure Nil+ go (Tip k v) = Tip k <$> f k v+ go (Bin p l r)+ | signBranch p = liftA2 (flip (Bin p)) (go r) (go l)+ | otherwise = liftA2 (Bin p) (go l) (go r)+{-# INLINE traverseWithKey #-}++-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)++-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumWithKey f a t+ = mapAccumL f a t++-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumL f a t+ = case t of+ Bin p l r+ | signBranch p ->+ let (a1,r') = mapAccumL f a r+ (a2,l') = mapAccumL f a1 l+ in (a2,Bin p l' r')+ | otherwise ->+ let (a1,l') = mapAccumL f a l+ (a2,r') = mapAccumL f a1 r+ in (a2,Bin p l' r')+ Tip k x -> let (a',x') = f a k x in (a',Tip k x')+ Nil -> (a,Nil)++-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumRWithKey f a t+ = case t of+ Bin p l r+ | signBranch p ->+ let (a1,l') = mapAccumRWithKey f a l+ (a2,r') = mapAccumRWithKey f a1 r+ in (a2,Bin p l' r')+ | otherwise ->+ let (a1,r') = mapAccumRWithKey f a r+ (a2,l') = mapAccumRWithKey f a1 l+ in (a2,Bin p l' r')+ Tip k x -> let (a',x') = f a k x in (a',Tip k x')+ Nil -> (a,Nil)++-- | \(O(n \min(n,W))\).+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the value at the greatest of the+-- original keys is retained.+--+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"++mapKeys :: (Key->Key) -> IntMap a -> IntMap a+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | \(O(n \min(n,W))\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"+--+-- Also see the performance note on 'fromListWith'.++mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a+mapKeysWith c f+ = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | \(O(n)\).+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- > ==> mapKeysMonotonic f s == mapKeys f s+-- > where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has slightly better performance than 'mapKeys'.+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'mapKeys' if the+-- precondition may not hold.+--+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]++mapKeysMonotonic :: (Key->Key) -> IntMap a -> IntMap a+mapKeysMonotonic f+ = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) []++{--------------------------------------------------------------------+ Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all values that satisfy some predicate.+--+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty++filter :: (a -> Bool) -> IntMap a -> IntMap a+filter p m+ = filterWithKey (\_ x -> p x) m++-- | \(O(n)\). Filter all keys that satisfy some predicate.+--+-- @+-- filterKeys p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- > filterKeys (> 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+--+-- @since 0.8++filterKeys :: (Key -> Bool) -> IntMap a -> IntMap a+filterKeys predicate = filterWithKey (\k _ -> predicate k)++-- | \(O(n)\). Filter all keys\/values that satisfy some predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a+filterWithKey predicate = go+ where+ go Nil = Nil+ go t@(Tip k x) = if predicate k x then t else Nil+ go (Bin p l r) = bin p (go l) (go r)++-- | \(O(n)\). Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partition p m+ = partitionWithKey (\_ x -> p x) m++-- | \(O(n)\). Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partitionWithKey predicate0 t0 = toPair $ go predicate0 t0+ where+ go predicate t =+ case t of+ Bin p l r ->+ let (l1 :*: l2) = go predicate l+ (r1 :*: r2) = go predicate r+ in bin p l1 r1 :*: bin p l2 r2+ Tip k x+ | predicate k x -> (t :*: Nil)+ | otherwise -> (Nil :*: t)+ Nil -> (Nil :*: Nil)++-- | \(O(\min(n,W))\). Take while a predicate on the keys holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'+-- takeWhileAntitone p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- @since 0.6.7+takeWhileAntitone :: (Key -> Bool) -> IntMap a -> IntMap a+takeWhileAntitone predicate t =+ case t of+ Bin p l r+ | signBranch p ->+ if predicate 0 -- handle negative numbers.+ then bin p (go predicate l) r+ else go predicate r+ _ -> go predicate t+ where+ go predicate' (Bin p l r)+ | predicate' (unPrefix p) = bin p l (go predicate' r)+ | otherwise = go predicate' l+ go predicate' t'@(Tip ky _)+ | predicate' ky = t'+ | otherwise = Nil+ go _ Nil = Nil++-- | \(O(\min(n,W))\). Drop while a predicate on the keys holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'+-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k))+-- @+--+-- @since 0.6.7+dropWhileAntitone :: (Key -> Bool) -> IntMap a -> IntMap a+dropWhileAntitone predicate t =+ case t of+ Bin p l r+ | signBranch p ->+ if predicate 0 -- handle negative numbers.+ then go predicate l+ else bin p l (go predicate r)+ _ -> go predicate t+ where+ go predicate' (Bin p l r)+ | predicate' (unPrefix p) = go predicate' r+ | otherwise = bin p (go predicate' l) r+ go predicate' t'@(Tip ky _)+ | predicate' ky = Nil+ | otherwise = t'+ go _ Nil = Nil++-- | \(O(\min(n,W))\). Divide a map at the point where a predicate on the keys stops holding.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = 'partitionWithKey' (\\k _ -> p k) xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map+-- at some /unspecified/ point.+--+-- @since 0.6.7+spanAntitone :: (Key -> Bool) -> IntMap a -> (IntMap a, IntMap a)+spanAntitone predicate t =+ case t of+ Bin p l r+ | signBranch p ->+ if predicate 0 -- handle negative numbers.+ then+ case go predicate l of+ (lt :*: gt) ->+ let !lt' = bin p lt r+ in (lt', gt)+ else+ case go predicate r of+ (lt :*: gt) ->+ let !gt' = bin p l gt+ in (lt, gt')+ _ -> case go predicate t of+ (lt :*: gt) -> (lt, gt)+ where+ go predicate' (Bin p l r)+ | predicate' (unPrefix p)+ = case go predicate' r of (lt :*: gt) -> bin p l lt :*: gt+ | otherwise+ = case go predicate' l of (lt :*: gt) -> lt :*: bin p gt r+ go predicate' t'@(Tip ky _)+ | predicate' ky = (t' :*: Nil)+ | otherwise = (Nil :*: t')+ go _ Nil = (Nil :*: Nil)++-- | \(O(n)\). Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | \(O(n)\). Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b+mapMaybeWithKey f (Bin p l r)+ = bin p (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+ Just y -> Tip k y+ Nothing -> Nil+mapMaybeWithKey _ Nil = Nil++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEither f m+ = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+ where+ go f (Bin p l r) =+ bin p l1 r1 :*: bin p l2 r2+ where+ (l1 :*: l2) = go f l+ (r1 :*: r2) = go f r+ go f (Tip k x) = case f k x of+ Left y -> (Tip k y :*: Nil)+ Right z -> (Nil :*: Tip k z)+ go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). The expression (@'split' k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)++split :: Key -> IntMap a -> (IntMap a, IntMap a)+split k t =+ case t of+ Bin p l r+ | signBranch p ->+ if k >= 0 -- handle negative numbers.+ then+ case go k l of+ (lt :*: gt) ->+ let !lt' = bin p lt r+ in (lt', gt)+ else+ case go k r of+ (lt :*: gt) ->+ let !gt' = bin p l gt+ in (lt, gt')+ _ -> case go k t of+ (lt :*: gt) -> (lt, gt)+ where+ go !k' t'@(Bin p l r)+ | nomatch k' p = if k' < unPrefix p then Nil :*: t' else t' :*: Nil+ | left k' p = case go k' l of (lt :*: gt) -> lt :*: bin p gt r+ | otherwise = case go k' r of (lt :*: gt) -> bin p l lt :*: gt+ go k' t'@(Tip ky _)+ | k' > ky = (t' :*: Nil)+ | k' < ky = (Nil :*: t')+ | otherwise = (Nil :*: Nil)+ go _ Nil = (Nil :*: Nil)+++data SplitLookup a = SplitLookup !(IntMap a) !(Maybe a) !(IntMap a)++mapLT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a+mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt+{-# INLINE mapLT #-}++mapGT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a+mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt)+{-# INLINE mapGT #-}++-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+--+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)++splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a)+splitLookup k t =+ case+ case t of+ Bin p l r+ | signBranch p ->+ if k >= 0 -- handle negative numbers.+ then mapLT (flip (bin p) r) (go k l)+ else mapGT (bin p l) (go k r)+ _ -> go k t+ of SplitLookup lt fnd gt -> (lt, fnd, gt)+ where+ go !k' t'@(Bin p l r)+ | nomatch k' p =+ if k' < unPrefix p+ then SplitLookup Nil Nothing t'+ else SplitLookup t' Nothing Nil+ | left k' p = mapGT (flip (bin p) r) (go k' l)+ | otherwise = mapLT (bin p l) (go k' r)+ go k' t'@(Tip ky y)+ | k' > ky = SplitLookup t' Nothing Nil+ | k' < ky = SplitLookup Nil Nothing t'+ | otherwise = SplitLookup Nil (Just y) Nil+ go _ Nil = SplitLookup Nil Nothing Nil++{--------------------------------------------------------------------+ Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr :: (a -> b -> b) -> b -> IntMap a -> b+foldr f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of+ Bin p l r+ | signBranch p -> go (go z l) r -- put negative numbers before+ | otherwise -> go (go z r) l+ _ -> go z t+ where+ go z' Nil = z'+ go z' (Tip _ x) = f x z'+ go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> IntMap a -> b+foldr' f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of+ Bin p l r+ | signBranch p -> go (go z l) r -- put negative numbers before+ | otherwise -> go (go z r) l+ _ -> go z t+ where+ go !z' Nil = z'+ go z' (Tip _ x) = f x z'+ go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+--+-- For example,+--+-- > elems = reverse . foldl (flip (:)) []+--+-- > let f len a = len + (length a)+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldl :: (a -> b -> a) -> a -> IntMap b -> a+foldl f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of+ Bin p l r+ | signBranch p -> go (go z r) l -- put negative numbers before+ | otherwise -> go (go z l) r+ _ -> go z t+ where+ go z' Nil = z'+ go z' (Tip _ x) = f z' x+ go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> IntMap b -> a+foldl' f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of+ Bin p l r+ | signBranch p -> go (go z r) l -- put negative numbers before+ | otherwise -> go (go z l) r+ _ -> go z t+ where+ go !z' Nil = z'+ go z' (Tip _ x) = f z' x+ go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrWithKey f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of+ Bin p l r+ | signBranch p -> go (go z l) r -- put negative numbers before+ | otherwise -> go (go z r) l+ _ -> go z t+ where+ go z' Nil = z'+ go z' (Tip kx x) = f kx x z'+ go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldrWithKey #-}++-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrWithKey' f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of+ Bin p l r+ | signBranch p -> go (go z l) r -- put negative numbers before+ | otherwise -> go (go z r) l+ _ -> go z t+ where+ go !z' Nil = z'+ go z' (Tip kx x) = f kx x z'+ go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldrWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+--+-- For example,+--+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []+--+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"+foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlWithKey f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of+ Bin p l r+ | signBranch p -> go (go z r) l -- put negative numbers before+ | otherwise -> go (go z l) r+ _ -> go z t+ where+ go z' Nil = z'+ go z' (Tip kx x) = f z' kx x+ go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldlWithKey #-}++-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlWithKey' f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of+ Bin p l r+ | signBranch p -> go (go z r) l -- put negative numbers before+ | otherwise -> go (go z l) r+ _ -> go z t+ where+ go !z' Nil = z'+ go z' (Tip kx x) = f z' kx x+ go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldlWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that+--+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@+--+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.+--+-- @since 0.5.4+foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m+foldMapWithKey f = go+ where+ go Nil = mempty+ go (Tip kx x) = f kx x+ go (Bin p l r)+ | signBranch p = go r `mappend` go l+ | otherwise = go l `mappend` go r+{-# INLINE foldMapWithKey #-}++{--------------------------------------------------------------------+ List variations+--------------------------------------------------------------------}+-- | \(O(n)\).+-- Return all elements of the map in the ascending order of their keys.+-- Subject to list fusion.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: IntMap a -> [a]+elems = foldr (:) []++-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list+-- fusion.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys :: IntMap a -> [Key]+keys = foldrWithKey (\k _ ks -> k : ks) []++-- | \(O(n)\). An alias for 'toAscList'. Returns all key\/value pairs in the+-- map in ascending key order. Subject to list fusion.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: IntMap a -> [(Key,a)]+assocs = toAscList++-- | \(O(n)\). The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]+-- > keysSet empty == Data.IntSet.empty++keysSet :: IntMap a -> IntSet.IntSet+keysSet Nil = IntSet.Nil+keysSet (Tip kx _) = IntSet.singleton kx+keysSet (Bin p l r)+ | unPrefix p .&. IntSet.suffixBitMask == 0+ = IntSet.Bin p (keysSet l) (keysSet r)+ | otherwise+ = IntSet.Tip (unPrefix p .&. IntSet.prefixBitMask) (computeBm (computeBm 0 l) r)+ where computeBm !acc (Bin _ l' r') = computeBm (computeBm acc l') r'+ computeBm acc (Tip kx _) = acc .|. IntSet.bitmapOf kx+ computeBm _ Nil = error "Data.IntSet.keysSet: Nil"++-- | \(O(n)\). Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.IntSet.empty == empty++fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a+fromSet _ IntSet.Nil = Nil+fromSet f (IntSet.Bin p l r) = Bin p (fromSet f l) (fromSet f r)+fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)+ where+ -- This is slightly complicated, as we to convert the dense+ -- representation of IntSet into tree representation of IntMap.+ --+ -- We are given a nonzero bit mask 'bmask' of 'bits' bits with+ -- prefix 'prefix'. We split bmask into halves corresponding+ -- to left and right subtree. If they are both nonempty, we+ -- create a Bin node, otherwise exactly one of them is nonempty+ -- and we construct the IntMap from that half.+ buildTree g !prefix !bmask bits = case bits of+ 0 -> Tip prefix (g prefix)+ _ -> case bits `iShiftRL` 1 of+ bits2+ | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->+ buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2+ | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->+ buildTree g prefix bmask bits2+ | otherwise ->+ Bin (Prefix (prefix .|. bits2))+ (buildTree g prefix bmask bits2)+ (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)++{--------------------------------------------------------------------+ Lists+--------------------------------------------------------------------}++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.6.2+instance GHCExts.IsList (IntMap a) where+ type Item (IntMap a) = (Key,a)+ fromList = fromList+ toList = toList+#endif++-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list+-- fusion.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: IntMap a -> [(Key,a)]+toList = toAscList++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the+-- keys are in ascending order. Subject to list fusion.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: IntMap a -> [(Key,a)]+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys+-- are in descending order. Subject to list fusion.+--+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]++toDescList :: IntMap a -> [(Key,a)]+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.+-- They are important to convert unfused methods back, see mapFB in prelude.+foldrFB :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrFB = foldrWithKey+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlFB = foldlWithKey+{-# INLINE[0] foldlFB #-}++-- Inline assocs and toList, so that we need to fuse only toAscList.+{-# INLINE assocs #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to+-- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to+-- inline it before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] elems #-}+{-# NOINLINE[0] keys #-}+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "IntMap.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}+{-# RULES "IntMap.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}+{-# RULES "IntMap.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}+{-# RULES "IntMap.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}+{-# RULES "IntMap.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}+{-# RULES "IntMap.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}+{-# RULES "IntMap.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}+{-# RULES "IntMap.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}+#endif+++-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> IntMap a+fromList xs+ = Foldable.foldl' ins empty xs+ where+ ins t (k,x) = insert k x t++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")]+-- > fromListWith (++) [] == empty+--+-- Note the reverse ordering of @"cba"@ in the example.+--+-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@.+--+-- === Performance+--+-- You should ensure that the given @f@ is fast with this order of arguments.+--+-- Symmetric functions may be slow in one order, and fast in another.+-- For the common case of collecting values of matching keys in a list, as above:+--+-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument.+-- Thus:+--+-- > fromListWith (++) (replicate 1000000 (3, "x")) -- O(n), fast+-- > fromListWith (flip (++)) (replicate 1000000 (3, "x")) -- O(n²), extremely slow+--+-- because they evaluate as, respectively:+--+-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))] -- O(n)+-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")] -- O(n²)+--+-- Thus, to get good performance with an operation like @(++)@ while also preserving+-- the same order as in the input list, reverse the input:+--+-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")]+--+-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in:+--+-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples++fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWith f xs+ = fromListWithKey (\_ x y -> f x y) xs++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty+--+-- Also see the performance note on 'fromListWith'.++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWithKey f xs+ = Foldable.foldl' ins empty xs+ where+ ins t (k,x) = insertWithKey f k x t++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> IntMap a+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+--+-- Also see the performance note on 'fromListWith'.++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)+{-# NOINLINE fromAscListWith #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")]+--+-- Also see the performance note on 'fromListWith'.++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWithKey f = fromMonoListWithKey Nondistinct f+{-# NOINLINE fromAscListWithKey #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+--+-- __Warning__: This function should be used only if the keys are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++fromDistinctAscList :: [(Key,a)] -> IntMap a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.+--+-- Also see the performance note on 'fromListWith'.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromMonoListWithKey distinct f = go+ where+ go [] = Nil+ go ((kx,vx) : zs1) = addAll' kx vx zs1++ -- `addAll'` collects all keys equal to `kx` into a single value,+ -- and then proceeds with `addAll`.+ addAll' !kx vx []+ = Tip kx vx+ addAll' !kx vx ((ky,vy) : zs)+ | Nondistinct <- distinct, kx == ky+ = let v = f kx vy vx in addAll' ky v zs+ -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)+ | m <- branchMask kx ky+ , Inserted ty zs' <- addMany' m ky vy zs+ = addAll kx (linkWithMask m ky ty kx (Tip kx vx)) zs'++ -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`+ -- `addAll` consumes the rest of the list, adding to the tree `tx`+ addAll !_kx !tx []+ = tx+ addAll !kx !tx ((ky,vy) : zs)+ | m <- branchMask kx ky+ , Inserted ty zs' <- addMany' m ky vy zs+ = addAll kx (linkWithMask m ky ty kx tx) zs'++ -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+ addMany' !_m !kx vx []+ = Inserted (Tip kx vx) []+ addMany' !m !kx vx zs0@((ky,vy) : zs)+ | Nondistinct <- distinct, kx == ky+ = let v = f kx vy vx in addMany' m ky v zs+ -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)+ | mask kx m /= mask ky m+ = Inserted (Tip kx vx) zs0+ | mxy <- branchMask kx ky+ , Inserted ty zs' <- addMany' mxy ky vy zs+ = addMany m kx (linkWithMask mxy ky ty kx (Tip kx vx)) zs'++ -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.+ addMany !_m !_kx tx []+ = Inserted tx []+ addMany !m !kx tx zs0@((ky,vy) : zs)+ | mask kx m /= mask ky m+ = Inserted tx zs0+ | mxy <- branchMask kx ky+ , Inserted ty zs' <- addMany' mxy ky vy zs+ = addMany m kx (linkWithMask mxy ky ty kx tx) zs'+{-# INLINE fromMonoListWithKey #-}++data Inserted a = Inserted !(IntMap a) ![(Key,a)]++data Distinct = Distinct | Nondistinct++{--------------------------------------------------------------------+ Eq+--------------------------------------------------------------------}+instance Eq a => Eq (IntMap a) where+ (==) = equal++equal :: Eq a => IntMap a -> IntMap a -> Bool+equal (Bin p1 l1 r1) (Bin p2 l2 r2)+ = (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx x) (Tip ky y)+ = (kx == ky) && (x==y)+equal Nil Nil = True+equal _ _ = False+{-# INLINABLE equal #-}++-- | @since 0.5.9+instance Eq1 IntMap where+ liftEq eq = go+ where+ go (Bin p1 l1 r1) (Bin p2 l2 r2) = p1 == p2 && go l1 l2 && go r1 r2+ go (Tip kx x) (Tip ky y) = kx == ky && eq x y+ go Nil Nil = True+ go _ _ = False+ {-# INLINE liftEq #-}++{--------------------------------------------------------------------+ Ord+--------------------------------------------------------------------}++instance Ord a => Ord (IntMap a) where+ compare m1 m2 = liftCmp compare m1 m2+ {-# INLINABLE compare #-}++-- | @since 0.5.9+instance Ord1 IntMap where+ liftCompare = liftCmp++liftCmp :: (a -> b -> Ordering) -> IntMap a -> IntMap b -> Ordering+liftCmp cmp m1 m2 = case (splitSign m1, splitSign m2) of+ ((l1, r1), (l2, r2)) -> case go l1 l2 of+ A_LT_B -> LT+ A_Prefix_B -> if null r1 then LT else GT+ A_EQ_B -> case go r1 r2 of+ A_LT_B -> LT+ A_Prefix_B -> LT+ A_EQ_B -> EQ+ B_Prefix_A -> GT+ A_GT_B -> GT+ B_Prefix_A -> if null r2 then GT else LT+ A_GT_B -> GT+ where+ go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> case go l1 t2 of+ A_Prefix_B -> A_GT_B+ A_EQ_B -> B_Prefix_A+ o -> o+ ABR -> A_LT_B+ BAL -> case go t1 l2 of+ A_EQ_B -> A_Prefix_B+ B_Prefix_A -> A_LT_B+ o -> o+ BAR -> A_GT_B+ EQL -> case go l1 l2 of+ A_Prefix_B -> A_GT_B+ A_EQ_B -> go r1 r2+ B_Prefix_A -> A_LT_B+ o -> o+ NOM -> if unPrefix p1 < unPrefix p2 then A_LT_B else A_GT_B+ go (Bin _ l1 _) (Tip k2 x2) = case lookupMinSure l1 of+ KeyValue k1 x1 -> case compare k1 k2 <> cmp x1 x2 of+ LT -> A_LT_B+ EQ -> B_Prefix_A+ GT -> A_GT_B+ go (Tip k1 x1) (Bin _ l2 _) = case lookupMinSure l2 of+ KeyValue k2 x2 -> case compare k1 k2 <> cmp x1 x2 of+ LT -> A_LT_B+ EQ -> A_Prefix_B+ GT -> A_GT_B+ go (Tip k1 x1) (Tip k2 x2) = case compare k1 k2 <> cmp x1 x2 of+ LT -> A_LT_B+ EQ -> A_EQ_B+ GT -> A_GT_B+ go Nil Nil = A_EQ_B+ go Nil _ = A_Prefix_B+ go _ Nil = B_Prefix_A+{-# INLINE liftCmp #-}++-- Split into negative and non-negative+splitSign :: IntMap a -> (IntMap a, IntMap a)+splitSign t@(Bin p l r)+ | signBranch p = (r, l)+ | unPrefix p < 0 = (t, Nil)+ | otherwise = (Nil, t)+splitSign t@(Tip k _)+ | k < 0 = (t, Nil)+ | otherwise = (Nil, t)+splitSign Nil = (Nil, Nil)+{-# INLINE splitSign #-}++{--------------------------------------------------------------------+ Functor+--------------------------------------------------------------------}++instance Functor IntMap where+ fmap = map++#ifdef __GLASGOW_HASKELL__+ a <$ Bin p l r = Bin p (a <$ l) (a <$ r)+ a <$ Tip k _ = Tip k a+ _ <$ Nil = Nil+#endif++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}++instance Show a => Show (IntMap a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++-- | @since 0.5.9+instance Show1 IntMap where+ liftShowsPrec sp sl d m =+ showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance (Read e) => Read (IntMap e) where+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++-- | @since 0.5.9+instance Read1 IntMap where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl++{--------------------------------------------------------------------+ Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+ Link+--------------------------------------------------------------------}++-- | Link two @IntMap@s. The maps must not be empty. The @Prefix@es of the two+-- maps must be different. @k1@ must share the prefix of @t1@. @p2@ must be the+-- prefix of @t2@.+linkKey :: Key -> IntMap a -> Prefix -> IntMap a -> IntMap a+linkKey k1 t1 p2 t2 = link k1 t1 (unPrefix p2) t2+{-# INLINE linkKey #-}++-- | Link two @IntMap@s. The maps must not be empty. The @Prefix@es of the two+-- maps must be different. @k1@ must share the prefix of @t1@ and @k2@ must+-- share the prefix of @t2@.+link :: Int -> IntMap a -> Int -> IntMap a -> IntMap a+link k1 t1 k2 t2 = linkWithMask (branchMask k1 k2) k1 t1 k2 t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Int -> Key -> IntMap a -> Key -> IntMap a -> IntMap a+linkWithMask m k1 t1 k2 t2+ | i2w k1 < i2w k2 = Bin p t1 t2+ | otherwise = Bin p t2 t1+ where+ p = Prefix (mask k1 m .|. m)+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+ @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}++bin :: Prefix -> IntMap a -> IntMap a -> IntMap a+bin _ l Nil = l+bin _ Nil r = r+bin p l r = Bin p l r+{-# INLINE bin #-}++-- binCheckLeft only checks that the left subtree is non-empty+binCheckLeft :: Prefix -> IntMap a -> IntMap a -> IntMap a+binCheckLeft _ Nil r = r+binCheckLeft p l r = Bin p l r+{-# INLINE binCheckLeft #-}++-- binCheckRight only checks that the right subtree is non-empty+binCheckRight :: Prefix -> IntMap a -> IntMap a -> IntMap a+binCheckRight _ l Nil = l+binCheckRight p l r = Bin p l r+{-# INLINE binCheckRight #-}++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}++-- | \(O(1)\). Decompose a map into pieces based on the structure+-- of the underlying tree. This function is useful for consuming a+-- map in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this. However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==+-- > [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]+--+-- > splitRoot empty == []+--+-- Note that the current implementation does not return more than two submaps,+-- but you should not depend on this behaviour because it can change in the+-- future without notice.+splitRoot :: IntMap a -> [IntMap a]+splitRoot orig =+ case orig of+ Nil -> []+ x@(Tip _ _) -> [x]+ Bin p l r+ | signBranch p -> [r, l]+ | otherwise -> [l, r]+{-# INLINE splitRoot #-}+++{--------------------------------------------------------------------+ Debugging+--------------------------------------------------------------------}++-- | \(O(n \min(n,W))\). Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => IntMap a -> String+showTree s+ = showTreeWith True False s+++{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the map. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String+showTreeWith hang wide t+ | hang = (showsTreeHang wide [] t) ""+ | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS+showsTree wide lbars rbars t = case t of+ Bin p l r ->+ showsTree wide (withBar rbars) (withEmpty rbars) r .+ showWide wide rbars .+ showsBars lbars . showString (showBin p) . showString "\n" .+ showWide wide lbars .+ showsTree wide (withEmpty lbars) (withBar lbars) l+ Tip k x ->+ showsBars lbars .+ showString " " . shows k . showString ":=" . shows x . showString "\n"+ Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS+showsTreeHang wide bars t = case t of+ Bin p l r ->+ showsBars bars . showString (showBin p) . showString "\n" .+ showWide wide bars .+ showsTreeHang wide (withBar bars) l .+ showWide wide bars .+ showsTreeHang wide (withEmpty bars) r+ Tip k x ->+ showsBars bars .+ showString " " . shows k . showString ":=" . shows x . showString "\n"+ Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> String+showBin _+ = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+ | wide = showString (concat (reverse bars)) . showString "|\n"+ | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+ = case bars of+ [] -> id+ _ : tl -> showString (concat (reverse tl)) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars = "| ":bars+withEmpty bars = " ":bars++{--------------------------------------------------------------------+ Notes+--------------------------------------------------------------------}++-- Note [Okasaki-Gill]+-- ~~~~~~~~~~~~~~~~~~~+--+-- The IntMap structure is based on the map described in the paper "Fast+-- Mergeable Integer Maps" by Chris Okasaki and Andy Gill, with some+-- differences.+--+-- The paper spends most of its time describing a little-endian tree, where the+-- branching is done first on low bits then high bits. It then briefly describes+-- a big-endian tree. The implementation here is big-endian.+--+-- The definition of Okasaki and Gill's map would be written in Haskell as+--+-- data Dict a+-- = Empty+-- | Lf !Int a+-- | Br !Int !Int !(Dict a) !(Dict a)+--+-- Empty is the same as IntMap's Nil, and Lf is the same as Tip.+--+-- In Br, the first Int is the shared prefix and the second is the mask bit by+-- itself. For the big-endian map, the paper suggests that the prefix be the+-- common prefix, followed by a 0-bit, followed by all 1-bits. This is so that+-- the prefix value can be used as a point of split for binary search.+--+-- IntMap's Bin corresponds to Br, but is different because it has only one+-- Int (newtyped as Prefix). This describes both prefix and mask, so it is not+-- necessary to store them separately. This value is, in fact, one plus the+-- value suggested for the prefix in the paper. This representation is chosen+-- because it saves one word per Bin without detriment to the efficiency of+-- operations.+--+-- The implementation of operations such as lookup, insert, union, follow+-- the described implementations on Dict and split into the same cases. For+-- instance, for insert, the three cases on a Br are whether the key belongs+-- outside the map, or it belongs in the left child, or it belongs in the+-- right child. We have the same three cases for a Bin. However, the bitwise+-- operations we use to determine the case is naturally different due to the+-- difference in representation.++-- Note [IntMap merge complexity]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The merge algorithm (used for union, intersection, etc.) is adopted from+-- Okasaki-Gill who give the complexity as O(m+n), where m and n are the sizes+-- of the two input maps. This is correct, since we visit all constructors in+-- both maps in the worst case, but we can try to find a tighter bound.+--+-- Consider that m<=n, i.e. m is the size of the smaller map and n is the size+-- of the larger. It does not matter which map is the first argument.+--+-- Now we have O(n) as one upper bound for our complexity, since O(n) is the+-- same as O(m+n) for m<=n.+--+-- Next, consider the smaller map. For this map, we will visit some+-- constructors, plus all the Bins of the larger map that lie in our way.+-- For the former, the worst case is that we visit all constructors, which is+-- O(m).+-- For the latter, the worst case is that we encounter Bins at every point+-- possible. This happens when for every key in the smaller map, the path to+-- that key's Tip in the larger map has a full length of W, with a Bin at every+-- bit position. To maximize the total number of Bins, the paths should be as+-- disjoint as possible. But even if the paths are spread out, at least O(m)+-- Bins are unavoidably shared, which extend up to a depth of lg(m) from the+-- root. Beyond this, the paths may be disjoint. This gives us a total of+-- O(m + m (W - lg m)) = O(m log (2^W / m)).+-- The number of Bins we encounter is also bounded by the total number of Bins,+-- which is n-1, but we already have O(n) as an upper bound.+--+-- Combining our bounds, we have the final complexity as+-- O(min(n, m log (2^W / m))).+--+-- Note that+-- * This is similar to the Map merge complexity, which is O(m log (n/m)).+-- * When m is a small constant the term simplifies to O(min(n, W)), which is+-- just the complexity we expect for single operations like insert and delete.
− src/Data/IntMap/Internal/DeprecatedDebug.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts, DataKinds, MonoLocalBinds #-}--module Data.IntMap.Internal.DeprecatedDebug where-import Data.IntMap.Internal (IntMap)--import Utils.Containers.Internal.TypeError----- | 'showTree' has moved to 'Data.IntMap.Internal.Debug.showTree'-showTree :: Whoops "Data.IntMap.showTree has moved to Data.IntMap.Internal.Debug.showTree"- => IntMap a -> String-showTree _ = undefined---- | 'showTreeWith' has moved to 'Data.IntMap.Internal.Debug.showTreeWith'-showTreeWith :: Whoops "Data.IntMap.showTreeWith has moved to Data.IntMap.Internal.Debug.showTreeWith"- => Bool -> Bool -> IntMap a -> String-showTreeWith _ _ _ = undefined
src/Data/IntMap/Lazy.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif @@ -28,7 +28,7 @@ -- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>. -- -- This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:+-- Prelude functions, e.g. -- -- > import Data.IntMap.Lazy (IntMap) -- > import qualified Data.IntMap.Lazy as IntMap@@ -38,16 +38,6 @@ -- prefer the values in the first argument to those in the second. -- ----- == Detailed performance information------ The amortized running time is given for each operation, with /n/ referring to--- the number of entries in the map and /W/ referring to the number of bits in--- an 'Int' (32 or 64).------ Benchmarks comparing "Data.IntMap.Lazy" with other dictionary--- implementations can be found at https://github.com/haskell-perf/dictionaries.------ -- == Implementation -- -- The implementation is based on /big-endian patricia trees/. This data@@ -56,22 +46,58 @@ -- on insertions and deletions when compared to a generic size-balanced map -- implementation (see "Data.Map"). ----- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",+-- * Chris Okasaki and Andy Gill,+-- \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86,--- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+-- <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>. ----- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",--- Journal of the ACM, 15(4), October 1968, pages 514-534.+-- * D.R. Morrison,+-- \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+-- Journal of the ACM, 15(4), October 1968, pages 514-534,+-- <https://doi.org/10.1145/321479.321481>. --+--+-- == Performance information+--+-- Operation comments contain the operation time complexity in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'lookup', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+-- the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+-- shared by all subelements, so there could not be more+-- than \(W\) levels.+--+-- If all \(n\) keys in the tree are between 0 and \(N\) (or, say, between+-- \(-N\) and \(N\)), the estimate can be refined to \(O(\min(n, \log N))\). If+-- the set of keys is sufficiently "dense", this becomes \(O(\min(n, \log n))\)+-- or simply the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntMap' are keys from a contiguous subset,+-- in which case the complexity is proportional to \(\log n\), capped by \(W\).+-- The worst scenario are exponentially growing keys \(1,2,4,\ldots,2^n\),+-- for which complexity grows as fast as \(n\) but again is capped by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.IntMap.Lazy" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+-- ----------------------------------------------------------------------------- module Data.IntMap.Lazy ( -- * Map type-#if !defined(TESTING) IntMap, Key -- instance Eq,Show-#else- IntMap(..), Key -- instance Eq,Show-#endif -- * Construction , empty@@ -142,6 +168,9 @@ , intersectionWith , intersectionWithKey + -- ** Symmetric difference+ , symmetricDifference+ -- ** Disjoint , disjoint @@ -172,8 +201,8 @@ , foldMapWithKey -- ** Strict folds- , foldr'- , foldl'+ , IM.foldr'+ , IM.foldl' , foldrWithKey' , foldlWithKey' @@ -192,12 +221,17 @@ -- * Filter , IM.filter+ , filterKeys , filterWithKey , restrictKeys , withoutKeys , partition , partitionWithKey + , takeWhileAntitone+ , dropWhileAntitone+ , spanAntitone+ , mapMaybe , mapMaybeWithKey , mapEither@@ -228,15 +262,6 @@ , maxView , minViewWithKey , maxViewWithKey--#ifdef __GLASGOW_HASKELL__- -- * Debugging- , showTree- , showTreeWith-#endif ) where -import Data.IntMap.Internal as IM hiding (showTree, showTreeWith)-#ifdef __GLASGOW_HASKELL__-import Data.IntMap.Internal.DeprecatedDebug-#endif+import Data.IntMap.Internal as IM
src/Data/IntMap/Merge/Lazy.hs view
@@ -1,19 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}-#define USE_MAGIC_PROXY 1-#endif--#if USE_MAGIC_PROXY-{-# LANGUAGE MagicHash #-} #endif #include "containers.h"
src/Data/IntMap/Merge/Strict.hs view
@@ -1,21 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} #endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}-#define USE_MAGIC_PROXY 1-#endif -#if USE_MAGIC_PROXY-{-# LANGUAGE MagicHash #-}-#endif- #include "containers.h" -----------------------------------------------------------------------------@@ -112,9 +100,6 @@ , runWhenMissing ) import Data.IntMap.Strict.Internal-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (Applicative (..), (<$>))-#endif import Prelude hiding (filter, map, foldl, foldr) -- | Map covariantly over a @'WhenMissing' f k x@.
src/Data/IntMap/Strict.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} #endif @@ -36,7 +35,7 @@ -- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>. -- -- This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:+-- Prelude functions, e.g. -- -- > import Data.IntMap.Strict (IntMap) -- > import qualified Data.IntMap.Strict as IntMap@@ -46,16 +45,6 @@ -- prefer the values in the first argument to those in the second. -- ----- == Detailed performance information------ The amortized running time is given for each operation, with /n/ referring to--- the number of entries in the map and /W/ referring to the number of bits in--- an 'Int' (32 or 64).------ Benchmarks comparing "Data.IntMap.Strict" with other dictionary--- implementations can be found at https://github.com/haskell-perf/dictionaries.------ -- == Warning -- -- The 'IntMap' type is shared between the lazy and strict modules, meaning that@@ -73,24 +62,60 @@ -- on insertions and deletions when compared to a generic size-balanced map -- implementation (see "Data.Map"). ----- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",+-- * Chris Okasaki and Andy Gill,+-- \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86,--- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+-- <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>. ----- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",--- Journal of the ACM, 15(4), October 1968, pages 514-534.+-- * D.R. Morrison,+-- \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+-- Journal of the ACM, 15(4), October 1968, pages 514-534,+-- <https://doi.org/10.1145/321479.321481>. --+--+-- == Performance information+--+-- Operation comments contain the operation time complexity in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'lookup', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+-- the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+-- shared by all subelements, so there could not be more+-- than \(W\) levels.+--+-- If all \(n\) keys in the tree are between 0 and \(N\) (or, say, between+-- \(-N\) and \(N\)), the estimate can be refined to \(O(\min(n, \log N))\). If+-- the set of keys is sufficiently "dense", this becomes \(O(\min(n, \log n))\)+-- or simply the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntMap' are keys from a contiguous subset,+-- in which case the complexity is proportional to \(\log n\), capped by \(W\).+-- The worst scenario are exponentially growing keys \(1,2,4,\ldots,2^n\),+-- for which complexity grows as fast as \(n\) but again is capped by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.IntMap.Strict" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+-- ----------------------------------------------------------------------------- -- See the notes at the beginning of Data.IntMap.Internal. module Data.IntMap.Strict ( -- * Map type-#if !defined(TESTING) IntMap, Key -- instance Eq,Show-#else- IntMap(..), Key -- instance Eq,Show-#endif -- * Construction , empty@@ -161,6 +186,9 @@ , intersectionWith , intersectionWithKey + -- ** Symmetric difference+ , symmetricDifference+ -- ** Disjoint , disjoint @@ -211,12 +239,17 @@ -- * Filter , filter+ , filterKeys , filterWithKey , restrictKeys , withoutKeys , partition , partitionWithKey + , takeWhileAntitone+ , dropWhileAntitone+ , spanAntitone+ , mapMaybe , mapMaybeWithKey , mapEither@@ -247,12 +280,6 @@ , maxView , minViewWithKey , maxViewWithKey--#ifdef __GLASGOW_HASKELL__- -- * Debugging- , showTree- , showTreeWith-#endif ) where import Data.IntMap.Strict.Internal
src/Data/IntMap/Strict/Internal.hs view
@@ -15,54 +15,23 @@ -- Maintainer : libraries@haskell.org -- Portability : portable -------- = Finite Int Maps (strict interface)------ The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)--- from key of type @Int@ to values of type @v@.------ Each function in this module is careful to force values before installing--- them in an 'IntMap'. This is usually more efficient when laziness is not--- necessary. When laziness /is/ required, use the functions in--- "Data.IntMap.Lazy".------ In particular, the functions in this module obey the following law:------ - If all values stored in all maps in the arguments are in WHNF, then all--- values stored in all maps in the results will be in WHNF once those maps--- are evaluated.------ For a walkthrough of the most commonly used functions see the--- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.------ This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:------ > import Data.IntMap.Strict (IntMap)--- > import qualified Data.IntMap.Strict as IntMap------ Note that the implementation is generally /left-biased/. Functions that take--- two maps as arguments and combine them, such as `union` and `intersection`,--- prefer the values in the first argument to those in the second.+-- = WARNING --+-- This module is considered __internal__. ----- == Detailed performance information+-- The Package Versioning Policy __does not apply__. ----- The amortized running time is given for each operation, with /n/ referring to--- the number of entries in the map and /W/ referring to the number of bits in--- an 'Int' (32 or 64).+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package. ----- Benchmarks comparing "Data.IntMap.Strict" with other dictionary--- implementations can be found at https://github.com/haskell-perf/dictionaries.+-- Authors importing this module are expected to track development+-- closely. -- ----- == Warning+-- = Finite Int Maps (strict interface internals) ----- The 'IntMap' type is shared between the lazy and strict modules, meaning that--- the same 'IntMap' value can be passed to functions in both modules. This--- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are--- the same as for the "Data.IntMap.Lazy" module, so if they are used the--- resulting map may contain suspended values (thunks).+-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)+-- from key of type @Int@ to values of type @v@. -- -- -- == Implementation@@ -73,12 +42,15 @@ -- on insertions and deletions when compared to a generic size-balanced map -- implementation (see "Data.Map"). ----- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",+-- * Chris Okasaki and Andy Gill,+-- \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86,--- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+-- <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>. ----- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",--- Journal of the ACM, 15(4), October 1968, pages 514-534.+-- * D.R. Morrison,+-- \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+-- Journal of the ACM, 15(4), October 1968, pages 514-534,+-- <https://doi.org/10.1145/321479.321481>. -- ----------------------------------------------------------------------------- @@ -86,11 +58,7 @@ module Data.IntMap.Strict.Internal ( -- * Map type-#if !defined(TESTING) IntMap, Key -- instance Eq,Show-#else- IntMap(..), Key -- instance Eq,Show-#endif -- * Construction , empty@@ -161,6 +129,9 @@ , intersectionWith , intersectionWithKey + -- ** Symmetric difference+ , symmetricDifference+ -- ** Disjoint , disjoint @@ -211,12 +182,17 @@ -- * Filter , filter+ , filterKeys , filterWithKey , restrictKeys , withoutKeys , partition , partitionWithKey + , takeWhileAntitone+ , dropWhileAntitone+ , spanAntitone+ , mapMaybe , mapMaybeWithKey , mapEither@@ -247,31 +223,23 @@ , maxView , minViewWithKey , maxViewWithKey--#ifdef __GLASGOW_HASKELL__- -- * Debugging- , showTree- , showTreeWith-#endif ) where -import Prelude hiding (lookup,map,filter,foldr,foldl,null)+import Utils.Containers.Internal.Prelude hiding+ (lookup,map,filter,foldr,foldl,foldl',null)+import Prelude () import Data.Bits import qualified Data.IntMap.Internal as L+import Data.IntSet.Internal.IntTreeCommons+ (Key, Prefix(..), nomatch, left, signBranch, mask, branchMask) import Data.IntMap.Internal ( IntMap (..)- , Key- , mask- , branchMask- , nomatch- , zero- , natFromInt- , intFromNat , bin , binCheckLeft , binCheckRight , link+ , linkKey , linkWithMask , (\\)@@ -280,6 +248,7 @@ , empty , assocs , filter+ , filterKeys , filterWithKey , findMin , findMax@@ -309,6 +278,7 @@ , isSubmapOf , isSubmapOfBy , lookup+ , findWithDefault , lookupLE , lookupGE , lookupLT@@ -327,11 +297,15 @@ , null , partition , partitionWithKey+ , takeWhileAntitone+ , dropWhileAntitone+ , spanAntitone , restrictKeys , size , split , splitLookup , splitRoot+ , symmetricDifference , toAscList , toDescList , toList@@ -339,47 +313,15 @@ , unions , withoutKeys )-#ifdef __GLASGOW_HASKELL__-import Data.IntMap.Internal.DeprecatedDebug (showTree, showTreeWith)-#endif import qualified Data.IntSet.Internal as IntSet-import Utils.Containers.Internal.BitUtil+import Utils.Containers.Internal.BitUtil (iShiftRL, shiftLL, shiftRL) import Utils.Containers.Internal.StrictPair-#if !MIN_VERSION_base(4,8,0)-import Data.Functor((<$>))-#endif-import Control.Applicative (Applicative (..), liftA2) import qualified Data.Foldable as Foldable-#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable())-#endif {--------------------------------------------------------------------- Query---------------------------------------------------------------------}---- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@--- returns the value at key @k@ or returns @def@ when the key is not an--- element of the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'---- See IntMap.Internal.Note: Local 'go' functions and capturing]-findWithDefault :: a -> Key -> IntMap a -> a-findWithDefault def !k = go- where- go (Bin p m l r) | nomatch k p m = def- | zero k m = go l- | otherwise = go r- go (Tip kx x) | k == kx = x- | otherwise = def- go Nil = def--{-------------------------------------------------------------------- Construction --------------------------------------------------------------------}--- | /O(1)/. A map of one element.+-- | \(O(1)\). A map of one element. -- -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1@@ -392,7 +334,7 @@ {-------------------------------------------------------------------- Insert --------------------------------------------------------------------}--- | /O(min(n,W))/. Insert a new key\/value pair in the map.+-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map. -- If the key is already present in the map, the associated value is -- replaced with the supplied value, i.e. 'insert' is equivalent to -- @'insertWith' 'const'@.@@ -404,17 +346,17 @@ insert :: Key -> a -> IntMap a -> IntMap a insert !k !x t = case t of- Bin p m l r- | nomatch k p m -> link k (Tip k x) p t- | zero k m -> Bin p m (insert k x l) r- | otherwise -> Bin p m l (insert k x r)+ Bin p l r+ | nomatch k p -> linkKey k (Tip k x) p t+ | left k p -> Bin p (insert k x l) r+ | otherwise -> Bin p l (insert k x r) Tip ky _ | k==ky -> Tip k x | otherwise -> link k (Tip k x) ky t Nil -> Tip k x -- right-biased insertion, used by 'union'--- | /O(min(n,W))/. Insert with a combining function.+-- | \(O(\min(n,W))\). Insert with a combining function. -- @'insertWith' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will@@ -423,12 +365,14 @@ -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'. insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWith f k x t = insertWithKey (\_ x' y' -> f x' y') k x t --- | /O(min(n,W))/. Insert with a combining function.+-- | \(O(\min(n,W))\). Insert with a combining function. -- @'insertWithKey' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will@@ -441,20 +385,22 @@ -- -- If the key exists in the map, this function is lazy in @value@ but strict -- in the result of @f@.+--+-- Also see the performance note on 'fromListWith'. insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a insertWithKey f !k x t = case t of- Bin p m l r- | nomatch k p m -> link k (singleton k x) p t- | zero k m -> Bin p m (insertWithKey f k x l) r- | otherwise -> Bin p m l (insertWithKey f k x r)+ Bin p l r+ | nomatch k p -> linkKey k (singleton k x) p t+ | left k p -> Bin p (insertWithKey f k x l) r+ | otherwise -> Bin p l (insertWithKey f k x r) Tip ky y | k==ky -> Tip k $! f k x y | otherwise -> link k (singleton k x) ky t Nil -> singleton k x --- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)+-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@) -- is a pair where the first element is equal to (@'lookup' k map@) -- and the second element equal to (@'insertWithKey' f k x map@). --@@ -468,16 +414,18 @@ -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])+--+-- Also see the performance note on 'fromListWith'. insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0 where go f k x t = case t of- Bin p m l r- | nomatch k p m -> Nothing :*: link k (singleton k x) p t- | zero k m -> let (found :*: l') = go f k x l in (found :*: Bin p m l' r)- | otherwise -> let (found :*: r') = go f k x r in (found :*: Bin p m l r')+ Bin p l r+ | nomatch k p -> Nothing :*: linkKey k (singleton k x) p t+ | left k p -> let (found :*: l') = go f k x l in (found :*: Bin p l' r)+ | otherwise -> let (found :*: r') = go f k x r in (found :*: Bin p l r') Tip ky y | k==ky -> (Just y :*: (Tip k $! f k x y)) | otherwise -> (Nothing :*: link k (singleton k x) ky t)@@ -487,7 +435,7 @@ {-------------------------------------------------------------------- Deletion --------------------------------------------------------------------}--- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]@@ -498,7 +446,7 @@ adjust f k m = adjustWithKey (\_ x -> f x) k m --- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > let f key x = (show key) ++ ":new " ++ x@@ -509,16 +457,16 @@ adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a adjustWithKey f !k t = case t of- Bin p m l r- | nomatch k p m -> t- | zero k m -> Bin p m (adjustWithKey f k l) r- | otherwise -> Bin p m l (adjustWithKey f k r)+ Bin p l r+ | nomatch k p -> t+ | left k p -> Bin p (adjustWithKey f k l) r+ | otherwise -> Bin p l (adjustWithKey f k r) Tip ky y | k==ky -> Tip ky $! f k y | otherwise -> t Nil -> Nil --- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --@@ -531,7 +479,7 @@ update f = updateWithKey (\_ x -> f x) --- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --@@ -543,10 +491,10 @@ updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a updateWithKey f !k t = case t of- Bin p m l r- | nomatch k p m -> t- | zero k m -> binCheckLeft p m (updateWithKey f k l) r- | otherwise -> binCheckRight p m l (updateWithKey f k r)+ Bin p l r+ | nomatch k p -> t+ | left k p -> binCheckLeft p (updateWithKey f k l) r+ | otherwise -> binCheckRight p l (updateWithKey f k r) Tip ky y | k==ky -> case f k y of Just !y' -> Tip ky y'@@ -554,7 +502,7 @@ | otherwise -> t Nil -> Nil --- | /O(min(n,W))/. Lookup and update.+-- | \(O(\min(n,W))\). Look up and update. -- The function returns original value, if it is updated. -- This is different behavior than 'Data.Map.updateLookupWithKey'. -- Returns the original key value if the map entry is deleted.@@ -569,10 +517,10 @@ where go f k t = case t of- Bin p m l r- | nomatch k p m -> (Nothing :*: t)- | zero k m -> let (found :*: l') = go f k l in (found :*: binCheckLeft p m l' r)- | otherwise -> let (found :*: r') = go f k r in (found :*: binCheckRight p m l r')+ Bin p l r+ | nomatch k p -> (Nothing :*: t)+ | left k p -> let (found :*: l') = go f k l in (found :*: binCheckLeft p l' r)+ | otherwise -> let (found :*: r') = go f k r in (found :*: binCheckRight p l r') Tip ky y | k==ky -> case f k y of Just !y' -> (Just y :*: Tip ky y')@@ -582,18 +530,18 @@ --- | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alter' can be used to insert, delete, or update a value in an 'IntMap'. -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a alter f !k t = case t of- Bin p m l r- | nomatch k p m -> case f Nothing of- Nothing -> t- Just !x -> link k (Tip k x) p t- | zero k m -> binCheckLeft p m (alter f k l) r- | otherwise -> binCheckRight p m l (alter f k r)+ Bin p l r+ | nomatch k p -> case f Nothing of+ Nothing -> t+ Just !x -> linkKey k (Tip k x) p t+ | left k p -> binCheckLeft p (alter f k l) r+ | otherwise -> binCheckRight p l (alter f k r) Tip ky y | k==ky -> case f (Just y) of Just !x -> Tip ky x@@ -605,9 +553,9 @@ Just !x -> Tip k x Nothing -> Nil --- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at+-- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at -- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete,--- or update a value in an 'IntMap'. In short : @'lookup' k <$> 'alterF' f k m = f+-- or update a value in an 'IntMap'. In short : @'lookup' k \<$\> 'alterF' f k m = f -- ('lookup' k m)@. -- -- Example:@@ -655,18 +603,24 @@ unionsWith f ts = Foldable.foldl' (unionWith f) empty ts --- | /O(n+m)/. The union with a combining function.+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'. unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a unionWith f m1 m2 = unionWithKey (\_ x y -> f x y) m1 m2 --- | /O(n+m)/. The union with a combining function.+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'. unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a unionWithKey f m1 m2@@ -676,7 +630,8 @@ Difference --------------------------------------------------------------------} --- | /O(n+m)/. Difference with a combining function.+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function. -- -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])@@ -686,7 +641,8 @@ differenceWith f m1 m2 = differenceWithKey (\_ x y -> f x y) m1 m2 --- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). -- If it returns (@'Just' y@), the element is updated with a new value @y@.@@ -703,7 +659,8 @@ Intersection --------------------------------------------------------------------} --- | /O(n+m)/. The intersection with a combining function.+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" @@ -711,7 +668,8 @@ intersectionWith f m1 m2 = intersectionWithKey (\_ x y -> f x y) m1 m2 --- | /O(n+m)/. The intersection with a combining function.+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"@@ -724,12 +682,13 @@ MergeWithKey --------------------------------------------------------------------} --- | /O(n+m)/. A high-performance universal combining function. Using+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- A high-performance universal combining function. Using -- 'mergeWithKey', all combining functions can be defined without any loss of -- efficiency (with exception of 'union', 'difference' and 'intersection', -- where sharing of some nodes is lost with 'mergeWithKey'). ----- Please make sure you know what is going on when using 'mergeWithKey',+-- __Warning__: Please make sure you know what is going on when using 'mergeWithKey', -- otherwise you can be surprised by unexpected code growth or even -- corruption of the data structure. --@@ -773,39 +732,39 @@ Min\/Max --------------------------------------------------------------------} --- | /O(log n)/. Update the value at the minimal key.+-- | \(O(\min(n,W))\). Update the value at the minimal key. -- -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a" updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a updateMinWithKey f t =- case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)+ case t of Bin p l r | signBranch p -> binCheckRight p l (go f r) _ -> go f t where- go f' (Bin p m l r) = binCheckLeft p m (go f' l) r+ go f' (Bin p l r) = binCheckLeft p (go f' l) r go f' (Tip k y) = case f' k y of Just !y' -> Tip k y' Nothing -> Nil- go _ Nil = error "updateMinWithKey Nil"+ go _ Nil = Nil --- | /O(log n)/. Update the value at the maximal key.+-- | \(O(\min(n,W))\). Update the value at the maximal key. -- -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b" updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a updateMaxWithKey f t =- case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r+ case t of Bin p l r | signBranch p -> binCheckLeft p (go f l) r _ -> go f t where- go f' (Bin p m l r) = binCheckRight p m l (go f' r)+ go f' (Bin p l r) = binCheckRight p l (go f' r) go f' (Tip k y) = case f' k y of Just !y' -> Tip k y' Nothing -> Nil- go _ Nil = error "updateMaxWithKey Nil"+ go _ Nil = Nil --- | /O(log n)/. Update the value at the maximal key.+-- | \(O(\min(n,W))\). Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"@@ -813,7 +772,7 @@ updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a updateMax f = updateMaxWithKey (const f) --- | /O(log n)/. Update the value at the minimal key.+-- | \(O(\min(n,W))\). Update the value at the minimal key. -- -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"@@ -825,16 +784,16 @@ {-------------------------------------------------------------------- Mapping --------------------------------------------------------------------}--- | /O(n)/. Map a function over all values in the map.+-- | \(O(n)\). Map a function over all values in the map. -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] map :: (a -> b) -> IntMap a -> IntMap b map f = go where- go (Bin p m l r) = Bin p m (go l) (go r)- go (Tip k x) = Tip k $! f x- go Nil = Nil+ go (Bin p l r) = Bin p (go l) (go r)+ go (Tip k x) = Tip k $! f x+ go Nil = Nil #ifdef __GLASGOW_HASKELL__ {-# NOINLINE [1] map #-}@@ -844,7 +803,7 @@ #-} #endif --- | /O(n)/. Map a function over all values in the map.+-- | \(O(n)\). Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]@@ -852,9 +811,9 @@ mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b mapWithKey f t = case t of- Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)- Tip k x -> Tip k $! f k x- Nil -> Nil+ Bin p l r -> Bin p (mapWithKey f l) (mapWithKey f r)+ Tip k x -> Tip k $! f k x+ Nil -> Nil #ifdef __GLASGOW_HASKELL__ -- Pay close attention to strictness here. We need to force the@@ -868,7 +827,7 @@ -- lsmap :: (b -> c) -> (a -> b) -> IntMap a -> IntMap c -- lsmap _ _ Nil = Nil -- lsmap f g (Tip k x) = let !gx = g x in Tip k (f gx)--- lsmap f g (Bin p m l r) = Bin p m (lsmap f g l) (lsmap f g r)+-- lsmap f g (Bin p l r) = Bin p (lsmap f g l) (lsmap f g r) {-# NOINLINE [1] mapWithKey #-} {-# RULES "mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =@@ -886,7 +845,7 @@ #-} #endif --- | /O(n)/.+-- | \(O(n)\). -- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@ -- That is, behaves exactly like a regular 'traverse' except that the traversing -- function also has access to the key associated with a value.@@ -898,12 +857,12 @@ where go Nil = pure Nil go (Tip k v) = (\ !v' -> Tip k v') <$> f k v- go (Bin p m l r)- | m < 0 = liftA2 (flip (Bin p m)) (go r) (go l)- | otherwise = liftA2 (Bin p m) (go l) (go r)+ go (Bin p l r)+ | signBranch p = liftA2 (flip (Bin p)) (go r) (go l)+ | otherwise = liftA2 (Bin p) (go l) (go r) {-# INLINE traverseWithKey #-} --- | /O(n)/. Traverse keys\/values and collect the 'Just' results.+-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results. -- -- @since 0.6.4 traverseMaybeWithKey@@ -912,11 +871,11 @@ where go Nil = pure Nil go (Tip k x) = maybe Nil (Tip k $!) <$> f k x- go (Bin p m l r)- | m < 0 = liftA2 (flip (bin p m)) (go r) (go l)- | otherwise = liftA2 (bin p m) (go l) (go r)+ go (Bin p l r)+ | signBranch p = liftA2 (flip (bin p)) (go r) (go l)+ | otherwise = liftA2 (bin p) (go l) (go r) --- | /O(n)/. The function @'mapAccum'@ threads an accumulating+-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a b = (a ++ b, b ++ "X")@@ -925,7 +884,7 @@ mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccum f = mapAccumWithKey (\a' _ x -> f a' x) --- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating+-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")@@ -935,7 +894,7 @@ mapAccumWithKey f a t = mapAccumL f a t --- | /O(n)/. The function @'mapAccumL'@ threads an accumulating+-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating -- argument through the map in ascending order of keys. Strict in -- the accumulating argument and the both elements of the -- result of the function.@@ -944,38 +903,38 @@ where go f a t = case t of- Bin p m l r- | m < 0 ->+ Bin p l r+ | signBranch p -> let (a1 :*: r') = go f a r (a2 :*: l') = go f a1 l- in (a2 :*: Bin p m l' r')+ in (a2 :*: Bin p l' r') | otherwise -> let (a1 :*: l') = go f a l (a2 :*: r') = go f a1 r- in (a2 :*: Bin p m l' r')+ in (a2 :*: Bin p l' r') Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x') Nil -> (a :*: Nil) --- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating+-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0 where go f a t = case t of- Bin p m l r- | m < 0 ->+ Bin p l r+ | signBranch p -> let (a1 :*: l') = go f a l (a2 :*: r') = go f a1 r- in (a2 :*: Bin p m l' r')+ in (a2 :*: Bin p l' r') | otherwise -> let (a1 :*: r') = go f a r (a2 :*: l') = go f a1 l- in (a2 :*: Bin p m l' r')+ in (a2 :*: Bin p l' r') Tip k x -> let !(a',!x') = f a k x in (a' :*: Tip k x') Nil -> (a :*: Nil) --- | /O(n*log n)/.+-- | \(O(n \min(n,W))\). -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct@@ -984,6 +943,8 @@ -- -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"+--+-- Also see the performance note on 'fromListWith'. mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []@@ -991,7 +952,7 @@ {-------------------------------------------------------------------- Filter --------------------------------------------------------------------}--- | /O(n)/. Map values and collect the 'Just' results.+-- | \(O(n)\). Map values and collect the 'Just' results. -- -- > let f x = if x == "a" then Just "new a" else Nothing -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"@@ -999,20 +960,20 @@ mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b mapMaybe f = mapMaybeWithKey (\_ x -> f x) --- | /O(n)/. Map keys\/values and collect the 'Just' results.+-- | \(O(n)\). Map keys\/values and collect the 'Just' results. -- -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3" mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b-mapMaybeWithKey f (Bin p m l r)- = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Bin p l r)+ = bin p (mapMaybeWithKey f l) (mapMaybeWithKey f r) mapMaybeWithKey f (Tip k x) = case f k x of Just !y -> Tip k y Nothing -> Nil mapMaybeWithKey _ Nil = Nil --- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. -- -- > let f a = if a < "c" then Left a else Right a -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])@@ -1025,7 +986,7 @@ mapEither f m = mapEitherWithKey (\_ x -> f x) m --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results. -- -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])@@ -1037,8 +998,8 @@ mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) mapEitherWithKey f0 t0 = toPair $ go f0 t0 where- go f (Bin p m l r)- = bin p m l1 r1 :*: bin p m l2 r2+ go f (Bin p l r)+ = bin p l1 r1 :*: bin p l2 r2 where (l1 :*: l2) = go f l (r1 :*: r2) = go f r@@ -1051,7 +1012,7 @@ Conversions --------------------------------------------------------------------} --- | /O(n)/. Build a map from a set of keys and a function which for each key+-- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value. -- -- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]@@ -1059,7 +1020,7 @@ fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a fromSet _ IntSet.Nil = Nil-fromSet f (IntSet.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)+fromSet f (IntSet.Bin p l r) = Bin p (fromSet f l) (fromSet f r) fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) where -- This is slightly complicated, as we to convert the dense -- representation of IntSet into tree representation of IntMap.@@ -1070,18 +1031,18 @@ -- one of them is nonempty and we construct the IntMap from that half. buildTree g !prefix !bmask bits = case bits of 0 -> Tip prefix $! g prefix- _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of+ _ -> case bits `iShiftRL` 1 of bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 -> buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2 | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 -> buildTree g prefix bmask bits2 | otherwise ->- Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)+ Bin (Prefix (prefix .|. bits2)) (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) {-------------------------------------------------------------------- Lists --------------------------------------------------------------------}--- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.+-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs. -- -- > fromList [] == empty -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]@@ -1093,19 +1054,53 @@ where ins t (k,x) = insert k x t --- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. ----- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")] -- > fromListWith (++) [] == empty+--+-- Note the reverse ordering of @"cba"@ in the example.+--+-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@.+--+-- === Performance+--+-- You should ensure that the given @f@ is fast with this order of arguments.+--+-- Symmetric functions may be slow in one order, and fast in another.+-- For the common case of collecting values of matching keys in a list, as above:+--+-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument.+-- Thus:+--+-- > fromListWith (++) (replicate 1000000 (3, "x")) -- O(n), fast+-- > fromListWith (flip (++)) (replicate 1000000 (3, "x")) -- O(n²), extremely slow+--+-- because they evaluate as, respectively:+--+-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))] -- O(n)+-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")] -- O(n²)+--+-- Thus, to get good performance with an operation like @(++)@ while also preserving+-- the same order as in the input list, reverse the input:+--+-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")]+--+-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in:+--+-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a fromListWith f xs = fromListWithKey (\_ x y -> f x y) xs --- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'. ----- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]--- > fromListWith (++) [] == empty+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty+--+-- Also see the performance note on 'fromListWith'. fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromListWithKey f xs@@ -1113,9 +1108,13 @@ where ins t (k,x) = insertWithKey f k x t --- | /O(n)/. Build a map from a list of key\/value pairs where+-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order. --+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+-- -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] @@ -1123,42 +1122,57 @@ fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x) {-# NOINLINE fromAscList #-} --- | /O(n)/. Build a map from a list of key\/value pairs where+-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./ --+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+-- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+--+-- Also see the performance note on 'fromListWith'. fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y) {-# NOINLINE fromAscListWith #-} --- | /O(n)/. Build a map from a list of key\/value pairs where+-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./ --+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+-- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+--+-- Also see the performance note on 'fromListWith'. fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromAscListWithKey f = fromMonoListWithKey Nondistinct f {-# NOINLINE fromAscListWithKey #-} --- | /O(n)/. Build a map from a list of key\/value pairs where+-- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct.--- /The precondition (input list is strictly ascending) is not checked./ --+-- __Warning__: This function should be used only if the keys are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+-- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] fromDistinctAscList :: [(Key,a)] -> IntMap a fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x) {-# NOINLINE fromDistinctAscList #-} --- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys+-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys -- and a combining function. -- -- The precise conditions under which this function works are subtle: -- For any branch mask, keys with the same prefix w.r.t. the branch -- mask must occur consecutively in the list.+--+-- Also see the performance note on 'fromListWith'. fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a fromMonoListWithKey distinct f = go@@ -1168,15 +1182,18 @@ -- `addAll'` collects all keys equal to `kx` into a single value, -- and then proceeds with `addAll`.- addAll' !kx vx []- = Tip kx $! vx- addAll' !kx vx ((ky,vy) : zs)+ --+ -- We want to have the same strictness as fromListWithKey, which is achieved+ -- with the bang on vx.+ addAll' !kx !vx []+ = Tip kx vx+ addAll' !kx !vx ((ky,vy) : zs) | Nondistinct <- distinct, kx == ky- = let !v = f kx vy vx in addAll' ky v zs- -- inlined: | otherwise = addAll kx (Tip kx $! vx) (ky : zs)+ = addAll' ky (f kx vy vx) zs+ -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs) | m <- branchMask kx ky , Inserted ty zs' <- addMany' m ky vy zs- = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx $! vx)) zs'+ = addAll kx (linkWithMask m ky ty kx (Tip kx vx)) zs' -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx` -- `addAll` consumes the rest of the list, adding to the tree `tx`@@ -1185,20 +1202,23 @@ addAll !kx !tx ((ky,vy) : zs) | m <- branchMask kx ky , Inserted ty zs' <- addMany' m ky vy zs- = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'+ = addAll kx (linkWithMask m ky ty kx tx) zs' -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.- addMany' !_m !kx vx []- = Inserted (Tip kx $! vx) []- addMany' !m !kx vx zs0@((ky,vy) : zs)+ --+ -- We want to have the same strictness as fromListWithKey, which is achieved+ -- with the bang on vx.+ addMany' !_m !kx !vx []+ = Inserted (Tip kx vx) []+ addMany' !m !kx !vx zs0@((ky,vy) : zs) | Nondistinct <- distinct, kx == ky- = let !v = f kx vy vx in addMany' m ky v zs- -- inlined: | otherwise = addMany m kx (Tip kx $! vx) (ky : zs)+ = addMany' m ky (f kx vy vx) zs+ -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs) | mask kx m /= mask ky m- = Inserted (Tip kx $! vx) zs0+ = Inserted (Tip kx vx) zs0 | mxy <- branchMask kx ky , Inserted ty zs' <- addMany' mxy ky vy zs- = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs'+ = addMany m kx (linkWithMask mxy ky ty kx (Tip kx vx)) zs' -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`. addMany !_m !_kx tx []@@ -1208,7 +1228,7 @@ = Inserted tx zs0 | mxy <- branchMask kx ky , Inserted ty zs' <- addMany' mxy ky vy zs- = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'+ = addMany m kx (linkWithMask mxy ky ty kx tx) zs' {-# INLINE fromMonoListWithKey #-} data Inserted a = Inserted !(IntMap a) ![(Key,a)]
src/Data/IntSet.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif @@ -17,7 +17,8 @@ -- -- = Finite Int Sets ----- The @'IntSet'@ type represents a set of elements of type @Int@.+-- The @'IntSet'@ type represents a set of elements of type @Int@. An @IntSet@+-- is strict in its elements. -- -- For a walkthrough of the most commonly used functions see their -- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>.@@ -29,28 +30,23 @@ -- > import qualified Data.IntSet as IntSet -- ----- == Performance information------ Many operations have a worst-case complexity of /O(min(n,W))/.--- This means that the operation can become linear in the number of--- elements with a maximum of /W/ -- the number of bits in an 'Int'--- (32 or 64).------ -- == Implementation -- -- The implementation is based on /big-endian patricia trees/. This data -- structure performs especially well on binary operations like 'union'--- and 'intersection'. However, my benchmarks show that it is also+-- and 'intersection'. Additionally, benchmarks show that it is also -- (much) faster on insertions and deletions when compared to a generic -- size-balanced set implementation (see "Data.Set"). ----- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",+-- * Chris Okasaki and Andy Gill,+-- \"/Fast Mergeable Integer Maps/\", -- Workshop on ML, September 1998, pages 77-86,--- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+-- <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>. ----- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",--- Journal of the ACM, 15(4), October 1968, pages 514-534.+-- * D.R. Morrison,+-- \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+-- Journal of the ACM, 15(4), October 1968, pages 514-534,+-- <https://doi.org/10.1145/321479.321481>. -- -- Additionally, this implementation places bitmaps in the leaves of the tree. -- Their size is the natural size of a machine word (32 or 64 bits) and greatly@@ -58,24 +54,53 @@ -- where it is likely that many values lie close to each other. The asymptotics -- are not affected by this optimization. --+--+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'member', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+-- the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+-- shared by all subelements, so there could not be more+-- than \(W\) levels.+--+-- If all \(n\) elements in the tree are between 0 and \(N\) (or, say, between+-- \(-N\) and \(N\)), the estimate can be refined to \(O(\min(n, \log N))\). If+-- the set is sufficiently "dense", this becomes \(O(\min(n, \log n))\) or+-- simply the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntSet' are elements from a contiguous+-- subset, in which case the complexity is proportional to \(\log n\), capped+-- by \(W\). The worst scenario are exponentially growing elements \(1,2,4,+-- \ldots,2^n\), for which complexity grows as fast as \(n\) but again is capped+-- by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input sets respectively.+-- ----------------------------------------------------------------------------- module Data.IntSet (- -- * Strictness properties- -- $strictness- -- * Set type-#if !defined(TESTING) IntSet -- instance Eq,Show-#else- IntSet(..) -- instance Eq,Show-#endif , Key -- * Construction , empty , singleton , fromList+ , fromRange , fromAscList , fromDistinctAscList @@ -107,10 +132,18 @@ , difference , (\\) , intersection+ , intersections+ , symmetricDifference+ , Intersection(..) -- * Filter , IS.filter , partition++ , takeWhileAntitone+ , dropWhileAntitone+ , spanAntitone+ , split , splitMember , splitRoot@@ -122,13 +155,16 @@ -- * Folds , IS.foldr , IS.foldl+ , IS.foldMap -- ** Strict folds- , foldr'- , foldl'+ , IS.foldr'+ , IS.foldl' -- ** Legacy folds , fold -- * Min\/Max+ , lookupMin+ , lookupMax , findMin , findMax , deleteMin@@ -149,21 +185,6 @@ -- * Debugging , showTree , showTreeWith--#if defined(TESTING)- -- * Internals- , match-#endif ) where import Data.IntSet.Internal as IS---- $strictness------ This module satisfies the following strictness property:------ * Key arguments are evaluated to WHNF------ Here are some examples that illustrate the property:------ > delete undefined s == undefined
src/Data/IntSet/Internal.hs view
@@ -1,1652 +1,2002 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE TypeFamilies #-}-#endif--{-# OPTIONS_HADDOCK not-home #-}--#include "containers.h"---------------------------------------------------------------------------------- |--- Module : Data.IntSet.Internal--- Copyright : (c) Daan Leijen 2002--- (c) Joachim Breitner 2011--- License : BSD-style--- Maintainer : libraries@haskell.org--- Portability : portable------ = WARNING------ This module is considered __internal__.------ The Package Versioning Policy __does not apply__.------ The contents of this module may change __in any way whatsoever__--- and __without any warning__ between minor versions of this package.------ Authors importing this module are expected to track development--- closely.------ = Description------ An efficient implementation of integer sets.------ These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.------ > import Data.IntSet (IntSet)--- > import qualified Data.IntSet as IntSet------ The implementation is based on /big-endian patricia trees/. This data--- structure performs especially well on binary operations like 'union'--- and 'intersection'. However, my benchmarks show that it is also--- (much) faster on insertions and deletions when compared to a generic--- size-balanced set implementation (see "Data.Set").------ * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",--- Workshop on ML, September 1998, pages 77-86,--- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>------ * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",--- Journal of the ACM, 15(4), October 1968, pages 514-534.------ Additionally, this implementation places bitmaps in the leaves of the tree.--- Their size is the natural size of a machine word (32 or 64 bits) and greatly--- reduce memory footprint and execution times for dense sets, e.g. sets where--- it is likely that many values lie close to each other. The asymptotics are--- not affected by this optimization.------ Many operations have a worst-case complexity of /O(min(n,W))/.--- This means that the operation can become linear in the number of--- elements with a maximum of /W/ -- the number of bits in an 'Int'--- (32 or 64).------ @since 0.5.9---------------------------------------------------------------------------------- [Note: INLINE bit fiddling]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- It is essential that the bit fiddling functions like mask, zero, branchMask--- etc are inlined. If they do not, the memory allocation skyrockets. The GHC--- usually gets it right, but it is disastrous if it does not. Therefore we--- explicitly mark these functions INLINE.----- [Note: Local 'go' functions and capturing]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Care must be taken when using 'go' function which captures an argument.--- Sometimes (for example when the argument is passed to a data constructor,--- as in insert), GHC heap-allocates more than necessary. Therefore C-- code--- must be checked for increased allocation when creating and modifying such--- functions.----- [Note: Order of constructors]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The order of constructors of IntSet matters when considering performance.--- Currently in GHC 7.0, when type has 3 constructors, they are matched from--- the first to the last -- the best performance is achieved when the--- constructors are ordered by frequency.--- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil--- improves the benchmark by circa 10%.--module Data.IntSet.Internal (- -- * Set type- IntSet(..), Key -- instance Eq,Show- , Prefix, Mask, BitMap-- -- * Operators- , (\\)-- -- * Query- , null- , size- , member- , notMember- , lookupLT- , lookupGT- , lookupLE- , lookupGE- , isSubsetOf- , isProperSubsetOf- , disjoint-- -- * Construction- , empty- , singleton- , insert- , delete- , alterF-- -- * Combine- , union- , unions- , difference- , intersection-- -- * Filter- , filter- , partition- , split- , splitMember- , splitRoot-- -- * Map- , map- , mapMonotonic-- -- * Folds- , foldr- , foldl- -- ** Strict folds- , foldr'- , foldl'- -- ** Legacy folds- , fold-- -- * Min\/Max- , findMin- , findMax- , deleteMin- , deleteMax- , deleteFindMin- , deleteFindMax- , maxView- , minView-- -- * Conversion-- -- ** List- , elems- , toList- , fromList-- -- ** Ordered list- , toAscList- , toDescList- , fromAscList- , fromDistinctAscList-- -- * Debugging- , showTree- , showTreeWith-- -- * Internals- , match- , suffixBitMask- , prefixBitMask- , bitmapOf- , zero- ) where--import Control.Applicative (Const(..))-import Control.DeepSeq (NFData(rnf))-import Data.Bits-import qualified Data.List as List-import Data.Maybe (fromMaybe)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-import Data.Word (Word)-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup(stimes))-#endif-#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>)))-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (stimesIdempotentMonoid)-#endif-import Data.Typeable-import Prelude hiding (filter, foldr, foldl, null, map)--import Utils.Containers.Internal.BitUtil-import Utils.Containers.Internal.StrictPair--#if __GLASGOW_HASKELL__-import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType)-import qualified Data.Data-import Text.Read-#endif--#if __GLASGOW_HASKELL__-import qualified GHC.Exts-#if !(MIN_VERSION_base(4,8,0) && (WORD_SIZE_IN_BITS==64))-import qualified GHC.Int-#endif-#endif--import qualified Data.Foldable as Foldable-#if MIN_VERSION_base(4,8,0)-import Data.Functor.Identity (Identity(..))-#else-import Data.Foldable (Foldable())-#endif--infixl 9 \\{-This comment teaches CPP correct behaviour -}---- A "Nat" is a natural machine word (an unsigned Int)-type Nat = Word--natFromInt :: Int -> Nat-natFromInt i = fromIntegral i-{-# INLINE natFromInt #-}--intFromNat :: Nat -> Int-intFromNat w = fromIntegral w-{-# INLINE intFromNat #-}--{--------------------------------------------------------------------- Operators---------------------------------------------------------------------}--- | /O(n+m)/. See 'difference'.-(\\) :: IntSet -> IntSet -> IntSet-m1 \\ m2 = difference m1 m2--{--------------------------------------------------------------------- Types---------------------------------------------------------------------}---- | A set of integers.---- See Note: Order of constructors-data IntSet = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntSet !IntSet--- Invariant: Nil is never found as a child of Bin.--- Invariant: The Mask is a power of 2. It is the largest bit position at which--- two elements of the set differ.--- Invariant: Prefix is the common high-order bits that all elements share to--- the left of the Mask bit.--- Invariant: In Bin prefix mask left right, left consists of the elements that--- don't have the mask bit set; right is all the elements that do.- | Tip {-# UNPACK #-} !Prefix {-# UNPACK #-} !BitMap--- Invariant: The Prefix is zero for the last 5 (on 32 bit arches) or 6 bits--- (on 64 bit arches). The values of the set represented by a tip--- are the prefix plus the indices of the set bits in the bit map.- | Nil---- A number stored in a set is stored as--- * Prefix (all but last 5-6 bits) and--- * BitMap (last 5-6 bits stored as a bitmask)--- Last 5-6 bits are called a Suffix.--type Prefix = Int-type Mask = Int-type BitMap = Word-type Key = Int--instance Monoid IntSet where- mempty = empty- mconcat = unions-#if !(MIN_VERSION_base(4,9,0))- mappend = union-#else- mappend = (<>)---- | @since 0.5.7-instance Semigroup IntSet where- (<>) = union- stimes = stimesIdempotentMonoid-#endif--#if __GLASGOW_HASKELL__--{--------------------------------------------------------------------- A Data instance---------------------------------------------------------------------}---- This instance preserves data abstraction at the cost of inefficiency.--- We provide limited reflection services for the sake of data abstraction.--instance Data IntSet where- gfoldl f z is = z fromList `f` (toList is)- toConstr _ = fromListConstr- gunfold k z c = case constrIndex c of- 1 -> k (z fromList)- _ -> error "gunfold"- dataTypeOf _ = intSetDataType--fromListConstr :: Constr-fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix--intSetDataType :: DataType-intSetDataType = mkDataType "Data.IntSet.Internal.IntSet" [fromListConstr]--#endif--{--------------------------------------------------------------------- Query---------------------------------------------------------------------}--- | /O(1)/. Is the set empty?-null :: IntSet -> Bool-null Nil = True-null _ = False-{-# INLINE null #-}---- | /O(n)/. Cardinality of the set.-size :: IntSet -> Int-size = go 0- where- go !acc (Bin _ _ l r) = go (go acc l) r- go acc (Tip _ bm) = acc + bitcount 0 bm- go acc Nil = acc---- | /O(min(n,W))/. Is the value a member of the set?---- See Note: Local 'go' functions and capturing.-member :: Key -> IntSet -> Bool-member !x = go- where- go (Bin p m l r)- | nomatch x p m = False- | zero x m = go l- | otherwise = go r- go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0- go Nil = False---- | /O(min(n,W))/. Is the element not in the set?-notMember :: Key -> IntSet -> Bool-notMember k = not . member k---- | /O(log n)/. Find largest element smaller than the given one.------ > lookupLT 3 (fromList [3, 5]) == Nothing--- > lookupLT 5 (fromList [3, 5]) == Just 3---- See Note: Local 'go' functions and capturing.-lookupLT :: Key -> IntSet -> Maybe Key-lookupLT !x t = case t of- Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r- _ -> go Nil t- where- go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r- | zero x m = go def l- | otherwise = go l r- go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm- | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT- | otherwise = unsafeFindMax def- where maskLT = (bitmapOf x - 1) .&. bm- go def Nil = unsafeFindMax def----- | /O(log n)/. Find smallest element greater than the given one.------ > lookupGT 4 (fromList [3, 5]) == Just 5--- > lookupGT 5 (fromList [3, 5]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGT :: Key -> IntSet -> Maybe Key-lookupGT !x t = case t of- Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r- _ -> go Nil t- where- go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def- | zero x m = go r l- | otherwise = go def r- go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm- | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT- | otherwise = unsafeFindMin def- where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm- go def Nil = unsafeFindMin def----- | /O(log n)/. Find largest element smaller or equal to the given one.------ > lookupLE 2 (fromList [3, 5]) == Nothing--- > lookupLE 4 (fromList [3, 5]) == Just 3--- > lookupLE 5 (fromList [3, 5]) == Just 5---- See Note: Local 'go' functions and capturing.-lookupLE :: Key -> IntSet -> Maybe Key-lookupLE !x t = case t of- Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r- _ -> go Nil t- where- go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r- | zero x m = go def l- | otherwise = go l r- go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm- | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE- | otherwise = unsafeFindMax def- where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm- go def Nil = unsafeFindMax def----- | /O(log n)/. Find smallest element greater or equal to the given one.------ > lookupGE 3 (fromList [3, 5]) == Just 3--- > lookupGE 4 (fromList [3, 5]) == Just 5--- > lookupGE 6 (fromList [3, 5]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGE :: Key -> IntSet -> Maybe Key-lookupGE !x t = case t of- Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r- _ -> go Nil t- where- go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def- | zero x m = go r l- | otherwise = go def r- go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm- | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE- | otherwise = unsafeFindMin def- where maskGE = (- (bitmapOf x)) .&. bm- go def Nil = unsafeFindMin def------ Helper function for lookupGE and lookupGT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMin :: IntSet -> Maybe Key-unsafeFindMin Nil = Nothing-unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm-unsafeFindMin (Bin _ _ l _) = unsafeFindMin l---- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMax :: IntSet -> Maybe Key-unsafeFindMax Nil = Nothing-unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm-unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r--{--------------------------------------------------------------------- Construction---------------------------------------------------------------------}--- | /O(1)/. The empty set.-empty :: IntSet-empty- = Nil-{-# INLINE empty #-}---- | /O(1)/. A set of one element.-singleton :: Key -> IntSet-singleton x- = Tip (prefixOf x) (bitmapOf x)-{-# INLINE singleton #-}--{--------------------------------------------------------------------- Insert---------------------------------------------------------------------}--- | /O(min(n,W))/. Add a value to the set. There is no left- or right bias for--- IntSets.-insert :: Key -> IntSet -> IntSet-insert !x = insertBM (prefixOf x) (bitmapOf x)---- Helper function for insert and union.-insertBM :: Prefix -> BitMap -> IntSet -> IntSet-insertBM !kx !bm t@(Bin p m l r)- | nomatch kx p m = link kx (Tip kx bm) p t- | zero kx m = Bin p m (insertBM kx bm l) r- | otherwise = Bin p m l (insertBM kx bm r)-insertBM kx bm t@(Tip kx' bm')- | kx' == kx = Tip kx' (bm .|. bm')- | otherwise = link kx (Tip kx bm) kx' t-insertBM kx bm Nil = Tip kx bm---- | /O(min(n,W))/. Delete a value in the set. Returns the--- original set when the value was not present.-delete :: Key -> IntSet -> IntSet-delete !x = deleteBM (prefixOf x) (bitmapOf x)---- Deletes all values mentioned in the BitMap from the set.--- Helper function for delete and difference.-deleteBM :: Prefix -> BitMap -> IntSet -> IntSet-deleteBM !kx !bm t@(Bin p m l r)- | nomatch kx p m = t- | zero kx m = bin p m (deleteBM kx bm l) r- | otherwise = bin p m l (deleteBM kx bm r)-deleteBM kx bm t@(Tip kx' bm')- | kx' == kx = tip kx (bm' .&. complement bm)- | otherwise = t-deleteBM _ _ Nil = Nil---- | /O(min(n,W))/. @('alterF' f x s)@ can delete or insert @x@ in @s@ depending--- on whether it is already present in @s@.------ In short:------ @--- 'member' x \<$\> 'alterF' f x s = f ('member' x s)--- @------ Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".------ @since 0.6.3.1-alterF :: Functor f => (Bool -> f Bool) -> Key -> IntSet -> f IntSet-alterF f k s = fmap choose (f member_)- where- member_ = member k s-- (inserted, deleted)- | member_ = (s , delete k s)- | otherwise = (insert k s, s )-- choose True = inserted- choose False = deleted-#ifndef __GLASGOW_HASKELL__-{-# INLINE alterF #-}-#else-{-# INLINABLE [2] alterF #-}--{-# RULES-"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s- #-}-#endif--#if MIN_VERSION_base(4,8,0)-{-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> IntSet -> Identity IntSet #-}-#endif--{--------------------------------------------------------------------- Union---------------------------------------------------------------------}--- | The union of a list of sets.-unions :: Foldable f => f IntSet -> IntSet-unions xs- = Foldable.foldl' union empty xs----- | /O(n+m)/. The union of two sets.-union :: IntSet -> IntSet -> IntSet-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)- | shorter m1 m2 = union1- | shorter m2 m1 = union2- | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)- | otherwise = link p1 t1 p2 t2- where- union1 | nomatch p2 p1 m1 = link p1 t1 p2 t2- | zero p2 m1 = Bin p1 m1 (union l1 t2) r1- | otherwise = Bin p1 m1 l1 (union r1 t2)-- union2 | nomatch p1 p2 m2 = link p1 t1 p2 t2- | zero p1 m2 = Bin p2 m2 (union t1 l2) r2- | otherwise = Bin p2 m2 l2 (union t1 r2)--union t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t-union t@(Bin _ _ _ _) Nil = t-union (Tip kx bm) t = insertBM kx bm t-union Nil t = t---{--------------------------------------------------------------------- Difference---------------------------------------------------------------------}--- | /O(n+m)/. Difference between two sets.-difference :: IntSet -> IntSet -> IntSet-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)- | shorter m1 m2 = difference1- | shorter m2 m1 = difference2- | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)- | otherwise = t1- where- difference1 | nomatch p2 p1 m1 = t1- | zero p2 m1 = bin p1 m1 (difference l1 t2) r1- | otherwise = bin p1 m1 l1 (difference r1 t2)-- difference2 | nomatch p1 p2 m2 = t1- | zero p1 m2 = difference t1 l2- | otherwise = difference t1 r2--difference t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t-difference t@(Bin _ _ _ _) Nil = t--difference t1@(Tip kx bm) t2 = differenceTip t2- where differenceTip (Bin p2 m2 l2 r2) | nomatch kx p2 m2 = t1- | zero kx m2 = differenceTip l2- | otherwise = differenceTip r2- differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2)- | otherwise = t1- differenceTip Nil = t1--difference Nil _ = Nil----{--------------------------------------------------------------------- Intersection---------------------------------------------------------------------}--- | /O(n+m)/. The intersection of two sets.-intersection :: IntSet -> IntSet -> IntSet-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)- | shorter m1 m2 = intersection1- | shorter m2 m1 = intersection2- | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)- | otherwise = Nil- where- intersection1 | nomatch p2 p1 m1 = Nil- | zero p2 m1 = intersection l1 t2- | otherwise = intersection r1 t2-- intersection2 | nomatch p1 p2 m2 = Nil- | zero p1 m2 = intersection t1 l2- | otherwise = intersection t1 r2--intersection t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1- where intersectBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = Nil- | zero kx2 m1 = intersectBM l1- | otherwise = intersectBM r1- intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)- | otherwise = Nil- intersectBM Nil = Nil--intersection (Bin _ _ _ _) Nil = Nil--intersection (Tip kx1 bm1) t2 = intersectBM t2- where intersectBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = Nil- | zero kx1 m2 = intersectBM l2- | otherwise = intersectBM r2- intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)- | otherwise = Nil- intersectBM Nil = Nil--intersection Nil _ = Nil--{--------------------------------------------------------------------- Subset---------------------------------------------------------------------}--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).-isProperSubsetOf :: IntSet -> IntSet -> Bool-isProperSubsetOf t1 t2- = case subsetCmp t1 t2 of- LT -> True- _ -> False--subsetCmp :: IntSet -> IntSet -> Ordering-subsetCmp t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- | shorter m1 m2 = GT- | shorter m2 m1 = case subsetCmpLt of- GT -> GT- _ -> LT- | p1 == p2 = subsetCmpEq- | otherwise = GT -- disjoint- where- subsetCmpLt | nomatch p1 p2 m2 = GT- | zero p1 m2 = subsetCmp t1 l2- | otherwise = subsetCmp t1 r2- subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of- (GT,_ ) -> GT- (_ ,GT) -> GT- (EQ,EQ) -> EQ- _ -> LT--subsetCmp (Bin _ _ _ _) _ = GT-subsetCmp (Tip kx1 bm1) (Tip kx2 bm2)- | kx1 /= kx2 = GT -- disjoint- | bm1 == bm2 = EQ- | bm1 .&. complement bm2 == 0 = LT- | otherwise = GT-subsetCmp t1@(Tip kx _) (Bin p m l r)- | nomatch kx p m = GT- | zero kx m = case subsetCmp t1 l of GT -> GT ; _ -> LT- | otherwise = case subsetCmp t1 r of GT -> GT ; _ -> LT-subsetCmp (Tip _ _) Nil = GT -- disjoint-subsetCmp Nil Nil = EQ-subsetCmp Nil _ = LT---- | /O(n+m)/. Is this a subset?--- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.--isSubsetOf :: IntSet -> IntSet -> Bool-isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- | shorter m1 m2 = False- | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2- else isSubsetOf t1 r2)- | otherwise = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2-isSubsetOf (Bin _ _ _ _) _ = False-isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0-isSubsetOf t1@(Tip kx _) (Bin p m l r)- | nomatch kx p m = False- | zero kx m = isSubsetOf t1 l- | otherwise = isSubsetOf t1 r-isSubsetOf (Tip _ _) Nil = False-isSubsetOf Nil _ = True---{--------------------------------------------------------------------- Disjoint---------------------------------------------------------------------}--- | /O(n+m)/. Check whether two sets are disjoint (i.e. their intersection--- is empty).------ > disjoint (fromList [2,4,6]) (fromList [1,3]) == True--- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False--- > disjoint (fromList [1,2]) (fromList [1,2,3,4]) == False--- > disjoint (fromList []) (fromList []) == True------ @since 0.5.11-disjoint :: IntSet -> IntSet -> Bool-disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)- | shorter m1 m2 = disjoint1- | shorter m2 m1 = disjoint2- | p1 == p2 = disjoint l1 l2 && disjoint r1 r2- | otherwise = True- where- disjoint1 | nomatch p2 p1 m1 = True- | zero p2 m1 = disjoint l1 t2- | otherwise = disjoint r1 t2-- disjoint2 | nomatch p1 p2 m2 = True- | zero p1 m2 = disjoint t1 l2- | otherwise = disjoint t1 r2--disjoint t1@(Bin _ _ _ _) (Tip kx2 bm2) = disjointBM t1- where disjointBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = True- | zero kx2 m1 = disjointBM l1- | otherwise = disjointBM r1- disjointBM (Tip kx1 bm1) | kx1 == kx2 = (bm1 .&. bm2) == 0- | otherwise = True- disjointBM Nil = True--disjoint (Bin _ _ _ _) Nil = True--disjoint (Tip kx1 bm1) t2 = disjointBM t2- where disjointBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = True- | zero kx1 m2 = disjointBM l2- | otherwise = disjointBM r2- disjointBM (Tip kx2 bm2) | kx1 == kx2 = (bm1 .&. bm2) == 0- | otherwise = True- disjointBM Nil = True--disjoint Nil _ = True---{--------------------------------------------------------------------- Filter---------------------------------------------------------------------}--- | /O(n)/. Filter all elements that satisfy some predicate.-filter :: (Key -> Bool) -> IntSet -> IntSet-filter predicate t- = case t of- Bin p m l r- -> bin p m (filter predicate l) (filter predicate r)- Tip kx bm- -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm)- Nil -> Nil- where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi- | otherwise = bm- {-# INLINE bitPred #-}---- | /O(n)/. partition the set according to some predicate.-partition :: (Key -> Bool) -> IntSet -> (IntSet,IntSet)-partition predicate0 t0 = toPair $ go predicate0 t0- where- go predicate t- = case t of- Bin p m l r- -> let (l1 :*: l2) = go predicate l- (r1 :*: r2) = go predicate r- in bin p m l1 r1 :*: bin p m l2 r2- Tip kx bm- -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm- in tip kx bm1 :*: tip kx (bm `xor` bm1)- Nil -> (Nil :*: Nil)- where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi- | otherwise = bm- {-# INLINE bitPred #-}----- | /O(min(n,W))/. The expression (@'split' x set@) is a pair @(set1,set2)@--- where @set1@ comprises the elements of @set@ less than @x@ and @set2@--- comprises the elements of @set@ greater than @x@.------ > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])-split :: Key -> IntSet -> (IntSet,IntSet)-split x t =- case t of- Bin _ m l r- | m < 0 -> if x >= 0 -- handle negative numbers.- then case go x l of (lt :*: gt) -> let !lt' = union lt r- in (lt', gt)- else case go x r of (lt :*: gt) -> let !gt' = union gt l- in (lt, gt')- _ -> case go x t of- (lt :*: gt) -> (lt, gt)- where- go !x' t'@(Bin p m l r)- | match x' p m = if zero x' m- then case go x' l of- (lt :*: gt) -> lt :*: union gt r- else case go x' r of- (lt :*: gt) -> union lt l :*: gt- | otherwise = if x' < p then (Nil :*: t')- else (t' :*: Nil)- go x' t'@(Tip kx' bm)- | kx' > x' = (Nil :*: t')- -- equivalent to kx' > prefixOf x'- | kx' < prefixOf x' = (t' :*: Nil)- | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)- where lowerBitmap = bitmapOf x' - 1- higherBitmap = complement (lowerBitmap + bitmapOf x')- go _ Nil = (Nil :*: Nil)---- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot--- element was found in the original set.-splitMember :: Key -> IntSet -> (IntSet,Bool,IntSet)-splitMember x t =- case t of- Bin _ m l r | m < 0 -> if x >= 0- then case go x l of- (lt, fnd, gt) -> let !lt' = union lt r- in (lt', fnd, gt)- else case go x r of- (lt, fnd, gt) -> let !gt' = union gt l- in (lt, fnd, gt')- _ -> go x t- where- go x' t'@(Bin p m l r)- | match x' p m = if zero x' m- then case go x' l of- (lt, fnd, gt) -> (lt, fnd, union gt r)- else case go x' r of- (lt, fnd, gt) -> (union lt l, fnd, gt)- | otherwise = if x' < p then (Nil, False, t') else (t', False, Nil)- go x' t'@(Tip kx' bm)- | kx' > x' = (Nil, False, t')- -- equivalent to kx' > prefixOf x'- | kx' < prefixOf x' = (t', False, Nil)- | otherwise = let !lt = tip kx' (bm .&. lowerBitmap)- !found = (bm .&. bitmapOfx') /= 0- !gt = tip kx' (bm .&. higherBitmap)- in (lt, found, gt)- where bitmapOfx' = bitmapOf x'- lowerBitmap = bitmapOfx' - 1- higherBitmap = complement (lowerBitmap + bitmapOfx')- go _ Nil = (Nil, False, Nil)--{----------------------------------------------------------------------- Min/Max-----------------------------------------------------------------------}---- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set--- stripped of that element, or 'Nothing' if passed an empty set.-maxView :: IntSet -> Maybe (Key, IntSet)-maxView t =- case t of Nil -> Nothing- Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, bin p m l' r)- _ -> Just (go t)- where- go (Bin p m l r) = case go r of (result, r') -> (result, bin p m l r')- go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))- go Nil = error "maxView Nil"---- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set--- stripped of that element, or 'Nothing' if passed an empty set.-minView :: IntSet -> Maybe (Key, IntSet)-minView t =- case t of Nil -> Nothing- Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, bin p m l r')- _ -> Just (go t)- where- go (Bin p m l r) = case go l of (result, l') -> (result, bin p m l' r)- go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))- go Nil = error "minView Nil"---- | /O(min(n,W))/. Delete and find the minimal element.------ > deleteFindMin set = (findMin set, deleteMin set)-deleteFindMin :: IntSet -> (Key, IntSet)-deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView---- | /O(min(n,W))/. Delete and find the maximal element.------ > deleteFindMax set = (findMax set, deleteMax set)-deleteFindMax :: IntSet -> (Key, IntSet)-deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView----- | /O(min(n,W))/. The minimal element of the set.-findMin :: IntSet -> Key-findMin Nil = error "findMin: empty set has no minimal element"-findMin (Tip kx bm) = kx + lowestBitSet bm-findMin (Bin _ m l r)- | m < 0 = find r- | otherwise = find l- where find (Tip kx bm) = kx + lowestBitSet bm- find (Bin _ _ l' _) = find l'- find Nil = error "findMin Nil"---- | /O(min(n,W))/. The maximal element of a set.-findMax :: IntSet -> Key-findMax Nil = error "findMax: empty set has no maximal element"-findMax (Tip kx bm) = kx + highestBitSet bm-findMax (Bin _ m l r)- | m < 0 = find l- | otherwise = find r- where find (Tip kx bm) = kx + highestBitSet bm- find (Bin _ _ _ r') = find r'- find Nil = error "findMax Nil"----- | /O(min(n,W))/. Delete the minimal element. Returns an empty set if the set is empty.------ Note that this is a change of behaviour for consistency with 'Data.Set.Set' –--- versions prior to 0.5 threw an error if the 'IntSet' was already empty.-deleteMin :: IntSet -> IntSet-deleteMin = maybe Nil snd . minView---- | /O(min(n,W))/. Delete the maximal element. Returns an empty set if the set is empty.------ Note that this is a change of behaviour for consistency with 'Data.Set.Set' –--- versions prior to 0.5 threw an error if the 'IntSet' was already empty.-deleteMax :: IntSet -> IntSet-deleteMax = maybe Nil snd . maxView--{----------------------------------------------------------------------- Map-----------------------------------------------------------------------}---- | /O(n*min(n,W))/.--- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.------ It's worth noting that the size of the result may be smaller if,--- for some @(x,y)@, @x \/= y && f x == f y@--map :: (Key -> Key) -> IntSet -> IntSet-map f = fromList . List.map f . toList---- | /O(n)/. The------ @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.--- /The precondition is not checked./--- Semi-formally, we have:------ > and [x < y ==> f x < f y | x <- ls, y <- ls]--- > ==> mapMonotonic f s == map f s--- > where ls = toList s------ @since 0.6.3.1---- Note that for now the test is insufficient to support any fancier implementation.-mapMonotonic :: (Key -> Key) -> IntSet -> IntSet-mapMonotonic f = fromDistinctAscList . List.map f . toAscList---{--------------------------------------------------------------------- Fold---------------------------------------------------------------------}--- | /O(n)/. Fold the elements in the set using the given right-associative--- binary operator. This function is an equivalent of 'foldr' and is present--- for compatibility only.------ /Please note that fold will be deprecated in the future and removed./-fold :: (Key -> b -> b) -> b -> IntSet -> b-fold = foldr-{-# INLINE fold #-}---- | /O(n)/. Fold the elements in the set using the given right-associative--- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.------ For example,------ > toAscList set = foldr (:) [] set-foldr :: (Key -> b -> b) -> b -> IntSet -> b-foldr f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before- | otherwise -> go (go z r) l- _ -> go z t- where- go z' Nil = z'- go z' (Tip kx bm) = foldrBits kx f z' bm- go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr #-}---- | /O(n)/. A strict version of 'foldr'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldr' :: (Key -> b -> b) -> b -> IntSet -> b-foldr' f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before- | otherwise -> go (go z r) l- _ -> go z t- where- go !z' Nil = z'- go z' (Tip kx bm) = foldr'Bits kx f z' bm- go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr' #-}---- | /O(n)/. Fold the elements in the set using the given left-associative--- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.------ For example,------ > toDescList set = foldl (flip (:)) [] set-foldl :: (a -> Key -> a) -> a -> IntSet -> a-foldl f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before- | otherwise -> go (go z l) r- _ -> go z t- where- go z' Nil = z'- go z' (Tip kx bm) = foldlBits kx f z' bm- go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl #-}---- | /O(n)/. A strict version of 'foldl'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldl' :: (a -> Key -> a) -> a -> IntSet -> a-foldl' f z = \t -> -- Use lambda t to be inlinable with two arguments only.- case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before- | otherwise -> go (go z l) r- _ -> go z t- where- go !z' Nil = z'- go z' (Tip kx bm) = foldl'Bits kx f z' bm- go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl' #-}--{--------------------------------------------------------------------- List variations---------------------------------------------------------------------}--- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order.--- Subject to list fusion.-elems :: IntSet -> [Key]-elems- = toAscList--{--------------------------------------------------------------------- Lists---------------------------------------------------------------------}-#if __GLASGOW_HASKELL__ >= 708--- | @since 0.5.6.2-instance GHC.Exts.IsList IntSet where- type Item IntSet = Key- fromList = fromList- toList = toList-#endif---- | /O(n)/. Convert the set to a list of elements. Subject to list fusion.-toList :: IntSet -> [Key]-toList- = toAscList---- | /O(n)/. Convert the set to an ascending list of elements. Subject to list--- fusion.-toAscList :: IntSet -> [Key]-toAscList = foldr (:) []---- | /O(n)/. Convert the set to a descending list of elements. Subject to list--- fusion.-toDescList :: IntSet -> [Key]-toDescList = foldl (flip (:)) []---- List fusion for the list generating functions.-#if __GLASGOW_HASKELL__--- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.--- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.-foldrFB :: (Key -> b -> b) -> b -> IntSet -> b-foldrFB = foldr-{-# INLINE[0] foldrFB #-}-foldlFB :: (a -> Key -> a) -> a -> IntSet -> a-foldlFB = foldl-{-# INLINE[0] foldlFB #-}---- Inline elems and toList, so that we need to fuse only toAscList.-{-# INLINE elems #-}-{-# INLINE toList #-}---- The fusion is enabled up to phase 2 included. If it does not succeed,--- convert in phase 1 the expanded to{Asc,Desc}List calls back to--- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in--- a list fusion, otherwise it would go away in phase 1), and let compiler do--- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it--- before phase 0, otherwise the fusion rules would not fire at all.-{-# NOINLINE[0] toAscList #-}-{-# NOINLINE[0] toDescList #-}-{-# RULES "IntSet.toAscList" [~1] forall s . toAscList s = GHC.Exts.build (\c n -> foldrFB c n s) #-}-{-# RULES "IntSet.toAscListBack" [1] foldrFB (:) [] = toAscList #-}-{-# RULES "IntSet.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}-{-# RULES "IntSet.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}-#endif----- | /O(n*min(n,W))/. Create a set from a list of integers.-fromList :: [Key] -> IntSet-fromList xs- = Foldable.foldl' ins empty xs- where- ins t x = insert x t---- | /O(n)/. Build a set from an ascending list of elements.--- /The precondition (input list is ascending) is not checked./-fromAscList :: [Key] -> IntSet-fromAscList = fromMonoList-{-# NOINLINE fromAscList #-}---- | /O(n)/. Build a set from an ascending list of distinct elements.--- /The precondition (input list is strictly ascending) is not checked./-fromDistinctAscList :: [Key] -> IntSet-fromDistinctAscList = fromAscList-{-# INLINE fromDistinctAscList #-}---- | /O(n)/. Build a set from a monotonic list of elements.------ The precise conditions under which this function works are subtle:--- For any branch mask, keys with the same prefix w.r.t. the branch--- mask must occur consecutively in the list.-fromMonoList :: [Key] -> IntSet-fromMonoList [] = Nil-fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1- where- -- `addAll'` collects all keys with the prefix `px` into a single- -- bitmap, and then proceeds with `addAll`.- addAll' !px !bm []- = Tip px bm- addAll' !px !bm (ky : zs)- | px == prefixOf ky- = addAll' px (bm .|. bitmapOf ky) zs- -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs)- | py <- prefixOf ky- , m <- branchMask px py- , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs- = addAll px (linkWithMask m py ty {-px-} (Tip px bm)) zs'-- -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx`- -- `addAll` consumes the rest of the list, adding to the tree `tx`- addAll !_px !tx []- = tx- addAll !px !tx (ky : zs)- | py <- prefixOf ky- , m <- branchMask px py- , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs- = addAll px (linkWithMask m py ty {-px-} tx) zs'-- -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.- addMany' !_m !px !bm []- = Inserted (Tip px bm) []- addMany' !m !px !bm zs0@(ky : zs)- | px == prefixOf ky- = addMany' m px (bm .|. bitmapOf ky) zs- -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs)- | mask px m /= mask ky m- = Inserted (Tip (prefixOf px) bm) zs0- | py <- prefixOf ky- , mxy <- branchMask px py- , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs- = addMany m px (linkWithMask mxy py ty {-px-} (Tip px bm)) zs'-- -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`.- addMany !_m !_px tx []- = Inserted tx []- addMany !m !px tx zs0@(ky : zs)- | mask px m /= mask ky m- = Inserted tx zs0- | py <- prefixOf ky- , mxy <- branchMask px py- , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs- = addMany m px (linkWithMask mxy py ty {-px-} tx) zs'-{-# INLINE fromMonoList #-}--data Inserted = Inserted !IntSet ![Key]--{--------------------------------------------------------------------- Eq---------------------------------------------------------------------}-instance Eq IntSet where- t1 == t2 = equal t1 t2- t1 /= t2 = nequal t1 t2--equal :: IntSet -> IntSet -> Bool-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)-equal (Tip kx1 bm1) (Tip kx2 bm2)- = kx1 == kx2 && bm1 == bm2-equal Nil Nil = True-equal _ _ = False--nequal :: IntSet -> IntSet -> Bool-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)- = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)-nequal (Tip kx1 bm1) (Tip kx2 bm2)- = kx1 /= kx2 || bm1 /= bm2-nequal Nil Nil = False-nequal _ _ = True--{--------------------------------------------------------------------- Ord---------------------------------------------------------------------}--instance Ord IntSet where- compare s1 s2 = compare (toAscList s1) (toAscList s2)- -- tentative implementation. See if more efficient exists.--{--------------------------------------------------------------------- Show---------------------------------------------------------------------}-instance Show IntSet where- showsPrec p xs = showParen (p > 10) $- showString "fromList " . shows (toList xs)--{--------------------------------------------------------------------- Read---------------------------------------------------------------------}-instance Read IntSet where-#ifdef __GLASGOW_HASKELL__- readPrec = parens $ prec 10 $ do- Ident "fromList" <- lexP- xs <- readPrec- return (fromList xs)-- readListPrec = readListPrecDefault-#else- readsPrec p = readParen (p > 10) $ \ r -> do- ("fromList",s) <- lex r- (xs,t) <- reads s- return (fromList xs,t)-#endif--{--------------------------------------------------------------------- Typeable---------------------------------------------------------------------}--INSTANCE_TYPEABLE0(IntSet)--{--------------------------------------------------------------------- NFData---------------------------------------------------------------------}---- The IntSet constructors consist only of strict fields of Ints and--- IntSets, thus the default NFData instance which evaluates to whnf--- should suffice-instance NFData IntSet where rnf x = seq x ()--{--------------------------------------------------------------------- Debugging---------------------------------------------------------------------}--- | /O(n)/. Show the tree that implements the set. The tree is shown--- in a compressed, hanging format.-showTree :: IntSet -> String-showTree s- = showTreeWith True False s---{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows- the tree that implements the set. If @hang@ is- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If- @wide@ is 'True', an extra wide version is shown.--}-showTreeWith :: Bool -> Bool -> IntSet -> String-showTreeWith hang wide t- | hang = (showsTreeHang wide [] t) ""- | otherwise = (showsTree wide [] [] t) ""--showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS-showsTree wide lbars rbars t- = case t of- Bin p m l r- -> showsTree wide (withBar rbars) (withEmpty rbars) r .- showWide wide rbars .- showsBars lbars . showString (showBin p m) . showString "\n" .- showWide wide lbars .- showsTree wide (withEmpty lbars) (withBar lbars) l- Tip kx bm- -> showsBars lbars . showString " " . shows kx . showString " + " .- showsBitMap bm . showString "\n"- Nil -> showsBars lbars . showString "|\n"--showsTreeHang :: Bool -> [String] -> IntSet -> ShowS-showsTreeHang wide bars t- = case t of- Bin p m l r- -> showsBars bars . showString (showBin p m) . showString "\n" .- showWide wide bars .- showsTreeHang wide (withBar bars) l .- showWide wide bars .- showsTreeHang wide (withEmpty bars) r- Tip kx bm- -> showsBars bars . showString " " . shows kx . showString " + " .- showsBitMap bm . showString "\n"- Nil -> showsBars bars . showString "|\n"--showBin :: Prefix -> Mask -> String-showBin _ _- = "*" -- ++ show (p,m)--showWide :: Bool -> [String] -> String -> String-showWide wide bars- | wide = showString (concat (reverse bars)) . showString "|\n"- | otherwise = id--showsBars :: [String] -> ShowS-showsBars [] = id-showsBars bars = showString (concat (reverse (tail bars))) . showString node--showsBitMap :: Word -> ShowS-showsBitMap = showString . showBitMap--showBitMap :: Word -> String-showBitMap w = show $ foldrBits 0 (:) [] w--node :: String-node = "+--"--withBar, withEmpty :: [String] -> [String]-withBar bars = "| ":bars-withEmpty bars = " ":bars---{--------------------------------------------------------------------- Helpers---------------------------------------------------------------------}-{--------------------------------------------------------------------- Link---------------------------------------------------------------------}-link :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet-link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2-{-# INLINE link #-}---- `linkWithMask` is useful when the `branchMask` has already been computed-linkWithMask :: Mask -> Prefix -> IntSet -> IntSet -> IntSet-linkWithMask m p1 t1 {-p2-} t2- | zero p1 m = Bin p m t1 t2- | otherwise = Bin p m t2 t1- where- p = mask p1 m-{-# INLINE linkWithMask #-}--{--------------------------------------------------------------------- @bin@ assures that we never have empty trees within a tree.---------------------------------------------------------------------}-bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet-bin _ _ l Nil = l-bin _ _ Nil r = r-bin p m l r = Bin p m l r-{-# INLINE bin #-}--{--------------------------------------------------------------------- @tip@ assures that we never have empty bitmaps within a tree.---------------------------------------------------------------------}-tip :: Prefix -> BitMap -> IntSet-tip _ 0 = Nil-tip kx bm = Tip kx bm-{-# INLINE tip #-}---{----------------------------------------------------------------------- Functions that generate Prefix and BitMap of a Key or a Suffix.-----------------------------------------------------------------------}--suffixBitMask :: Int-#if MIN_VERSION_base(4,7,0)-suffixBitMask = finiteBitSize (undefined::Word) - 1-#else-suffixBitMask = bitSize (undefined::Word) - 1-#endif-{-# INLINE suffixBitMask #-}--prefixBitMask :: Int-prefixBitMask = complement suffixBitMask-{-# INLINE prefixBitMask #-}--prefixOf :: Int -> Prefix-prefixOf x = x .&. prefixBitMask-{-# INLINE prefixOf #-}--suffixOf :: Int -> Int-suffixOf x = x .&. suffixBitMask-{-# INLINE suffixOf #-}--bitmapOfSuffix :: Int -> BitMap-bitmapOfSuffix s = 1 `shiftLL` s-{-# INLINE bitmapOfSuffix #-}--bitmapOf :: Int -> BitMap-bitmapOf x = bitmapOfSuffix (suffixOf x)-{-# INLINE bitmapOf #-}---{--------------------------------------------------------------------- Endian independent bit twiddling---------------------------------------------------------------------}--- Returns True iff the bits set in i and the Mask m are disjoint.-zero :: Int -> Mask -> Bool-zero i m- = (natFromInt i) .&. (natFromInt m) == 0-{-# INLINE zero #-}--nomatch,match :: Int -> Prefix -> Mask -> Bool-nomatch i p m- = (mask i m) /= p-{-# INLINE nomatch #-}--match i p m- = (mask i m) == p-{-# INLINE match #-}---- Suppose a is largest such that 2^a divides 2*m.--- Then mask i m is i with the low a bits zeroed out.-mask :: Int -> Mask -> Prefix-mask i m- = maskW (natFromInt i) (natFromInt m)-{-# INLINE mask #-}--{--------------------------------------------------------------------- Big endian operations---------------------------------------------------------------------}-maskW :: Nat -> Nat -> Prefix-maskW i m- = intFromNat (i .&. (complement (m-1) `xor` m))-{-# INLINE maskW #-}--shorter :: Mask -> Mask -> Bool-shorter m1 m2- = (natFromInt m1) > (natFromInt m2)-{-# INLINE shorter #-}--branchMask :: Prefix -> Prefix -> Mask-branchMask p1 p2- = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))-{-# INLINE branchMask #-}--{----------------------------------------------------------------------- To get best performance, we provide fast implementations of- lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.- If the intel bsf and bsr instructions ever become GHC primops,- this code should be reimplemented using these.-- Performance of this code is crucial for folds, toList, filter, partition.-- The signatures of methods in question are placed after this comment.-----------------------------------------------------------------------}--lowestBitSet :: Nat -> Int-highestBitSet :: Nat -> Int-foldlBits :: Int -> (a -> Int -> a) -> a -> Nat -> a-foldl'Bits :: Int -> (a -> Int -> a) -> a -> Nat -> a-foldrBits :: Int -> (Int -> a -> a) -> a -> Nat -> a-foldr'Bits :: Int -> (Int -> a -> a) -> a -> Nat -> a--{-# INLINE lowestBitSet #-}-{-# INLINE highestBitSet #-}-{-# INLINE foldlBits #-}-{-# INLINE foldl'Bits #-}-{-# INLINE foldrBits #-}-{-# INLINE foldr'Bits #-}--#if defined(__GLASGOW_HASKELL__) && (WORD_SIZE_IN_BITS==32 || WORD_SIZE_IN_BITS==64)-indexOfTheOnlyBit :: Nat -> Int-{-# INLINE indexOfTheOnlyBit #-}-#if MIN_VERSION_base(4,8,0) && (WORD_SIZE_IN_BITS==64)-indexOfTheOnlyBit bitmask = countTrailingZeros bitmask--lowestBitSet x = countTrailingZeros x--highestBitSet x = WORD_SIZE_IN_BITS - 1 - countLeadingZeros x--#else-{----------------------------------------------------------------------- For lowestBitSet we use wordsize-dependant implementation based on- multiplication and DeBrujn indeces, which was proposed by Edward Kmett- <http://haskell.org/pipermail/libraries/2011-September/016749.html>-- The core of this implementation is fast indexOfTheOnlyBit,- which is given a Nat with exactly one bit set, and returns- its index.-- Lot of effort was put in these implementations, please benchmark carefully- before changing this code.-----------------------------------------------------------------------}--indexOfTheOnlyBit bitmask =- fromIntegral (GHC.Int.I8# (lsbArray `GHC.Exts.indexInt8OffAddr#` unboxInt (intFromNat ((bitmask * magic) `shiftRL` offset))))- where unboxInt (GHC.Exts.I# i) = i-#if WORD_SIZE_IN_BITS==32- magic = 0x077CB531- offset = 27- !lsbArray = "\0\1\28\2\29\14\24\3\30\22\20\15\25\17\4\8\31\27\13\23\21\19\16\7\26\12\18\6\11\5\10\9"#-#else- magic = 0x07EDD5E59A4E28C2- offset = 58- !lsbArray = "\63\0\58\1\59\47\53\2\60\39\48\27\54\33\42\3\61\51\37\40\49\18\28\20\55\30\34\11\43\14\22\4\62\57\46\52\38\26\32\41\50\36\17\19\29\10\13\21\56\45\25\31\35\16\9\12\44\24\15\8\23\7\6\5"#-#endif--- The lsbArray gets inlined to every call site of indexOfTheOnlyBit.--- That cannot be easily avoided, as GHC forbids top-level Addr# literal.--- One could go around that by supplying getLsbArray :: () -> Addr# marked--- as NOINLINE. But the code size of calling it and processing the result--- is 48B on 32-bit and 56B on 64-bit architectures -- so the 32B and 64B array--- is actually improvement on 32-bit and only a 8B size increase on 64-bit.--lowestBitSet x = indexOfTheOnlyBit (lowestBitMask x)--highestBitSet x = indexOfTheOnlyBit (highestBitMask x)--#endif--lowestBitMask :: Nat -> Nat-lowestBitMask x = x .&. negate x-{-# INLINE lowestBitMask #-}---- Reverse the order of bits in the Nat.-revNat :: Nat -> Nat-#if WORD_SIZE_IN_BITS==32-revNat x1 = case ((x1 `shiftRL` 1) .&. 0x55555555) .|. ((x1 .&. 0x55555555) `shiftLL` 1) of- x2 -> case ((x2 `shiftRL` 2) .&. 0x33333333) .|. ((x2 .&. 0x33333333) `shiftLL` 2) of- x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F) `shiftLL` 4) of- x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF) .|. ((x4 .&. 0x00FF00FF) `shiftLL` 8) of- x5 -> ( x5 `shiftRL` 16 ) .|. ( x5 `shiftLL` 16);-#else-revNat x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of- x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of- x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of- x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of- x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of- x6 -> ( x6 `shiftRL` 32 ) .|. ( x6 `shiftLL` 32);-#endif--foldlBits prefix f z bitmap = go bitmap z- where go 0 acc = acc- go bm acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))- where- !bitmask = lowestBitMask bm- !bi = indexOfTheOnlyBit bitmask--foldl'Bits prefix f z bitmap = go bitmap z- where go 0 acc = acc- go bm !acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))- where !bitmask = lowestBitMask bm- !bi = indexOfTheOnlyBit bitmask--foldrBits prefix f z bitmap = go (revNat bitmap) z- where go 0 acc = acc- go bm acc = go (bm `xor` bitmask) ((f $! (prefix+(WORD_SIZE_IN_BITS-1)-bi)) acc)- where !bitmask = lowestBitMask bm- !bi = indexOfTheOnlyBit bitmask---foldr'Bits prefix f z bitmap = go (revNat bitmap) z- where go 0 acc = acc- go bm !acc = go (bm `xor` bitmask) ((f $! (prefix+(WORD_SIZE_IN_BITS-1)-bi)) acc)- where !bitmask = lowestBitMask bm- !bi = indexOfTheOnlyBit bitmask--#else-{----------------------------------------------------------------------- In general case we use logarithmic implementation of- lowestBitSet and highestBitSet, which works up to bit sizes of 64.-- Folds are linear scans.-----------------------------------------------------------------------}--lowestBitSet n0 =- let (n1,b1) = if n0 .&. 0xFFFFFFFF /= 0 then (n0,0) else (n0 `shiftRL` 32, 32)- (n2,b2) = if n1 .&. 0xFFFF /= 0 then (n1,b1) else (n1 `shiftRL` 16, 16+b1)- (n3,b3) = if n2 .&. 0xFF /= 0 then (n2,b2) else (n2 `shiftRL` 8, 8+b2)- (n4,b4) = if n3 .&. 0xF /= 0 then (n3,b3) else (n3 `shiftRL` 4, 4+b3)- (n5,b5) = if n4 .&. 0x3 /= 0 then (n4,b4) else (n4 `shiftRL` 2, 2+b4)- b6 = if n5 .&. 0x1 /= 0 then b5 else 1+b5- in b6--highestBitSet n0 =- let (n1,b1) = if n0 .&. 0xFFFFFFFF00000000 /= 0 then (n0 `shiftRL` 32, 32) else (n0,0)- (n2,b2) = if n1 .&. 0xFFFF0000 /= 0 then (n1 `shiftRL` 16, 16+b1) else (n1,b1)- (n3,b3) = if n2 .&. 0xFF00 /= 0 then (n2 `shiftRL` 8, 8+b2) else (n2,b2)- (n4,b4) = if n3 .&. 0xF0 /= 0 then (n3 `shiftRL` 4, 4+b3) else (n3,b3)- (n5,b5) = if n4 .&. 0xC /= 0 then (n4 `shiftRL` 2, 2+b4) else (n4,b4)- b6 = if n5 .&. 0x2 /= 0 then 1+b5 else b5- in b6--foldlBits prefix f z bm = let lb = lowestBitSet bm- in go (prefix+lb) z (bm `shiftRL` lb)- where go !_ acc 0 = acc- go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)- | otherwise = go (bi + 1) acc (n `shiftRL` 1)--foldl'Bits prefix f z bm = let lb = lowestBitSet bm- in go (prefix+lb) z (bm `shiftRL` lb)- where go !_ !acc 0 = acc- go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)- | otherwise = go (bi + 1) acc (n `shiftRL` 1)--foldrBits prefix f z bm = let lb = lowestBitSet bm- in go (prefix+lb) (bm `shiftRL` lb)- where go !_ 0 = z- go bi n | n `testBit` 0 = f bi (go (bi + 1) (n `shiftRL` 1))- | otherwise = go (bi + 1) (n `shiftRL` 1)--foldr'Bits prefix f z bm = let lb = lowestBitSet bm- in go (prefix+lb) (bm `shiftRL` lb)- where- go !_ 0 = z- go bi n | n `testBit` 0 = f bi $! go (bi + 1) (n `shiftRL` 1)- | otherwise = go (bi + 1) (n `shiftRL` 1)--#endif---{--------------------------------------------------------------------- Utilities---------------------------------------------------------------------}---- | /O(1)/. Decompose a set into pieces based on the structure of the underlying--- tree. This function is useful for consuming a set in parallel.------ No guarantee is made as to the sizes of the pieces; an internal, but--- deterministic process determines this. However, it is guaranteed that the--- pieces returned will be in ascending order (all elements in the first submap--- less than all elements in the second, and so on).------ Examples:------ > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]--- > splitRoot empty == []------ Note that the current implementation does not return more than two subsets,--- but you should not depend on this behaviour because it can change in the--- future without notice. Also, the current version does not continue--- splitting all the way to individual singleton sets -- it stops at some--- point.-splitRoot :: IntSet -> [IntSet]-splitRoot Nil = []--- NOTE: we don't currently split below Tip, but we could.-splitRoot x@(Tip _ _) = [x]-splitRoot (Bin _ m l r) | m < 0 = [r, l]- | otherwise = [l, r]+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module : Data.IntSet.Internal+-- Copyright : (c) Daan Leijen 2002+-- (c) Joachim Breitner 2011+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Portability : portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Int Sets (internals)+--+-- The @'IntSet'@ type represents a set of elements of type @Int@. An @IntSet@+-- is strict in its elements.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/. This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. Additionally, benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced set implementation (see "Data.Set").+--+-- * Chris Okasaki and Andy Gill,+-- \"/Fast Mergeable Integer Maps/\",+-- Workshop on ML, September 1998, pages 77-86,+-- <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+-- * D.R. Morrison,+-- \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+-- Journal of the ACM, 15(4), October 1968, pages 514-534,+-- <https://doi.org/10.1145/321479.321481>.+--+-- Additionally, this implementation places bitmaps in the leaves of the tree.+-- Their size is the natural size of a machine word (32 or 64 bits) and greatly+-- reduces the memory footprint and execution times for dense sets, e.g. sets+-- where it is likely that many values lie close to each other. The asymptotics+-- are not affected by this optimization.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of IntSet matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.++module Data.IntSet.Internal (+ -- * Set type+ IntSet(..) -- instance Eq,Show+ , Key+ , BitMap++ -- * Operators+ , (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookupLT+ , lookupGT+ , lookupLE+ , lookupGE+ , isSubsetOf+ , isProperSubsetOf+ , disjoint++ -- * Construction+ , empty+ , singleton+ , fromRange+ , insert+ , delete+ , alterF++ -- * Combine+ , union+ , unions+ , difference+ , intersection+ , intersections+ , symmetricDifference+ , Intersection(..)++ -- * Filter+ , filter+ , partition++ , takeWhileAntitone+ , dropWhileAntitone+ , spanAntitone++ , split+ , splitMember+ , splitRoot++ -- * Map+ , map+ , mapMonotonic++ -- * Folds+ , foldr+ , foldl+ , foldMap+ -- ** Strict folds+ , foldr'+ , foldl'+ -- ** Legacy folds+ , fold++ -- * Min\/Max+ , lookupMin+ , lookupMax+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , maxView+ , minView++ -- * Conversion++ -- ** List+ , elems+ , toList+ , fromList++ -- ** Ordered list+ , toAscList+ , toDescList+ , fromAscList+ , fromDistinctAscList++ -- * Debugging+ , showTree+ , showTreeWith++ -- * Internals+ , suffixBitMask+ , prefixBitMask+ , bitmapOf+ ) where++import Control.Applicative (Const(..))+import Control.DeepSeq (NFData(rnf))+import Data.Bits+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (fromMaybe)+import Data.Semigroup (Semigroup(..), stimesIdempotent, stimesIdempotentMonoid)+import Utils.Containers.Internal.Prelude hiding+ (filter, foldr, foldl, foldl', foldMap, null, map)+import Prelude ()++import Utils.Containers.Internal.BitUtil (iShiftRL, shiftLL, shiftRL)+import Utils.Containers.Internal.StrictPair+import Data.IntSet.Internal.IntTreeCommons+ ( Key+ , Prefix(..)+ , nomatch+ , left+ , signBranch+ , mask+ , branchMask+ , TreeTreeBranch(..)+ , treeTreeBranch+ , i2w+ , Order(..)+ )++#if __GLASGOW_HASKELL__+import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType)+import qualified Data.Data+import Text.Read+import Data.Coerce (coerce)+#endif++#if __GLASGOW_HASKELL__+import qualified GHC.Exts+# if !(WORD_SIZE_IN_BITS==64)+import qualified GHC.Int+# endif+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif++import qualified Data.Foldable as Foldable+import Data.Functor.Identity (Identity(..))++infixl 9 \\{-This comment teaches CPP correct behaviour -}++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- See 'difference'.+(\\) :: IntSet -> IntSet -> IntSet+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+ Types+--------------------------------------------------------------------}++-- | A set of integers.++-- See Note: Order of constructors+data IntSet = Bin {-# UNPACK #-} !Prefix+ !IntSet+ !IntSet+ | Tip {-# UNPACK #-} !Int+ {-# UNPACK #-} !BitMap+ | Nil++type BitMap = Word++--+-- Note [IntSet structure and invariants]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- * Nil is never found as a child of Bin.+--+-- * The Prefix of a Bin indicates the common high-order bits that all keys in+-- the Bin share.+--+-- * The least significant set bit of the Int value of a Prefix is called the+-- mask bit.+--+-- * All the bits to the left of the mask bit are called the shared prefix. All+-- keys stored in the Bin begin with the shared prefix.+--+-- * All keys in the left child of the Bin have the mask bit unset, and all keys+-- in the right child have the mask bit set. It follows that+--+-- 1. The Int value of the Prefix of a Bin is the smallest key that can be+-- present in the right child of the Bin.+--+-- 2. All keys in the right child of a Bin are greater than keys in the+-- left child, with one exceptional situation. If the Bin separates+-- negative and non-negative keys, the mask bit is the sign bit and the+-- left child stores the non-negative keys while the right child stores the+-- negative keys.+--+-- * All bits to the right of the mask bit are set to 0 in a Prefix.+--+-- * The shared prefix of a Bin is never longer than+-- (WORD_SIZE - lg(WORD_SIZE) - 1) bits.+--+-- * In the context of a Tip, the highest (WORD_SIZE - lg(WORD_SIZE)) bits of+-- a key are called "prefix" and the lowest lg(WORD_SIZE) bits are called+-- "suffix". In Tip kx bm, kx is the shared prefix and bm is a bitmask of the+-- suffixes of the keys. In other words, the keys of Tip kx bm are (kx .|. i)+-- for every set bit i in bm.+--+-- * In Tip kx _, the lowest lg(WORD_SIZE) bits of kx are set to 0.+--+-- * In Tip _ bm, bm is never 0.+--++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+deriving instance Lift IntSet+#endif++-- | @mempty@ = 'empty'+instance Monoid IntSet where+ mempty = empty+ mconcat = unions+ mappend = (<>)++-- | @(<>)@ = 'union'+--+-- @since 0.5.7+instance Semigroup IntSet where+ (<>) = union+ stimes = stimesIdempotentMonoid++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+ A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data IntSet where+ gfoldl f z is = z fromList `f` (toList is)+ toConstr _ = fromListConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z fromList)+ _ -> error "gunfold"+ dataTypeOf _ = intSetDataType++fromListConstr :: Constr+fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix++intSetDataType :: DataType+intSetDataType = mkDataType "Data.IntSet.Internal.IntSet" [fromListConstr]++#endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the set empty?+null :: IntSet -> Bool+null Nil = True+null _ = False+{-# INLINE null #-}++-- | \(O(n)\). Cardinality of the set.+size :: IntSet -> Int+size = go 0+ where+ go !acc (Bin _ l r) = go (go acc l) r+ go acc (Tip _ bm) = acc + popCount bm+ go acc Nil = acc++-- | \(O(\min(n,W))\). Is the value a member of the set?++-- See Note: Local 'go' functions and capturing.+member :: Key -> IntSet -> Bool+member !x = go+ where+ go (Bin p l r)+ | nomatch x p = False+ | left x p = go l+ | otherwise = go r+ go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0+ go Nil = False++-- | \(O(\min(n,W))\). Is the element not in the set?+notMember :: Key -> IntSet -> Bool+notMember k = not . member k++-- | \(O(\min(n,W))\). Find largest element smaller than the given one.+--+-- > lookupLT 3 (fromList [3, 5]) == Nothing+-- > lookupLT 5 (fromList [3, 5]) == Just 3++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> IntSet -> Maybe Key+lookupLT !x t = case t of+ Bin p l r | signBranch p -> if x >= 0 then go r l else go Nil r+ _ -> go Nil t+ where+ go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMax def else unsafeFindMax r+ | left x p = go def l+ | otherwise = go l r+ go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm+ | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT+ | otherwise = unsafeFindMax def+ where maskLT = (bitmapOf x - 1) .&. bm+ go def Nil = unsafeFindMax def+++-- | \(O(\min(n,W))\). Find smallest element greater than the given one.+--+-- > lookupGT 4 (fromList [3, 5]) == Just 5+-- > lookupGT 5 (fromList [3, 5]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> IntSet -> Maybe Key+lookupGT !x t = case t of+ Bin p l r | signBranch p -> if x >= 0 then go Nil l else go l r+ _ -> go Nil t+ where+ go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMin l else unsafeFindMin def+ | left x p = go r l+ | otherwise = go def r+ go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm+ | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT+ | otherwise = unsafeFindMin def+ where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm+ go def Nil = unsafeFindMin def+++-- | \(O(\min(n,W))\). Find largest element smaller or equal to the given one.+--+-- > lookupLE 2 (fromList [3, 5]) == Nothing+-- > lookupLE 4 (fromList [3, 5]) == Just 3+-- > lookupLE 5 (fromList [3, 5]) == Just 5++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> IntSet -> Maybe Key+lookupLE !x t = case t of+ Bin p l r | signBranch p -> if x >= 0 then go r l else go Nil r+ _ -> go Nil t+ where+ go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMax def else unsafeFindMax r+ | left x p = go def l+ | otherwise = go l r+ go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm+ | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE+ | otherwise = unsafeFindMax def+ where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm+ go def Nil = unsafeFindMax def+++-- | \(O(\min(n,W))\). Find smallest element greater or equal to the given one.+--+-- > lookupGE 3 (fromList [3, 5]) == Just 3+-- > lookupGE 4 (fromList [3, 5]) == Just 5+-- > lookupGE 6 (fromList [3, 5]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> IntSet -> Maybe Key+lookupGE !x t = case t of+ Bin p l r | signBranch p -> if x >= 0 then go Nil l else go l r+ _ -> go Nil t+ where+ go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMin l else unsafeFindMin def+ | left x p = go r l+ | otherwise = go def r+ go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm+ | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE+ | otherwise = unsafeFindMin def+ where maskGE = (- (bitmapOf x)) .&. bm+ go def Nil = unsafeFindMin def++++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: IntSet -> Maybe Key+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm+unsafeFindMin (Bin _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: IntSet -> Maybe Key+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm+unsafeFindMax (Bin _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty set.+empty :: IntSet+empty+ = Nil+{-# INLINE empty #-}++-- | \(O(1)\). A set of one element.+singleton :: Key -> IntSet+singleton x+ = Tip (prefixOf x) (bitmapOf x)+{-# INLINE singleton #-}++{--------------------------------------------------------------------+ Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Add a value to the set. There is no left- or right bias for+-- IntSets.+insert :: Key -> IntSet -> IntSet+insert !x = insertBM (prefixOf x) (bitmapOf x)++-- Helper function for insert and union.+insertBM :: Int -> BitMap -> IntSet -> IntSet+insertBM !kx !bm t@(Bin p l r)+ | nomatch kx p = linkKey kx (Tip kx bm) p t+ | left kx p = Bin p (insertBM kx bm l) r+ | otherwise = Bin p l (insertBM kx bm r)+insertBM kx bm t@(Tip kx' bm')+ | kx' == kx = Tip kx' (bm .|. bm')+ | otherwise = link kx (Tip kx bm) kx' t+insertBM kx bm Nil = Tip kx bm++-- | \(O(\min(n,W))\). Delete a value in the set. Returns the+-- original set when the value was not present.+delete :: Key -> IntSet -> IntSet+delete !x = deleteBM (prefixOf x) (bitmapOf x)++-- Deletes all values mentioned in the BitMap from the set.+-- Helper function for delete and difference.+deleteBM :: Int -> BitMap -> IntSet -> IntSet+deleteBM !kx !bm t@(Bin p l r)+ | nomatch kx p = t+ | left kx p = bin p (deleteBM kx bm l) r+ | otherwise = bin p l (deleteBM kx bm r)+deleteBM kx bm t@(Tip kx' bm')+ | kx' == kx = tip kx (bm' .&. complement bm)+ | otherwise = t+deleteBM _ _ Nil = Nil++-- | \(O(\min(n,W))\). @('alterF' f x s)@ can delete or insert @x@ in @s@ depending+-- on whether it is already present in @s@.+--+-- In short:+--+-- @+-- 'member' x \<$\> 'alterF' f x s = f ('member' x s)+-- @+--+-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".+--+-- @since 0.6.3.1+alterF :: Functor f => (Bool -> f Bool) -> Key -> IntSet -> f IntSet+alterF f k s = fmap choose (f member_)+ where+ member_ = member k s++ (inserted, deleted)+ | member_ = (s , delete k s)+ | otherwise = (insert k s, s )++ choose True = inserted+ choose False = deleted+#ifndef __GLASGOW_HASKELL__+{-# INLINE alterF #-}+#else+{-# INLINABLE [2] alterF #-}++{-# RULES+"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s+ #-}+#endif++{-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> IntSet -> Identity IntSet #-}++{--------------------------------------------------------------------+ Union+--------------------------------------------------------------------}+-- | The union of a list of sets.+unions :: Foldable f => f IntSet -> IntSet+unions xs+ = Foldable.foldl' union empty xs+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union of two sets.+union :: IntSet -> IntSet -> IntSet+union t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> Bin p1 (union l1 t2) r1+ ABR -> Bin p1 l1 (union r1 t2)+ BAL -> Bin p2 (union t1 l2) r2+ BAR -> Bin p2 l2 (union t1 r2)+ EQL -> Bin p1 (union l1 l2) (union r1 r2)+ NOM -> link (unPrefix p1) t1 (unPrefix p2) t2+union t@(Bin _ _ _) (Tip kx bm) = insertBM kx bm t+union t@(Bin _ _ _) Nil = t+union (Tip kx bm) t = insertBM kx bm t+union Nil t = t+++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference between two sets.+difference :: IntSet -> IntSet -> IntSet+difference t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> bin p1 (difference l1 t2) r1+ ABR -> bin p1 l1 (difference r1 t2)+ BAL -> difference t1 l2+ BAR -> difference t1 r2+ EQL -> bin p1 (difference l1 l2) (difference r1 r2)+ NOM -> t1++difference t@(Bin _ _ _) (Tip kx bm) = deleteBM kx bm t+difference t@(Bin _ _ _) Nil = t++difference t1@(Tip kx bm) t2 = differenceTip t2+ where differenceTip (Bin p2 l2 r2) | nomatch kx p2 = t1+ | left kx p2 = differenceTip l2+ | otherwise = differenceTip r2+ differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2)+ | otherwise = t1+ differenceTip Nil = t1++difference Nil _ = Nil++++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection of two sets.+intersection :: IntSet -> IntSet -> IntSet+intersection t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> intersection l1 t2+ ABR -> intersection r1 t2+ BAL -> intersection t1 l2+ BAR -> intersection t1 r2+ EQL -> bin p1 (intersection l1 l2) (intersection r1 r2)+ NOM -> Nil++intersection t1@(Bin _ _ _) (Tip kx2 bm2) = intersectBM t1+ where intersectBM (Bin p1 l1 r1) | nomatch kx2 p1 = Nil+ | left kx2 p1 = intersectBM l1+ | otherwise = intersectBM r1+ intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+ | otherwise = Nil+ intersectBM Nil = Nil++intersection (Bin _ _ _) Nil = Nil++intersection (Tip kx1 bm1) t2 = intersectBM t2+ where intersectBM (Bin p2 l2 r2) | nomatch kx1 p2 = Nil+ | left kx1 p2 = intersectBM l2+ | otherwise = intersectBM r2+ intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+ | otherwise = Nil+ intersectBM Nil = Nil++intersection Nil _ = Nil++-- | The intersection of a series of sets. Intersections are performed+-- left-to-right.+--+-- @since 0.8+intersections :: NonEmpty IntSet -> IntSet+intersections (s0 :| ss)+ | null s0 = empty+ | otherwise = List.foldr go id ss s0+ where+ go s r acc+ | null acc' = empty+ | otherwise = r acc'+ where+ acc' = intersection acc s+{-# INLINABLE intersections #-}++-- | @IntSet@s form a 'Semigroup' under 'intersection'.+--+-- A @Monoid@ instance is not defined because it would be impractical to+-- construct @mempty@, the @IntSet@ containing all @Int@s.+--+-- @since 0.8+newtype Intersection = Intersection { getIntersection :: IntSet }+ deriving (Show, Eq, Ord)++instance Semigroup Intersection where+ Intersection s1 <> Intersection s2 = Intersection (intersection s1 s2)++ stimes = stimesIdempotent+ {-# INLINABLE stimes #-}++ sconcat =+#ifdef __GLASGOW_HASKELL__+ coerce intersections+#else+ Intersection . intersections . fmap getIntersection+#endif++{--------------------------------------------------------------------+ Symmetric difference+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The symmetric difference of two sets.+--+-- The result contains elements that appear in exactly one of the two sets.+--+-- @+-- symmetricDifference (fromList [0,2,4,6]) (fromList [0,3,6,9]) == fromList [2,3,4,9]+-- @+--+-- @since 0.8+symmetricDifference :: IntSet -> IntSet -> IntSet+symmetricDifference t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) =+ case treeTreeBranch p1 p2 of+ ABL -> bin p1 (symmetricDifference l1 t2) r1+ ABR -> bin p1 l1 (symmetricDifference r1 t2)+ BAL -> bin p2 (symmetricDifference t1 l2) r2+ BAR -> bin p2 l2 (symmetricDifference t1 r2)+ EQL -> bin p1 (symmetricDifference l1 l2) (symmetricDifference r1 r2)+ NOM -> link (unPrefix p1) t1 (unPrefix p2) t2+symmetricDifference t1@(Bin _ _ _) t2@(Tip kx2 bm2) = symDiffTip t2 kx2 bm2 t1+symmetricDifference t1@(Bin _ _ _) Nil = t1+symmetricDifference t1@(Tip kx1 bm1) t2 = symDiffTip t1 kx1 bm1 t2+symmetricDifference Nil t2 = t2++symDiffTip :: IntSet -> Int -> BitMap -> IntSet -> IntSet+symDiffTip !t1 !kx1 !bm1 = go+ where+ go t2@(Bin p2 l2 r2)+ | nomatch kx1 p2 = linkKey kx1 t1 p2 t2+ | left kx1 p2 = bin p2 (go l2) r2+ | otherwise = bin p2 l2 (go r2)+ go t2@(Tip kx2 bm2)+ | kx1 == kx2 = tip kx1 (bm1 `xor` bm2)+ | otherwise = link kx1 t1 kx2 t2+ go Nil = t1++{--------------------------------------------------------------------+ Subset+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Is this a proper subset? (ie. a subset but not equal).+isProperSubsetOf :: IntSet -> IntSet -> Bool+isProperSubsetOf t1 t2+ = case subsetCmp t1 t2 of+ LT -> True+ _ -> False++subsetCmp :: IntSet -> IntSet -> Ordering+subsetCmp t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> GT+ ABR -> GT+ BAL -> case subsetCmp t1 l2 of GT -> GT ; _ -> LT+ BAR -> case subsetCmp t1 r2 of GT -> GT ; _ -> LT+ EQL -> subsetCmpEq+ NOM -> GT -- disjoint+ where+ subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of+ (GT,_ ) -> GT+ (_ ,GT) -> GT+ (EQ,EQ) -> EQ+ _ -> LT++subsetCmp (Bin _ _ _) _ = GT+subsetCmp (Tip kx1 bm1) (Tip kx2 bm2)+ | kx1 /= kx2 = GT -- disjoint+ | bm1 == bm2 = EQ+ | bm1 .&. complement bm2 == 0 = LT+ | otherwise = GT+subsetCmp t1@(Tip kx _) (Bin p l r)+ | nomatch kx p = GT+ | left kx p = case subsetCmp t1 l of GT -> GT ; _ -> LT+ | otherwise = case subsetCmp t1 r of GT -> GT ; _ -> LT+subsetCmp (Tip _ _) Nil = GT -- disjoint+subsetCmp Nil Nil = EQ+subsetCmp Nil _ = LT++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Is this a subset?+-- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.++isSubsetOf :: IntSet -> IntSet -> Bool+isSubsetOf t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> False+ ABR -> False+ BAL -> isSubsetOf t1 l2+ BAR -> isSubsetOf t1 r2+ EQL -> isSubsetOf l1 l2 && isSubsetOf r1 r2+ NOM -> False+isSubsetOf (Bin _ _ _) _ = False+isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0+isSubsetOf t1@(Tip kx _) (Bin p l r)+ | nomatch kx p = False+ | left kx p = isSubsetOf t1 l+ | otherwise = isSubsetOf t1 r+isSubsetOf (Tip _ _) Nil = False+isSubsetOf Nil _ = True+++{--------------------------------------------------------------------+ Disjoint+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Check whether two sets are disjoint (i.e. their intersection+-- is empty).+--+-- > disjoint (fromList [2,4,6]) (fromList [1,3]) == True+-- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False+-- > disjoint (fromList [1,2]) (fromList [1,2,3,4]) == False+-- > disjoint (fromList []) (fromList []) == True+--+-- @since 0.5.11+disjoint :: IntSet -> IntSet -> Bool+disjoint t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> disjoint l1 t2+ ABR -> disjoint r1 t2+ BAL -> disjoint t1 l2+ BAR -> disjoint t1 r2+ EQL -> disjoint l1 l2 && disjoint r1 r2+ NOM -> True++disjoint t1@(Bin _ _ _) (Tip kx2 bm2) = disjointBM t1+ where disjointBM (Bin p1 l1 r1) | nomatch kx2 p1 = True+ | left kx2 p1 = disjointBM l1+ | otherwise = disjointBM r1+ disjointBM (Tip kx1 bm1) | kx1 == kx2 = (bm1 .&. bm2) == 0+ | otherwise = True+ disjointBM Nil = True++disjoint (Bin _ _ _) Nil = True++disjoint (Tip kx1 bm1) t2 = disjointBM t2+ where disjointBM (Bin p2 l2 r2) | nomatch kx1 p2 = True+ | left kx1 p2 = disjointBM l2+ | otherwise = disjointBM r2+ disjointBM (Tip kx2 bm2) | kx1 == kx2 = (bm1 .&. bm2) == 0+ | otherwise = True+ disjointBM Nil = True++disjoint Nil _ = True+++{--------------------------------------------------------------------+ Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all elements that satisfy some predicate.+filter :: (Key -> Bool) -> IntSet -> IntSet+filter predicate t+ = case t of+ Bin p l r+ -> bin p (filter predicate l) (filter predicate r)+ Tip kx bm+ -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm)+ Nil -> Nil+ where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+ | otherwise = bm+ {-# INLINE bitPred #-}++-- | \(O(n)\). partition the set according to some predicate.+partition :: (Key -> Bool) -> IntSet -> (IntSet,IntSet)+partition predicate0 t0 = toPair $ go predicate0 t0+ where+ go predicate t+ = case t of+ Bin p l r+ -> let (l1 :*: l2) = go predicate l+ (r1 :*: r2) = go predicate r+ in bin p l1 r1 :*: bin p l2 r2+ Tip kx bm+ -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm+ in tip kx bm1 :*: tip kx (bm `xor` bm1)+ Nil -> (Nil :*: Nil)+ where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+ | otherwise = bm+ {-# INLINE bitPred #-}++-- | \(O(\min(n,W))\). Take while a predicate on the elements holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'+-- takeWhileAntitone p = 'filter' p+-- @+--+-- @since 0.6.7+takeWhileAntitone :: (Key -> Bool) -> IntSet -> IntSet+takeWhileAntitone predicate t =+ case t of+ Bin p l r+ | signBranch p ->+ if predicate 0 -- handle negative numbers.+ then bin p (go predicate l) r+ else go predicate r+ _ -> go predicate t+ where+ go predicate' (Bin p l r)+ | predicate' (unPrefix p) = bin p l (go predicate' r)+ | otherwise = go predicate' l+ go predicate' (Tip kx bm) = tip kx (takeWhileAntitoneBits kx predicate' bm)+ go _ Nil = Nil++-- | \(O(\min(n,W))\). Drop while a predicate on the elements holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'+-- dropWhileAntitone p = 'filter' (not . p)+-- @+--+-- @since 0.6.7+dropWhileAntitone :: (Key -> Bool) -> IntSet -> IntSet+dropWhileAntitone predicate t =+ case t of+ Bin p l r+ | signBranch p ->+ if predicate 0 -- handle negative numbers.+ then go predicate l+ else bin p l (go predicate r)+ _ -> go predicate t+ where+ go predicate' (Bin p l r)+ | predicate' (unPrefix p) = go predicate' r+ | otherwise = bin p (go predicate' l) r+ go predicate' (Tip kx bm) = tip kx (bm `xor` takeWhileAntitoneBits kx predicate' bm)+ go _ Nil = Nil++-- | \(O(\min(n,W))\). Divide a set at the point where a predicate on the elements stops holding.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = 'partition' p xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set+-- at some /unspecified/ point.+--+-- @since 0.6.7+spanAntitone :: (Key -> Bool) -> IntSet -> (IntSet, IntSet)+spanAntitone predicate t =+ case t of+ Bin p l r+ | signBranch p ->+ if predicate 0 -- handle negative numbers.+ then+ case go predicate l of+ (lt :*: gt) ->+ let !lt' = bin p lt r+ in (lt', gt)+ else+ case go predicate r of+ (lt :*: gt) ->+ let !gt' = bin p l gt+ in (lt, gt')+ _ -> case go predicate t of+ (lt :*: gt) -> (lt, gt)+ where+ go predicate' (Bin p l r)+ | predicate' (unPrefix p) = case go predicate' r of (lt :*: gt) -> bin p l lt :*: gt+ | otherwise = case go predicate' l of (lt :*: gt) -> lt :*: bin p gt r+ go predicate' (Tip kx bm) = let bm' = takeWhileAntitoneBits kx predicate' bm+ in (tip kx bm' :*: tip kx (bm `xor` bm'))+ go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). The expression (@'split' x set@) is a pair @(set1,set2)@+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@+-- comprises the elements of @set@ greater than @x@.+--+-- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])+split :: Key -> IntSet -> (IntSet,IntSet)+split x t =+ case t of+ Bin p l r+ | signBranch p ->+ if x >= 0 -- handle negative numbers.+ then+ case go x l of+ (lt :*: gt) ->+ let !lt' = bin p lt r+ in (lt', gt)+ else+ case go x r of+ (lt :*: gt) ->+ let !gt' = bin p l gt+ in (lt, gt')+ _ -> case go x t of+ (lt :*: gt) -> (lt, gt)+ where+ go !x' t'@(Bin p l r)+ | nomatch x' p = if x' < unPrefix p then (Nil :*: t') else (t' :*: Nil)+ | left x' p = case go x' l of (lt :*: gt) -> lt :*: bin p gt r+ | otherwise = case go x' r of (lt :*: gt) -> bin p l lt :*: gt+ go x' t'@(Tip kx' bm)+ | kx' > x' = (Nil :*: t')+ -- equivalent to kx' > prefixOf x'+ | kx' < prefixOf x' = (t' :*: Nil)+ | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)+ where lowerBitmap = bitmapOf x' - 1+ higherBitmap = complement (lowerBitmap + bitmapOf x')+ go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Key -> IntSet -> (IntSet,Bool,IntSet)+splitMember x t =+ case t of+ Bin p l r+ | signBranch p ->+ if x >= 0 -- handle negative numbers.+ then+ case go x l of+ (lt, fnd, gt) ->+ let !lt' = bin p lt r+ in (lt', fnd, gt)+ else+ case go x r of+ (lt, fnd, gt) ->+ let !gt' = bin p l gt+ in (lt, fnd, gt')+ _ -> go x t+ where+ go !x' t'@(Bin p l r)+ | nomatch x' p = if x' < unPrefix p then (Nil, False, t') else (t', False, Nil)+ | left x' p =+ case go x' l of+ (lt, fnd, gt) ->+ let !gt' = bin p gt r+ in (lt, fnd, gt')+ | otherwise =+ case go x' r of+ (lt, fnd, gt) ->+ let !lt' = bin p l lt+ in (lt', fnd, gt)+ go x' t'@(Tip kx' bm)+ | kx' > x' = (Nil, False, t')+ -- equivalent to kx' > prefixOf x'+ | kx' < prefixOf x' = (t', False, Nil)+ | otherwise = let !lt = tip kx' (bm .&. lowerBitmap)+ !found = (bm .&. bitmapOfx') /= 0+ !gt = tip kx' (bm .&. higherBitmap)+ in (lt, found, gt)+ where bitmapOfx' = bitmapOf x'+ lowerBitmap = bitmapOfx' - 1+ higherBitmap = complement (lowerBitmap + bitmapOfx')+ go _ Nil = (Nil, False, Nil)++{----------------------------------------------------------------------+ Min/Max+----------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Retrieves the maximal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+maxView :: IntSet -> Maybe (Key, IntSet)+maxView t =+ case t of Nil -> Nothing+ Bin p l r | signBranch p -> case go l of (result, l') -> Just (result, bin p l' r)+ _ -> Just (go t)+ where+ go (Bin p l r) = case go r of (result, r') -> (result, bin p l r')+ go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))+ go Nil = error "maxView Nil"++-- | \(O(\min(n,W))\). Retrieves the minimal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+minView :: IntSet -> Maybe (Key, IntSet)+minView t =+ case t of Nil -> Nothing+ Bin p l r | signBranch p -> case go r of (result, r') -> Just (result, bin p l r')+ _ -> Just (go t)+ where+ go (Bin p l r) = case go l of (result, l') -> (result, bin p l' r)+ go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))+ go Nil = error "minView Nil"++-- | \(O(\min(n,W))\). Delete and find the minimal element.+--+-- > deleteFindMin set = (findMin set, deleteMin set)+deleteFindMin :: IntSet -> (Key, IntSet)+deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView++-- | \(O(\min(n,W))\). Delete and find the maximal element.+--+-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: IntSet -> (Key, IntSet)+deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView++lookupMinSure :: IntSet -> Key+lookupMinSure (Tip kx bm) = kx + lowestBitSet bm+lookupMinSure (Bin _ l _) = lookupMinSure l+lookupMinSure Nil = error "lookupMin Nil"++-- | \(O(\min(n,W))\). The minimal element of the set. Returns 'Nothing' if the+-- set is empty.+--+-- @since 0.8+lookupMin :: IntSet -> Maybe Key+lookupMin Nil = Nothing+lookupMin (Tip kx bm) = Just $! kx + lowestBitSet bm+lookupMin (Bin p l r) = Just $! lookupMinSure (if signBranch p then r else l)+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The minimal element of the set. Calls 'error' if the set+-- is empty.+findMin :: IntSet -> Key+findMin t+ | Just r <- lookupMin t = r+ | otherwise = error "findMin: empty set has no minimal element"++lookupMaxSure :: IntSet -> Key+lookupMaxSure (Tip kx bm) = kx + highestBitSet bm+lookupMaxSure (Bin _ _ r) = lookupMaxSure r+lookupMaxSure Nil = error "lookupMax Nil"++-- | \(O(\min(n,W))\). The maximal element of the set. Returns 'Nothing' if the+-- set is empty.+--+-- @since 0.8+lookupMax :: IntSet -> Maybe Key+lookupMax Nil = Nothing+lookupMax (Tip kx bm) = Just $! kx + highestBitSet bm+lookupMax (Bin p l r) = Just $! lookupMaxSure (if signBranch p then l else r)+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The maximal element of the set. Calls 'error' if the set+-- is empty.+findMax :: IntSet -> Key+findMax t+ | Just r <- lookupMax t = r+ | otherwise = error "findMax: empty set has no maximal element"++-- | \(O(\min(n,W))\). Delete the minimal element. Returns an empty set if the set is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' –+-- versions prior to 0.5 threw an error if the 'IntSet' was already empty.+deleteMin :: IntSet -> IntSet+deleteMin = maybe Nil snd . minView++-- | \(O(\min(n,W))\). Delete the maximal element. Returns an empty set if the set is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' –+-- versions prior to 0.5 threw an error if the 'IntSet' was already empty.+deleteMax :: IntSet -> IntSet+deleteMax = maybe Nil snd . maxView++{----------------------------------------------------------------------+ Map+----------------------------------------------------------------------}++-- | \(O(n \min(n,W))\).+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.+--+-- It's worth noting that the size of the result may be smaller if,+-- for some @(x,y)@, @x \/= y && f x == f y@++map :: (Key -> Key) -> IntSet -> IntSet+map f = fromList . List.map f . toList++-- | \(O(n)\). The+--+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- > ==> mapMonotonic f s == map f s+-- > where ls = toList s+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'map' if the+-- precondition may not hold.+--+-- @since 0.6.3.1++-- Note that for now the test is insufficient to support any fancier implementation.+mapMonotonic :: (Key -> Key) -> IntSet -> IntSet+mapMonotonic f = fromDistinctAscList . List.map f . toAscList+++{--------------------------------------------------------------------+ Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator.+--+{-# DEPRECATED fold "Use Data.IntSet.foldr instead" #-}+fold :: (Key -> b -> b) -> b -> IntSet -> b+fold = foldr+{-# INLINE fold #-}++-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.+--+-- For example,+--+-- > toAscList set = foldr (:) [] set+foldr :: (Key -> b -> b) -> b -> IntSet -> b+foldr f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of Bin p l r | signBranch p -> go (go z l) r -- put negative numbers before+ | otherwise -> go (go z r) l+ _ -> go z t+ where+ go z' Nil = z'+ go z' (Tip kx bm) = foldrBits kx f z' bm+ go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (Key -> b -> b) -> b -> IntSet -> b+foldr' f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of Bin p l r | signBranch p -> go (go z l) r -- put negative numbers before+ | otherwise -> go (go z r) l+ _ -> go z t+ where+ go !z' Nil = z'+ go z' (Tip kx bm) = foldr'Bits kx f z' bm+ go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the elements in the set using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.+--+-- For example,+--+-- > toDescList set = foldl (flip (:)) [] set+foldl :: (a -> Key -> a) -> a -> IntSet -> a+foldl f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of Bin p l r | signBranch p -> go (go z r) l -- put negative numbers before+ | otherwise -> go (go z l) r+ _ -> go z t+ where+ go z' Nil = z'+ go z' (Tip kx bm) = foldlBits kx f z' bm+ go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> Key -> a) -> a -> IntSet -> a+foldl' f z = \t -> -- Use lambda t to be inlinable with two arguments only.+ case t of Bin p l r | signBranch p -> go (go z r) l -- put negative numbers before+ | otherwise -> go (go z l) r+ _ -> go z t+ where+ go !z' Nil = z'+ go z' (Tip kx bm) = foldl'Bits kx f z' bm+ go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++-- | \(O(n)\). Map the elements in the set to a monoid and combine with @(<>)@.+--+-- @since 0.8+foldMap :: Monoid a => (Key -> a) -> IntSet -> a+foldMap f = \t -> -- Use lambda t to be inlinable with one argument only.+ case t of+ Bin p l r+#if MIN_VERSION_base(4,11,0)+ | signBranch p -> go r <> go l -- handle negative numbers+ | otherwise -> go l <> go r+#else+ | signBranch p -> go r `mappend` go l -- handle negative numbers+ | otherwise -> go l `mappend` go r+#endif+ _ -> go t+ where+#if MIN_VERSION_base(4,11,0)+ go (Bin _ l r) = go l <> go r+#else+ go (Bin _ l r) = go l `mappend` go r+#endif+ go (Tip kx bm) = foldMapBits kx f bm+ go Nil = mempty+{-# INLINE foldMap #-}++{--------------------------------------------------------------------+ List variations+--------------------------------------------------------------------}+-- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order.+-- Subject to list fusion.+elems :: IntSet -> [Key]+elems+ = toAscList++{--------------------------------------------------------------------+ Lists+--------------------------------------------------------------------}++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.6.2+instance GHC.Exts.IsList IntSet where+ type Item IntSet = Key+ fromList = fromList+ toList = toList+#endif++-- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion.+toList :: IntSet -> [Key]+toList+ = toAscList++-- | \(O(n)\). Convert the set to an ascending list of elements. Subject to list+-- fusion.+toAscList :: IntSet -> [Key]+toAscList = foldr (:) []++-- | \(O(n)\). Convert the set to a descending list of elements. Subject to list+-- fusion.+toDescList :: IntSet -> [Key]+toDescList = foldl (flip (:)) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.+-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.+foldrFB :: (Key -> b -> b) -> b -> IntSet -> b+foldrFB = foldr+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> a) -> a -> IntSet -> a+foldlFB = foldl+{-# INLINE[0] foldlFB #-}++-- Inline elems and toList, so that we need to fuse only toAscList.+{-# INLINE elems #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded to{Asc,Desc}List calls back to+-- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in+-- a list fusion, otherwise it would go away in phase 1), and let compiler do+-- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it+-- before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "IntSet.toAscList" [~1] forall s . toAscList s = GHC.Exts.build (\c n -> foldrFB c n s) #-}+{-# RULES "IntSet.toAscListBack" [1] foldrFB (:) [] = toAscList #-}+{-# RULES "IntSet.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}+{-# RULES "IntSet.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}+#endif+++-- | \(O(n \min(n,W))\). Create a set from a list of integers.+fromList :: [Key] -> IntSet+fromList xs+ = Foldable.foldl' ins empty xs+ where+ ins t x = insert x t++-- | \(O(n / W)\). Create a set from a range of integers.+--+-- > fromRange (low, high) == fromList [low..high]+--+-- @since 0.7+fromRange :: (Key, Key) -> IntSet+fromRange (lx,rx)+ | lx > rx = empty+ | lp == rp = Tip lp (bitmapOf rx `shiftLL` 1 - bitmapOf lx)+ | otherwise =+ let m = branchMask lx rx+ p = Prefix (mask lx m .|. m)+ in if signBranch p -- handle negative numbers+ then Bin p (goR 0) (goL 0)+ else Bin p (goL (unPrefix p)) (goR (unPrefix p))+ where+ lp = prefixOf lx+ rp = prefixOf rx+ -- goL p0 = fromList [lx .. p0-1]+ -- Expected: p0 is lx where one 0-bit is flipped to 1 and all bits lower than that are 0.+ -- p0 can be 0 (pretend that bit WORD_SIZE is flipped to 1).+ goL :: Int -> IntSet+ goL !p0 = go (Tip lp (- bitmapOf lx)) (lp + lbm prefixBitMask)+ where+ go !l p | p == p0 = l+ go l p =+ let m = lbm p+ l' = Bin (Prefix p) l (goFull p (shr1 m))+ in go l' (p + m)+ -- goR p0 = fromList [p0 .. rx]+ -- Expected: p0 is a prefix of rx+ goR :: Int -> IntSet+ goR !p0 = go (Tip rp (bitmapOf rx `shiftLL` 1 - 1)) rp+ where+ go !r p | p == p0 = r+ go r p =+ let m = lbm p+ p' = p `xor` m+ r' = Bin (Prefix p) (goFull p' (shr1 m)) r+ in go r' p'+ -- goFull p m = fromList [p .. p+2*m-1]+ -- Expected: popCount m == 1, p == mask p m+ goFull :: Int -> Int -> IntSet+ goFull p m+ | m < suffixBitMask = Tip p (complement 0)+ | otherwise = Bin (Prefix (p .|. m)) (goFull p (shr1 m)) (goFull (p .|. m) (shr1 m))+ lbm :: Int -> Int+ lbm p = p .&. negate p -- lowest bit mask+ {-# INLINE lbm #-}+ shr1 :: Int -> Int+ shr1 m = m `iShiftRL` 1+ {-# INLINE shr1 #-}++-- | \(O(n)\). Build a set from an ascending list of elements.+--+-- __Warning__: This function should be used only if the elements are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+fromAscList :: [Key] -> IntSet+fromAscList = fromMonoList+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a set from an ascending list of distinct elements.+--+-- __Warning__: This function should be used only if the elements are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+fromDistinctAscList :: [Key] -> IntSet+fromDistinctAscList = fromAscList+{-# INLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a set from a monotonic list of elements.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.+fromMonoList :: [Key] -> IntSet+fromMonoList [] = Nil+fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1+ where+ -- `addAll'` collects all keys with the prefix `px` into a single+ -- bitmap, and then proceeds with `addAll`.+ addAll' !px !bm []+ = Tip px bm+ addAll' !px !bm (ky : zs)+ | px == prefixOf ky+ = addAll' px (bm .|. bitmapOf ky) zs+ -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs)+ | py <- prefixOf ky+ , m <- branchMask px py+ , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs+ = addAll px (linkWithMask m py ty px (Tip px bm)) zs'++ -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx`+ -- `addAll` consumes the rest of the list, adding to the tree `tx`+ addAll !_px !tx []+ = tx+ addAll !px !tx (ky : zs)+ | py <- prefixOf ky+ , m <- branchMask px py+ , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs+ = addAll px (linkWithMask m py ty px tx) zs'++ -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+ addMany' !_m !px !bm []+ = Inserted (Tip px bm) []+ addMany' !m !px !bm zs0@(ky : zs)+ | px == prefixOf ky+ = addMany' m px (bm .|. bitmapOf ky) zs+ -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs)+ | mask px m /= mask ky m+ = Inserted (Tip (prefixOf px) bm) zs0+ | py <- prefixOf ky+ , mxy <- branchMask px py+ , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs+ = addMany m px (linkWithMask mxy py ty px (Tip px bm)) zs'++ -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`.+ addMany !_m !_px tx []+ = Inserted tx []+ addMany !m !px tx zs0@(ky : zs)+ | mask px m /= mask ky m+ = Inserted tx zs0+ | py <- prefixOf ky+ , mxy <- branchMask px py+ , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs+ = addMany m px (linkWithMask mxy py ty px tx) zs'+{-# INLINE fromMonoList #-}++data Inserted = Inserted !IntSet ![Key]++{--------------------------------------------------------------------+ Eq+--------------------------------------------------------------------}+instance Eq IntSet where+ (==) = equal++equal :: IntSet -> IntSet -> Bool+equal (Bin p1 l1 r1) (Bin p2 l2 r2)+ = (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx1 bm1) (Tip kx2 bm2)+ = kx1 == kx2 && bm1 == bm2+equal Nil Nil = True+equal _ _ = False++{--------------------------------------------------------------------+ Ord+--------------------------------------------------------------------}++instance Ord IntSet where+ compare = compareIntSets++compareIntSets :: IntSet -> IntSet -> Ordering+compareIntSets s1 s2 = case (splitSign s1, splitSign s2) of+ ((l1, r1), (l2, r2)) -> case go l1 l2 of+ A_LT_B -> LT+ A_Prefix_B -> if null r1 then LT else GT+ A_EQ_B -> case go r1 r2 of+ A_LT_B -> LT+ A_Prefix_B -> LT+ A_EQ_B -> EQ+ B_Prefix_A -> GT+ A_GT_B -> GT+ B_Prefix_A -> if null r2 then GT else LT+ A_GT_B -> GT+ where+ go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+ ABL -> case go l1 t2 of+ A_Prefix_B -> A_GT_B+ A_EQ_B -> B_Prefix_A+ o -> o+ ABR -> A_LT_B+ BAL -> case go t1 l2 of+ A_EQ_B -> A_Prefix_B+ B_Prefix_A -> A_LT_B+ o -> o+ BAR -> A_GT_B+ EQL -> case go l1 l2 of+ A_Prefix_B -> A_GT_B+ A_EQ_B -> go r1 r2+ B_Prefix_A -> A_LT_B+ o -> o+ NOM -> if unPrefix p1 < unPrefix p2 then A_LT_B else A_GT_B+ go (Bin _ l1 _) (Tip k2 bm2) = case leftmostTipSure l1 of+ Tip' k1 bm1 -> case orderTips k1 bm1 k2 bm2 of+ A_Prefix_B -> A_GT_B+ A_EQ_B -> B_Prefix_A+ o -> o+ go (Tip k1 bm1) (Bin _ l2 _) = case leftmostTipSure l2 of+ Tip' k2 bm2 -> case orderTips k1 bm1 k2 bm2 of+ A_EQ_B -> A_Prefix_B+ B_Prefix_A -> A_LT_B+ o -> o+ go (Tip k1 bm1) (Tip k2 bm2) = orderTips k1 bm1 k2 bm2+ go Nil Nil = A_EQ_B+ go Nil _ = A_Prefix_B+ go _ Nil = B_Prefix_A++-- This type allows GHC to return unboxed ints from leftmostTipSure, as+-- $wleftmostTipSure :: IntSet -> (# Int#, Word# #)+-- On a modern enough GHC (>=9.4) this is unnecessary, we could use StrictPair+-- instead and get the same Core.+data Tip' = Tip' {-# UNPACK #-} !Int {-# UNPACK #-} !BitMap++leftmostTipSure :: IntSet -> Tip'+leftmostTipSure (Bin _ l _) = leftmostTipSure l+leftmostTipSure (Tip k bm) = Tip' k bm+leftmostTipSure Nil = error "leftmostTipSure: Nil"++orderTips :: Int -> BitMap -> Int -> BitMap -> Order+orderTips k1 bm1 k2 bm2 = case compare k1 k2 of+ LT -> A_LT_B+ EQ | bm1 == bm2 -> A_EQ_B+ | otherwise ->+ -- To lexicographically compare the elements of two BitMaps,+ -- - Find the lowest bit where they differ.+ -- - For the BitMap with this bit 0, check if all higher bits are also+ -- 0. If yes it is a prefix, otherwise it is greater.+ let diff = bm1 `xor` bm2+ lowestDiff = diff .&. negate diff+ highMask = negate lowestDiff+ in if bm1 .&. lowestDiff == 0+ then (if bm1 .&. highMask == 0 then A_Prefix_B else A_GT_B)+ else (if bm2 .&. highMask == 0 then B_Prefix_A else A_LT_B)+ GT -> A_GT_B+{-# INLINE orderTips #-}++-- Split into negative and non-negative+splitSign :: IntSet -> (IntSet, IntSet)+splitSign t@(Bin p l r)+ | signBranch p = (r, l)+ | unPrefix p < 0 = (t, Nil)+ | otherwise = (Nil, t)+splitSign t@(Tip k _)+ | k < 0 = (t, Nil)+ | otherwise = (Nil, t)+splitSign Nil = (Nil, Nil)+{-# INLINE splitSign #-}++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}+instance Show IntSet where+ showsPrec p xs = showParen (p > 10) $+ showString "fromList " . shows (toList xs)++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance Read IntSet where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++{--------------------------------------------------------------------+ NFData+--------------------------------------------------------------------}++-- The IntSet constructors consist only of strict fields of Ints and+-- IntSets, thus the default NFData instance which evaluates to whnf+-- should suffice+instance NFData IntSet where rnf x = seq x ()++{--------------------------------------------------------------------+ Debugging+--------------------------------------------------------------------}+-- | \(O(n \min(n,W))\). Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: IntSet -> String+showTree s+ = showTreeWith True False s+++{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the set. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Bool -> Bool -> IntSet -> String+showTreeWith hang wide t+ | hang = (showsTreeHang wide [] t) ""+ | otherwise = (showsTree wide [] [] t) ""++showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS+showsTree wide lbars rbars t+ = case t of+ Bin p l r+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .+ showWide wide rbars .+ showsBars lbars . showString (showBin p) . showString "\n" .+ showWide wide lbars .+ showsTree wide (withEmpty lbars) (withBar lbars) l+ Tip kx bm+ -> showsBars lbars . showString " " . shows kx . showString " + " .+ showsBitMap bm . showString "\n"+ Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Bool -> [String] -> IntSet -> ShowS+showsTreeHang wide bars t+ = case t of+ Bin p l r+ -> showsBars bars . showString (showBin p) . showString "\n" .+ showWide wide bars .+ showsTreeHang wide (withBar bars) l .+ showWide wide bars .+ showsTreeHang wide (withEmpty bars) r+ Tip kx bm+ -> showsBars bars . showString " " . shows kx . showString " + " .+ showsBitMap bm . showString "\n"+ Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> String+showBin _+ = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+ | wide = showString (concat (reverse bars)) . showString "|\n"+ | otherwise = id++showsBars :: [String] -> ShowS+showsBars [] = id+showsBars (_ : tl) = showString (concat (reverse tl)) . showString node++showsBitMap :: Word -> ShowS+showsBitMap = showString . showBitMap++showBitMap :: Word -> String+showBitMap w = show $ foldrBits 0 (:) [] w++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars = "| ":bars+withEmpty bars = " ":bars+++{--------------------------------------------------------------------+ Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+ Link+--------------------------------------------------------------------}++-- | Link two @IntSet@s. The sets must not be empty. The @Prefix@es of the two+-- sets must be different. @k1@ must share the prefix of @t1@. @p2@ must be the+-- prefix of @t2@.+linkKey :: Key -> IntSet -> Prefix -> IntSet -> IntSet+linkKey k1 t1 p2 t2 = link k1 t1 (unPrefix p2) t2+{-# INLINE linkKey #-}++-- | Link two @IntSets. The sets must not be empty. The @Prefix@es of the two+-- sets must be different. @k1@ must share the prefix of @t1@ and @k2@ must+-- share the prefix of @t2@.+link :: Int -> IntSet -> Int -> IntSet -> IntSet+link k1 t1 k2 t2 = linkWithMask (branchMask k1 k2) k1 t1 k2 t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Int -> Key -> IntSet -> Key -> IntSet -> IntSet+linkWithMask m k1 t1 k2 t2+ | i2w k1 < i2w k2 = Bin p t1 t2+ | otherwise = Bin p t2 t1+ where+ p = Prefix (mask k1 m .|. m)+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+ @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> IntSet -> IntSet -> IntSet+bin _ l Nil = l+bin _ Nil r = r+bin p l r = Bin p l r+{-# INLINE bin #-}++{--------------------------------------------------------------------+ @tip@ assures that we never have empty bitmaps within a tree.+--------------------------------------------------------------------}+tip :: Int -> BitMap -> IntSet+tip _ 0 = Nil+tip kx bm = Tip kx bm+{-# INLINE tip #-}+++{----------------------------------------------------------------------+ Functions that generate Prefix and BitMap of a Key or a Suffix.+----------------------------------------------------------------------}++suffixBitMask :: Int+suffixBitMask = finiteBitSize (undefined::Word) - 1+{-# INLINE suffixBitMask #-}++prefixBitMask :: Int+prefixBitMask = complement suffixBitMask+{-# INLINE prefixBitMask #-}++prefixOf :: Int -> Int+prefixOf x = x .&. prefixBitMask+{-# INLINE prefixOf #-}++suffixOf :: Int -> Int+suffixOf x = x .&. suffixBitMask+{-# INLINE suffixOf #-}++bitmapOfSuffix :: Int -> BitMap+bitmapOfSuffix s = 1 `shiftLL` s+{-# INLINE bitmapOfSuffix #-}++bitmapOf :: Int -> BitMap+bitmapOf x = bitmapOfSuffix (suffixOf x)+{-# INLINE bitmapOf #-}+++{----------------------------------------------------------------------+ To get best performance, we provide fast implementations of+ lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.+ If the intel bsf and bsr instructions ever become GHC primops,+ this code should be reimplemented using these.++ Performance of this code is crucial for folds, toList, filter, partition.++ The signatures of methods in question are placed after this comment.+----------------------------------------------------------------------}++lowestBitSet :: Word -> Int+highestBitSet :: Word -> Int+foldlBits :: Int -> (a -> Int -> a) -> a -> Word -> a+foldl'Bits :: Int -> (a -> Int -> a) -> a -> Word -> a+foldrBits :: Int -> (Int -> a -> a) -> a -> Word -> a+foldr'Bits :: Int -> (Int -> a -> a) -> a -> Word -> a+#if MIN_VERSION_base(4,11,0)+foldMapBits :: Semigroup a => Int -> (Int -> a) -> Word -> a+#else+foldMapBits :: Monoid a => Int -> (Int -> a) -> Word -> a+#endif+takeWhileAntitoneBits :: Int -> (Int -> Bool) -> Word -> Word++{-# INLINE lowestBitSet #-}+{-# INLINE highestBitSet #-}+{-# INLINE foldlBits #-}+{-# INLINE foldl'Bits #-}+{-# INLINE foldrBits #-}+{-# INLINE foldr'Bits #-}+{-# INLINE foldMapBits #-}+{-# INLINE takeWhileAntitoneBits #-}++#if defined(__GLASGOW_HASKELL__)++lowestBitSet x = countTrailingZeros x++highestBitSet x = WORD_SIZE_IN_BITS - 1 - countLeadingZeros x++-- Reverse the order of bits in the Word.+revWord :: Word -> Word+#if WORD_SIZE_IN_BITS==32+revWord x1 = case ((x1 `shiftRL` 1) .&. 0x55555555) .|. ((x1 .&. 0x55555555) `shiftLL` 1) of+ x2 -> case ((x2 `shiftRL` 2) .&. 0x33333333) .|. ((x2 .&. 0x33333333) `shiftLL` 2) of+ x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F) `shiftLL` 4) of+ x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF) .|. ((x4 .&. 0x00FF00FF) `shiftLL` 8) of+ x5 -> ( x5 `shiftRL` 16 ) .|. ( x5 `shiftLL` 16);+#else+revWord x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of+ x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of+ x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of+ x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of+ x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of+ x6 -> ( x6 `shiftRL` 32 ) .|. ( x6 `shiftLL` 32);+#endif++foldlBits prefix f z0 bitmap = go z0 $! revWord bitmap+ where+ -- Note: We pass the z as a static argument because it helps GHC with demand+ -- analysis. See GHC #25578 for details.+ go z !bm = f (if bm' == 0 then z else go z bm') x+ where+ bi = WORD_SIZE_IN_BITS - 1 - countTrailingZeros bm+ !x = prefix .|. bi+ bm' = bm .&. (bm-1)++foldl'Bits prefix f z0 bitmap = go z0 bitmap+ where+ go !z !bm = if bm' == 0 then z' else go z' bm'+ where+ bi = countTrailingZeros bm+ !x = prefix .|. bi+ !z' = f z x+ bm' = bm .&. (bm-1)++foldrBits prefix f z0 bitmap = go bitmap z0+ where+ -- Note: We pass the z as a static argument because it helps GHC with demand+ -- analysis. See GHC #25578 for details.+ go !bm z = f x (if bm' == 0 then z else go bm' z)+ where+ bi = countTrailingZeros bm+ !x = prefix .|. bi+ bm' = bm .&. (bm-1)++foldr'Bits prefix f z0 bitmap = (go $! revWord bitmap) z0+ where+ go !bm !z = if bm' == 0 then z' else go bm' z'+ where+ bi = WORD_SIZE_IN_BITS - 1 - countTrailingZeros bm+ !x = prefix .|. bi+ !z' = f x z+ bm' = bm .&. (bm-1)++foldMapBits prefix f bitmap = go bitmap+ where+ go !bm = if bm' == 0+ then f x+#if MIN_VERSION_base(4,11,0)+ else f x <> go bm'+#else+ else f x `mappend` go bm'+#endif+ where+ bi = countTrailingZeros bm+ !x = prefix .|. bi+ bm' = bm .&. (bm-1)++takeWhileAntitoneBits prefix predicate bitmap =+ -- Binary search for the first index where the predicate returns false, but skip a predicate+ -- call if the high half of the current range is empty. This ensures+ -- min (log2 WORD_SIZE_IN_BITS + 1) (popcount bitmap) predicate calls.+ let next d h (n',b') =+ if n' .&. h /= 0 && (predicate $! prefix+b'+d) then (n' `shiftRL` d, b'+d) else (n',b')+ {-# INLINE next #-}+ (_,b) = next 1 0x2 $+ next 2 0xC $+ next 4 0xF0 $+ next 8 0xFF00 $+ next 16 0xFFFF0000 $+#if WORD_SIZE_IN_BITS==64+ next 32 0xFFFFFFFF00000000 $+#endif+ (bitmap,0)+ m = if b /= 0 || (bitmap .&. 0x1 /= 0 && predicate prefix)+ then ((2 `shiftLL` b) - 1)+ else ((1 `shiftLL` b) - 1)+ in bitmap .&. m++#else+{----------------------------------------------------------------------+ In general case we use logarithmic implementation of+ lowestBitSet and highestBitSet, which works up to bit sizes of 64.++ Folds are linear scans.+----------------------------------------------------------------------}++lowestBitSet n0 =+ let (n1,b1) = if n0 .&. 0xFFFFFFFF /= 0 then (n0,0) else (n0 `shiftRL` 32, 32)+ (n2,b2) = if n1 .&. 0xFFFF /= 0 then (n1,b1) else (n1 `shiftRL` 16, 16+b1)+ (n3,b3) = if n2 .&. 0xFF /= 0 then (n2,b2) else (n2 `shiftRL` 8, 8+b2)+ (n4,b4) = if n3 .&. 0xF /= 0 then (n3,b3) else (n3 `shiftRL` 4, 4+b3)+ (n5,b5) = if n4 .&. 0x3 /= 0 then (n4,b4) else (n4 `shiftRL` 2, 2+b4)+ b6 = if n5 .&. 0x1 /= 0 then b5 else 1+b5+ in b6++highestBitSet n0 =+ let (n1,b1) = if n0 .&. 0xFFFFFFFF00000000 /= 0 then (n0 `shiftRL` 32, 32) else (n0,0)+ (n2,b2) = if n1 .&. 0xFFFF0000 /= 0 then (n1 `shiftRL` 16, 16+b1) else (n1,b1)+ (n3,b3) = if n2 .&. 0xFF00 /= 0 then (n2 `shiftRL` 8, 8+b2) else (n2,b2)+ (n4,b4) = if n3 .&. 0xF0 /= 0 then (n3 `shiftRL` 4, 4+b3) else (n3,b3)+ (n5,b5) = if n4 .&. 0xC /= 0 then (n4 `shiftRL` 2, 2+b4) else (n4,b4)+ b6 = if n5 .&. 0x2 /= 0 then 1+b5 else b5+ in b6++foldlBits prefix f z bm = let lb = lowestBitSet bm+ in go (prefix+lb) z (bm `shiftRL` lb)+ where go !_ acc 0 = acc+ go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)+ | otherwise = go (bi + 1) acc (n `shiftRL` 1)++foldl'Bits prefix f z bm = let lb = lowestBitSet bm+ in go (prefix+lb) z (bm `shiftRL` lb)+ where go !_ !acc 0 = acc+ go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)+ | otherwise = go (bi + 1) acc (n `shiftRL` 1)++foldrBits prefix f z bm = let lb = lowestBitSet bm+ in go (prefix+lb) (bm `shiftRL` lb)+ where go !_ 0 = z+ go bi n | n `testBit` 0 = f bi (go (bi + 1) (n `shiftRL` 1))+ | otherwise = go (bi + 1) (n `shiftRL` 1)++foldr'Bits prefix f z bm = let lb = lowestBitSet bm+ in go (prefix+lb) (bm `shiftRL` lb)+ where+ go !_ 0 = z+ go bi n | n `testBit` 0 = f bi $! go (bi + 1) (n `shiftRL` 1)+ | otherwise = go (bi + 1) (n `shiftRL` 1)++foldMapBits prefix f bm = go x0 (x0 + 1) ((bm `shiftRL` lb) `shiftRL` 1)+ where+ lb = lowestBitSet bm+ x0 = prefix + lb+ go !x !_ 0 = f x+ go !x !bi n+#if MIN_VERSION_base(4,11,0)+ | n `testBit` 0 = f x <> go bi (bi + 1) (n `shiftRL` 1)+#else+ | n `testBit` 0 = f x `mappend` go bi (bi + 1) (n `shiftRL` 1)+#endif+ | otherwise = go x (bi + 1) (n `shiftRL` 1)++takeWhileAntitoneBits prefix predicate = foldl'Bits prefix f 0 -- Does not use antitone property+ where+ f acc bi | predicate bi = acc .|. bitmapOf bi+ | otherwise = acc++#endif+++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}++-- | \(O(1)\). Decompose a set into pieces based on the structure of the underlying+-- tree. This function is useful for consuming a set in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this. However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]+-- > splitRoot empty == []+--+-- Note that the current implementation does not return more than two subsets,+-- but you should not depend on this behaviour because it can change in the+-- future without notice. Also, the current version does not continue+-- splitting all the way to individual singleton sets -- it stops at some+-- point.+splitRoot :: IntSet -> [IntSet]+splitRoot Nil = []+-- NOTE: we don't currently split below Tip, but we could.+splitRoot x@(Tip _ _) = [x]+splitRoot (Bin p l r) | signBranch p = [r, l]+ | otherwise = [l, r] {-# INLINE splitRoot #-}
+ src/Data/IntSet/Internal/IntTreeCommons.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif++-- |+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- This module defines common constructs used by both "Data.IntSet" and+-- "Data.IntMap".+--+-- @since 0.8+--++module Data.IntSet.Internal.IntTreeCommons+ ( Key+ , Prefix(..)+ , nomatch+ , left+ , signBranch+ , TreeTreeBranch(..)+ , treeTreeBranch+ , mask+ , branchMask+ , i2w+ , Order(..)+ ) where++import Data.Bits (Bits(..), countLeadingZeros)+import Utils.Containers.Internal.BitUtil (wordSize)++#ifdef __GLASGOW_HASKELL__+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif+++type Key = Int++-- | A @Prefix@ represents some prefix of high-order bits of an @Int@.+--+-- A @Prefix@ is usually considered in the context of a+-- 'Data.IntSet.Internal.Bin' or 'Data.IntMap.Internal.Bin'.++-- See Note [IntSet structure and invariants] in Data.IntSet.Internal and+-- Note [IntMap structure and invariants] in Data.IntMap.Internal for details.+newtype Prefix = Prefix { unPrefix :: Int }+ deriving Eq++#ifdef __GLASGOW_HASKELL__+deriving instance Lift Prefix+#endif++-- | Whether the @Int@ does not start with the given @Prefix@.+--+-- An @Int@ starts with a @Prefix@ if it shares the high bits with the internal+-- @Int@ value of the @Prefix@ up to the mask bit.+--+-- @nomatch@ is usually used to determine whether a key belongs in a @Bin@,+-- since all keys in a @Bin@ share a @Prefix@.+nomatch :: Int -> Prefix -> Bool+nomatch i p = (i `xor` px) .&. prefixMask /= 0+ where+ px = unPrefix p+ prefixMask = px `xor` (-px)+{-# INLINE nomatch #-}++-- | Whether the @Int@ is to the left of the split created by a @Bin@ with this+-- @Prefix@.+--+-- This does not imply that the @Int@ belongs in this @Bin@. That fact is+-- usually determined first using @nomatch@.+left :: Int -> Prefix -> Bool+left i p = i2w i < i2w (unPrefix p)+{-# INLINE left #-}++-- | A @TreeTreeBranch@ is returned by 'treeTreeBranch' to indicate how two+-- @Bin@s relate to each other.+--+-- Consider that @A@ and @B@ are the @Bin@s whose @Prefix@es are given to+-- @treeTreeBranch@ as the first and second arguments respectively.+data TreeTreeBranch+ = ABL -- ^ A contains B in the left child+ | ABR -- ^ A contains B in the right child+ | BAL -- ^ B contains A in the left child+ | BAR -- ^ B contains A in the right child+ | EQL -- ^ A and B have equal prefixes+ | NOM -- ^ A and B have prefixes that do not match++-- | Calculates how two @Bin@s relate to each other by comparing their+-- @Prefix@es.++-- Notes:+-- * pw .|. (pw-1) sets every bit below the mask bit to 1. This is the greatest+-- key the Bin can have.+-- * pw .&. (pw-1) sets the mask bit and every bit below it to 0. This is the+-- smallest key the Bin can have.+--+-- First, we compare the prefixes to each other. Then we compare a prefix+-- against the greatest/smallest keys the other prefix's Bin could have. This is+-- enough to determine how the two Bins relate to each other. The conditions can+-- be stated as:+--+-- * If pw1 from Bin A is less than pw2 from Bin B, and pw2 is <= the greatest+-- key of Bin A, then Bin A contains Bin B in its right child.+-- * ...and so on++treeTreeBranch :: Prefix -> Prefix -> TreeTreeBranch+treeTreeBranch p1 p2 = case compare pw1 pw2 of+ LT | pw2 <= greatest pw1 -> ABR+ | smallest pw2 <= pw1 -> BAL+ | otherwise -> NOM+ GT | pw1 <= greatest pw2 -> BAR+ | smallest pw1 <= pw2 -> ABL+ | otherwise -> NOM+ EQ -> EQL+ where+ pw1 = i2w (unPrefix p1)+ pw2 = i2w (unPrefix p2)+ greatest pw = pw .|. (pw-1)+ smallest pw = pw .&. (pw-1)+{-# INLINE treeTreeBranch #-}++-- | Whether this @Prefix@ splits a @Bin@ at the sign bit.+--+-- This can only be True at the top level.+-- If it is true, the left child contains non-negative keys and the right child+-- contains negative keys.+signBranch :: Prefix -> Bool+signBranch p = unPrefix p == (minBound :: Int)+{-# INLINE signBranch #-}++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@.+mask :: Key -> Int -> Int+mask i m = i .&. ((-m) `xor` m)+{-# INLINE mask #-}++-- | The first switching bit where the two prefixes disagree.+--+-- Precondition for defined behavior: p1 /= p2+branchMask :: Int -> Int -> Int+branchMask p1 p2 =+ unsafeShiftL 1 (wordSize - 1 - countLeadingZeros (p1 `xor` p2))+{-# INLINE branchMask #-}++i2w :: Int -> Word+i2w = fromIntegral+{-# INLINE i2w #-}++-- Used to compare IntSets and IntMaps+data Order+ = A_LT_B -- holds for [0,3,4] [0,3,5,1]+ | A_Prefix_B -- holds for [0,3,4] [0,3,4,5]+ | A_EQ_B -- holds for [0,3,4] [0,3,4]+ | B_Prefix_A -- holds for [0,3,4] [0,3]+ | A_GT_B -- holds for [0,3,4] [0,2,5]++{--------------------------------------------------------------------+ Notes+--------------------------------------------------------------------}++-- Note [INLINE bit fiddling]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It is essential that the bit fiddling functions like nomatch, mask,+-- branchMask etc are inlined. If they do not, the memory allocation skyrockets.+-- The GHC usually gets it right, but it is disastrous if it does not. Therefore+-- we explicitly mark these functions INLINE.
src/Data/Map.hs view
@@ -1,13 +1,6 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif- #ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DataKinds, FlexibleContexts #-}-#endif-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE Safe #-} #endif #include "containers.h"@@ -21,94 +14,91 @@ -- Maintainer : libraries@haskell.org -- Portability : portable ----- /Note:/ You should use "Data.Map.Strict" instead of this module if: ----- * You will eventually need all the values stored.+-- = Finite Maps (lazy interface) ----- * The stored values don't represent large virtual data structures--- to be lazily computed.+-- This module re-exports the value lazy "Data.Map.Lazy" API. ----- An efficient implementation of ordered maps from keys to values--- (dictionaries).+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@. A 'Map' is strict in its keys but lazy+-- in its values. ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.+-- The functions in "Data.Map.Strict" are careful to force values before+-- installing them in a 'Map'. This is usually more efficient in cases where+-- laziness is not essential. The functions in this module do not do so. ----- > import qualified Data.Map as Map+-- When deciding if this is the correct data structure to use, consider: --+-- * If you are using 'Prelude.Int' keys, you will get much better performance for most+-- operations using "Data.IntMap.Lazy".+--+-- * If you don't care about ordering, consider using @Data.HashMap.Lazy@ from the+-- <https://hackage.haskell.org/package/unordered-containers unordered-containers>+-- package instead.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- > import Data.Map (Map)+-- > import qualified Data.Map as Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Warning+--+-- The size of a 'Map' must not exceed @'Prelude.maxBound' :: 'Prelude.Int'@.+-- Violation of this condition is not detected and if the size limit is exceeded,+-- its behaviour is undefined.+--+--+-- == Implementation+-- -- The implementation of 'Map' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: ----- * Stephen Adams, \"/Efficient sets: a balancing act/\",--- Journal of Functional Programming 3(4):553-562, October 1993,--- <http://www.swiss.ai.mit.edu/~adams/BB/>.+-- * Stephen Adams, \"/Efficient sets—a balancing act/\",+-- Journal of Functional Programming 3(4):553-562, October 1993,+-- <https://doi.org/10.1017/S0956796800000885>,+-- <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. -- * J. Nievergelt and E.M. Reingold, -- \"/Binary search trees of bounded balance/\", -- SIAM journal of computing 2(1), March 1973.+-- <https://doi.org/10.1137/0202005>.+-- * Yoichi Hirai and Kazuhiko Yamamoto,+-- \"/Balancing weight-balanced trees/\",+-- Journal of Functional Programming 21(3):287-307, 2011,+-- <https://doi.org/10.1017/S0956796811000104> -- -- Bounds for 'union', 'intersection', and 'difference' are as given -- by -- -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,--- \"/Just Join for Parallel Ordered Sets/\",--- <https://arxiv.org/abs/1602.02120v3>.+-- \"/Parallel Ordered Sets Using Join/\",+-- <https://arxiv.org/abs/1602.02120v4>. ----- Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'. ----- /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of--- this condition is not detected and if the size limit is exceeded, its--- behaviour is undefined.+-- == Performance information ----- Operation comments contain the operation time complexity in--- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map.+--+-- Operations like 'lookup', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+-- ----------------------------------------------------------------------------- module Data.Map ( module Data.Map.Lazy-#ifdef __GLASGOW_HASKELL__- , insertWith'- , insertWithKey'- , insertLookupWithKey'- , fold- , foldWithKey-#endif ) where import Data.Map.Lazy--#ifdef __GLASGOW_HASKELL__-import Utils.Containers.Internal.TypeError---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.insertWith'.-insertWith' :: Whoops "Data.Map.insertWith' is gone. Use Data.Map.Strict.insertWith."- => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWith' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.insertWithKey'.-insertWithKey' :: Whoops "Data.Map.insertWithKey' is gone. Use Data.Map.Strict.insertWithKey."- => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKey' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.insertLookupWithKey'.-insertLookupWithKey' :: Whoops "Data.Map.insertLookupWithKey' is gone. Use Data.Map.Strict.insertLookupWithKey."- => (k -> a -> a -> a) -> k -> a -> Map k a- -> (Maybe a, Map k a)-insertLookupWithKey' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.foldr'.-fold :: Whoops "Data.Map.fold is gone. Use foldr."- => (a -> b -> b) -> b -> Map k a -> b-fold _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'foldrWithKey'.-foldWithKey :: Whoops "Data.Map.foldWithKey is gone. Use foldrWithKey."- => (k -> a -> b -> b) -> b -> Map k a -> b-foldWithKey _ _ _ = undefined-#endif
src/Data/Map/Internal.hs view
@@ -1,4361 +1,4552 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}-#define USE_MAGIC_PROXY 1-#endif--#ifdef USE_MAGIC_PROXY-{-# LANGUAGE MagicHash #-}-#endif--{-# OPTIONS_HADDOCK not-home #-}--#include "containers.h"--#if !(WORD_SIZE_IN_BITS >= 61)-#define DEFINE_ALTERF_FALLBACK 1-#endif---------------------------------------------------------------------------------- |--- Module : Data.Map.Internal--- Copyright : (c) Daan Leijen 2002--- (c) Andriy Palamarchuk 2008--- License : BSD-style--- Maintainer : libraries@haskell.org--- Portability : portable------ = WARNING------ This module is considered __internal__.------ The Package Versioning Policy __does not apply__.------ The contents of this module may change __in any way whatsoever__--- and __without any warning__ between minor versions of this package.------ Authors importing this module are expected to track development--- closely.------ = Description------ An efficient implementation of maps from keys to values (dictionaries).------ Since many function names (but not the type name) clash with--- "Prelude" names, this module is usually imported @qualified@, e.g.------ > import Data.Map (Map)--- > import qualified Data.Map as Map------ The implementation of 'Map' is based on /size balanced/ binary trees (or--- trees of /bounded balance/) as described by:------ * Stephen Adams, \"/Efficient sets: a balancing act/\",--- Journal of Functional Programming 3(4):553-562, October 1993,--- <http://www.swiss.ai.mit.edu/~adams/BB/>.--- * J. Nievergelt and E.M. Reingold,--- \"/Binary search trees of bounded balance/\",--- SIAM journal of computing 2(1), March 1973.------ Bounds for 'union', 'intersection', and 'difference' are as given--- by------ * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,--- \"/Just Join for Parallel Ordered Sets/\",--- <https://arxiv.org/abs/1602.02120v3>.------ Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'.------ Operation comments contain the operation time complexity in--- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.------ @since 0.5.9---------------------------------------------------------------------------------- [Note: Using INLINABLE]--- ~~~~~~~~~~~~~~~~~~~~~~~--- It is crucial to the performance that the functions specialize on the Ord--- type when possible. GHC 7.0 and higher does this by itself when it sees th--- unfolding of a function -- that is why all public functions are marked--- INLINABLE (that exposes the unfolding).----- [Note: Using INLINE]--- ~~~~~~~~~~~~~~~~~~~~--- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.--- We mark the functions that just navigate down the tree (lookup, insert,--- delete and similar). That navigation code gets inlined and thus specialized--- when possible. There is a price to pay -- code growth. The code INLINED is--- therefore only the tree navigation, all the real work (rebalancing) is not--- INLINED by using a NOINLINE.------ All methods marked INLINE have to be nonrecursive -- a 'go' function doing--- the real work is provided.----- [Note: Type of local 'go' function]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- If the local 'go' function uses an Ord class, it sometimes heap-allocates--- the Ord dictionary when the 'go' function does not have explicit type.--- In that case we give 'go' explicit type. But this slightly decrease--- performance, as the resulting 'go' function can float out to top level.----- [Note: Local 'go' functions and capturing]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- As opposed to Map, when 'go' function captures an argument, increased--- heap-allocation can occur: sometimes in a polymorphic function, the 'go'--- floats out of its enclosing function and then it heap-allocates the--- dictionary and the argument. Maybe it floats out too late and strictness--- analyzer cannot see that these could be passed on stack.------- [Note: Order of constructors]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The order of constructors of Map matters when considering performance.--- Currently in GHC 7.0, when type has 2 constructors, a forward conditional--- jump is made when successfully matching second constructor. Successful match--- of first constructor results in the forward jump not taken.--- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip--- improves the benchmark by up to 10% on x86.--module Data.Map.Internal (- -- * Map type- Map(..) -- instance Eq,Show,Read- , Size-- -- * Operators- , (!), (!?), (\\)-- -- * Query- , null- , size- , member- , notMember- , lookup- , findWithDefault- , lookupLT- , lookupGT- , lookupLE- , lookupGE-- -- * Construction- , empty- , singleton-- -- ** Insertion- , insert- , insertWith- , insertWithKey- , insertLookupWithKey-- -- ** Delete\/Update- , delete- , adjust- , adjustWithKey- , update- , updateWithKey- , updateLookupWithKey- , alter- , alterF-- -- * Combine-- -- ** Union- , union- , unionWith- , unionWithKey- , unions- , unionsWith-- -- ** Difference- , difference- , differenceWith- , differenceWithKey-- -- ** Intersection- , intersection- , intersectionWith- , intersectionWithKey-- -- ** Disjoint- , disjoint-- -- ** Compose- , compose-- -- ** General combining function- , SimpleWhenMissing- , SimpleWhenMatched- , runWhenMatched- , runWhenMissing- , merge- -- *** @WhenMatched@ tactics- , zipWithMaybeMatched- , zipWithMatched- -- *** @WhenMissing@ tactics- , mapMaybeMissing- , dropMissing- , preserveMissing- , preserveMissing'- , mapMissing- , filterMissing-- -- ** Applicative general combining function- , WhenMissing (..)- , WhenMatched (..)- , mergeA-- -- *** @WhenMatched@ tactics- -- | The tactics described for 'merge' work for- -- 'mergeA' as well. Furthermore, the following- -- are available.- , zipWithMaybeAMatched- , zipWithAMatched-- -- *** @WhenMissing@ tactics- -- | The tactics described for 'merge' work for- -- 'mergeA' as well. Furthermore, the following- -- are available.- , traverseMaybeMissing- , traverseMissing- , filterAMissing-- -- ** Deprecated general combining function-- , mergeWithKey-- -- * Traversal- -- ** Map- , map- , mapWithKey- , traverseWithKey- , traverseMaybeWithKey- , mapAccum- , mapAccumWithKey- , mapAccumRWithKey- , mapKeys- , mapKeysWith- , mapKeysMonotonic-- -- * Folds- , foldr- , foldl- , foldrWithKey- , foldlWithKey- , foldMapWithKey-- -- ** Strict folds- , foldr'- , foldl'- , foldrWithKey'- , foldlWithKey'-- -- * Conversion- , elems- , keys- , assocs- , keysSet- , fromSet-- -- ** Lists- , toList- , fromList- , fromListWith- , fromListWithKey-- -- ** Ordered lists- , toAscList- , toDescList- , fromAscList- , fromAscListWith- , fromAscListWithKey- , fromDistinctAscList- , fromDescList- , fromDescListWith- , fromDescListWithKey- , fromDistinctDescList-- -- * Filter- , filter- , filterWithKey-- , takeWhileAntitone- , dropWhileAntitone- , spanAntitone-- , restrictKeys- , withoutKeys- , partition- , partitionWithKey-- , mapMaybe- , mapMaybeWithKey- , mapEither- , mapEitherWithKey-- , split- , splitLookup- , splitRoot-- -- * Submap- , isSubmapOf, isSubmapOfBy- , isProperSubmapOf, isProperSubmapOfBy-- -- * Indexed- , lookupIndex- , findIndex- , elemAt- , updateAt- , deleteAt- , take- , drop- , splitAt-- -- * Min\/Max- , lookupMin- , lookupMax- , findMin- , findMax- , deleteMin- , deleteMax- , deleteFindMin- , deleteFindMax- , updateMin- , updateMax- , updateMinWithKey- , updateMaxWithKey- , minView- , maxView- , minViewWithKey- , maxViewWithKey-- -- Used by the strict version- , AreWeStrict (..)- , atKeyImpl-#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)- , atKeyPlain-#endif- , bin- , balance- , balanceL- , balanceR- , delta- , insertMax- , link- , link2- , glue- , MaybeS(..)- , Identity(..)-- -- Used by Map.Merge.Lazy- , mapWhenMissing- , mapWhenMatched- , lmapWhenMissing- , contramapFirstWhenMatched- , contramapSecondWhenMatched- , mapGentlyWhenMissing- , mapGentlyWhenMatched- ) where--#if MIN_VERSION_base(4,8,0)-import Data.Functor.Identity (Identity (..))-import Control.Applicative (liftA3)-#else-import Control.Applicative (Applicative(..), (<$>), liftA3)-import Data.Monoid (Monoid(..))-import Data.Traversable (Traversable(traverse))-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Functor.Classes-import Data.Semigroup (stimesIdempotentMonoid)-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup(stimes))-#endif-#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>)))-#endif-import Control.Applicative (Const (..))-import Control.DeepSeq (NFData(rnf))-import Data.Bits (shiftL, shiftR)-import qualified Data.Foldable as Foldable-#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable())-#endif-#if MIN_VERSION_base(4,10,0)-import Data.Bifoldable-#endif-import Data.Typeable-import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop)--import qualified Data.Set.Internal as Set-import Data.Set.Internal (Set)-import Utils.Containers.Internal.PtrEquality (ptrEq)-import Utils.Containers.Internal.StrictPair-import Utils.Containers.Internal.StrictMaybe-import Utils.Containers.Internal.BitQueue-#ifdef DEFINE_ALTERF_FALLBACK-import Utils.Containers.Internal.BitUtil (wordSize)-#endif--#if __GLASGOW_HASKELL__-import GHC.Exts (build, lazy)-#if !MIN_VERSION_base(4,8,0)-import Data.Functor ((<$))-#endif-#ifdef USE_MAGIC_PROXY-import GHC.Exts (Proxy#, proxy# )-#endif-#if __GLASGOW_HASKELL__ >= 708-import qualified GHC.Exts as GHCExts-#endif-import Text.Read hiding (lift)-import Data.Data-import qualified Control.Category as Category-#endif-#if __GLASGOW_HASKELL__ >= 708-import Data.Coerce-#endif---{--------------------------------------------------------------------- Operators---------------------------------------------------------------------}-infixl 9 !,!?,\\ ------ | /O(log n)/. Find the value at a key.--- Calls 'error' when the element can not be found.------ > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map--- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'--(!) :: Ord k => Map k a -> k -> a-(!) m k = find k m-#if __GLASGOW_HASKELL__-{-# INLINE (!) #-}-#endif---- | /O(log n)/. Find the value at a key.--- Returns 'Nothing' when the element can not be found.------ prop> fromList [(5, 'a'), (3, 'b')] !? 1 == Nothing--- prop> fromList [(5, 'a'), (3, 'b')] !? 5 == Just 'a'------ @since 0.5.9--(!?) :: Ord k => Map k a -> k -> Maybe a-(!?) m k = lookup k m-#if __GLASGOW_HASKELL__-{-# INLINE (!?) #-}-#endif---- | Same as 'difference'.-(\\) :: Ord k => Map k a -> Map k b -> Map k a-m1 \\ m2 = difference m1 m2-#if __GLASGOW_HASKELL__-{-# INLINE (\\) #-}-#endif--{--------------------------------------------------------------------- Size balanced trees.---------------------------------------------------------------------}--- | A Map from keys @k@ to values @a@.------ The 'Semigroup' operation for 'Map' is 'union', which prefers--- values from the left operand. If @m1@ maps a key @k@ to a value--- @a1@, and @m2@ maps the same key to a different value @a2@, then--- their union @m1 <> m2@ maps @k@ to @a1@.---- See Note: Order of constructors-data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)- | Tip--type Size = Int--#if __GLASGOW_HASKELL__ >= 708-type role Map nominal representational-#endif--instance (Ord k) => Monoid (Map k v) where- mempty = empty- mconcat = unions-#if !(MIN_VERSION_base(4,9,0))- mappend = union-#else- mappend = (<>)--instance (Ord k) => Semigroup (Map k v) where- (<>) = union- stimes = stimesIdempotentMonoid-#endif--#if __GLASGOW_HASKELL__--{--------------------------------------------------------------------- A Data instance---------------------------------------------------------------------}---- This instance preserves data abstraction at the cost of inefficiency.--- We provide limited reflection services for the sake of data abstraction.--instance (Data k, Data a, Ord k) => Data (Map k a) where- gfoldl f z m = z fromList `f` toList m- toConstr _ = fromListConstr- gunfold k z c = case constrIndex c of- 1 -> k (z fromList)- _ -> error "gunfold"- dataTypeOf _ = mapDataType- dataCast2 f = gcast2 f--fromListConstr :: Constr-fromListConstr = mkConstr mapDataType "fromList" [] Prefix--mapDataType :: DataType-mapDataType = mkDataType "Data.Map.Internal.Map" [fromListConstr]--#endif--{--------------------------------------------------------------------- Query---------------------------------------------------------------------}--- | /O(1)/. Is the map empty?------ > Data.Map.null (empty) == True--- > Data.Map.null (singleton 1 'a') == False--null :: Map k a -> Bool-null Tip = True-null (Bin {}) = False-{-# INLINE null #-}---- | /O(1)/. The number of elements in the map.------ > size empty == 0--- > size (singleton 1 'a') == 1--- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3--size :: Map k a -> Int-size Tip = 0-size (Bin sz _ _ _ _) = sz-{-# INLINE size #-}----- | /O(log n)/. Lookup the value at a key in the map.------ The function will return the corresponding value as @('Just' value)@,--- or 'Nothing' if the key isn't in the map.------ An example of using @lookup@:------ > import Prelude hiding (lookup)--- > import Data.Map--- >--- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])--- > deptCountry = fromList([("IT","USA"), ("Sales","France")])--- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])--- >--- > employeeCurrency :: String -> Maybe String--- > employeeCurrency name = do--- > dept <- lookup name employeeDept--- > country <- lookup dept deptCountry--- > lookup country countryCurrency--- >--- > main = do--- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))--- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))------ The output of this program:------ > John's currency: Just "Euro"--- > Pete's currency: Nothing-lookup :: Ord k => k -> Map k a -> Maybe a-lookup = go- where- go !_ Tip = Nothing- go k (Bin _ kx x l r) = case compare k kx of- LT -> go k l- GT -> go k r- EQ -> Just x-#if __GLASGOW_HASKELL__-{-# INLINABLE lookup #-}-#else-{-# INLINE lookup #-}-#endif---- | /O(log n)/. Is the key a member of the map? See also 'notMember'.------ > member 5 (fromList [(5,'a'), (3,'b')]) == True--- > member 1 (fromList [(5,'a'), (3,'b')]) == False-member :: Ord k => k -> Map k a -> Bool-member = go- where- go !_ Tip = False- go k (Bin _ kx _ l r) = case compare k kx of- LT -> go k l- GT -> go k r- EQ -> True-#if __GLASGOW_HASKELL__-{-# INLINABLE member #-}-#else-{-# INLINE member #-}-#endif---- | /O(log n)/. Is the key not a member of the map? See also 'member'.------ > notMember 5 (fromList [(5,'a'), (3,'b')]) == False--- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True--notMember :: Ord k => k -> Map k a -> Bool-notMember k m = not $ member k m-#if __GLASGOW_HASKELL__-{-# INLINABLE notMember #-}-#else-{-# INLINE notMember #-}-#endif---- | /O(log n)/. Find the value at a key.--- Calls 'error' when the element can not be found.-find :: Ord k => k -> Map k a -> a-find = go- where- go !_ Tip = error "Map.!: given key is not an element in the map"- go k (Bin _ kx x l r) = case compare k kx of- LT -> go k l- GT -> go k r- EQ -> x-#if __GLASGOW_HASKELL__-{-# INLINABLE find #-}-#else-{-# INLINE find #-}-#endif---- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns--- the value at key @k@ or returns default value @def@--- when the key is not in the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'-findWithDefault :: Ord k => a -> k -> Map k a -> a-findWithDefault = go- where- go def !_ Tip = def- go def k (Bin _ kx x l r) = case compare k kx of- LT -> go def k l- GT -> go def k r- EQ -> x-#if __GLASGOW_HASKELL__-{-# INLINABLE findWithDefault #-}-#else-{-# INLINE findWithDefault #-}-#endif---- | /O(log n)/. Find largest key smaller than the given one and return the--- corresponding (key, value) pair.------ > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing--- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')-lookupLT :: Ord k => k -> Map k v -> Maybe (k, v)-lookupLT = goNothing- where- goNothing !_ Tip = Nothing- goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l- | otherwise = goJust k kx x r-- goJust !_ kx' x' Tip = Just (kx', x')- goJust k kx' x' (Bin _ kx x l r) | k <= kx = goJust k kx' x' l- | otherwise = goJust k kx x r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupLT #-}-#else-{-# INLINE lookupLT #-}-#endif---- | /O(log n)/. Find smallest key greater than the given one and return the--- corresponding (key, value) pair.------ > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')--- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing-lookupGT :: Ord k => k -> Map k v -> Maybe (k, v)-lookupGT = goNothing- where- goNothing !_ Tip = Nothing- goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l- | otherwise = goNothing k r-- goJust !_ kx' x' Tip = Just (kx', x')- goJust k kx' x' (Bin _ kx x l r) | k < kx = goJust k kx x l- | otherwise = goJust k kx' x' r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupGT #-}-#else-{-# INLINE lookupGT #-}-#endif---- | /O(log n)/. Find largest key smaller or equal to the given one and return--- the corresponding (key, value) pair.------ > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing--- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')--- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')-lookupLE :: Ord k => k -> Map k v -> Maybe (k, v)-lookupLE = goNothing- where- goNothing !_ Tip = Nothing- goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goNothing k l- EQ -> Just (kx, x)- GT -> goJust k kx x r-- goJust !_ kx' x' Tip = Just (kx', x')- goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx' x' l- EQ -> Just (kx, x)- GT -> goJust k kx x r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupLE #-}-#else-{-# INLINE lookupLE #-}-#endif---- | /O(log n)/. Find smallest key greater or equal to the given one and return--- the corresponding (key, value) pair.------ > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')--- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')--- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing-lookupGE :: Ord k => k -> Map k v -> Maybe (k, v)-lookupGE = goNothing- where- goNothing !_ Tip = Nothing- goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l- EQ -> Just (kx, x)- GT -> goNothing k r-- goJust !_ kx' x' Tip = Just (kx', x')- goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l- EQ -> Just (kx, x)- GT -> goJust k kx' x' r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupGE #-}-#else-{-# INLINE lookupGE #-}-#endif--{--------------------------------------------------------------------- Construction---------------------------------------------------------------------}--- | /O(1)/. The empty map.------ > empty == fromList []--- > size empty == 0--empty :: Map k a-empty = Tip-{-# INLINE empty #-}---- | /O(1)/. A map with a single element.------ > singleton 1 'a' == fromList [(1, 'a')]--- > size (singleton 1 'a') == 1--singleton :: k -> a -> Map k a-singleton k x = Bin 1 k x Tip Tip-{-# INLINE singleton #-}--{--------------------------------------------------------------------- Insertion---------------------------------------------------------------------}--- | /O(log n)/. Insert a new key and value in the map.--- If the key is already present in the map, the associated value is--- replaced with the supplied value. 'insert' is equivalent to--- @'insertWith' 'const'@.------ > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]--- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]--- > insert 5 'x' empty == singleton 5 'x'---- See Note: Type of local 'go' function--- See Note: Avoiding worker/wrapper-insert :: Ord k => k -> a -> Map k a -> Map k a-insert kx0 = go kx0 kx0- where- -- Unlike insertR, we only get sharing here- -- when the inserted value is at the same address- -- as the present value. We try anyway; this condition- -- seems particularly likely to occur in 'union'.- go :: Ord k => k -> k -> a -> Map k a -> Map k a- go orig !_ x Tip = singleton (lazy orig) x- go orig !kx x t@(Bin sz ky y l r) =- case compare kx ky of- LT | l' `ptrEq` l -> t- | otherwise -> balanceL ky y l' r- where !l' = go orig kx x l- GT | r' `ptrEq` r -> t- | otherwise -> balanceR ky y l r'- where !r' = go orig kx x r- EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t- | otherwise -> Bin sz (lazy orig) x l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insert #-}-#else-{-# INLINE insert #-}-#endif--#ifndef __GLASGOW_HASKELL__-lazy :: a -> a-lazy a = a-#endif---- [Note: Avoiding worker/wrapper]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- 'insert' has to go to great lengths to get pointer equality right and--- to prevent unnecessary allocation. The trouble is that GHC *really* wants--- to unbox the key and throw away the boxed one. This is bad for us, because--- we want to compare the pointer of the box we are given to the one already--- present if they compare EQ. It's also bad for us because it leads to the--- key being *reboxed* if it's actually stored in the map. Ugh! So we pass the--- 'go' function *two copies* of the key we're given. One of them we use for--- comparisons; the other we keep in our pocket. To prevent worker/wrapper from--- messing with the copy in our pocket, we sprinkle about calls to the magical--- function 'lazy'. This is all horrible, but it seems to work okay.----- Insert a new key and value in the map if it is not already present.--- Used by `union`.---- See Note: Type of local 'go' function--- See Note: Avoiding worker/wrapper-insertR :: Ord k => k -> a -> Map k a -> Map k a-insertR kx0 = go kx0 kx0- where- go :: Ord k => k -> k -> a -> Map k a -> Map k a- go orig !_ x Tip = singleton (lazy orig) x- go orig !kx x t@(Bin _ ky y l r) =- case compare kx ky of- LT | l' `ptrEq` l -> t- | otherwise -> balanceL ky y l' r- where !l' = go orig kx x l- GT | r' `ptrEq` r -> t- | otherwise -> balanceR ky y l r'- where !r' = go orig kx x r- EQ -> t-#if __GLASGOW_HASKELL__-{-# INLINABLE insertR #-}-#else-{-# INLINE insertR #-}-#endif---- | /O(log n)/. Insert with a function, combining new value and old value.--- @'insertWith' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key, f new_value old_value)@.------ > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"--insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWith = go- where- -- We have no hope of making pointer equality tricks work- -- here, because lazy insertWith *always* changes the tree,- -- either adding a new entry or replacing an element with a- -- thunk.- go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a- go _ !kx x Tip = singleton kx x- go f !kx x (Bin sy ky y l r) =- case compare kx ky of- LT -> balanceL ky y (go f kx x l) r- GT -> balanceR ky y l (go f kx x r)- EQ -> Bin sy kx (f x y) l r--#if __GLASGOW_HASKELL__-{-# INLINABLE insertWith #-}-#else-{-# INLINE insertWith #-}-#endif---- | A helper function for 'unionWith'. When the key is already in--- the map, the key is left alone, not replaced. The combining--- function is flipped--it is applied to the old value and then the--- new value.--insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithR = go- where- go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a- go _ !kx x Tip = singleton kx x- go f !kx x (Bin sy ky y l r) =- case compare kx ky of- LT -> balanceL ky y (go f kx x l) r- GT -> balanceR ky y l (go f kx x r)- EQ -> Bin sy ky (f y x) l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insertWithR #-}-#else-{-# INLINE insertWithR #-}-#endif---- | /O(log n)/. Insert with a function, combining key, new value and old value.--- @'insertWithKey' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key,f key new_value old_value)@.--- Note that the key passed to f is the same key passed to 'insertWithKey'.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"---- See Note: Type of local 'go' function-insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKey = go- where- go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a- go _ !kx x Tip = singleton kx x- go f kx x (Bin sy ky y l r) =- case compare kx ky of- LT -> balanceL ky y (go f kx x l) r- GT -> balanceR ky y l (go f kx x r)- EQ -> Bin sy kx (f kx x y) l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insertWithKey #-}-#else-{-# INLINE insertWithKey #-}-#endif---- | A helper function for 'unionWithKey'. When the key is already in--- the map, the key is left alone, not replaced. The combining--- function is flipped--it is applied to the old value and then the--- new value.-insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKeyR = go- where- go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a- go _ !kx x Tip = singleton kx x- go f kx x (Bin sy ky y l r) =- case compare kx ky of- LT -> balanceL ky y (go f kx x l) r- GT -> balanceR ky y l (go f kx x r)- EQ -> Bin sy ky (f ky y x) l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insertWithKeyR #-}-#else-{-# INLINE insertWithKeyR #-}-#endif---- | /O(log n)/. Combines insert operation with old value retrieval.--- The expression (@'insertLookupWithKey' f k x map@)--- is a pair where the first element is equal to (@'lookup' k map@)--- and the second element equal to (@'insertWithKey' f k x map@).------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])--- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])--- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")------ This is how to define @insertLookup@ using @insertLookupWithKey@:------ > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t--- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])--- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])---- See Note: Type of local 'go' function-insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a- -> (Maybe a, Map k a)-insertLookupWithKey f0 k0 x0 = toPair . go f0 k0 x0- where- go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)- go _ !kx x Tip = (Nothing :*: singleton kx x)- go f kx x (Bin sy ky y l r) =- case compare kx ky of- LT -> let !(found :*: l') = go f kx x l- !t' = balanceL ky y l' r- in (found :*: t')- GT -> let !(found :*: r') = go f kx x r- !t' = balanceR ky y l r'- in (found :*: t')- EQ -> (Just y :*: Bin sy kx (f kx x y) l r)-#if __GLASGOW_HASKELL__-{-# INLINABLE insertLookupWithKey #-}-#else-{-# INLINE insertLookupWithKey #-}-#endif--{--------------------------------------------------------------------- Deletion---------------------------------------------------------------------}--- | /O(log n)/. Delete a key and its value from the map. When the key is not--- a member of the map, the original map is returned.------ > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > delete 5 empty == empty---- See Note: Type of local 'go' function-delete :: Ord k => k -> Map k a -> Map k a-delete = go- where- go :: Ord k => k -> Map k a -> Map k a- go !_ Tip = Tip- go k t@(Bin _ kx x l r) =- case compare k kx of- LT | l' `ptrEq` l -> t- | otherwise -> balanceR kx x l' r- where !l' = go k l- GT | r' `ptrEq` r -> t- | otherwise -> balanceL kx x l r'- where !r' = go k r- EQ -> glue l r-#if __GLASGOW_HASKELL__-{-# INLINABLE delete #-}-#else-{-# INLINE delete #-}-#endif---- | /O(log n)/. Update a value at a specific key with the result of the provided function.--- When the key is not--- a member of the map, the original map is returned.------ > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjust ("new " ++) 7 empty == empty--adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a-adjust f = adjustWithKey (\_ x -> f x)-#if __GLASGOW_HASKELL__-{-# INLINABLE adjust #-}-#else-{-# INLINE adjust #-}-#endif---- | /O(log n)/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > let f key x = (show key) ++ ":new " ++ x--- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjustWithKey f 7 empty == empty--adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a-adjustWithKey = go- where- go :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a- go _ !_ Tip = Tip- go f k (Bin sx kx x l r) =- case compare k kx of- LT -> Bin sx kx x (go f k l) r- GT -> Bin sx kx x l (go f k r)- EQ -> Bin sx kx (f kx x) l r-#if __GLASGOW_HASKELL__-{-# INLINABLE adjustWithKey #-}-#else-{-# INLINE adjustWithKey #-}-#endif---- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f x = if x == "a" then Just "new a" else Nothing--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a-update f = updateWithKey (\_ x -> f x)-#if __GLASGOW_HASKELL__-{-# INLINABLE update #-}-#else-{-# INLINE update #-}-#endif---- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the--- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound--- to the new value @y@.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"---- See Note: Type of local 'go' function-updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a-updateWithKey = go- where- go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a- go _ !_ Tip = Tip- go f k(Bin sx kx x l r) =- case compare k kx of- LT -> balanceR kx x (go f k l) r- GT -> balanceL kx x l (go f k r)- EQ -> case f kx x of- Just x' -> Bin sx kx x' l r- Nothing -> glue l r-#if __GLASGOW_HASKELL__-{-# INLINABLE updateWithKey #-}-#else-{-# INLINE updateWithKey #-}-#endif---- | /O(log n)/. Lookup and update. See also 'updateWithKey'.--- The function returns changed value, if it is updated.--- Returns the original key value if the map entry is deleted.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])--- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])--- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")---- See Note: Type of local 'go' function-updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)-updateLookupWithKey f0 k0 = toPair . go f0 k0- where- go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)- go _ !_ Tip = (Nothing :*: Tip)- go f k (Bin sx kx x l r) =- case compare k kx of- LT -> let !(found :*: l') = go f k l- !t' = balanceR kx x l' r- in (found :*: t')- GT -> let !(found :*: r') = go f k r- !t' = balanceL kx x l r'- in (found :*: t')- EQ -> case f kx x of- Just x' -> (Just x' :*: Bin sx kx x' l r)- Nothing -> let !glued = glue l r- in (Just x :*: glued)-#if __GLASGOW_HASKELL__-{-# INLINABLE updateLookupWithKey #-}-#else-{-# INLINE updateLookupWithKey #-}-#endif---- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.--- 'alter' can be used to insert, delete, or update a value in a 'Map'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.------ > let f _ = Nothing--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- >--- > let f _ = Just "c"--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]------ Note that @'adjust' = alter . fmap@.---- See Note: Type of local 'go' function-alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a-alter = go- where- go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a- go f !k Tip = case f Nothing of- Nothing -> Tip- Just x -> singleton k x-- go f k (Bin sx kx x l r) = case compare k kx of- LT -> balance kx x (go f k l) r- GT -> balance kx x l (go f k r)- EQ -> case f (Just x) of- Just x' -> Bin sx kx x' l r- Nothing -> glue l r-#if __GLASGOW_HASKELL__-{-# INLINABLE alter #-}-#else-{-# INLINE alter #-}-#endif---- Used to choose the appropriate alterF implementation.-data AreWeStrict = Strict | Lazy---- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at--- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete,--- or update a value in a 'Map'. In short: @'lookup' k \<$\> 'alterF' f k m = f--- ('lookup' k m)@.------ Example:------ @--- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)--- interactiveAlter k m = alterF f k m where--- f Nothing = do--- putStrLn $ show k ++--- " was not found in the map. Would you like to add it?"--- getUserResponse1 :: IO (Maybe String)--- f (Just old) = do--- putStrLn $ "The key is currently bound to " ++ show old ++--- ". Would you like to change or delete it?"--- getUserResponse2 :: IO (Maybe String)--- @------ 'alterF' is the most general operation for working with an individual--- key that may or may not be in a given map. When used with trivial--- functors like 'Identity' and 'Const', it is often slightly slower than--- more specialized combinators like 'lookup' and 'insert'. However, when--- the functor is non-trivial and key comparison is not particularly cheap,--- it is the fastest way.------ Note on rewrite rules:------ This module includes GHC rewrite rules to optimize 'alterF' for--- the 'Const' and 'Identity' functors. In general, these rules--- improve performance. The sole exception is that when using--- 'Identity', deleting a key that is already absent takes longer--- than it would without the rules. If you expect this to occur--- a very large fraction of the time, you might consider using a--- private copy of the 'Identity' type.------ Note: 'alterF' is a flipped version of the @at@ combinator from--- @Control.Lens.At@.------ @since 0.5.8-alterF :: (Functor f, Ord k)- => (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)-alterF f k m = atKeyImpl Lazy k f m--#ifndef __GLASGOW_HASKELL__-{-# INLINE alterF #-}-#else-{-# INLINABLE [2] alterF #-}---- We can save a little time by recognizing the special case of--- `Control.Applicative.Const` and just doing a lookup.-{-# RULES-"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m- #-}--#if MIN_VERSION_base(4,8,0)--- base 4.8 and above include Data.Functor.Identity, so we can--- save a pretty decent amount of time by handling it specially.-{-# RULES-"alterF/Identity" forall k f . alterF f k = atKeyIdentity k f- #-}-#endif-#endif--atKeyImpl :: (Functor f, Ord k) =>- AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)-#ifdef DEFINE_ALTERF_FALLBACK-atKeyImpl strict !k f m--- It doesn't seem sensible to worry about overflowing the queue--- if the word size is 61 or more. If I calculate it correctly,--- that would take a map with nearly a quadrillion entries.- | wordSize < 61 && size m >= alterFCutoff = alterFFallback strict k f m-#endif-atKeyImpl strict !k f m = case lookupTrace k m of- TraceResult mv q -> (<$> f mv) $ \ fres ->- case fres of- Nothing -> case mv of- Nothing -> m- Just old -> deleteAlong old q m- Just new -> case strict of- Strict -> new `seq` case mv of- Nothing -> insertAlong q k new m- Just _ -> replaceAlong q new m- Lazy -> case mv of- Nothing -> insertAlong q k new m- Just _ -> replaceAlong q new m--{-# INLINE atKeyImpl #-}--#ifdef DEFINE_ALTERF_FALLBACK-alterFCutoff :: Int-#if WORD_SIZE_IN_BITS == 32-alterFCutoff = 55744454-#else-alterFCutoff = case wordSize of- 30 -> 17637893- 31 -> 31356255- 32 -> 55744454- x -> (4^(x*2-2)) `quot` (3^(x*2-2)) -- Unlikely-#endif-#endif--data TraceResult a = TraceResult (Maybe a) {-# UNPACK #-} !BitQueue---- Look up a key and return a result indicating whether it was found--- and what path was taken.-lookupTrace :: Ord k => k -> Map k a -> TraceResult a-lookupTrace = go emptyQB- where- go :: Ord k => BitQueueB -> k -> Map k a -> TraceResult a- go !q !_ Tip = TraceResult Nothing (buildQ q)- go q k (Bin _ kx x l r) = case compare k kx of- LT -> (go $! q `snocQB` False) k l- GT -> (go $! q `snocQB` True) k r- EQ -> TraceResult (Just x) (buildQ q)---- GHC 7.8 doesn't manage to unbox the queue properly--- unless we explicitly inline this function. This stuff--- is a bit touchy, unfortunately.-#if __GLASGOW_HASKELL__ >= 710-{-# INLINABLE lookupTrace #-}-#else-{-# INLINE lookupTrace #-}-#endif---- Insert at a location (which will always be a leaf)--- described by the path passed in.-insertAlong :: BitQueue -> k -> a -> Map k a -> Map k a-insertAlong !_ kx x Tip = singleton kx x-insertAlong q kx x (Bin sz ky y l r) =- case unconsQ q of- Just (False, tl) -> balanceL ky y (insertAlong tl kx x l) r- Just (True,tl) -> balanceR ky y l (insertAlong tl kx x r)- Nothing -> Bin sz kx x l r -- Shouldn't happen---- Delete from a location (which will always be a node)--- described by the path passed in.------ This is fairly horrifying! We don't actually have any--- use for the old value we're deleting. But if GHC sees--- that, then it will allocate a thunk representing the--- Map with the key deleted before we have any reason to--- believe we'll actually want that. This transformation--- enhances sharing, but we don't care enough about that.--- So deleteAlong needs to take the old value, and we need--- to convince GHC somehow that it actually uses it. We--- can't NOINLINE deleteAlong, because that would prevent--- the BitQueue from being unboxed. So instead we pass the--- old value to a NOINLINE constant function and then--- convince GHC that we use the result throughout the--- computation. Doing the obvious thing and just passing--- the value itself through the recursion costs 3-4% time,--- so instead we convert the value to a magical zero-width--- proxy that's ultimately erased.-deleteAlong :: any -> BitQueue -> Map k a -> Map k a-deleteAlong old !q0 !m = go (bogus old) q0 m where-#ifdef USE_MAGIC_PROXY- go :: Proxy# () -> BitQueue -> Map k a -> Map k a-#else- go :: any -> BitQueue -> Map k a -> Map k a-#endif- go !_ !_ Tip = Tip- go foom q (Bin _ ky y l r) =- case unconsQ q of- Just (False, tl) -> balanceR ky y (go foom tl l) r- Just (True, tl) -> balanceL ky y l (go foom tl r)- Nothing -> glue l r--#ifdef USE_MAGIC_PROXY-{-# NOINLINE bogus #-}-bogus :: a -> Proxy# ()-bogus _ = proxy#-#else--- No point hiding in this case.-{-# INLINE bogus #-}-bogus :: a -> a-bogus a = a-#endif---- Replace the value found in the node described--- by the given path with a new one.-replaceAlong :: BitQueue -> a -> Map k a -> Map k a-replaceAlong !_ _ Tip = Tip -- Should not happen-replaceAlong q x (Bin sz ky y l r) =- case unconsQ q of- Just (False, tl) -> Bin sz ky y (replaceAlong tl x l) r- Just (True,tl) -> Bin sz ky y l (replaceAlong tl x r)- Nothing -> Bin sz ky x l r--#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)-atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)-atKeyIdentity k f t = Identity $ atKeyPlain Lazy k (coerce f) t-{-# INLINABLE atKeyIdentity #-}--atKeyPlain :: Ord k => AreWeStrict -> k -> (Maybe a -> Maybe a) -> Map k a -> Map k a-atKeyPlain strict k0 f0 t = case go k0 f0 t of- AltSmaller t' -> t'- AltBigger t' -> t'- AltAdj t' -> t'- AltSame -> t- where- go :: Ord k => k -> (Maybe a -> Maybe a) -> Map k a -> Altered k a- go !k f Tip = case f Nothing of- Nothing -> AltSame- Just x -> case strict of- Lazy -> AltBigger $ singleton k x- Strict -> x `seq` (AltBigger $ singleton k x)-- go k f (Bin sx kx x l r) = case compare k kx of- LT -> case go k f l of- AltSmaller l' -> AltSmaller $ balanceR kx x l' r- AltBigger l' -> AltBigger $ balanceL kx x l' r- AltAdj l' -> AltAdj $ Bin sx kx x l' r- AltSame -> AltSame- GT -> case go k f r of- AltSmaller r' -> AltSmaller $ balanceL kx x l r'- AltBigger r' -> AltBigger $ balanceR kx x l r'- AltAdj r' -> AltAdj $ Bin sx kx x l r'- AltSame -> AltSame- EQ -> case f (Just x) of- Just x' -> case strict of- Lazy -> AltAdj $ Bin sx kx x' l r- Strict -> x' `seq` (AltAdj $ Bin sx kx x' l r)- Nothing -> AltSmaller $ glue l r-{-# INLINE atKeyPlain #-}--data Altered k a = AltSmaller !(Map k a) | AltBigger !(Map k a) | AltAdj !(Map k a) | AltSame-#endif--#ifdef DEFINE_ALTERF_FALLBACK--- When the map is too large to use a bit queue, we fall back to--- this much slower version which uses a more "natural" implementation--- improved with Yoneda to avoid repeated fmaps. This works okayish for--- some operations, but it's pretty lousy for lookups.-alterFFallback :: (Functor f, Ord k)- => AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)-alterFFallback Lazy k f t = alterFYoneda k (\m q -> q <$> f m) t id-alterFFallback Strict k f t = alterFYoneda k (\m q -> q . forceMaybe <$> f m) t id- where- forceMaybe Nothing = Nothing- forceMaybe may@(Just !_) = may-{-# NOINLINE alterFFallback #-}--alterFYoneda :: Ord k =>- k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b-alterFYoneda = go- where- go :: Ord k =>- k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b- go !k f Tip g = f Nothing $ \ mx -> case mx of- Nothing -> g Tip- Just x -> g (singleton k x)- go k f (Bin sx kx x l r) g = case compare k kx of- LT -> go k f l (\m -> g (balance kx x m r))- GT -> go k f r (\m -> g (balance kx x l m))- EQ -> f (Just x) $ \ mx' -> case mx' of- Just x' -> g (Bin sx kx x' l r)- Nothing -> g (glue l r)-{-# INLINE alterFYoneda #-}-#endif--{--------------------------------------------------------------------- Indexing---------------------------------------------------------------------}--- | /O(log n)/. Return the /index/ of a key, which is its zero-based index in--- the sequence sorted by keys. The index is a number from /0/ up to, but not--- including, the 'size' of the map. Calls 'error' when the key is not--- a 'member' of the map.------ > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map--- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0--- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1--- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map---- See Note: Type of local 'go' function-findIndex :: Ord k => k -> Map k a -> Int-findIndex = go 0- where- go :: Ord k => Int -> k -> Map k a -> Int- go !_ !_ Tip = error "Map.findIndex: element is not in the map"- go idx k (Bin _ kx _ l r) = case compare k kx of- LT -> go idx k l- GT -> go (idx + size l + 1) k r- EQ -> idx + size l-#if __GLASGOW_HASKELL__-{-# INLINABLE findIndex #-}-#endif---- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index in--- the sequence sorted by keys. The index is a number from /0/ up to, but not--- including, the 'size' of the map.------ > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False--- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0--- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1--- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False---- See Note: Type of local 'go' function-lookupIndex :: Ord k => k -> Map k a -> Maybe Int-lookupIndex = go 0- where- go :: Ord k => Int -> k -> Map k a -> Maybe Int- go !_ !_ Tip = Nothing- go idx k (Bin _ kx _ l r) = case compare k kx of- LT -> go idx k l- GT -> go (idx + size l + 1) k r- EQ -> Just $! idx + size l-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupIndex #-}-#endif---- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based--- index in the sequence sorted by keys. If the /index/ is out of range (less--- than zero, greater or equal to 'size' of the map), 'error' is called.------ > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")--- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")--- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range--elemAt :: Int -> Map k a -> (k,a)-elemAt !_ Tip = error "Map.elemAt: index out of range"-elemAt i (Bin _ kx x l r)- = case compare i sizeL of- LT -> elemAt i l- GT -> elemAt (i-sizeL-1) r- EQ -> (kx,x)- where- sizeL = size l---- | Take a given number of entries in key order, beginning--- with the smallest keys.------ @--- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'--- @------ @since 0.5.8--take :: Int -> Map k a -> Map k a-take i m | i >= size m = m-take i0 m0 = go i0 m0- where- go i !_ | i <= 0 = Tip- go !_ Tip = Tip- go i (Bin _ kx x l r) =- case compare i sizeL of- LT -> go i l- GT -> link kx x l (go (i - sizeL - 1) r)- EQ -> l- where sizeL = size l---- | Drop a given number of entries in key order, beginning--- with the smallest keys.------ @--- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'--- @------ @since 0.5.8-drop :: Int -> Map k a -> Map k a-drop i m | i >= size m = Tip-drop i0 m0 = go i0 m0- where- go i m | i <= 0 = m- go !_ Tip = Tip- go i (Bin _ kx x l r) =- case compare i sizeL of- LT -> link kx x (go i l) r- GT -> go (i - sizeL - 1) r- EQ -> insertMin kx x r- where sizeL = size l---- | /O(log n)/. Split a map at a particular index.------ @--- splitAt !n !xs = ('take' n xs, 'drop' n xs)--- @------ @since 0.5.8-splitAt :: Int -> Map k a -> (Map k a, Map k a)-splitAt i0 m0- | i0 >= size m0 = (m0, Tip)- | otherwise = toPair $ go i0 m0- where- go i m | i <= 0 = Tip :*: m- go !_ Tip = Tip :*: Tip- go i (Bin _ kx x l r)- = case compare i sizeL of- LT -> case go i l of- ll :*: lr -> ll :*: link kx x lr r- GT -> case go (i - sizeL - 1) r of- rl :*: rr -> link kx x l rl :*: rr- EQ -> l :*: insertMin kx x r- where sizeL = size l---- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in--- the sequence sorted by keys. If the /index/ is out of range (less than zero,--- greater or equal to 'size' of the map), 'error' is called.------ > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]--- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]--- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range--- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range--- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range--- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range--updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a-updateAt f !i t =- case t of- Tip -> error "Map.updateAt: index out of range"- Bin sx kx x l r -> case compare i sizeL of- LT -> balanceR kx x (updateAt f i l) r- GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)- EQ -> case f kx x of- Just x' -> Bin sx kx x' l r- Nothing -> glue l r- where- sizeL = size l---- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in--- the sequence sorted by keys. If the /index/ is out of range (less than zero,--- greater or equal to 'size' of the map), 'error' is called.------ > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range--- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range--deleteAt :: Int -> Map k a -> Map k a-deleteAt !i t =- case t of- Tip -> error "Map.deleteAt: index out of range"- Bin _ kx x l r -> case compare i sizeL of- LT -> balanceR kx x (deleteAt i l) r- GT -> balanceL kx x l (deleteAt (i-sizeL-1) r)- EQ -> glue l r- where- sizeL = size l---{--------------------------------------------------------------------- Minimal, Maximal---------------------------------------------------------------------}--lookupMinSure :: k -> a -> Map k a -> (k, a)-lookupMinSure k a Tip = (k, a)-lookupMinSure _ _ (Bin _ k a l _) = lookupMinSure k a l---- | /O(log n)/. The minimal key of the map. Returns 'Nothing' if the map is empty.------ > lookupMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b")--- > lookupMin empty = Nothing------ @since 0.5.9--lookupMin :: Map k a -> Maybe (k,a)-lookupMin Tip = Nothing-lookupMin (Bin _ k x l _) = Just $! lookupMinSure k x l---- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty.------ > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")--- > findMin empty Error: empty map has no minimal element--findMin :: Map k a -> (k,a)-findMin t- | Just r <- lookupMin t = r- | otherwise = error "Map.findMin: empty map has no minimal element"---- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty.------ > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")--- > findMax empty Error: empty map has no maximal element--lookupMaxSure :: k -> a -> Map k a -> (k, a)-lookupMaxSure k a Tip = (k, a)-lookupMaxSure _ _ (Bin _ k a _ r) = lookupMaxSure k a r---- | /O(log n)/. The maximal key of the map. Returns 'Nothing' if the map is empty.------ > lookupMax (fromList [(5,"a"), (3,"b")]) == Just (5,"a")--- > lookupMax empty = Nothing------ @since 0.5.9--lookupMax :: Map k a -> Maybe (k, a)-lookupMax Tip = Nothing-lookupMax (Bin _ k x _ r) = Just $! lookupMaxSure k x r--findMax :: Map k a -> (k,a)-findMax t- | Just r <- lookupMax t = r- | otherwise = error "Map.findMax: empty map has no maximal element"---- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.------ > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]--- > deleteMin empty == empty--deleteMin :: Map k a -> Map k a-deleteMin (Bin _ _ _ Tip r) = r-deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r-deleteMin Tip = Tip---- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.------ > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]--- > deleteMax empty == empty--deleteMax :: Map k a -> Map k a-deleteMax (Bin _ _ _ l Tip) = l-deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r)-deleteMax Tip = Tip---- | /O(log n)/. Update the value at the minimal key.------ > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]--- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMin :: (a -> Maybe a) -> Map k a -> Map k a-updateMin f m- = updateMinWithKey (\_ x -> f x) m---- | /O(log n)/. Update the value at the maximal key.------ > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]--- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMax :: (a -> Maybe a) -> Map k a -> Map k a-updateMax f m- = updateMaxWithKey (\_ x -> f x) m----- | /O(log n)/. Update the value at the minimal key.------ > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]--- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-updateMinWithKey _ Tip = Tip-updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of- Nothing -> r- Just x' -> Bin sx kx x' Tip r-updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r---- | /O(log n)/. Update the value at the maximal key.------ > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]--- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-updateMaxWithKey _ Tip = Tip-updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of- Nothing -> l- Just x' -> Bin sx kx x' l Tip-updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r)---- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")--- > minViewWithKey empty == Nothing--minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)-minViewWithKey Tip = Nothing-minViewWithKey (Bin _ k x l r) = Just $- case minViewSure k x l r of- MinView km xm t -> ((km, xm), t)--- We inline this to give GHC the best possible chance of getting--- rid of the Maybe and pair constructors, as well as the thunk under--- the Just.-{-# INLINE minViewWithKey #-}---- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")--- > maxViewWithKey empty == Nothing--maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)-maxViewWithKey Tip = Nothing-maxViewWithKey (Bin _ k x l r) = Just $- case maxViewSure k x l r of- MaxView km xm t -> ((km, xm), t)--- See note on inlining at minViewWithKey-{-# INLINE maxViewWithKey #-}---- | /O(log n)/. Retrieves the value associated with minimal key of the--- map, and the map stripped of that element, or 'Nothing' if passed an--- empty map.------ > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")--- > minView empty == Nothing--minView :: Map k a -> Maybe (a, Map k a)-minView t = case minViewWithKey t of- Nothing -> Nothing- Just ~((_, x), t') -> Just (x, t')---- | /O(log n)/. Retrieves the value associated with maximal key of the--- map, and the map stripped of that element, or 'Nothing' if passed an--- empty map.------ > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")--- > maxView empty == Nothing--maxView :: Map k a -> Maybe (a, Map k a)-maxView t = case maxViewWithKey t of- Nothing -> Nothing- Just ~((_, x), t') -> Just (x, t')--{--------------------------------------------------------------------- Union.---------------------------------------------------------------------}--- | The union of a list of maps:--- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).------ > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- > == fromList [(3, "b"), (5, "a"), (7, "C")]--- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]--- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]--unions :: (Foldable f, Ord k) => f (Map k a) -> Map k a-unions ts- = Foldable.foldl' union empty ts-#if __GLASGOW_HASKELL__-{-# INLINABLE unions #-}-#endif---- | The union of a list of maps, with a combining operation:--- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).------ > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]--unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a-unionsWith f ts- = Foldable.foldl' (unionWith f) empty ts-#if __GLASGOW_HASKELL__-{-# INLINABLE unionsWith #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/.--- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.--- It prefers @t1@ when duplicate keys are encountered,--- i.e. (@'union' == 'unionWith' 'const'@).------ > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]--union :: Ord k => Map k a -> Map k a -> Map k a-union t1 Tip = t1-union t1 (Bin _ k x Tip Tip) = insertR k x t1-union (Bin _ k x Tip Tip) t2 = insert k x t2-union Tip t2 = t2-union t1@(Bin _ k1 x1 l1 r1) t2 = case split k1 t2 of- (l2, r2) | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1- | otherwise -> link k1 x1 l1l2 r1r2- where !l1l2 = union l1 l2- !r1r2 = union r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE union #-}-#endif--{--------------------------------------------------------------------- Union with a combining function---------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function.------ > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]--unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a--- QuickCheck says pointer equality never happens here.-unionWith _f t1 Tip = t1-unionWith f t1 (Bin _ k x Tip Tip) = insertWithR f k x t1-unionWith f (Bin _ k x Tip Tip) t2 = insertWith f k x t2-unionWith _f Tip t2 = t2-unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of- (l2, mb, r2) -> case mb of- Nothing -> link k1 x1 l1l2 r1r2- Just x2 -> link k1 (f x1 x2) l1l2 r1r2- where !l1l2 = unionWith f l1 l2- !r1r2 = unionWith f r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE unionWith #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/.--- Union with a combining function.------ > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]--unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a-unionWithKey _f t1 Tip = t1-unionWithKey f t1 (Bin _ k x Tip Tip) = insertWithKeyR f k x t1-unionWithKey f (Bin _ k x Tip Tip) t2 = insertWithKey f k x t2-unionWithKey _f Tip t2 = t2-unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of- (l2, mb, r2) -> case mb of- Nothing -> link k1 x1 l1l2 r1r2- Just x2 -> link k1 (f k1 x1 x2) l1l2 r1r2- where !l1l2 = unionWithKey f l1 l2- !r1r2 = unionWithKey f r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE unionWithKey #-}-#endif--{--------------------------------------------------------------------- Difference---------------------------------------------------------------------}---- We don't currently attempt to use any pointer equality tricks for--- 'difference'. To do so, we'd have to match on the first argument--- and split the second. Unfortunately, the proof of the time bound--- relies on doing it the way we do, and it's not clear whether that--- bound holds the other way.---- | /O(m*log(n\/m + 1)), m <= n/. Difference of two maps.--- Return elements of the first map not existing in the second map.------ > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"--difference :: Ord k => Map k a -> Map k b -> Map k a-difference Tip _ = Tip-difference t1 Tip = t1-difference t1 (Bin _ k _ l2 r2) = case split k t1 of- (l1, r1)- | size l1l2 + size r1r2 == size t1 -> t1- | otherwise -> link2 l1l2 r1r2- where- !l1l2 = difference l1 l2- !r1r2 = difference r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE difference #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Remove all keys in a 'Set' from a 'Map'.------ @--- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``Set.notMember`` s) m--- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s--- @------ @since 0.5.8--withoutKeys :: Ord k => Map k a -> Set k -> Map k a-withoutKeys Tip _ = Tip-withoutKeys m Set.Tip = m-withoutKeys m (Set.Bin _ k ls rs) = case splitMember k m of- (lm, b, rm)- | not b && lm' `ptrEq` lm && rm' `ptrEq` rm -> m- | otherwise -> link2 lm' rm'- where- !lm' = withoutKeys lm ls- !rm' = withoutKeys rm rs-#if __GLASGOW_HASKELL__-{-# INLINABLE withoutKeys #-}-#endif---- | /O(n+m)/. Difference with a combining function.--- When two equal keys are--- encountered, the combining function is applied to the values of these keys.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@.------ > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing--- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])--- > == singleton 3 "b:B"-differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a-differenceWith f = merge preserveMissing dropMissing $- zipWithMaybeMatched (\_ x y -> f x y)-#if __GLASGOW_HASKELL__-{-# INLINABLE differenceWith #-}-#endif---- | /O(n+m)/. Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@.------ > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing--- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])--- > == singleton 3 "3:b|B"--differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a-differenceWithKey f =- merge preserveMissing dropMissing (zipWithMaybeMatched f)-#if __GLASGOW_HASKELL__-{-# INLINABLE differenceWithKey #-}-#endif---{--------------------------------------------------------------------- Intersection---------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. Intersection of two maps.--- Return data in the first map for the keys existing in both maps.--- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).------ > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"--intersection :: Ord k => Map k a -> Map k b -> Map k a-intersection Tip _ = Tip-intersection _ Tip = Tip-intersection t1@(Bin _ k x l1 r1) t2- | mb = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1- then t1- else link k x l1l2 r1r2- | otherwise = link2 l1l2 r1r2- where- !(l2, mb, r2) = splitMember k t2- !l1l2 = intersection l1 l2- !r1r2 = intersection r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE intersection #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Restrict a 'Map' to only those keys--- found in a 'Set'.------ @--- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``Set.member`` s) m--- m \`restrictKeys\` s = m ``intersection`` 'fromSet' (const ()) s--- @------ @since 0.5.8-restrictKeys :: Ord k => Map k a -> Set k -> Map k a-restrictKeys Tip _ = Tip-restrictKeys _ Set.Tip = Tip-restrictKeys m@(Bin _ k x l1 r1) s- | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1- then m- else link k x l1l2 r1r2- | otherwise = link2 l1l2 r1r2- where- !(l2, b, r2) = Set.splitMember k s- !l1l2 = restrictKeys l1 l2- !r1r2 = restrictKeys r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE restrictKeys #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.------ > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"--intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c--- We have no hope of pointer equality tricks here because every single--- element in the result will be a thunk.-intersectionWith _f Tip _ = Tip-intersectionWith _f _ Tip = Tip-intersectionWith f (Bin _ k x1 l1 r1) t2 = case mb of- Just x2 -> link k (f x1 x2) l1l2 r1r2- Nothing -> link2 l1l2 r1r2- where- !(l2, mb, r2) = splitLookup k t2- !l1l2 = intersectionWith f l1 l2- !r1r2 = intersectionWith f r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE intersectionWith #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.------ > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar--- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"--intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c-intersectionWithKey _f Tip _ = Tip-intersectionWithKey _f _ Tip = Tip-intersectionWithKey f (Bin _ k x1 l1 r1) t2 = case mb of- Just x2 -> link k (f k x1 x2) l1l2 r1r2- Nothing -> link2 l1l2 r1r2- where- !(l2, mb, r2) = splitLookup k t2- !l1l2 = intersectionWithKey f l1 l2- !r1r2 = intersectionWithKey f r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE intersectionWithKey #-}-#endif--{--------------------------------------------------------------------- Disjoint---------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. Check whether the key sets of two--- maps are disjoint (i.e., their 'intersection' is empty).------ > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True--- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False--- > disjoint (fromList []) (fromList []) == True------ @--- xs ``disjoint`` ys = null (xs ``intersection`` ys)--- @------ @since 0.6.2.1---- See 'Data.Set.Internal.isSubsetOfX' for some background--- on the implementation design.-disjoint :: Ord k => Map k a -> Map k b -> Bool-disjoint Tip _ = True-disjoint _ Tip = True-disjoint (Bin 1 k _ _ _) t = k `notMember` t-disjoint (Bin _ k _ l r) t- = not found && disjoint l lt && disjoint r gt- where- (lt,found,gt) = splitMember k t--{--------------------------------------------------------------------- Compose---------------------------------------------------------------------}--- | Relate the keys of one map to the values of--- the other, by using the values of the former as keys for lookups--- in the latter.------ Complexity: \( O (n * \log(m)) \), where \(m\) is the size of the first argument------ > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]------ @--- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')--- @------ __Note:__ Prior to v0.6.4, "Data.Map.Strict" exposed a version of--- 'compose' that forced the values of the output 'Map'. This version does not--- force these values.------ @since 0.6.3.1-compose :: Ord b => Map b c -> Map a b -> Map a c-compose bc !ab- | null bc = empty- | otherwise = mapMaybe (bc !?) ab--#if !MIN_VERSION_base (4,8,0)--- | The identity type.-newtype Identity a = Identity { runIdentity :: a }-#if __GLASGOW_HASKELL__ == 708-instance Functor Identity where- fmap = coerce-instance Applicative Identity where- (<*>) = coerce- pure = Identity-#else-instance Functor Identity where- fmap f (Identity a) = Identity (f a)-instance Applicative Identity where- Identity f <*> Identity x = Identity (f x)- pure = Identity-#endif-#endif---- | A tactic for dealing with keys present in one map but not the other in--- 'merge' or 'mergeA'.------ A tactic of type @ WhenMissing f k x z @ is an abstract representation--- of a function of type @ k -> x -> f (Maybe z) @.------ @since 0.5.9--data WhenMissing f k x y = WhenMissing- { missingSubtree :: Map k x -> f (Map k y)- , missingKey :: k -> x -> f (Maybe y)}---- | @since 0.5.9-instance (Applicative f, Monad f) => Functor (WhenMissing f k x) where- fmap = mapWhenMissing- {-# INLINE fmap #-}---- | @since 0.5.9-instance (Applicative f, Monad f)- => Category.Category (WhenMissing f k) where- id = preserveMissing- f . g = traverseMaybeMissing $- \ k x -> missingKey g k x >>= \y ->- case y of- Nothing -> pure Nothing- Just q -> missingKey f k q- {-# INLINE id #-}- {-# INLINE (.) #-}---- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.------ @since 0.5.9-instance (Applicative f, Monad f) => Applicative (WhenMissing f k x) where- pure x = mapMissing (\ _ _ -> x)- f <*> g = traverseMaybeMissing $ \k x -> do- res1 <- missingKey f k x- case res1 of- Nothing -> pure Nothing- Just r -> (pure $!) . fmap r =<< missingKey g k x- {-# INLINE pure #-}- {-# INLINE (<*>) #-}---- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.------ @since 0.5.9-instance (Applicative f, Monad f) => Monad (WhenMissing f k x) where-#if !MIN_VERSION_base(4,8,0)- return = pure-#endif- m >>= f = traverseMaybeMissing $ \k x -> do- res1 <- missingKey m k x- case res1 of- Nothing -> pure Nothing- Just r -> missingKey (f r) k x- {-# INLINE (>>=) #-}---- | Map covariantly over a @'WhenMissing' f k x@.------ @since 0.5.9-mapWhenMissing :: (Applicative f, Monad f)- => (a -> b)- -> WhenMissing f k x a -> WhenMissing f k x b-mapWhenMissing f t = WhenMissing- { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'- , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }-{-# INLINE mapWhenMissing #-}---- | Map covariantly over a @'WhenMissing' f k x@, using only a 'Functor f'--- constraint.-mapGentlyWhenMissing :: Functor f- => (a -> b)- -> WhenMissing f k x a -> WhenMissing f k x b-mapGentlyWhenMissing f t = WhenMissing- { missingSubtree = \m -> fmap f <$> missingSubtree t m- , missingKey = \k x -> fmap f <$> missingKey t k x }-{-# INLINE mapGentlyWhenMissing #-}---- | Map covariantly over a @'WhenMatched' f k x@, using only a 'Functor f'--- constraint.-mapGentlyWhenMatched :: Functor f- => (a -> b)- -> WhenMatched f k x y a -> WhenMatched f k x y b-mapGentlyWhenMatched f t = zipWithMaybeAMatched $- \k x y -> fmap f <$> runWhenMatched t k x y-{-# INLINE mapGentlyWhenMatched #-}---- | Map contravariantly over a @'WhenMissing' f k _ x@.------ @since 0.5.9-lmapWhenMissing :: (b -> a) -> WhenMissing f k a x -> WhenMissing f k b x-lmapWhenMissing f t = WhenMissing- { missingSubtree = \m -> missingSubtree t (fmap f m)- , missingKey = \k x -> missingKey t k (f x) }-{-# INLINE lmapWhenMissing #-}---- | Map contravariantly over a @'WhenMatched' f k _ y z@.------ @since 0.5.9-contramapFirstWhenMatched :: (b -> a)- -> WhenMatched f k a y z- -> WhenMatched f k b y z-contramapFirstWhenMatched f t = WhenMatched $- \k x y -> runWhenMatched t k (f x) y-{-# INLINE contramapFirstWhenMatched #-}---- | Map contravariantly over a @'WhenMatched' f k x _ z@.------ @since 0.5.9-contramapSecondWhenMatched :: (b -> a)- -> WhenMatched f k x a z- -> WhenMatched f k x b z-contramapSecondWhenMatched f t = WhenMatched $- \k x y -> runWhenMatched t k x (f y)-{-# INLINE contramapSecondWhenMatched #-}---- | A tactic for dealing with keys present in one map but not the other in--- 'merge'.------ A tactic of type @ SimpleWhenMissing k x z @ is an abstract representation--- of a function of type @ k -> x -> Maybe z @.------ @since 0.5.9-type SimpleWhenMissing = WhenMissing Identity---- | A tactic for dealing with keys present in both--- maps in 'merge' or 'mergeA'.------ A tactic of type @ WhenMatched f k x y z @ is an abstract representation--- of a function of type @ k -> x -> y -> f (Maybe z) @.------ @since 0.5.9-newtype WhenMatched f k x y z = WhenMatched- { matchedKey :: k -> x -> y -> f (Maybe z) }---- | Along with zipWithMaybeAMatched, witnesses the isomorphism between--- @WhenMatched f k x y z@ and @k -> x -> y -> f (Maybe z)@.------ @since 0.5.9-runWhenMatched :: WhenMatched f k x y z -> k -> x -> y -> f (Maybe z)-runWhenMatched = matchedKey-{-# INLINE runWhenMatched #-}---- | Along with traverseMaybeMissing, witnesses the isomorphism between--- @WhenMissing f k x y@ and @k -> x -> f (Maybe y)@.------ @since 0.5.9-runWhenMissing :: WhenMissing f k x y -> k -> x -> f (Maybe y)-runWhenMissing = missingKey-{-# INLINE runWhenMissing #-}---- | @since 0.5.9-instance Functor f => Functor (WhenMatched f k x y) where- fmap = mapWhenMatched- {-# INLINE fmap #-}---- | @since 0.5.9-instance (Monad f, Applicative f) => Category.Category (WhenMatched f k x) where- id = zipWithMatched (\_ _ y -> y)- f . g = zipWithMaybeAMatched $- \k x y -> do- res <- runWhenMatched g k x y- case res of- Nothing -> pure Nothing- Just r -> runWhenMatched f k x r- {-# INLINE id #-}- {-# INLINE (.) #-}---- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @------ @since 0.5.9-instance (Monad f, Applicative f) => Applicative (WhenMatched f k x y) where- pure x = zipWithMatched (\_ _ _ -> x)- fs <*> xs = zipWithMaybeAMatched $ \k x y -> do- res <- runWhenMatched fs k x y- case res of- Nothing -> pure Nothing- Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y- {-# INLINE pure #-}- {-# INLINE (<*>) #-}---- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @------ @since 0.5.9-instance (Monad f, Applicative f) => Monad (WhenMatched f k x y) where-#if !MIN_VERSION_base(4,8,0)- return = pure-#endif- m >>= f = zipWithMaybeAMatched $ \k x y -> do- res <- runWhenMatched m k x y- case res of- Nothing -> pure Nothing- Just r -> runWhenMatched (f r) k x y- {-# INLINE (>>=) #-}---- | Map covariantly over a @'WhenMatched' f k x y@.------ @since 0.5.9-mapWhenMatched :: Functor f- => (a -> b)- -> WhenMatched f k x y a- -> WhenMatched f k x y b-mapWhenMatched f (WhenMatched g) = WhenMatched $ \k x y -> fmap (fmap f) (g k x y)-{-# INLINE mapWhenMatched #-}---- | A tactic for dealing with keys present in both maps in 'merge'.------ A tactic of type @ SimpleWhenMatched k x y z @ is an abstract representation--- of a function of type @ k -> x -> y -> Maybe z @.------ @since 0.5.9-type SimpleWhenMatched = WhenMatched Identity---- | When a key is found in both maps, apply a function to the--- key and values and use the result in the merged map.------ @--- zipWithMatched :: (k -> x -> y -> z)--- -> SimpleWhenMatched k x y z--- @------ @since 0.5.9-zipWithMatched :: Applicative f- => (k -> x -> y -> z)- -> WhenMatched f k x y z-zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y-{-# INLINE zipWithMatched #-}---- | When a key is found in both maps, apply a function to the--- key and values to produce an action and use its result in the merged map.------ @since 0.5.9-zipWithAMatched :: Applicative f- => (k -> x -> y -> f z)- -> WhenMatched f k x y z-zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y-{-# INLINE zipWithAMatched #-}---- | When a key is found in both maps, apply a function to the--- key and values and maybe use the result in the merged map.------ @--- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)--- -> SimpleWhenMatched k x y z--- @------ @since 0.5.9-zipWithMaybeMatched :: Applicative f- => (k -> x -> y -> Maybe z)- -> WhenMatched f k x y z-zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y-{-# INLINE zipWithMaybeMatched #-}---- | When a key is found in both maps, apply a function to the--- key and values, perform the resulting action, and maybe use--- the result in the merged map.------ This is the fundamental 'WhenMatched' tactic.------ @since 0.5.9-zipWithMaybeAMatched :: (k -> x -> y -> f (Maybe z))- -> WhenMatched f k x y z-zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y-{-# INLINE zipWithMaybeAMatched #-}---- | Drop all the entries whose keys are missing from the other--- map.------ @--- dropMissing :: SimpleWhenMissing k x y--- @------ prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)------ but @dropMissing@ is much faster.------ @since 0.5.9-dropMissing :: Applicative f => WhenMissing f k x y-dropMissing = WhenMissing- { missingSubtree = const (pure Tip)- , missingKey = \_ _ -> pure Nothing }-{-# INLINE dropMissing #-}---- | Preserve, unchanged, the entries whose keys are missing from--- the other map.------ @--- preserveMissing :: SimpleWhenMissing k x x--- @------ prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)------ but @preserveMissing@ is much faster.------ @since 0.5.9-preserveMissing :: Applicative f => WhenMissing f k x x-preserveMissing = WhenMissing- { missingSubtree = pure- , missingKey = \_ v -> pure (Just v) }-{-# INLINE preserveMissing #-}---- | Force the entries whose keys are missing from--- the other map and otherwise preserve them unchanged.------ @--- preserveMissing' :: SimpleWhenMissing k x x--- @------ prop> preserveMissing' = Merge.Lazy.mapMaybeMissing (\_ x -> Just $! x)------ but @preserveMissing'@ is quite a bit faster.------ @since 0.5.9-preserveMissing' :: Applicative f => WhenMissing f k x x-preserveMissing' = WhenMissing- { missingSubtree = \t -> pure $! forceTree t `seq` t- , missingKey = \_ v -> pure $! Just $! v }-{-# INLINE preserveMissing' #-}---- Force all the values in a tree.-forceTree :: Map k a -> ()-forceTree (Bin _ _ v l r) = v `seq` forceTree l `seq` forceTree r `seq` ()-forceTree Tip = ()---- | Map over the entries whose keys are missing from the other map.------ @--- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y--- @------ prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)------ but @mapMissing@ is somewhat faster.------ @since 0.5.9-mapMissing :: Applicative f => (k -> x -> y) -> WhenMissing f k x y-mapMissing f = WhenMissing- { missingSubtree = \m -> pure $! mapWithKey f m- , missingKey = \ k x -> pure $ Just (f k x) }-{-# INLINE mapMissing #-}---- | Map over the entries whose keys are missing from the other map,--- optionally removing some. This is the most powerful 'SimpleWhenMissing'--- tactic, but others are usually more efficient.------ @--- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y--- @------ prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))------ but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.------ @since 0.5.9-mapMaybeMissing :: Applicative f => (k -> x -> Maybe y) -> WhenMissing f k x y-mapMaybeMissing f = WhenMissing- { missingSubtree = \m -> pure $! mapMaybeWithKey f m- , missingKey = \k x -> pure $! f k x }-{-# INLINE mapMaybeMissing #-}---- | Filter the entries whose keys are missing from the other map.------ @--- filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing k x x--- @------ prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x------ but this should be a little faster.------ @since 0.5.9-filterMissing :: Applicative f- => (k -> x -> Bool) -> WhenMissing f k x x-filterMissing f = WhenMissing- { missingSubtree = \m -> pure $! filterWithKey f m- , missingKey = \k x -> pure $! if f k x then Just x else Nothing }-{-# INLINE filterMissing #-}---- | Filter the entries whose keys are missing from the other map--- using some 'Applicative' action.------ @--- filterAMissing f = Merge.Lazy.traverseMaybeMissing $--- \k x -> (\b -> guard b *> Just x) <$> f k x--- @------ but this should be a little faster.------ @since 0.5.9-filterAMissing :: Applicative f- => (k -> x -> f Bool) -> WhenMissing f k x x-filterAMissing f = WhenMissing- { missingSubtree = \m -> filterWithKeyA f m- , missingKey = \k x -> bool Nothing (Just x) <$> f k x }-{-# INLINE filterAMissing #-}---- | This wasn't in Data.Bool until 4.7.0, so we define it here-bool :: a -> a -> Bool -> a-bool f _ False = f-bool _ t True = t---- | Traverse over the entries whose keys are missing from the other map.------ @since 0.5.9-traverseMissing :: Applicative f- => (k -> x -> f y) -> WhenMissing f k x y-traverseMissing f = WhenMissing- { missingSubtree = traverseWithKey f- , missingKey = \k x -> Just <$> f k x }-{-# INLINE traverseMissing #-}---- | Traverse over the entries whose keys are missing from the other map,--- optionally producing values to put in the result.--- This is the most powerful 'WhenMissing' tactic, but others are usually--- more efficient.------ @since 0.5.9-traverseMaybeMissing :: Applicative f- => (k -> x -> f (Maybe y)) -> WhenMissing f k x y-traverseMaybeMissing f = WhenMissing- { missingSubtree = traverseMaybeWithKey f- , missingKey = f }-{-# INLINE traverseMaybeMissing #-}---- | Merge two maps.------ 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched'--- tactic and two maps. It uses the tactics to merge the maps.--- Its behavior is best understood via its fundamental tactics,--- 'mapMaybeMissing' and 'zipWithMaybeMatched'.------ Consider------ @--- merge (mapMaybeMissing g1)--- (mapMaybeMissing g2)--- (zipWithMaybeMatched f)--- m1 m2--- @------ Take, for example,------ @--- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ 'merge' will first \"align\" these maps by key:------ @--- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ It will then pass the individual entries and pairs of entries--- to @g1@, @g2@, or @f@ as appropriate:------ @--- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]--- @------ This produces a 'Maybe' for each key:------ @--- keys = 0 1 2 3 4--- results = [Nothing, Just True, Just False, Nothing, Just True]--- @------ Finally, the @Just@ results are collected into a map:------ @--- return value = [(1, True), (2, False), (4, True)]--- @------ The other tactics below are optimizations or simplifications of--- 'mapMaybeMissing' for special cases. Most importantly,------ * 'dropMissing' drops all the keys.--- * 'preserveMissing' leaves all the entries alone.------ When 'merge' is given three arguments, it is inlined at the call--- site. To prevent excessive inlining, you should typically use 'merge'--- to define your custom combining functions.--------- Examples:------ prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)--- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)--- prop> differenceWith f = merge preserveMissing dropMissing (zipWithMatched f)--- prop> symmetricDifference = merge preserveMissing preserveMissing (zipWithMaybeMatched $ \ _ _ _ -> Nothing)--- prop> mapEachPiece f g h = merge (mapMissing f) (mapMissing g) (zipWithMatched h)------ @since 0.5.9-merge :: Ord k- => SimpleWhenMissing k a c -- ^ What to do with keys in @m1@ but not @m2@- -> SimpleWhenMissing k b c -- ^ What to do with keys in @m2@ but not @m1@- -> SimpleWhenMatched k a b c -- ^ What to do with keys in both @m1@ and @m2@- -> Map k a -- ^ Map @m1@- -> Map k b -- ^ Map @m2@- -> Map k c-merge g1 g2 f m1 m2 = runIdentity $- mergeA g1 g2 f m1 m2-{-# INLINE merge #-}---- | An applicative version of 'merge'.------ 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'--- tactic and two maps. It uses the tactics to merge the maps.--- Its behavior is best understood via its fundamental tactics,--- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.------ Consider------ @--- mergeA (traverseMaybeMissing g1)--- (traverseMaybeMissing g2)--- (zipWithMaybeAMatched f)--- m1 m2--- @------ Take, for example,------ @--- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ @mergeA@ will first \"align\" these maps by key:------ @--- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ It will then pass the individual entries and pairs of entries--- to @g1@, @g2@, or @f@ as appropriate:------ @--- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]--- @------ Next, it will perform the actions in the @actions@ list in order from--- left to right.------ @--- keys = 0 1 2 3 4--- results = [Nothing, Just True, Just False, Nothing, Just True]--- @------ Finally, the @Just@ results are collected into a map:------ @--- return value = [(1, True), (2, False), (4, True)]--- @------ The other tactics below are optimizations or simplifications of--- 'traverseMaybeMissing' for special cases. Most importantly,------ * 'dropMissing' drops all the keys.--- * 'preserveMissing' leaves all the entries alone.--- * 'mapMaybeMissing' does not use the 'Applicative' context.------ When 'mergeA' is given three arguments, it is inlined at the call--- site. To prevent excessive inlining, you should generally only use--- 'mergeA' to define custom combining functions.------ @since 0.5.9-mergeA- :: (Applicative f, Ord k)- => WhenMissing f k a c -- ^ What to do with keys in @m1@ but not @m2@- -> WhenMissing f k b c -- ^ What to do with keys in @m2@ but not @m1@- -> WhenMatched f k a b c -- ^ What to do with keys in both @m1@ and @m2@- -> Map k a -- ^ Map @m1@- -> Map k b -- ^ Map @m2@- -> f (Map k c)-mergeA- WhenMissing{missingSubtree = g1t, missingKey = g1k}- WhenMissing{missingSubtree = g2t}- (WhenMatched f) = go- where- go t1 Tip = g1t t1- go Tip t2 = g2t t2- go (Bin _ kx x1 l1 r1) t2 = case splitLookup kx t2 of- (l2, mx2, r2) -> case mx2 of- Nothing -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')- l1l2 (g1k kx x1) r1r2- Just x2 -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')- l1l2 (f kx x1 x2) r1r2- where- !l1l2 = go l1 l2- !r1r2 = go r1 r2-{-# INLINE mergeA #-}---{--------------------------------------------------------------------- MergeWithKey---------------------------------------------------------------------}---- | /O(n+m)/. An unsafe general combining function.------ WARNING: This function can produce corrupt maps and its results--- may depend on the internal structures of its inputs. Users should--- prefer 'merge' or 'mergeA'.------ When 'mergeWithKey' is given three arguments, it is inlined to the call--- site. You should therefore use 'mergeWithKey' only to define custom--- combining functions. For example, you could define 'unionWithKey',--- 'differenceWithKey' and 'intersectionWithKey' as------ > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2--- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2--- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2------ When calling @'mergeWithKey' combine only1 only2@, a function combining two--- 'Map's is created, such that------ * if a key is present in both maps, it is passed with both corresponding--- values to the @combine@ function. Depending on the result, the key is either--- present in the result with specified value, or is left out;------ * a nonempty subtree present only in the first map is passed to @only1@ and--- the output is added to the result;------ * a nonempty subtree present only in the second map is passed to @only2@ and--- the output is added to the result.------ The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.--- The values can be modified arbitrarily. Most common variants of @only1@ and--- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@,--- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@.--mergeWithKey :: Ord k- => (k -> a -> b -> Maybe c)- -> (Map k a -> Map k c)- -> (Map k b -> Map k c)- -> Map k a -> Map k b -> Map k c-mergeWithKey f g1 g2 = go- where- go Tip t2 = g2 t2- go t1 Tip = g1 t1- go (Bin _ kx x l1 r1) t2 =- case found of- Nothing -> case g1 (singleton kx x) of- Tip -> link2 l' r'- (Bin _ _ x' Tip Tip) -> link kx x' l' r'- _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"- Just x2 -> case f kx x x2 of- Nothing -> link2 l' r'- Just x' -> link kx x' l' r'- where- (l2, found, r2) = splitLookup kx t2- l' = go l1 l2- r' = go r1 r2-{-# INLINE mergeWithKey #-}--{--------------------------------------------------------------------- Submap---------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/.--- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).----isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool-isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2-#if __GLASGOW_HASKELL__-{-# INLINABLE isSubmapOf #-}-#endif--{- | /O(m*log(n\/m + 1)), m <= n/.- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following- expressions are all 'True':-- > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])-- But the following are all 'False':-- > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])-- Note that @isSubmapOfBy (\_ _ -> True) m1 m2@ tests whether all the keys- in @m1@ are also keys in @m2@.---}-isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool-isSubmapOfBy f t1 t2- = size t1 <= size t2 && submap' f t1 t2-#if __GLASGOW_HASKELL__-{-# INLINABLE isSubmapOfBy #-}-#endif---- Test whether a map is a submap of another without the *initial*--- size test. See Data.Set.Internal.isSubsetOfX for notes on--- implementation and analysis.-submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool-submap' _ Tip _ = True-submap' _ _ Tip = False-submap' f (Bin 1 kx x _ _) t- = case lookup kx t of- Just y -> f x y- Nothing -> False-submap' f (Bin _ kx x l r) t- = case found of- Nothing -> False- Just y -> f x y- && size l <= size lt && size r <= size gt- && submap' f l lt && submap' f r gt- where- (lt,found,gt) = splitLookup kx t-#if __GLASGOW_HASKELL__-{-# INLINABLE submap' #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).--- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).-isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool-isProperSubmapOf m1 m2- = isProperSubmapOfBy (==) m1 m2-#if __GLASGOW_HASKELL__-{-# INLINABLE isProperSubmapOf #-}-#endif--{- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when- @keys m1@ and @keys m2@ are not equal,- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following- expressions are all 'True':-- > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])- > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-- But the following are all 'False':-- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])- > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])- > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])----}-isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool-isProperSubmapOfBy f t1 t2- = size t1 < size t2 && submap' f t1 t2-#if __GLASGOW_HASKELL__-{-# INLINABLE isProperSubmapOfBy #-}-#endif--{--------------------------------------------------------------------- Filter and partition---------------------------------------------------------------------}--- | /O(n)/. Filter all values that satisfy the predicate.------ > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty--- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty--filter :: (a -> Bool) -> Map k a -> Map k a-filter p m- = filterWithKey (\_ x -> p x) m---- | /O(n)/. Filter all keys\/values that satisfy the predicate.------ > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a-filterWithKey _ Tip = Tip-filterWithKey p t@(Bin _ kx x l r)- | p kx x = if pl `ptrEq` l && pr `ptrEq` r- then t- else link kx x pl pr- | otherwise = link2 pl pr- where !pl = filterWithKey p l- !pr = filterWithKey p r---- | /O(n)/. Filter keys and values using an 'Applicative'--- predicate.-filterWithKeyA :: Applicative f => (k -> a -> f Bool) -> Map k a -> f (Map k a)-filterWithKeyA _ Tip = pure Tip-filterWithKeyA p t@(Bin _ kx x l r) =- liftA3 combine (p kx x) (filterWithKeyA p l) (filterWithKeyA p r)- where- combine True pl pr- | pl `ptrEq` l && pr `ptrEq` r = t- | otherwise = link kx x pl pr- combine False pl pr = link2 pl pr---- | /O(log n)/. Take while a predicate on the keys holds.--- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,--- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.------ @--- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'--- takeWhileAntitone p = 'filterWithKey' (\k _ -> p k)--- @------ @since 0.5.8--takeWhileAntitone :: (k -> Bool) -> Map k a -> Map k a-takeWhileAntitone _ Tip = Tip-takeWhileAntitone p (Bin _ kx x l r)- | p kx = link kx x l (takeWhileAntitone p r)- | otherwise = takeWhileAntitone p l---- | /O(log n)/. Drop while a predicate on the keys holds.--- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,--- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.------ @--- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'--- dropWhileAntitone p = 'filterWithKey' (\k -> not (p k))--- @------ @since 0.5.8--dropWhileAntitone :: (k -> Bool) -> Map k a -> Map k a-dropWhileAntitone _ Tip = Tip-dropWhileAntitone p (Bin _ kx x l r)- | p kx = dropWhileAntitone p r- | otherwise = link kx x (dropWhileAntitone p l) r---- | /O(log n)/. Divide a map at the point where a predicate on the keys stops holding.--- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,--- @j \< k ==\> p j \>= p k@.------ @--- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)--- spanAntitone p xs = partitionWithKey (\k _ -> p k) xs--- @------ Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map--- at some /unspecified/ point where the predicate switches from holding to not--- holding (where the predicate is seen to hold before the first key and to fail--- after the last key).------ @since 0.5.8--spanAntitone :: (k -> Bool) -> Map k a -> (Map k a, Map k a)-spanAntitone p0 m = toPair (go p0 m)- where- go _ Tip = Tip :*: Tip- go p (Bin _ kx x l r)- | p kx = let u :*: v = go p r in link kx x l u :*: v- | otherwise = let u :*: v = go p l in u :*: link kx x v r---- | /O(n)/. Partition the map according to a predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partition :: (a -> Bool) -> Map k a -> (Map k a,Map k a)-partition p m- = partitionWithKey (\_ x -> p x) m---- | /O(n)/. Partition the map according to a predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")--- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)-partitionWithKey p0 t0 = toPair $ go p0 t0- where- go _ Tip = (Tip :*: Tip)- go p t@(Bin _ kx x l r)- | p kx x = (if l1 `ptrEq` l && r1 `ptrEq` r- then t- else link kx x l1 r1) :*: link2 l2 r2- | otherwise = link2 l1 r1 :*:- (if l2 `ptrEq` l && r2 `ptrEq` r- then t- else link kx x l2 r2)- where- (l1 :*: l2) = go p l- (r1 :*: r2) = go p r---- | /O(n)/. Map values and collect the 'Just' results.------ > let f x = if x == "a" then Just "new a" else Nothing--- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"--mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b-mapMaybe f = mapMaybeWithKey (\_ x -> f x)---- | /O(n)/. Map keys\/values and collect the 'Just' results.------ > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing--- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"--mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b-mapMaybeWithKey _ Tip = Tip-mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of- Just y -> link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)- Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r)---- | /O(n)/. Traverse keys\/values and collect the 'Just' results.------ @since 0.5.8-traverseMaybeWithKey :: Applicative f- => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)-traverseMaybeWithKey = go- where- go _ Tip = pure Tip- go f (Bin _ kx x Tip Tip) = maybe Tip (\x' -> Bin 1 kx x' Tip Tip) <$> f kx x- go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r)- where- combine !l' mx !r' = case mx of- Nothing -> link2 l' r'- Just x' -> link kx x' l' r'---- | /O(n)/. Map values and separate the 'Left' and 'Right' results.------ > let f a = if a < "c" then Left a else Right a--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])--- >--- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)-mapEither f m- = mapEitherWithKey (\_ x -> f x) m---- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.------ > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])--- >--- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])--mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)-mapEitherWithKey f0 t0 = toPair $ go f0 t0- where- go _ Tip = (Tip :*: Tip)- go f (Bin _ kx x l r) = case f kx x of- Left y -> link kx y l1 r1 :*: link2 l2 r2- Right z -> link2 l1 r1 :*: link kx z l2 r2- where- (l1 :*: l2) = go f l- (r1 :*: r2) = go f r--{--------------------------------------------------------------------- Mapping---------------------------------------------------------------------}--- | /O(n)/. Map a function over all values in the map.------ > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]--map :: (a -> b) -> Map k a -> Map k b-map f = go where- go Tip = Tip- go (Bin sx kx x l r) = Bin sx kx (f x) (go l) (go r)--- We use a `go` function to allow `map` to inline. This makes--- a big difference if someone uses `map (const x) m` instead--- of `x <$ m`; it doesn't seem to do any harm.--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] map #-}-{-# RULES-"map/map" forall f g xs . map f (map g xs) = map (f . g) xs- #-}-#endif-#if __GLASGOW_HASKELL__ >= 709--- Safe coercions were introduced in 7.8, but did not work well with RULES yet.-{-# RULES-"map/coerce" map coerce = coerce- #-}-#endif---- | /O(n)/. Map a function over all values in the map.------ > let f key x = (show key) ++ ":" ++ x--- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]--mapWithKey :: (k -> a -> b) -> Map k a -> Map k b-mapWithKey _ Tip = Tip-mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] mapWithKey #-}-{-# RULES-"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =- mapWithKey (\k a -> f k (g k a)) xs-"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =- mapWithKey (\k a -> f k (g a)) xs-"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =- mapWithKey (\k a -> f (g k a)) xs- #-}-#endif---- | /O(n)/.--- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@--- That is, behaves exactly like a regular 'traverse' except that the traversing--- function also has access to the key associated with a value.------ > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])--- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing-traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)-traverseWithKey f = go- where- go Tip = pure Tip- go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v- go (Bin s k v l r) = liftA3 (flip (Bin s k)) (go l) (f k v) (go r)-{-# INLINE traverseWithKey #-}---- | /O(n)/. The function 'mapAccum' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a b = (a ++ b, b ++ "X")--- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])--mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccum f a m- = mapAccumWithKey (\a' _ x' -> f a' x') a m---- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])--mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumWithKey f a t- = mapAccumL f a t---- | /O(n)/. The function 'mapAccumL' threads an accumulating--- argument through the map in ascending order of keys.-mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumL _ a Tip = (a,Tip)-mapAccumL f a (Bin sx kx x l r) =- let (a1,l') = mapAccumL f a l- (a2,x') = f a1 kx x- (a3,r') = mapAccumL f a2 r- in (a3,Bin sx kx x' l' r')---- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating--- argument through the map in descending order of keys.-mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumRWithKey _ a Tip = (a,Tip)-mapAccumRWithKey f a (Bin sx kx x l r) =- let (a1,r') = mapAccumRWithKey f a r- (a2,x') = f a1 kx x- (a3,l') = mapAccumRWithKey f a2 l- in (a3,Bin sx kx x' l' r')---- | /O(n*log n)/.--- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key. In this case the value at the greatest of the--- original keys is retained.------ > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]--- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"--- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"--mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a-mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []-#if __GLASGOW_HASKELL__-{-# INLINABLE mapKeys #-}-#endif---- | /O(n*log n)/.--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key. In this case the associated values will be--- combined using @c@. The value at the greater of the two original keys--- is used as the first argument to @c@.------ > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"--mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a-mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []-#if __GLASGOW_HASKELL__-{-# INLINABLE mapKeysWith #-}-#endif----- | /O(n)/.--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@--- is strictly monotonic.--- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.--- /The precondition is not checked./--- Semi-formally, we have:------ > and [x < y ==> f x < f y | x <- ls, y <- ls]--- > ==> mapKeysMonotonic f s == mapKeys f s--- > where ls = keys s------ This means that @f@ maps distinct original keys to distinct resulting keys.--- This function has better performance than 'mapKeys'.------ > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]--- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True--- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False--mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a-mapKeysMonotonic _ Tip = Tip-mapKeysMonotonic f (Bin sz k x l r) =- Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)--{--------------------------------------------------------------------- Folds---------------------------------------------------------------------}---- | /O(n)/. Fold the values in the map using the given right-associative--- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.------ For example,------ > elems map = foldr (:) [] map------ > let f a len = len + (length a)--- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-foldr :: (a -> b -> b) -> b -> Map k a -> b-foldr f z = go z- where- go z' Tip = z'- go z' (Bin _ _ x l r) = go (f x (go z' r)) l-{-# INLINE foldr #-}---- | /O(n)/. A strict version of 'foldr'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldr' :: (a -> b -> b) -> b -> Map k a -> b-foldr' f z = go z- where- go !z' Tip = z'- go z' (Bin _ _ x l r) = go (f x $! go z' r) l-{-# INLINE foldr' #-}---- | /O(n)/. Fold the values in the map using the given left-associative--- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.------ For example,------ > elems = reverse . foldl (flip (:)) []------ > let f len a = len + (length a)--- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-foldl :: (a -> b -> a) -> a -> Map k b -> a-foldl f z = go z- where- go z' Tip = z'- go z' (Bin _ _ x l r) = go (f (go z' l) x) r-{-# INLINE foldl #-}---- | /O(n)/. A strict version of 'foldl'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldl' :: (a -> b -> a) -> a -> Map k b -> a-foldl' f z = go z- where- go !z' Tip = z'- go z' (Bin _ _ x l r) =- let !z'' = go z' l- in go (f z'' x) r-{-# INLINE foldl' #-}---- | /O(n)/. Fold the keys and values in the map using the given right-associative--- binary operator, such that--- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.------ For example,------ > keys map = foldrWithKey (\k x ks -> k:ks) [] map------ > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"-foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b-foldrWithKey f z = go z- where- go z' Tip = z'- go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l-{-# INLINE foldrWithKey #-}---- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b-foldrWithKey' f z = go z- where- go !z' Tip = z'- go z' (Bin _ kx x l r) = go (f kx x $! go z' r) l-{-# INLINE foldrWithKey' #-}---- | /O(n)/. Fold the keys and values in the map using the given left-associative--- binary operator, such that--- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.------ For example,------ > keys = reverse . foldlWithKey (\ks k x -> k:ks) []------ > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"-foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a-foldlWithKey f z = go z- where- go z' Tip = z'- go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r-{-# INLINE foldlWithKey #-}---- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a-foldlWithKey' f z = go z- where- go !z' Tip = z'- go z' (Bin _ kx x l r) =- let !z'' = go z' l- in go (f z'' kx x) r-{-# INLINE foldlWithKey' #-}---- | /O(n)/. Fold the keys and values in the map using the given monoid, such that------ @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@------ This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.------ @since 0.5.4-foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m-foldMapWithKey f = go- where- go Tip = mempty- go (Bin 1 k v _ _) = f k v- go (Bin _ k v l r) = go l `mappend` (f k v `mappend` go r)-{-# INLINE foldMapWithKey #-}--{--------------------------------------------------------------------- List variations---------------------------------------------------------------------}--- | /O(n)/.--- Return all elements of the map in the ascending order of their keys.--- Subject to list fusion.------ > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]--- > elems empty == []--elems :: Map k a -> [a]-elems = foldr (:) []---- | /O(n)/. Return all keys of the map in ascending order. Subject to list--- fusion.------ > keys (fromList [(5,"a"), (3,"b")]) == [3,5]--- > keys empty == []--keys :: Map k a -> [k]-keys = foldrWithKey (\k _ ks -> k : ks) []---- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map--- in ascending key order. Subject to list fusion.------ > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > assocs empty == []--assocs :: Map k a -> [(k,a)]-assocs m- = toAscList m---- | /O(n)/. The set of all keys of the map.------ > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]--- > keysSet empty == Data.Set.empty--keysSet :: Map k a -> Set.Set k-keysSet Tip = Set.Tip-keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r)---- | /O(n)/. Build a map from a set of keys and a function which for each key--- computes its value.------ > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]--- > fromSet undefined Data.Set.empty == empty--fromSet :: (k -> a) -> Set.Set k -> Map k a-fromSet _ Set.Tip = Tip-fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r)--{--------------------------------------------------------------------- Lists---------------------------------------------------------------------}-#if __GLASGOW_HASKELL__ >= 708--- | @since 0.5.6.2-instance (Ord k) => GHCExts.IsList (Map k v) where- type Item (Map k v) = (k,v)- fromList = fromList- toList = toList-#endif---- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.--- If the list contains more than one value for the same key, the last value--- for the key is retained.------ If the keys of the list are ordered, linear-time implementation is used,--- with the performance equal to 'fromDistinctAscList'.------ > fromList [] == empty--- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]--- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]---- For some reason, when 'singleton' is used in fromList or in--- create, it is not inlined, so we inline it manually.-fromList :: Ord k => [(k,a)] -> Map k a-fromList [] = Tip-fromList [(kx, x)] = Bin 1 kx x Tip Tip-fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0- | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0- where- not_ordered _ [] = False- not_ordered kx ((ky,_) : _) = kx >= ky- {-# INLINE not_ordered #-}-- fromList' t0 xs = Foldable.foldl' ins t0 xs- where ins t (k,x) = insert k x t-- go !_ t [] = t- go _ t [(kx, x)] = insertMax kx x t- go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs- | otherwise = case create s xss of- (r, ys, []) -> go (s `shiftL` 1) (link kx x l r) ys- (r, _, ys) -> fromList' (link kx x l r) ys-- -- The create is returning a triple (tree, xs, ys). Both xs and ys- -- represent not yet processed elements and only one of them can be nonempty.- -- If ys is nonempty, the keys in ys are not ordered with respect to tree- -- and must be inserted using fromList'. Otherwise the keys have been- -- ordered so far.- create !_ [] = (Tip, [], [])- create s xs@(xp : xss)- | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss)- | otherwise -> (Bin 1 kx x Tip Tip, xss, [])- | otherwise = case create (s `shiftR` 1) xs of- res@(_, [], _) -> res- (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs)- (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)- | otherwise -> case create (s `shiftR` 1) yss of- (r, zs, ws) -> (link ky y l r, zs, ws)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromList #-}-#endif---- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.------ > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]--- > fromListWith (++) [] == empty--fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a-fromListWith f xs- = fromListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromListWith #-}-#endif---- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.------ > let f k a1 a2 = (show k) ++ a1 ++ a2--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]--- > fromListWithKey f [] == empty--fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromListWithKey f xs- = Foldable.foldl' ins empty xs- where- ins t (k,x) = insertWithKey f k x t-#if __GLASGOW_HASKELL__-{-# INLINABLE fromListWithKey #-}-#endif---- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list fusion.------ > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > toList empty == []--toList :: Map k a -> [(k,a)]-toList = toAscList---- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are--- in ascending order. Subject to list fusion.------ > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--toAscList :: Map k a -> [(k,a)]-toAscList = foldrWithKey (\k x xs -> (k,x):xs) []---- | /O(n)/. Convert the map to a list of key\/value pairs where the keys--- are in descending order. Subject to list fusion.------ > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]--toDescList :: Map k a -> [(k,a)]-toDescList = foldlWithKey (\xs k x -> (k,x):xs) []---- List fusion for the list generating functions.-#if __GLASGOW_HASKELL__--- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.--- They are important to convert unfused methods back, see mapFB in prelude.-foldrFB :: (k -> a -> b -> b) -> b -> Map k a -> b-foldrFB = foldrWithKey-{-# INLINE[0] foldrFB #-}-foldlFB :: (a -> k -> b -> a) -> a -> Map k b -> a-foldlFB = foldlWithKey-{-# INLINE[0] foldlFB #-}---- Inline assocs and toList, so that we need to fuse only toAscList.-{-# INLINE assocs #-}-{-# INLINE toList #-}---- The fusion is enabled up to phase 2 included. If it does not succeed,--- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to--- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were--- used in a list fusion, otherwise it would go away in phase 1), and let compiler--- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to--- inline it before phase 0, otherwise the fusion rules would not fire at all.-{-# NOINLINE[0] elems #-}-{-# NOINLINE[0] keys #-}-{-# NOINLINE[0] toAscList #-}-{-# NOINLINE[0] toDescList #-}-{-# RULES "Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}-{-# RULES "Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}-{-# RULES "Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}-{-# RULES "Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}-{-# RULES "Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}-{-# RULES "Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}-{-# RULES "Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}-{-# RULES "Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}-#endif--{--------------------------------------------------------------------- Building trees from ascending/descending lists can be done in linear time.-- Note that if [xs] is ascending that:- fromAscList xs == fromList xs- fromAscListWith f xs == fromListWith f xs---------------------------------------------------------------------}--- | /O(n)/. Build a map from an ascending list in linear time.--- /The precondition (input list is ascending) is not checked./------ > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]--- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True--- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False--fromAscList :: Eq k => [(k,a)] -> Map k a-fromAscList xs- = fromDistinctAscList (combineEq xs)- where- -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]- combineEq xs'- = case xs' of- [] -> []- [x] -> [x]- (x:xx) -> combineEq' x xx-- combineEq' z [] = [z]- combineEq' z@(kz,_) (x@(kx,xx):xs')- | kx==kz = combineEq' (kx,xx) xs'- | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscList #-}-#endif---- | /O(n)/. Build a map from a descending list in linear time.--- /The precondition (input list is descending) is not checked./------ > fromDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]--- > fromDescList [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "b")]--- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True--- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False------ @since 0.5.8--fromDescList :: Eq k => [(k,a)] -> Map k a-fromDescList xs = fromDistinctDescList (combineEq xs)- where- -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]- combineEq xs'- = case xs' of- [] -> []- [x] -> [x]- (x:xx) -> combineEq' x xx-- combineEq' z [] = [z]- combineEq' z@(kz,_) (x@(kx,xx):xs')- | kx==kz = combineEq' (kx,xx) xs'- | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescList #-}-#endif---- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.--- /The precondition (input list is ascending) is not checked./------ > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]--- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True--- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False--fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a-fromAscListWith f xs- = fromAscListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscListWith #-}-#endif---- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys.--- /The precondition (input list is descending) is not checked./------ > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")]--- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True--- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False------ @since 0.5.8--fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a-fromDescListWith f xs- = fromDescListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescListWith #-}-#endif---- | /O(n)/. Build a map from an ascending list in linear time with a--- combining function for equal keys.--- /The precondition (input list is ascending) is not checked./------ > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2--- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]--- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True--- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False--fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromAscListWithKey f xs- = fromDistinctAscList (combineEq f xs)- where- -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]- combineEq _ xs'- = case xs' of- [] -> []- [x] -> [x]- (x:xx) -> combineEq' x xx-- combineEq' z [] = [z]- combineEq' z@(kz,zz) (x@(kx,xx):xs')- | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs'- | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscListWithKey #-}-#endif---- | /O(n)/. Build a map from a descending list in linear time with a--- combining function for equal keys.--- /The precondition (input list is descending) is not checked./------ > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2--- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]--- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True--- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False-fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromDescListWithKey f xs- = fromDistinctDescList (combineEq f xs)- where- -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]- combineEq _ xs'- = case xs' of- [] -> []- [x] -> [x]- (x:xx) -> combineEq' x xx-- combineEq' z [] = [z]- combineEq' z@(kz,zz) (x@(kx,xx):xs')- | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs'- | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescListWithKey #-}-#endif----- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.--- /The precondition is not checked./------ > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]--- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True--- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False---- For some reason, when 'singleton' is used in fromDistinctAscList or in--- create, it is not inlined, so we inline it manually.-fromDistinctAscList :: [(k,a)] -> Map k a-fromDistinctAscList [] = Tip-fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0- where- go !_ t [] = t- go s l ((kx, x) : xs) = case create s xs of- (r :*: ys) -> let !t' = link kx x l r- in go (s `shiftL` 1) t' ys-- create !_ [] = (Tip :*: [])- create s xs@(x' : xs')- | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')- | otherwise = case create (s `shiftR` 1) xs of- res@(_ :*: []) -> res- (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of- (r :*: zs) -> (link ky y l r :*: zs)---- | /O(n)/. Build a map from a descending list of distinct elements in linear time.--- /The precondition is not checked./------ > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]--- > valid (fromDistinctDescList [(5,"a"), (3,"b")]) == True--- > valid (fromDistinctDescList [(5,"a"), (5,"b"), (3,"b")]) == False------ @since 0.5.8---- For some reason, when 'singleton' is used in fromDistinctDescList or in--- create, it is not inlined, so we inline it manually.-fromDistinctDescList :: [(k,a)] -> Map k a-fromDistinctDescList [] = Tip-fromDistinctDescList ((kx0, x0) : xs0) = go (1 :: Int) (Bin 1 kx0 x0 Tip Tip) xs0- where- go !_ t [] = t- go s r ((kx, x) : xs) = case create s xs of- (l :*: ys) -> let !t' = link kx x l r- in go (s `shiftL` 1) t' ys-- create !_ [] = (Tip :*: [])- create s xs@(x' : xs')- | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')- | otherwise = case create (s `shiftR` 1) xs of- res@(_ :*: []) -> res- (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of- (l :*: zs) -> (link ky y l r :*: zs)--{---- Functions very similar to these were used to implement--- hedge union, intersection, and difference algorithms that we no--- longer use. These functions, however, seem likely to be useful--- in their own right, so I'm leaving them here in case we end up--- exporting them.--{--------------------------------------------------------------------- [filterGt b t] filter all keys >[b] from tree [t]- [filterLt b t] filter all keys <[b] from tree [t]---------------------------------------------------------------------}-filterGt :: Ord k => k -> Map k v -> Map k v-filterGt !_ Tip = Tip-filterGt !b (Bin _ kx x l r) =- case compare b kx of LT -> link kx x (filterGt b l) r- EQ -> r- GT -> filterGt b r-#if __GLASGOW_HASKELL__-{-# INLINABLE filterGt #-}-#endif--filterLt :: Ord k => k -> Map k v -> Map k v-filterLt !_ Tip = Tip-filterLt !b (Bin _ kx x l r) =- case compare kx b of LT -> link kx x l (filterLt b r)- EQ -> l- GT -> filterLt b l-#if __GLASGOW_HASKELL__-{-# INLINABLE filterLt #-}-#endif--}--{--------------------------------------------------------------------- Split---------------------------------------------------------------------}--- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where--- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.--- Any key equal to @k@ is found in neither @map1@ nor @map2@.------ > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])--- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")--- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)--- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)--split :: Ord k => k -> Map k a -> (Map k a,Map k a)-split !k0 t0 = toPair $ go k0 t0- where- go k t =- case t of- Tip -> Tip :*: Tip- Bin _ kx x l r -> case compare k kx of- LT -> let (lt :*: gt) = go k l in lt :*: link kx x gt r- GT -> let (lt :*: gt) = go k r in link kx x l lt :*: gt- EQ -> (l :*: r)-#if __GLASGOW_HASKELL__-{-# INLINABLE split #-}-#endif---- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just--- like 'split' but also returns @'lookup' k map@.------ > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])--- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")--- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")--- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)--- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)-splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)-splitLookup k0 m = case go k0 m of- StrictTriple l mv r -> (l, mv, r)- where- go :: Ord k => k -> Map k a -> StrictTriple (Map k a) (Maybe a) (Map k a)- go !k t =- case t of- Tip -> StrictTriple Tip Nothing Tip- Bin _ kx x l r -> case compare k kx of- LT -> let StrictTriple lt z gt = go k l- !gt' = link kx x gt r- in StrictTriple lt z gt'- GT -> let StrictTriple lt z gt = go k r- !lt' = link kx x l lt- in StrictTriple lt' z gt- EQ -> StrictTriple l (Just x) r-#if __GLASGOW_HASKELL__-{-# INLINABLE splitLookup #-}-#endif---- | A variant of 'splitLookup' that indicates only whether the--- key was present, rather than producing its value. This is used to--- implement 'intersection' to avoid allocating unnecessary 'Just'--- constructors.-splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)-splitMember k0 m = case go k0 m of- StrictTriple l mv r -> (l, mv, r)- where- go :: Ord k => k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)- go !k t =- case t of- Tip -> StrictTriple Tip False Tip- Bin _ kx x l r -> case compare k kx of- LT -> let StrictTriple lt z gt = go k l- !gt' = link kx x gt r- in StrictTriple lt z gt'- GT -> let StrictTriple lt z gt = go k r- !lt' = link kx x l lt- in StrictTriple lt' z gt- EQ -> StrictTriple l True r-#if __GLASGOW_HASKELL__-{-# INLINABLE splitMember #-}-#endif--data StrictTriple a b c = StrictTriple !a !b !c--{--------------------------------------------------------------------- Utility functions that maintain the balance properties of the tree.- All constructors assume that all values in [l] < [k] and all values- in [r] > [k], and that [l] and [r] are valid trees.-- In order of sophistication:- [Bin sz k x l r] The type constructor.- [bin k x l r] Maintains the correct size, assumes that both [l]- and [r] are balanced with respect to each other.- [balance k x l r] Restores the balance and size.- Assumes that the original tree was balanced and- that [l] or [r] has changed by at most one element.- [link k x l r] Restores balance and size.-- Furthermore, we can construct a new tree from two trees. Both operations- assume that all values in [l] < all values in [r] and that [l] and [r]- are valid:- [glue l r] Glues [l] and [r] together. Assumes that [l] and- [r] are already balanced with respect to each other.- [link2 l r] Merges two trees and restores balance.---------------------------------------------------------------------}--{--------------------------------------------------------------------- Link---------------------------------------------------------------------}-link :: k -> a -> Map k a -> Map k a -> Map k a-link kx x Tip r = insertMin kx x r-link kx x l Tip = insertMax kx x l-link kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)- | delta*sizeL < sizeR = balanceL kz z (link kx x l lz) rz- | delta*sizeR < sizeL = balanceR ky y ly (link kx x ry r)- | otherwise = bin kx x l r----- insertMin and insertMax don't perform potentially expensive comparisons.-insertMax,insertMin :: k -> a -> Map k a -> Map k a-insertMax kx x t- = case t of- Tip -> singleton kx x- Bin _ ky y l r- -> balanceR ky y l (insertMax kx x r)--insertMin kx x t- = case t of- Tip -> singleton kx x- Bin _ ky y l r- -> balanceL ky y (insertMin kx x l) r--{--------------------------------------------------------------------- [link2 l r]: merges two trees.---------------------------------------------------------------------}-link2 :: Map k a -> Map k a -> Map k a-link2 Tip r = r-link2 l Tip = l-link2 l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)- | delta*sizeL < sizeR = balanceL ky y (link2 l ly) ry- | delta*sizeR < sizeL = balanceR kx x lx (link2 rx r)- | otherwise = glue l r--{--------------------------------------------------------------------- [glue l r]: glues two trees together.- Assumes that [l] and [r] are already balanced with respect to each other.---------------------------------------------------------------------}-glue :: Map k a -> Map k a -> Map k a-glue Tip r = r-glue l Tip = l-glue l@(Bin sl kl xl ll lr) r@(Bin sr kr xr rl rr)- | sl > sr = let !(MaxView km m l') = maxViewSure kl xl ll lr in balanceR km m l' r- | otherwise = let !(MinView km m r') = minViewSure kr xr rl rr in balanceL km m l r'--data MinView k a = MinView !k a !(Map k a)-data MaxView k a = MaxView !k a !(Map k a)--minViewSure :: k -> a -> Map k a -> Map k a -> MinView k a-minViewSure = go- where- go k x Tip r = MinView k x r- go k x (Bin _ kl xl ll lr) r =- case go kl xl ll lr of- MinView km xm l' -> MinView km xm (balanceR k x l' r)-{-# NOINLINE minViewSure #-}--maxViewSure :: k -> a -> Map k a -> Map k a -> MaxView k a-maxViewSure = go- where- go k x l Tip = MaxView k x l- go k x l (Bin _ kr xr rl rr) =- case go kr xr rl rr of- MaxView km xm r' -> MaxView km xm (balanceL k x l r')-{-# NOINLINE maxViewSure #-}---- | /O(log n)/. Delete and find the minimal element.------ > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])--- > deleteFindMin empty Error: can not return the minimal element of an empty map--deleteFindMin :: Map k a -> ((k,a),Map k a)-deleteFindMin t = case minViewWithKey t of- Nothing -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)- Just res -> res---- | /O(log n)/. Delete and find the maximal element.------ > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])--- > deleteFindMax empty Error: can not return the maximal element of an empty map--deleteFindMax :: Map k a -> ((k,a),Map k a)-deleteFindMax t = case maxViewWithKey t of- Nothing -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)- Just res -> res--{--------------------------------------------------------------------- [balance l x r] balances two trees with value x.- The sizes of the trees should balance after decreasing the- size of one of them. (a rotation).-- [delta] is the maximal relative difference between the sizes of- two trees, it corresponds with the [w] in Adams' paper.- [ratio] is the ratio between an outer and inner sibling of the- heavier subtree in an unbalanced setting. It determines- whether a double or single rotation should be performed- to restore balance. It is corresponds with the inverse- of $\alpha$ in Adam's article.-- Note that according to the Adam's paper:- - [delta] should be larger than 4.646 with a [ratio] of 2.- - [delta] should be larger than 3.745 with a [ratio] of 1.534.-- But the Adam's paper is erroneous:- - It can be proved that for delta=2 and delta>=5 there does- not exist any ratio that would work.- - Delta=4.5 and ratio=2 does not work.-- That leaves two reasonable variants, delta=3 and delta=4,- both with ratio=2.-- - A lower [delta] leads to a more 'perfectly' balanced tree.- - A higher [delta] performs less rebalancing.-- In the benchmarks, delta=3 is faster on insert operations,- and delta=4 has slightly better deletes. As the insert speedup- is larger, we currently use delta=3.----------------------------------------------------------------------}-delta,ratio :: Int-delta = 3-ratio = 2---- The balance function is equivalent to the following:------ balance :: k -> a -> Map k a -> Map k a -> Map k a--- balance k x l r--- | sizeL + sizeR <= 1 = Bin sizeX k x l r--- | sizeR > delta*sizeL = rotateL k x l r--- | sizeL > delta*sizeR = rotateR k x l r--- | otherwise = Bin sizeX k x l r--- where--- sizeL = size l--- sizeR = size r--- sizeX = sizeL + sizeR + 1------ rotateL :: a -> b -> Map a b -> Map a b -> Map a b--- rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r--- | otherwise = doubleL k x l r------ rotateR :: a -> b -> Map a b -> Map a b -> Map a b--- rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r--- | otherwise = doubleR k x l r------ singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b--- singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3--- singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)------ doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b--- 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)--- 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)------ It is only written in such a way that every node is pattern-matched only once.--balance :: k -> a -> Map k a -> Map k a -> Map k a-balance k x l r = case l of- Tip -> case r of- Tip -> Bin 1 k x Tip Tip- (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r- (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr- (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)- (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))- | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr- | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)-- (Bin ls lk lx ll lr) -> case r of- Tip -> case (ll, lr) of- (Tip, Tip) -> Bin 2 k x l Tip- (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)- ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)- ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr))- | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)- | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)- (Bin rs rk rx rl rr)- | rs > delta*ls -> case (rl, rr) of- (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)- | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr- | 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)- (_, _) -> error "Failure in Data.Map.balance"- | ls > delta*rs -> case (ll, lr) of- (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)- | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)- | 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)- (_, _) -> error "Failure in Data.Map.balance"- | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balance #-}---- Functions balanceL and balanceR are specialised versions of balance.--- balanceL only checks whether the left subtree is too big,--- balanceR only checks whether the right subtree is too big.---- balanceL is called when left subtree might have been inserted to or when--- right subtree might have been deleted from.-balanceL :: k -> a -> Map k a -> Map k a -> Map k a-balanceL k x l r = case r of- Tip -> case l of- Tip -> Bin 1 k x Tip Tip- (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip- (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)- (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)- (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))- | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)- | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)-- (Bin rs _ _ _ _) -> case l of- Tip -> Bin (1+rs) k x Tip r-- (Bin ls lk lx ll lr)- | ls > delta*rs -> case (ll, lr) of- (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)- | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)- | 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)- (_, _) -> error "Failure in Data.Map.balanceL"- | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceL #-}---- balanceR is called when right subtree might have been inserted to or when--- left subtree might have been deleted from.-balanceR :: k -> a -> Map k a -> Map k a -> Map k a-balanceR k x l r = case l of- Tip -> case r of- Tip -> Bin 1 k x Tip Tip- (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r- (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr- (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)- (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))- | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr- | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)-- (Bin ls _ _ _ _) -> case r of- Tip -> Bin (1+ls) k x l Tip-- (Bin rs rk rx rl rr)- | rs > delta*ls -> case (rl, rr) of- (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)- | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr- | 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)- (_, _) -> error "Failure in Data.Map.balanceR"- | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceR #-}---{--------------------------------------------------------------------- The bin constructor maintains the size of the tree---------------------------------------------------------------------}-bin :: k -> a -> Map k a -> Map k a -> Map k a-bin k x l r- = Bin (size l + size r + 1) k x l r-{-# INLINE bin #-}---{--------------------------------------------------------------------- Eq converts the tree to a list. In a lazy setting, this- actually seems one of the faster methods to compare two trees- and it is certainly the simplest :-)---------------------------------------------------------------------}-instance (Eq k,Eq a) => Eq (Map k a) where- t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)--{--------------------------------------------------------------------- Ord---------------------------------------------------------------------}--instance (Ord k, Ord v) => Ord (Map k v) where- compare m1 m2 = compare (toAscList m1) (toAscList m2)--#if MIN_VERSION_base(4,9,0)-{--------------------------------------------------------------------- Lifted instances---------------------------------------------------------------------}---- | @since 0.5.9-instance Eq2 Map where- liftEq2 eqk eqv m n =- size m == size n && liftEq (liftEq2 eqk eqv) (toList m) (toList n)---- | @since 0.5.9-instance Eq k => Eq1 (Map k) where- liftEq = liftEq2 (==)---- | @since 0.5.9-instance Ord2 Map where- liftCompare2 cmpk cmpv m n =- liftCompare (liftCompare2 cmpk cmpv) (toList m) (toList n)---- | @since 0.5.9-instance Ord k => Ord1 (Map k) where- liftCompare = liftCompare2 compare---- | @since 0.5.9-instance Show2 Map where- liftShowsPrec2 spk slk spv slv d m =- showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)- where- sp = liftShowsPrec2 spk slk spv slv- sl = liftShowList2 spk slk spv slv---- | @since 0.5.9-instance Show k => Show1 (Map k) where- liftShowsPrec = liftShowsPrec2 showsPrec showList---- | @since 0.5.9-instance (Ord k, Read k) => Read1 (Map k) where- liftReadsPrec rp rl = readsData $- readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList- where- rp' = liftReadsPrec rp rl- rl' = liftReadList rp rl-#endif--{--------------------------------------------------------------------- Functor---------------------------------------------------------------------}-instance Functor (Map k) where- fmap f m = map f m-#ifdef __GLASGOW_HASKELL__- _ <$ Tip = Tip- a <$ (Bin sx kx _ l r) = Bin sx kx a (a <$ l) (a <$ r)-#endif---- | Traverses in order of increasing key.-instance Traversable (Map k) where- traverse f = traverseWithKey (\_ -> f)- {-# INLINE traverse #-}---- | Folds in order of increasing key.-instance Foldable.Foldable (Map k) where- fold = go- where go Tip = mempty- go (Bin 1 _ v _ _) = v- go (Bin _ _ v l r) = go l `mappend` (v `mappend` go r)- {-# INLINABLE fold #-}- foldr = foldr- {-# INLINE foldr #-}- foldl = foldl- {-# INLINE foldl #-}- foldMap f t = go t- where go Tip = mempty- go (Bin 1 _ v _ _) = f v- go (Bin _ _ v l r) = go l `mappend` (f v `mappend` go r)- {-# INLINE foldMap #-}- foldl' = foldl'- {-# INLINE foldl' #-}- foldr' = foldr'- {-# INLINE foldr' #-}-#if MIN_VERSION_base(4,8,0)- length = size- {-# INLINE length #-}- null = null- {-# INLINE null #-}- toList = elems -- NB: Foldable.toList /= Map.toList- {-# INLINE toList #-}- elem = go- where go !_ Tip = False- go x (Bin _ _ v l r) = x == v || go x l || go x r- {-# INLINABLE elem #-}- maximum = start- where start Tip = error "Data.Foldable.maximum (for Data.Map): empty map"- start (Bin _ _ v l r) = go (go v l) r-- go !m Tip = m- go m (Bin _ _ v l r) = go (go (max m v) l) r- {-# INLINABLE maximum #-}- minimum = start- where start Tip = error "Data.Foldable.minimum (for Data.Map): empty map"- start (Bin _ _ v l r) = go (go v l) r-- go !m Tip = m- go m (Bin _ _ v l r) = go (go (min m v) l) r- {-# INLINABLE minimum #-}- sum = foldl' (+) 0- {-# INLINABLE sum #-}- product = foldl' (*) 1- {-# INLINABLE product #-}-#endif--#if MIN_VERSION_base(4,10,0)--- | @since 0.6.3.1-instance Bifoldable Map where- bifold = go- where go Tip = mempty- go (Bin 1 k v _ _) = k `mappend` v- go (Bin _ k v l r) = go l `mappend` (k `mappend` (v `mappend` go r))- {-# INLINABLE bifold #-}- bifoldr f g z = go z- where go z' Tip = z'- go z' (Bin _ k v l r) = go (f k (g v (go z' r))) l- {-# INLINE bifoldr #-}- bifoldl f g z = go z- where go z' Tip = z'- go z' (Bin _ k v l r) = go (g (f (go z' l) k) v) r- {-# INLINE bifoldl #-}- bifoldMap f g t = go t- where go Tip = mempty- go (Bin 1 k v _ _) = f k `mappend` g v- go (Bin _ k v l r) = go l `mappend` (f k `mappend` (g v `mappend` go r))- {-# INLINE bifoldMap #-}-#endif--instance (NFData k, NFData a) => NFData (Map k a) where- rnf Tip = ()- rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r--{--------------------------------------------------------------------- Read---------------------------------------------------------------------}-instance (Ord k, Read k, Read e) => Read (Map k e) where-#ifdef __GLASGOW_HASKELL__- readPrec = parens $ prec 10 $ do- Ident "fromList" <- lexP- xs <- readPrec- return (fromList xs)-- readListPrec = readListPrecDefault-#else- readsPrec p = readParen (p > 10) $ \ r -> do- ("fromList",s) <- lex r- (xs,t) <- reads s- return (fromList xs,t)-#endif--{--------------------------------------------------------------------- Show---------------------------------------------------------------------}-instance (Show k, Show a) => Show (Map k a) where- showsPrec d m = showParen (d > 10) $- showString "fromList " . shows (toList m)--{--------------------------------------------------------------------- Typeable---------------------------------------------------------------------}--INSTANCE_TYPEABLE2(Map)--{--------------------------------------------------------------------- Utilities---------------------------------------------------------------------}---- | /O(1)/. Decompose a map into pieces based on the structure of the underlying+#if defined(__GLASGOW_HASKELL__)+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+#define USE_MAGIC_PROXY 1+#endif++#ifdef USE_MAGIC_PROXY+{-# LANGUAGE MagicHash #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++#include "containers.h"++#if !(WORD_SIZE_IN_BITS >= 61)+#define DEFINE_ALTERF_FALLBACK 1+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Data.Map.Internal+-- Copyright : (c) Daan Leijen 2002+-- (c) Andriy Palamarchuk 2008+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Portability : portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Maps (lazy interface internals)+--+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@. A 'Map' is strict in its keys+-- but lazy in its values.+--+--+-- == Implementation+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+-- * Stephen Adams, \"/Efficient sets—a balancing act/\",+-- Journal of Functional Programming 3(4):553-562, October 1993,+-- <https://doi.org/10.1017/S0956796800000885>,+-- <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>.+-- * J. Nievergelt and E.M. Reingold,+-- \"/Binary search trees of bounded balance/\",+-- SIAM journal of computing 2(1), March 1973.+-- <https://doi.org/10.1137/0202005>.+-- * Yoichi Hirai and Kazuhiko Yamamoto,+-- \"/Balancing weight-balanced trees/\",+-- Journal of Functional Programming 21(3):287-307, 2011,+-- <https://doi.org/10.1017/S0956796811000104>+--+-- Bounds for 'union', 'intersection', and 'difference' are as given+-- by+--+-- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+-- \"/Parallel Ordered Sets Using Join/\",+-- <https://arxiv.org/abs/1602.02120v4>.+--+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: Using INLINABLE]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- It is crucial to the performance that the functions specialize on the Ord+-- type when possible. GHC 7.0 and higher does this by itself when it sees th+-- unfolding of a function -- that is why all public functions are marked+-- INLINABLE (that exposes the unfolding).+++-- [Note: Using INLINE]+-- ~~~~~~~~~~~~~~~~~~~~+-- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.+-- We mark the functions that just navigate down the tree (lookup, insert,+-- delete and similar). That navigation code gets inlined and thus specialized+-- when possible. There is a price to pay -- code growth. The code INLINED is+-- therefore only the tree navigation, all the real work (rebalancing) is not+-- INLINED by using a NOINLINE.+--+-- All methods marked INLINE have to be nonrecursive -- a 'go' function doing+-- the real work is provided.+++-- [Note: Type of local 'go' function]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- If the local 'go' function uses an Ord class, it sometimes heap-allocates+-- the Ord dictionary when the 'go' function does not have explicit type.+-- In that case we give 'go' explicit type. But this slightly decrease+-- performance, as the resulting 'go' function can float out to top level.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- As opposed to Map, when 'go' function captures an argument, increased+-- heap-allocation can occur: sometimes in a polymorphic function, the 'go'+-- floats out of its enclosing function and then it heap-allocates the+-- dictionary and the argument. Maybe it floats out too late and strictness+-- analyzer cannot see that these could be passed on stack.+--++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of Map matters when considering performance.+-- Currently in GHC 7.0, when type has 2 constructors, a forward conditional+-- jump is made when successfully matching second constructor. Successful match+-- of first constructor results in the forward jump not taken.+-- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip+-- improves the benchmark by up to 10% on x86.++module Data.Map.Internal (+ -- * Map type+ Map(..) -- instance Eq,Show,Read+ , Size++ -- * Operators+ , (!), (!?), (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault+ , lookupLT+ , lookupGT+ , lookupLE+ , lookupGE++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith+ , insertWithKey+ , insertLookupWithKey++ -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter+ , alterF++ -- * Combine++ -- ** Union+ , union+ , unionWith+ , unionWithKey+ , unions+ , unionsWith++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey++ -- ** Intersection+ , intersection+ , intersectionWith+ , intersectionWithKey++ -- ** Symmetric difference+ , symmetricDifference++ -- ** Disjoint+ , disjoint++ -- ** Compose+ , compose++ -- ** General combining function+ , SimpleWhenMissing+ , SimpleWhenMatched+ , runWhenMatched+ , runWhenMissing+ , merge+ -- *** @WhenMatched@ tactics+ , zipWithMaybeMatched+ , zipWithMatched+ -- *** @WhenMissing@ tactics+ , mapMaybeMissing+ , dropMissing+ , preserveMissing+ , preserveMissing'+ , mapMissing+ , filterMissing++ -- ** Applicative general combining function+ , WhenMissing (..)+ , WhenMatched (..)+ , mergeA++ -- *** @WhenMatched@ tactics+ -- | The tactics described for 'merge' work for+ -- 'mergeA' as well. Furthermore, the following+ -- are available.+ , zipWithMaybeAMatched+ , zipWithAMatched++ -- *** @WhenMissing@ tactics+ -- | The tactics described for 'merge' work for+ -- 'mergeA' as well. Furthermore, the following+ -- are available.+ , traverseMaybeMissing+ , traverseMissing+ , filterAMissing++ -- ** Deprecated general combining function++ , mergeWithKey++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , traverseWithKey+ , traverseMaybeWithKey+ , mapAccum+ , mapAccumWithKey+ , mapAccumRWithKey+ , mapKeys+ , mapKeysWith+ , mapKeysMonotonic++ -- * Folds+ , foldr+ , foldl+ , foldrWithKey+ , foldlWithKey+ , foldMapWithKey++ -- ** Strict folds+ , foldr'+ , foldl'+ , foldrWithKey'+ , foldlWithKey'++ -- * Conversion+ , elems+ , keys+ , assocs+ , keysSet+ , argSet+ , fromSet+ , fromArgSet++ -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Ordered lists+ , toAscList+ , toDescList+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList+ , fromDescList+ , fromDescListWith+ , fromDescListWithKey+ , fromDistinctDescList++ -- * Filter+ , filter+ , filterKeys+ , filterWithKey++ , takeWhileAntitone+ , dropWhileAntitone+ , spanAntitone++ , restrictKeys+ , withoutKeys+ , partition+ , partitionWithKey++ , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey++ , split+ , splitLookup+ , splitRoot++ -- * Submap+ , isSubmapOf, isSubmapOfBy+ , isProperSubmapOf, isProperSubmapOfBy++ -- * Indexed+ , lookupIndex+ , findIndex+ , elemAt+ , updateAt+ , deleteAt+ , take+ , drop+ , splitAt++ -- * Min\/Max+ , lookupMin+ , lookupMax+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey+ , minView+ , maxView+ , minViewWithKey+ , maxViewWithKey++ -- Used by the strict version+ , AreWeStrict (..)+ , atKeyImpl+#ifdef __GLASGOW_HASKELL__+ , atKeyPlain+#endif+ , bin+ , balance+ , balanceL+ , balanceR+ , delta+ , insertMax+ , link+ , link2+ , glue+ , ascLinkTop+ , ascLinkAll+ , descLinkTop+ , descLinkAll+ , MaybeS(..)+ , Identity(..)+ , Stack(..)+ , foldl'Stack+ , MapBuilder(..)+ , emptyB+ , insertB+ , finishB++ -- Used by Map.Merge.Lazy+ , mapWhenMissing+ , mapWhenMatched+ , lmapWhenMissing+ , contramapFirstWhenMatched+ , contramapSecondWhenMatched+ , mapGentlyWhenMissing+ , mapGentlyWhenMatched+ ) where++import Data.Functor.Identity (Identity (..))+import Control.Applicative (liftA3)+import Data.Functor.Classes+import Data.Semigroup (stimesIdempotentMonoid)+import Data.Semigroup (Arg(..), Semigroup(stimes))+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+import Control.Applicative (Const (..))+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf),NFData2(liftRnf2))+import qualified Data.Foldable as Foldable+import Data.Bifoldable+import Utils.Containers.Internal.Prelude hiding+ (lookup, map, filter, foldr, foldl, foldl', null, splitAt, take, drop)+import Prelude ()++import qualified Data.Set.Internal as Set+import Data.Set.Internal (Set)+import Utils.Containers.Internal.PtrEquality (ptrEq)+import Utils.Containers.Internal.StrictPair+import Utils.Containers.Internal.StrictMaybe+import Utils.Containers.Internal.BitQueue+import Utils.Containers.Internal.EqOrdUtil (EqM(..), OrdM(..))+#ifdef DEFINE_ALTERF_FALLBACK+import Utils.Containers.Internal.BitUtil (wordSize)+#endif++#if __GLASGOW_HASKELL__+import GHC.Exts (build, lazy)+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+# ifdef USE_MAGIC_PROXY+import GHC.Exts (Proxy#, proxy# )+# endif+import qualified GHC.Exts as GHCExts+import Data.Data+import Data.Coerce+#endif+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+import Text.Read hiding (lift)+#endif+import qualified Control.Category as Category++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}+infixl 9 !,!?,\\ --++-- | \(O(\log n)\). Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: Ord k => Map k a -> k -> a+(!) m k = find k m+#if __GLASGOW_HASKELL__+{-# INLINE (!) #-}+#endif++-- | \(O(\log n)\). Find the value at a key.+-- Returns 'Nothing' when the element can not be found.+--+-- prop> fromList [(5, 'a'), (3, 'b')] !? 1 == Nothing+-- prop> fromList [(5, 'a'), (3, 'b')] !? 5 == Just 'a'+--+-- @since 0.5.9++(!?) :: Ord k => Map k a -> k -> Maybe a+(!?) m k = lookup k m+#if __GLASGOW_HASKELL__+{-# INLINE (!?) #-}+#endif++-- | Same as 'difference'.+(\\) :: Ord k => Map k a -> Map k b -> Map k a+m1 \\ m2 = difference m1 m2+#if __GLASGOW_HASKELL__+{-# INLINE (\\) #-}+#endif++{--------------------------------------------------------------------+ Size balanced trees.+--------------------------------------------------------------------}+-- | A Map from keys @k@ to values @a@.++-- See Note: Order of constructors+data Map k a = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)+ | Tip++type Size = Int++#ifdef __GLASGOW_HASKELL__+type role Map nominal representational+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+deriving instance (Lift k, Lift a) => Lift (Map k a)+#endif++-- | @mempty@ = 'empty'+instance (Ord k) => Monoid (Map k v) where+ mempty = empty+ mconcat = unions+ mappend = (<>)++-- | @(<>)@ = 'union'+--+-- @since 0.5.7+instance (Ord k) => Semigroup (Map k v) where+ (<>) = union+ stimes = stimesIdempotentMonoid++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+ A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance (Data k, Data a, Ord k) => Data (Map k a) where+ gfoldl f z m = z fromList `f` toList m+ toConstr _ = fromListConstr+ gunfold k z c = case constrIndex c of+ 1 -> k (z fromList)+ _ -> error "gunfold"+ dataTypeOf _ = mapDataType+ dataCast2 f = gcast2 f++fromListConstr :: Constr+fromListConstr = mkConstr mapDataType "fromList" [] Prefix++mapDataType :: DataType+mapDataType = mkDataType "Data.Map.Internal.Map" [fromListConstr]++#endif++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the map empty?+--+-- > Data.Map.null (empty) == True+-- > Data.Map.null (singleton 1 'a') == False++null :: Map k a -> Bool+null Tip = True+null (Bin {}) = False+{-# INLINE null #-}++-- | \(O(1)\). The number of elements in the map.+--+-- > size empty == 0+-- > size (singleton 1 'a') == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3++size :: Map k a -> Int+size Tip = 0+size (Bin sz _ _ _ _) = sz+{-# INLINE size #-}+++-- | \(O(\log n)\). Look up the value at a key in the map.+--+-- The function will return the corresponding value as @('Just' value)@,+-- or 'Nothing' if the key isn't in the map.+--+-- An example of using @lookup@:+--+-- > import Prelude hiding (lookup)+-- > import Data.Map+-- >+-- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])+-- > deptCountry = fromList([("IT","USA"), ("Sales","France")])+-- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])+-- >+-- > employeeCurrency :: String -> Maybe String+-- > employeeCurrency name = do+-- > dept <- lookup name employeeDept+-- > country <- lookup dept deptCountry+-- > lookup country countryCurrency+-- >+-- > main = do+-- > putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))+-- > putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))+--+-- The output of this program:+--+-- > John's currency: Just "Euro"+-- > Pete's currency: Nothing+lookup :: Ord k => k -> Map k a -> Maybe a+lookup = go+ where+ go !_ Tip = Nothing+ go k (Bin _ kx x l r) = case compare k kx of+ LT -> go k l+ GT -> go k r+ EQ -> Just x+#if __GLASGOW_HASKELL__+{-# INLINABLE lookup #-}+#else+{-# INLINE lookup #-}+#endif++-- | \(O(\log n)\). Is the key a member of the map? See also 'notMember'.+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False+member :: Ord k => k -> Map k a -> Bool+member = go+ where+ go !_ Tip = False+ go k (Bin _ kx _ l r) = case compare k kx of+ LT -> go k l+ GT -> go k r+ EQ -> True+#if __GLASGOW_HASKELL__+{-# INLINABLE member #-}+#else+{-# INLINE member #-}+#endif++-- | \(O(\log n)\). Is the key not a member of the map? See also 'member'.+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Ord k => k -> Map k a -> Bool+notMember k m = not $ member k m+#if __GLASGOW_HASKELL__+{-# INLINABLE notMember #-}+#else+{-# INLINE notMember #-}+#endif++-- | \(O(\log n)\). Find the value at a key.+-- Calls 'error' when the element can not be found.+find :: Ord k => k -> Map k a -> a+find = go+ where+ go !_ Tip = error "Map.!: given key is not an element in the map"+ go k (Bin _ kx x l r) = case compare k kx of+ LT -> go k l+ GT -> go k r+ EQ -> x+#if __GLASGOW_HASKELL__+{-# INLINABLE find #-}+#else+{-# INLINE find #-}+#endif++-- | \(O(\log n)\). The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'+findWithDefault :: Ord k => a -> k -> Map k a -> a+findWithDefault = go+ where+ go def !_ Tip = def+ go def k (Bin _ kx x l r) = case compare k kx of+ LT -> go def k l+ GT -> go def k r+ EQ -> x+#if __GLASGOW_HASKELL__+{-# INLINABLE findWithDefault #-}+#else+{-# INLINE findWithDefault #-}+#endif++-- | \(O(\log n)\). Find largest key smaller than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+lookupLT :: Ord k => k -> Map k v -> Maybe (k, v)+lookupLT = goNothing+ where+ goNothing !_ Tip = Nothing+ goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l+ | otherwise = goJust k kx x r++ goJust !_ kx' x' Tip = Just (kx', x')+ goJust k kx' x' (Bin _ kx x l r) | k <= kx = goJust k kx' x' l+ | otherwise = goJust k kx x r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupLT #-}+#else+{-# INLINE lookupLT #-}+#endif++-- | \(O(\log n)\). Find smallest key greater than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing+lookupGT :: Ord k => k -> Map k v -> Maybe (k, v)+lookupGT = goNothing+ where+ goNothing !_ Tip = Nothing+ goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l+ | otherwise = goNothing k r++ goJust !_ kx' x' Tip = Just (kx', x')+ goJust k kx' x' (Bin _ kx x l r) | k < kx = goJust k kx x l+ | otherwise = goJust k kx' x' r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupGT #-}+#else+{-# INLINE lookupGT #-}+#endif++-- | \(O(\log n)\). Find largest key smaller or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+lookupLE :: Ord k => k -> Map k v -> Maybe (k, v)+lookupLE = goNothing+ where+ goNothing !_ Tip = Nothing+ goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goNothing k l+ EQ -> Just (kx, x)+ GT -> goJust k kx x r++ goJust !_ kx' x' Tip = Just (kx', x')+ goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx' x' l+ EQ -> Just (kx, x)+ GT -> goJust k kx x r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupLE #-}+#else+{-# INLINE lookupLE #-}+#endif++-- | \(O(\log n)\). Find smallest key greater or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing+lookupGE :: Ord k => k -> Map k v -> Maybe (k, v)+lookupGE = goNothing+ where+ goNothing !_ Tip = Nothing+ goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l+ EQ -> Just (kx, x)+ GT -> goNothing k r++ goJust !_ kx' x' Tip = Just (kx', x')+ goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l+ EQ -> Just (kx, x)+ GT -> goJust k kx' x' r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupGE #-}+#else+{-# INLINE lookupGE #-}+#endif++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty map.+--+-- > empty == fromList []+-- > size empty == 0++empty :: Map k a+empty = Tip+{-# INLINE empty #-}++-- | \(O(1)\). A map with a single element.+--+-- > singleton 1 'a' == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: k -> a -> Map k a+singleton k x = Bin 1 k x Tip Tip+{-# INLINE singleton #-}++{--------------------------------------------------------------------+ Insertion+--------------------------------------------------------------------}+-- | \(O(\log n)\). Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty == singleton 5 'x'++-- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper+insert :: Ord k => k -> a -> Map k a -> Map k a+insert kx0 = go kx0 kx0+ where+ -- Unlike insertR, we only get sharing here+ -- when the inserted value is at the same address+ -- as the present value. We try anyway; this condition+ -- seems particularly likely to occur in 'union'.+ go :: Ord k => k -> k -> a -> Map k a -> Map k a+ go orig !_ x Tip = singleton (lazy orig) x+ go orig !kx x t@(Bin sz ky y l r) =+ case compare kx ky of+ LT | l' `ptrEq` l -> t+ | otherwise -> balanceL ky y l' r+ where !l' = go orig kx x l+ GT | r' `ptrEq` r -> t+ | otherwise -> balanceR ky y l r'+ where !r' = go orig kx x r+ EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t+ | otherwise -> Bin sz (lazy orig) x l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insert #-}+#else+{-# INLINE insert #-}+#endif++#ifndef __GLASGOW_HASKELL__+lazy :: a -> a+lazy a = a+#endif++-- [Note: Avoiding worker/wrapper]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- 'insert' has to go to great lengths to get pointer equality right and+-- to prevent unnecessary allocation. The trouble is that GHC *really* wants+-- to unbox the key and throw away the boxed one. This is bad for us, because+-- we want to compare the pointer of the box we are given to the one already+-- present if they compare EQ. It's also bad for us because it leads to the+-- key being *reboxed* if it's actually stored in the map. Ugh! So we pass the+-- 'go' function *two copies* of the key we're given. One of them we use for+-- comparisons; the other we keep in our pocket. To prevent worker/wrapper from+-- messing with the copy in our pocket, we sprinkle about calls to the magical+-- function 'lazy'. This is all horrible, but it seems to work okay.+++-- Insert a new key and value in the map if it is not already present.+-- Used by `union`.++-- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper+insertR :: Ord k => k -> a -> Map k a -> Map k a+insertR kx0 = go kx0 kx0+ where+ go :: Ord k => k -> k -> a -> Map k a -> Map k a+ go orig !_ x Tip = singleton (lazy orig) x+ go orig !kx x t@(Bin _ ky y l r) =+ case compare kx ky of+ LT | l' `ptrEq` l -> t+ | otherwise -> balanceL ky y l' r+ where !l' = go orig kx x l+ GT | r' `ptrEq` r -> t+ | otherwise -> balanceR ky y l r'+ where !r' = go orig kx x r+ EQ -> t+#if __GLASGOW_HASKELL__+{-# INLINABLE insertR #-}+#else+{-# INLINE insertR #-}+#endif++-- | \(O(\log n)\). Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWith = go+ where+ -- We have no hope of making pointer equality tricks work+ -- here, because lazy insertWith *always* changes the tree,+ -- either adding a new entry or replacing an element with a+ -- thunk.+ go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+ go _ !kx x Tip = singleton kx x+ go f !kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go f kx x l) r+ GT -> balanceR ky y l (go f kx x r)+ EQ -> Bin sy kx (f x y) l r++#if __GLASGOW_HASKELL__+{-# INLINABLE insertWith #-}+#else+{-# INLINE insertWith #-}+#endif++-- | A helper function for 'unionWith'. When the key is already in+-- the map, the key is left alone, not replaced. The combining+-- function is flipped--it is applied to the old value and then the+-- new value.+--+-- Also see the performance note on 'fromListWith'.++insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithR = go+ where+ go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+ go _ !kx x Tip = singleton kx x+ go f !kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go f kx x l) r+ GT -> balanceR ky y l (go f kx x r)+ EQ -> Bin sy ky (f y x) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithR #-}+#else+{-# INLINE insertWithR #-}+#endif++-- | \(O(\log n)\). Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++-- See Note: Type of local 'go' function+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey = go+ where+ go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+ go _ !kx x Tip = singleton kx x+ go f kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go f kx x l) r+ GT -> balanceR ky y l (go f kx x r)+ EQ -> Bin sy kx (f kx x y) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithKey #-}+#else+{-# INLINE insertWithKey #-}+#endif++-- | A helper function for 'unionWithKey'. When the key is already in+-- the map, the key is left alone, not replaced. The combining+-- function is flipped--it is applied to the old value and then the+-- new value.+--+-- Also see the performance note on 'fromListWith'.++insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKeyR = go+ where+ go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+ go _ !kx x Tip = singleton kx x+ go f kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> balanceL ky y (go f kx x l) r+ GT -> balanceR ky y l (go f kx x r)+ EQ -> Bin sy ky (f ky y x) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithKeyR #-}+#else+{-# INLINE insertWithKeyR #-}+#endif++-- | \(O(\log n)\). Combines insert operation with old value retrieval.+-- The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])+--+-- Also see the performance note on 'fromListWith'.++-- See Note: Type of local 'go' function+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a+ -> (Maybe a, Map k a)+insertLookupWithKey f0 k0 x0 = toPair . go f0 k0 x0+ where+ go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)+ go _ !kx x Tip = (Nothing :*: singleton kx x)+ go f kx x (Bin sy ky y l r) =+ case compare kx ky of+ LT -> let !(found :*: l') = go f kx x l+ !t' = balanceL ky y l' r+ in (found :*: t')+ GT -> let !(found :*: r') = go f kx x r+ !t' = balanceR ky y l r'+ in (found :*: t')+ EQ -> (Just y :*: Bin sy kx (f kx x y) l r)+#if __GLASGOW_HASKELL__+{-# INLINABLE insertLookupWithKey #-}+#else+{-# INLINE insertLookupWithKey #-}+#endif++{--------------------------------------------------------------------+ Deletion+--------------------------------------------------------------------}+-- | \(O(\log n)\). Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > delete 5 empty == empty++-- See Note: Type of local 'go' function+delete :: Ord k => k -> Map k a -> Map k a+delete = go+ where+ go :: Ord k => k -> Map k a -> Map k a+ go !_ Tip = Tip+ go k t@(Bin _ kx x l r) =+ case compare k kx of+ LT | l' `ptrEq` l -> t+ | otherwise -> balanceR kx x l' r+ where !l' = go k l+ GT | r' `ptrEq` r -> t+ | otherwise -> balanceL kx x l r'+ where !r' = go k r+ EQ -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE delete #-}+#else+{-# INLINE delete #-}+#endif++-- | \(O(\log n)\). Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty == empty++adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a+adjust f = adjustWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__+{-# INLINABLE adjust #-}+#else+{-# INLINE adjust #-}+#endif++-- | \(O(\log n)\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty == empty++adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+adjustWithKey = go+ where+ go :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+ go _ !_ Tip = Tip+ go f k (Bin sx kx x l r) =+ case compare k kx of+ LT -> Bin sx kx x (go f k l) r+ GT -> Bin sx kx x l (go f k r)+ EQ -> Bin sx kx (f kx x) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE adjustWithKey #-}+#else+{-# INLINE adjustWithKey #-}+#endif++-- | \(O(\log n)\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a+update f = updateWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__+{-# INLINABLE update #-}+#else+{-# INLINE update #-}+#endif++-- | \(O(\log n)\). The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++-- See Note: Type of local 'go' function+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+updateWithKey = go+ where+ go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+ go _ !_ Tip = Tip+ go f k(Bin sx kx x l r) =+ case compare k kx of+ LT -> balanceR kx x (go f k l) r+ GT -> balanceL kx x l (go f k r)+ EQ -> case f kx x of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE updateWithKey #-}+#else+{-# INLINE updateWithKey #-}+#endif++-- | \(O(\log n)\). Look up and update. See also 'updateWithKey'.+-- This function returns the changed value, if it is updated.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++-- See Note: Type of local 'go' function+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)+updateLookupWithKey f0 k0 = toPair . go f0 k0+ where+ go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)+ go _ !_ Tip = (Nothing :*: Tip)+ go f k (Bin sx kx x l r) =+ case compare k kx of+ LT -> let !(found :*: l') = go f k l+ !t' = balanceR kx x l' r+ in (found :*: t')+ GT -> let !(found :*: r') = go f k r+ !t' = balanceL kx x l r'+ in (found :*: t')+ EQ -> case f kx x of+ Just x' -> (Just x' :*: Bin sx kx x' l r)+ Nothing -> let !glued = glue l r+ in (Just x :*: glued)+#if __GLASGOW_HASKELL__+{-# INLINABLE updateLookupWithKey #-}+#else+{-# INLINE updateLookupWithKey #-}+#endif++-- | \(O(\log n)\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+--+-- > let f _ = Nothing+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- >+-- > let f _ = Just "c"+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]+--+-- Note that @'adjust' = alter . fmap@.++-- See Note: Type of local 'go' function+alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+alter = go+ where+ go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+ go f !k Tip = case f Nothing of+ Nothing -> Tip+ Just x -> singleton k x++ go f k (Bin sx kx x l r) = case compare k kx of+ LT -> balance kx x (go f k l) r+ GT -> balance kx x l (go f k r)+ EQ -> case f (Just x) of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE alter #-}+#else+{-# INLINE alter #-}+#endif++-- Used to choose the appropriate alterF implementation.+data AreWeStrict = Strict | Lazy++-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof. 'alterF' can be used to inspect, insert, delete,+-- or update a value in a 'Map'. In short: @'lookup' k \<$\> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)+-- interactiveAlter k m = alterF f k m where+-- f Nothing = do+-- putStrLn $ show k +++-- " was not found in the map. Would you like to add it?"+-- getUserResponse1 :: IO (Maybe String)+-- f (Just old) = do+-- putStrLn $ "The key is currently bound to " ++ show old +++-- ". Would you like to change or delete it?"+-- getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map. When used with trivial+-- functors like 'Identity' and 'Const', it is often slightly slower than+-- more specialized combinators like 'lookup' and 'insert'. However, when+-- the functor is non-trivial and key comparison is not particularly cheap,+-- it is the fastest way.+--+-- Note on rewrite rules:+--+-- This module includes GHC rewrite rules to optimize 'alterF' for+-- the 'Const' and 'Identity' functors. In general, these rules+-- improve performance. The sole exception is that when using+-- 'Identity', deleting a key that is already absent takes longer+-- than it would without the rules. If you expect this to occur+-- a very large fraction of the time, you might consider using a+-- private copy of the 'Identity' type.+--+-- Note: 'alterF' is a flipped version of the @at@ combinator from+-- @Control.Lens.At@.+--+-- @since 0.5.8+alterF :: (Functor f, Ord k)+ => (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)+alterF f k m = atKeyImpl Lazy k f m++#ifndef __GLASGOW_HASKELL__+{-# INLINE alterF #-}+#else+{-# INLINABLE [2] alterF #-}++-- We can save a little time by recognizing the special case of+-- `Control.Applicative.Const` and just doing a lookup.+{-# RULES+"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m+ #-}++-- base 4.8 and above include Data.Functor.Identity, so we can+-- save a pretty decent amount of time by handling it specially.+{-# RULES+"alterF/Identity" forall k f . alterF f k = atKeyIdentity k f+ #-}+#endif++atKeyImpl :: (Functor f, Ord k) =>+ AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)+#ifdef DEFINE_ALTERF_FALLBACK+atKeyImpl strict !k f m+-- It doesn't seem sensible to worry about overflowing the queue+-- if the word size is 61 or more. If I calculate it correctly,+-- that would take a map with nearly a quadrillion entries.+ | wordSize < 61 && size m >= alterFCutoff = alterFFallback strict k f m+#endif+atKeyImpl strict !k f m = case lookupTrace k m of+ TraceResult mv q -> (<$> f mv) $ \ fres ->+ case fres of+ Nothing -> case mv of+ Nothing -> m+ Just old -> deleteAlong old q m+ Just new -> case strict of+ Strict -> new `seq` case mv of+ Nothing -> insertAlong q k new m+ Just _ -> replaceAlong q new m+ Lazy -> case mv of+ Nothing -> insertAlong q k new m+ Just _ -> replaceAlong q new m++{-# INLINE atKeyImpl #-}++#ifdef DEFINE_ALTERF_FALLBACK+alterFCutoff :: Int+#if WORD_SIZE_IN_BITS == 32+alterFCutoff = 55744454+#else+alterFCutoff = case wordSize of+ 30 -> 17637893+ 31 -> 31356255+ 32 -> 55744454+ x -> (4^(x*2-2)) `quot` (3^(x*2-2)) -- Unlikely+#endif+#endif++data TraceResult a = TraceResult (Maybe a) {-# UNPACK #-} !BitQueue++-- Look up a key and return a result indicating whether it was found+-- and what path was taken.+lookupTrace :: Ord k => k -> Map k a -> TraceResult a+lookupTrace = go emptyQB+ where+ go :: Ord k => BitQueueB -> k -> Map k a -> TraceResult a+ go !q !_ Tip = TraceResult Nothing (buildQ q)+ go q k (Bin _ kx x l r) = case compare k kx of+ LT -> (go $! q `snocQB` False) k l+ GT -> (go $! q `snocQB` True) k r+ EQ -> TraceResult (Just x) (buildQ q)++#ifdef __GLASGOW_HASKELL__+{-# INLINABLE lookupTrace #-}+#else+{-# INLINE lookupTrace #-}+#endif++-- Insert at a location (which will always be a leaf)+-- described by the path passed in.+insertAlong :: BitQueue -> k -> a -> Map k a -> Map k a+insertAlong !_ kx x Tip = singleton kx x+insertAlong q kx x (Bin sz ky y l r) =+ case unconsQ q of+ Just (False, tl) -> balanceL ky y (insertAlong tl kx x l) r+ Just (True,tl) -> balanceR ky y l (insertAlong tl kx x r)+ Nothing -> Bin sz kx x l r -- Shouldn't happen++-- Delete from a location (which will always be a node)+-- described by the path passed in.+--+-- This is fairly horrifying! We don't actually have any+-- use for the old value we're deleting. But if GHC sees+-- that, then it will allocate a thunk representing the+-- Map with the key deleted before we have any reason to+-- believe we'll actually want that. This transformation+-- enhances sharing, but we don't care enough about that.+-- So deleteAlong needs to take the old value, and we need+-- to convince GHC somehow that it actually uses it. We+-- can't NOINLINE deleteAlong, because that would prevent+-- the BitQueue from being unboxed. So instead we pass the+-- old value to a NOINLINE constant function and then+-- convince GHC that we use the result throughout the+-- computation. Doing the obvious thing and just passing+-- the value itself through the recursion costs 3-4% time,+-- so instead we convert the value to a magical zero-width+-- proxy that's ultimately erased.+deleteAlong :: any -> BitQueue -> Map k a -> Map k a+deleteAlong old !q0 !m = go (bogus old) q0 m where+#ifdef USE_MAGIC_PROXY+ go :: Proxy# () -> BitQueue -> Map k a -> Map k a+#else+ go :: any -> BitQueue -> Map k a -> Map k a+#endif+ go !_ !_ Tip = Tip+ go foom q (Bin _ ky y l r) =+ case unconsQ q of+ Just (False, tl) -> balanceR ky y (go foom tl l) r+ Just (True, tl) -> balanceL ky y l (go foom tl r)+ Nothing -> glue l r++#ifdef USE_MAGIC_PROXY+{-# NOINLINE bogus #-}+bogus :: a -> Proxy# ()+bogus _ = proxy#+#else+-- No point hiding in this case.+{-# INLINE bogus #-}+bogus :: a -> a+bogus a = a+#endif++-- Replace the value found in the node described+-- by the given path with a new one.+replaceAlong :: BitQueue -> a -> Map k a -> Map k a+replaceAlong !_ _ Tip = Tip -- Should not happen+replaceAlong q x (Bin sz ky y l r) =+ case unconsQ q of+ Just (False, tl) -> Bin sz ky y (replaceAlong tl x l) r+ Just (True,tl) -> Bin sz ky y l (replaceAlong tl x r)+ Nothing -> Bin sz ky x l r++#ifdef __GLASGOW_HASKELL__+atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)+atKeyIdentity k f t = Identity $ atKeyPlain Lazy k (coerce f) t+{-# INLINABLE atKeyIdentity #-}++atKeyPlain :: Ord k => AreWeStrict -> k -> (Maybe a -> Maybe a) -> Map k a -> Map k a+atKeyPlain strict k0 f0 t = case go k0 f0 t of+ AltSmaller t' -> t'+ AltBigger t' -> t'+ AltAdj t' -> t'+ AltSame -> t+ where+ go :: Ord k => k -> (Maybe a -> Maybe a) -> Map k a -> Altered k a+ go !k f Tip = case f Nothing of+ Nothing -> AltSame+ Just x -> case strict of+ Lazy -> AltBigger $ singleton k x+ Strict -> x `seq` (AltBigger $ singleton k x)++ go k f (Bin sx kx x l r) = case compare k kx of+ LT -> case go k f l of+ AltSmaller l' -> AltSmaller $ balanceR kx x l' r+ AltBigger l' -> AltBigger $ balanceL kx x l' r+ AltAdj l' -> AltAdj $ Bin sx kx x l' r+ AltSame -> AltSame+ GT -> case go k f r of+ AltSmaller r' -> AltSmaller $ balanceL kx x l r'+ AltBigger r' -> AltBigger $ balanceR kx x l r'+ AltAdj r' -> AltAdj $ Bin sx kx x l r'+ AltSame -> AltSame+ EQ -> case f (Just x) of+ Just x' -> case strict of+ Lazy -> AltAdj $ Bin sx kx x' l r+ Strict -> x' `seq` (AltAdj $ Bin sx kx x' l r)+ Nothing -> AltSmaller $ glue l r+{-# INLINE atKeyPlain #-}++data Altered k a = AltSmaller !(Map k a) | AltBigger !(Map k a) | AltAdj !(Map k a) | AltSame+#endif++#ifdef DEFINE_ALTERF_FALLBACK+-- When the map is too large to use a bit queue, we fall back to+-- this much slower version which uses a more "natural" implementation+-- improved with Yoneda to avoid repeated fmaps. This works okayish for+-- some operations, but it's pretty lousy for lookups.+alterFFallback :: (Functor f, Ord k)+ => AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)+alterFFallback Lazy k f t = alterFYoneda k (\m q -> q <$> f m) t id+alterFFallback Strict k f t = alterFYoneda k (\m q -> q . forceMaybe <$> f m) t id+ where+ forceMaybe Nothing = Nothing+ forceMaybe may@(Just !_) = may+{-# NOINLINE alterFFallback #-}++alterFYoneda :: Ord k =>+ k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b+alterFYoneda = go+ where+ go :: Ord k =>+ k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b+ go !k f Tip g = f Nothing $ \ mx -> case mx of+ Nothing -> g Tip+ Just x -> g (singleton k x)+ go k f (Bin sx kx x l r) g = case compare k kx of+ LT -> go k f l (\m -> g (balance kx x m r))+ GT -> go k f r (\m -> g (balance kx x l m))+ EQ -> f (Just x) $ \ mx' -> case mx' of+ Just x' -> g (Bin sx kx x' l r)+ Nothing -> g (glue l r)+{-# INLINE alterFYoneda #-}+#endif++{--------------------------------------------------------------------+ Indexing+--------------------------------------------------------------------}+-- | \(O(\log n)\). Return the /index/ of a key, which is its zero-based index in+-- the sequence sorted by keys. The index is a number from /0/ up to, but not+-- including, the 'size' of the map. Calls 'error' when the key is not+-- a 'member' of the map.+--+-- > findIndex 2 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map+-- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0+-- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1+-- > findIndex 6 (fromList [(5,"a"), (3,"b")]) Error: element is not in the map++-- See Note: Type of local 'go' function+findIndex :: Ord k => k -> Map k a -> Int+findIndex = go 0+ where+ go :: Ord k => Int -> k -> Map k a -> Int+ go !_ !_ Tip = error "Map.findIndex: element is not in the map"+ go idx k (Bin _ kx _ l r) = case compare k kx of+ LT -> go idx k l+ GT -> go (idx + size l + 1) k r+ EQ -> idx + size l+#if __GLASGOW_HASKELL__+{-# INLINABLE findIndex #-}+#endif++-- | \(O(\log n)\). Look up the /index/ of a key, which is its zero-based index in+-- the sequence sorted by keys. The index is a number from /0/ up to, but not+-- including, the 'size' of the map.+--+-- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")])) == False+-- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0+-- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1+-- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")])) == False++-- See Note: Type of local 'go' function+lookupIndex :: Ord k => k -> Map k a -> Maybe Int+lookupIndex = go 0+ where+ go :: Ord k => Int -> k -> Map k a -> Maybe Int+ go !_ !_ Tip = Nothing+ go idx k (Bin _ kx _ l r) = case compare k kx of+ LT -> go idx k l+ GT -> go (idx + size l + 1) k r+ EQ -> Just $! idx + size l+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupIndex #-}+#endif++-- | \(O(\log n)\). Retrieve an element by its /index/, i.e. by its zero-based+-- index in the sequence sorted by keys. If the /index/ is out of range (less+-- than zero, greater or equal to 'size' of the map), 'error' is called.+--+-- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")+-- > elemAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range++elemAt :: Int -> Map k a -> (k,a)+elemAt !_ Tip = error "Map.elemAt: index out of range"+elemAt i (Bin _ kx x l r)+ = case compare i sizeL of+ LT -> elemAt i l+ GT -> elemAt (i-sizeL-1) r+ EQ -> (kx,x)+ where+ sizeL = size l++-- | \(O(\log n)\). Take a given number of entries in key order, beginning+-- with the smallest keys.+--+-- @+-- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'+-- @+--+-- @since 0.5.8++take :: Int -> Map k a -> Map k a+take i m | i >= size m = m+take i0 m0 = go i0 m0+ where+ go i !_ | i <= 0 = Tip+ go !_ Tip = Tip+ go i (Bin _ kx x l r) =+ case compare i sizeL of+ LT -> go i l+ GT -> link kx x l (go (i - sizeL - 1) r)+ EQ -> l+ where sizeL = size l++-- | \(O(\log n)\). Drop a given number of entries in key order, beginning+-- with the smallest keys.+--+-- @+-- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'+-- @+--+-- @since 0.5.8+drop :: Int -> Map k a -> Map k a+drop i m | i >= size m = Tip+drop i0 m0 = go i0 m0+ where+ go i m | i <= 0 = m+ go !_ Tip = Tip+ go i (Bin _ kx x l r) =+ case compare i sizeL of+ LT -> link kx x (go i l) r+ GT -> go (i - sizeL - 1) r+ EQ -> insertMin kx x r+ where sizeL = size l++-- | \(O(\log n)\). Split a map at a particular index.+--+-- @+-- splitAt !n !xs = ('take' n xs, 'drop' n xs)+-- @+--+-- @since 0.5.8+splitAt :: Int -> Map k a -> (Map k a, Map k a)+splitAt i0 m0+ | i0 >= size m0 = (m0, Tip)+ | otherwise = toPair $ go i0 m0+ where+ go i m | i <= 0 = Tip :*: m+ go !_ Tip = Tip :*: Tip+ go i (Bin _ kx x l r)+ = case compare i sizeL of+ LT -> case go i l of+ ll :*: lr -> ll :*: link kx x lr r+ GT -> case go (i - sizeL - 1) r of+ rl :*: rr -> link kx x l rl :*: rr+ EQ -> l :*: insertMin kx x r+ where sizeL = size l++-- | \(O(\log n)\). Update the element at /index/, i.e. by its zero-based index in+-- the sequence sorted by keys. If the /index/ is out of range (less than zero,+-- greater or equal to 'size' of the map), 'error' is called.+--+-- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]+-- > updateAt (\ _ _ -> Just "x") 1 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]+-- > updateAt (\ _ _ -> Just "x") 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\_ _ -> Nothing) 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > updateAt (\_ _ -> Nothing) 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > updateAt (\_ _ -> Nothing) 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > updateAt (\_ _ -> Nothing) (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range++updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a+updateAt f !i t =+ case t of+ Tip -> error "Map.updateAt: index out of range"+ Bin sx kx x l r -> case compare i sizeL of+ LT -> balanceR kx x (updateAt f i l) r+ GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)+ EQ -> case f kx x of+ Just x' -> Bin sx kx x' l r+ Nothing -> glue l r+ where+ sizeL = size l++-- | \(O(\log n)\). Delete the element at /index/, i.e. by its zero-based index in+-- the sequence sorted by keys. If the /index/ is out of range (less than zero,+-- greater or equal to 'size' of the map), 'error' is called.+--+-- > deleteAt 0 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > deleteAt 1 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > deleteAt 2 (fromList [(5,"a"), (3,"b")]) Error: index out of range+-- > deleteAt (-1) (fromList [(5,"a"), (3,"b")]) Error: index out of range++deleteAt :: Int -> Map k a -> Map k a+deleteAt !i t =+ case t of+ Tip -> error "Map.deleteAt: index out of range"+ Bin _ kx x l r -> case compare i sizeL of+ LT -> balanceR kx x (deleteAt i l) r+ GT -> balanceL kx x l (deleteAt (i-sizeL-1) r)+ EQ -> glue l r+ where+ sizeL = size l+++{--------------------------------------------------------------------+ Minimal, Maximal+--------------------------------------------------------------------}++-- The KeyValue type is used when returning a key-value pair and helps GHC keep+-- track of the fact that key is in WHNF.+--+-- As an example, for a use case like+--+-- fmap (\(k,_) -> <strict use of k>) (lookupMin m)+--+-- on a non-empty map, GHC can decide to evaluate the usage of k if it is cheap+-- and put the result in the Just, instead of making a thunk for it.+-- If GHC does not know that k is in WHNF, it could be bottom, and so GHC must+-- always return Just with a thunk inside.++data KeyValue k a = KeyValue !k a++kvToTuple :: KeyValue k a -> (k, a)+kvToTuple (KeyValue k a) = (k, a)+{-# INLINE kvToTuple #-}++lookupMinSure :: k -> a -> Map k a -> KeyValue k a+lookupMinSure !k a Tip = KeyValue k a+lookupMinSure _ _ (Bin _ k a l _) = lookupMinSure k a l++-- | \(O(\log n)\). The minimal key of the map. Returns 'Nothing' if the map is empty.+--+-- > lookupMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b")+-- > lookupMin empty = Nothing+--+-- @since 0.5.9++lookupMin :: Map k a -> Maybe (k,a)+lookupMin Tip = Nothing+lookupMin (Bin _ k x l _) = Just $! kvToTuple (lookupMinSure k x l)+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\log n)\). The minimal key of the map. Calls 'error' if the map is empty.+--+-- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > findMin empty Error: empty map has no minimal element++findMin :: Map k a -> (k,a)+findMin t+ | Just r <- lookupMin t = r+ | otherwise = error "Map.findMin: empty map has no minimal element"++lookupMaxSure :: k -> a -> Map k a -> KeyValue k a+lookupMaxSure !k a Tip = KeyValue k a+lookupMaxSure _ _ (Bin _ k a _ r) = lookupMaxSure k a r++-- | \(O(\log n)\). The maximal key of the map. Returns 'Nothing' if the map is empty.+--+-- > lookupMax (fromList [(5,"a"), (3,"b")]) == Just (5,"a")+-- > lookupMax empty = Nothing+--+-- @since 0.5.9++lookupMax :: Map k a -> Maybe (k, a)+lookupMax Tip = Nothing+lookupMax (Bin _ k x _ r) = Just $! kvToTuple (lookupMaxSure k x r)+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\log n)\). The maximal key of the map. Calls 'error' if the map is empty.+--+-- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")+-- > findMax empty Error: empty map has no maximal element++findMax :: Map k a -> (k,a)+findMax t+ | Just r <- lookupMax t = r+ | otherwise = error "Map.findMax: empty map has no maximal element"++-- | \(O(\log n)\). Delete the minimal key. Returns an empty map if the map is empty.+--+-- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]+-- > deleteMin empty == empty++deleteMin :: Map k a -> Map k a+deleteMin (Bin _ _ _ Tip r) = r+deleteMin (Bin _ kx x l r) = balanceR kx x (deleteMin l) r+deleteMin Tip = Tip++-- | \(O(\log n)\). Delete the maximal key. Returns an empty map if the map is empty.+--+-- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]+-- > deleteMax empty == empty++deleteMax :: Map k a -> Map k a+deleteMax (Bin _ _ _ l Tip) = l+deleteMax (Bin _ kx x l r) = balanceL kx x l (deleteMax r)+deleteMax Tip = Tip++-- | \(O(\log n)\). Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> Map k a -> Map k a+updateMin f m+ = updateMinWithKey (\_ x -> f x) m++-- | \(O(\log n)\). Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> Map k a -> Map k a+updateMax f m+ = updateMaxWithKey (\_ x -> f x) m+++-- | \(O(\log n)\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMinWithKey _ Tip = Tip+updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of+ Nothing -> r+ Just x' -> Bin sx kx x' Tip r+updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r++-- | \(O(\log n)\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMaxWithKey _ Tip = Tip+updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of+ Nothing -> l+ Just x' -> Bin sx kx x' l Tip+updateMaxWithKey f (Bin _ kx x l r) = balanceL kx x l (updateMaxWithKey f r)++-- | \(O(\log n)\). Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)+minViewWithKey Tip = Nothing+minViewWithKey (Bin _ k x l r) = Just $+ case minViewSure k x l r of+ MinView km xm t -> ((km, xm), t)+-- We inline this to give GHC the best possible chance of getting+-- rid of the Maybe and pair constructors, as well as the thunk under+-- the Just.+{-# INLINE minViewWithKey #-}++-- | \(O(\log n)\). Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)+maxViewWithKey Tip = Nothing+maxViewWithKey (Bin _ k x l r) = Just $+ case maxViewSure k x l r of+ MaxView km xm t -> ((km, xm), t)+-- See note on inlining at minViewWithKey+{-# INLINE maxViewWithKey #-}++-- | \(O(\log n)\). Retrieves the value associated with minimal key of the+-- map, and the map stripped of that element, or 'Nothing' if passed an+-- empty map.+--+-- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")+-- > minView empty == Nothing++minView :: Map k a -> Maybe (a, Map k a)+minView t = case minViewWithKey t of+ Nothing -> Nothing+ Just ~((_, x), t') -> Just (x, t')++-- | \(O(\log n)\). Retrieves the value associated with maximal key of the+-- map, and the map stripped of that element, or 'Nothing' if passed an+-- empty map.+--+-- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")+-- > maxView empty == Nothing++maxView :: Map k a -> Maybe (a, Map k a)+maxView t = case maxViewWithKey t of+ Nothing -> Nothing+ Just ~((_, x), t') -> Just (x, t')++{--------------------------------------------------------------------+ Union.+--------------------------------------------------------------------}+-- | The union of a list of maps:+-- (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+--+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "b"), (5, "a"), (7, "C")]+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]+-- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]++unions :: (Foldable f, Ord k) => f (Map k a) -> Map k a+unions ts+ = Foldable.foldl' union empty ts+#if __GLASGOW_HASKELL__+{-# INLINABLE unions #-}+#endif++-- | The union of a list of maps, with a combining operation:+-- (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a+unionsWith f ts+ = Foldable.foldl' (unionWith f) empty ts+#if __GLASGOW_HASKELL__+{-# INLINABLE unionsWith #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.+-- It prefers @t1@ when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: Ord k => Map k a -> Map k a -> Map k a+union t1 Tip = t1+union t1 (Bin _ k x Tip Tip) = insertR k x t1+union (Bin _ k x Tip Tip) t2 = insert k x t2+union Tip t2 = t2+union t1@(Bin _ k1 x1 l1 r1) t2 = case split k1 t2 of+ (l2, r2) | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1+ | otherwise -> link k1 x1 l1l2 r1r2+ where !l1l2 = union l1 l2+ !r1r2 = union r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE union #-}+#endif++{--------------------------------------------------------------------+ Union with a combining function+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+-- QuickCheck says pointer equality never happens here.+unionWith _f t1 Tip = t1+unionWith f t1 (Bin _ k x Tip Tip) = insertWithR f k x t1+unionWith f (Bin _ k x Tip Tip) t2 = insertWith f k x t2+unionWith _f Tip t2 = t2+unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+ (l2, mb, r2) -> case mb of+ Nothing -> link k1 x1 l1l2 r1r2+ Just x2 -> link k1 (f x1 x2) l1l2 r1r2+ where !l1l2 = unionWith f l1 l2+ !r1r2 = unionWith f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE unionWith #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- Union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWithKey _f t1 Tip = t1+unionWithKey f t1 (Bin _ k x Tip Tip) = insertWithKeyR f k x t1+unionWithKey f (Bin _ k x Tip Tip) t2 = insertWithKey f k x t2+unionWithKey _f Tip t2 = t2+unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+ (l2, mb, r2) -> case mb of+ Nothing -> link k1 x1 l1l2 r1r2+ Just x2 -> link k1 (f k1 x1 x2) l1l2 r1r2+ where !l1l2 = unionWithKey f l1 l2+ !r1r2 = unionWithKey f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE unionWithKey #-}+#endif++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}++-- We don't currently attempt to use any pointer equality tricks for+-- 'difference'. To do so, we'd have to match on the first argument+-- and split the second. Unfortunately, the proof of the time bound+-- relies on doing it the way we do, and it's not clear whether that+-- bound holds the other way.++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Difference of two maps.+-- Return elements of the first map not existing in the second map.+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: Ord k => Map k a -> Map k b -> Map k a+difference Tip _ = Tip+difference t1 Tip = t1+difference t1 (Bin _ k _ l2 r2) = case split k t1 of+ (l1, r1)+ | size l1l2 + size r1r2 == size t1 -> t1+ | otherwise -> link2 l1l2 r1r2+ where+ !l1l2 = difference l1 l2+ !r1r2 = difference r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE difference #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Remove all keys in a 'Set' from a 'Map'.+--+-- @+-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``Set.notMember`` s) m+-- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s+-- @+--+-- @since 0.5.8++withoutKeys :: Ord k => Map k a -> Set k -> Map k a+withoutKeys Tip _ = Tip+withoutKeys m Set.Tip = m+withoutKeys m (Set.Bin _ k ls rs) = case splitMember k m of+ (lm, b, rm)+ | not b && lm' `ptrEq` lm && rm' `ptrEq` rm -> m+ | otherwise -> link2 lm' rm'+ where+ !lm' = withoutKeys lm ls+ !rm' = withoutKeys rm rs+#if __GLASGOW_HASKELL__+{-# INLINABLE withoutKeys #-}+#endif++-- | \(O(n+m)\). Difference with a combining function.+-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- > == singleton 3 "b:B"+differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWith f = merge preserveMissing dropMissing $+ zipWithMaybeMatched (\_ x y -> f x y)+#if __GLASGOW_HASKELL__+{-# INLINABLE differenceWith #-}+#endif++-- | \(O(n+m)\). Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- > == singleton 3 "3:b|B"++differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWithKey f =+ merge preserveMissing dropMissing (zipWithMaybeMatched f)+#if __GLASGOW_HASKELL__+{-# INLINABLE differenceWithKey #-}+#endif+++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection of two maps.+-- Return data in the first map for the keys existing in both maps.+-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: Ord k => Map k a -> Map k b -> Map k a+intersection Tip _ = Tip+intersection _ Tip = Tip+intersection t1@(Bin _ k x l1 r1) t2+ | mb = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1+ then t1+ else link k x l1l2 r1r2+ | otherwise = link2 l1l2 r1r2+ where+ !(l2, mb, r2) = splitMember k t2+ !l1l2 = intersection l1 l2+ !r1r2 = intersection r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersection #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Restrict a 'Map' to only those keys+-- found in a 'Set'.+--+-- @+-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``Set.member`` s) m+-- m \`restrictKeys\` s = m ``intersection`` 'fromSet' (const ()) s+-- @+--+-- @since 0.5.8+restrictKeys :: Ord k => Map k a -> Set k -> Map k a+restrictKeys Tip _ = Tip+restrictKeys _ Set.Tip = Tip+restrictKeys m@(Bin _ k x l1 r1) s+ | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1+ then m+ else link k x l1l2 r1r2+ | otherwise = link2 l1l2 r1r2+ where+ !(l2, b, r2) = Set.splitMember k s+ !l1l2 = restrictKeys l1 l2+ !r1r2 = restrictKeys r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE restrictKeys #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c+-- We have no hope of pointer equality tricks here because every single+-- element in the result will be a thunk.+intersectionWith _f Tip _ = Tip+intersectionWith _f _ Tip = Tip+intersectionWith f (Bin _ k x1 l1 r1) t2 = case mb of+ Just x2 -> link k (f x1 x2) l1l2 r1r2+ Nothing -> link2 l1l2 r1r2+ where+ !(l2, mb, r2) = splitLookup k t2+ !l1l2 = intersectionWith f l1 l2+ !r1r2 = intersectionWith f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersectionWith #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWithKey _f Tip _ = Tip+intersectionWithKey _f _ Tip = Tip+intersectionWithKey f (Bin _ k x1 l1 r1) t2 = case mb of+ Just x2 -> link k (f k x1 x2) l1l2 r1r2+ Nothing -> link2 l1l2 r1r2+ where+ !(l2, mb, r2) = splitLookup k t2+ !l1l2 = intersectionWithKey f l1 l2+ !r1r2 = intersectionWithKey f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersectionWithKey #-}+#endif++{--------------------------------------------------------------------+ Symmetric difference+--------------------------------------------------------------------}++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- The symmetric difference of two maps.+--+-- The result contains entries whose keys appear in exactly one of the two maps.+--+-- @+-- symmetricDifference+-- (fromList [(0,\'q\'),(2,\'b\'),(4,\'w\'),(6,\'o\')])+-- (fromList [(0,\'e\'),(3,\'r\'),(6,\'t\'),(9,\'s\')])+-- ==+-- fromList [(2,\'b\'),(3,\'r\'),(4,\'w\'),(9,\'s\')]+-- @+--+-- @since 0.8+symmetricDifference :: Ord k => Map k a -> Map k a -> Map k a+symmetricDifference Tip t2 = t2+symmetricDifference t1 Tip = t1+symmetricDifference (Bin _ k x l1 r1) t2+ | found = link2 l1l2 r1r2+ | otherwise = link k x l1l2 r1r2+ where+ !(l2, found, r2) = splitMember k t2+ !l1l2 = symmetricDifference l1 l2+ !r1r2 = symmetricDifference r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE symmetricDifference #-}+#endif++{--------------------------------------------------------------------+ Disjoint+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Check whether the key sets of two+-- maps are disjoint (i.e., their 'intersection' is empty).+--+-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())]) == True+-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False+-- > disjoint (fromList []) (fromList []) == True+--+-- @+-- xs ``disjoint`` ys = null (xs ``intersection`` ys)+-- @+--+-- @since 0.6.2.1++-- See 'Data.Set.Internal.isSubsetOfX' for some background+-- on the implementation design.+disjoint :: Ord k => Map k a -> Map k b -> Bool+disjoint Tip _ = True+disjoint _ Tip = True+disjoint (Bin 1 k _ _ _) t = k `notMember` t+disjoint (Bin _ k _ l r) t+ = not found && disjoint l lt && disjoint r gt+ where+ (lt,found,gt) = splitMember k t++{--------------------------------------------------------------------+ Compose+--------------------------------------------------------------------}+-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O (n \log m) \), where \(m\) is the size of the first argument+--+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- __Note:__ Prior to v0.6.4, "Data.Map.Strict" exposed a version of+-- 'compose' that forced the values of the output 'Map'. This version does not+-- force these values.+--+-- ==== __Note on complexity__+--+-- This function is asymptotically optimal. Given @n :: Map a b, m :: Map b c@,+-- the composition essentially maps each @a@ in @n@ to @Maybe c@, since the+-- composed lookup yields either one of the @c@ in @m@ or @Nothing@. The number+-- of possible such mappings is \((|m| + 1) ^ {|n|}\).+-- We now follow a similar reasoning to the one for+-- [sorting](https://en.wikipedia.org/wiki/Comparison_sort#Number_of_comparisons_required_to_sort_a_list).+-- To distinguish between \(x\) possible values, we need+-- \( \lceil \log_2 x \rceil \) bits. Thus, we have a lower bound of+-- \(\log_2 \left((|m| + 1) ^{|n|} \right) = |n| \cdot \log_2 (|m| + 1)\) bits.+-- @Map@ lookups are comparison-based, and each comparison gives us at most+-- one bit of information: in the worst case we'll always be left with at least+-- half of the remaining possible values, meaning we need at least as many+-- comparisons as we need bits.+--+-- @since 0.6.3.1+compose :: Ord b => Map b c -> Map a b -> Map a c+compose bc !ab+ | null bc = empty+ | otherwise = mapMaybe (bc !?) ab++-- | A tactic for dealing with keys present in one map but not the other in+-- 'merge' or 'mergeA'.+--+-- A tactic of type @ WhenMissing f k x z @ is an abstract representation+-- of a function of type @ k -> x -> f (Maybe z) @.+--+-- @since 0.5.9++data WhenMissing f k x y = WhenMissing+ { missingSubtree :: Map k x -> f (Map k y)+ , missingKey :: k -> x -> f (Maybe y)}++-- | @since 0.5.9+instance (Applicative f, Monad f) => Functor (WhenMissing f k x) where+ fmap = mapWhenMissing+ {-# INLINE fmap #-}++-- | @since 0.5.9+instance (Applicative f, Monad f)+ => Category.Category (WhenMissing f k) where+ id = preserveMissing+ f . g = traverseMaybeMissing $+ \ k x -> missingKey g k x >>= \y ->+ case y of+ Nothing -> pure Nothing+ Just q -> missingKey f k q+ {-# INLINE id #-}+ {-# INLINE (.) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Applicative (WhenMissing f k x) where+ pure x = mapMissing (\ _ _ -> x)+ f <*> g = traverseMaybeMissing $ \k x -> do+ res1 <- missingKey f k x+ case res1 of+ Nothing -> pure Nothing+ Just r -> (pure $!) . fmap r =<< missingKey g k x+ {-# INLINE pure #-}+ {-# INLINE (<*>) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Monad (WhenMissing f k x) where+ m >>= f = traverseMaybeMissing $ \k x -> do+ res1 <- missingKey m k x+ case res1 of+ Nothing -> pure Nothing+ Just r -> missingKey (f r) k x+ {-# INLINE (>>=) #-}++-- | Map covariantly over a @'WhenMissing' f k x@.+--+-- @since 0.5.9+mapWhenMissing :: (Applicative f, Monad f)+ => (a -> b)+ -> WhenMissing f k x a -> WhenMissing f k x b+mapWhenMissing f t = WhenMissing+ { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'+ , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }+{-# INLINE mapWhenMissing #-}++-- | Map covariantly over a @'WhenMissing' f k x@, using only a 'Functor f'+-- constraint.+mapGentlyWhenMissing :: Functor f+ => (a -> b)+ -> WhenMissing f k x a -> WhenMissing f k x b+mapGentlyWhenMissing f t = WhenMissing+ { missingSubtree = \m -> fmap f <$> missingSubtree t m+ , missingKey = \k x -> fmap f <$> missingKey t k x }+{-# INLINE mapGentlyWhenMissing #-}++-- | Map covariantly over a @'WhenMatched' f k x@, using only a 'Functor f'+-- constraint.+mapGentlyWhenMatched :: Functor f+ => (a -> b)+ -> WhenMatched f k x y a -> WhenMatched f k x y b+mapGentlyWhenMatched f t = zipWithMaybeAMatched $+ \k x y -> fmap f <$> runWhenMatched t k x y+{-# INLINE mapGentlyWhenMatched #-}++-- | Map contravariantly over a @'WhenMissing' f k _ x@.+--+-- @since 0.5.9+lmapWhenMissing :: (b -> a) -> WhenMissing f k a x -> WhenMissing f k b x+lmapWhenMissing f t = WhenMissing+ { missingSubtree = \m -> missingSubtree t (fmap f m)+ , missingKey = \k x -> missingKey t k (f x) }+{-# INLINE lmapWhenMissing #-}++-- | Map contravariantly over a @'WhenMatched' f k _ y z@.+--+-- @since 0.5.9+contramapFirstWhenMatched :: (b -> a)+ -> WhenMatched f k a y z+ -> WhenMatched f k b y z+contramapFirstWhenMatched f t = WhenMatched $+ \k x y -> runWhenMatched t k (f x) y+{-# INLINE contramapFirstWhenMatched #-}++-- | Map contravariantly over a @'WhenMatched' f k x _ z@.+--+-- @since 0.5.9+contramapSecondWhenMatched :: (b -> a)+ -> WhenMatched f k x a z+ -> WhenMatched f k x b z+contramapSecondWhenMatched f t = WhenMatched $+ \k x y -> runWhenMatched t k x (f y)+{-# INLINE contramapSecondWhenMatched #-}++-- | A tactic for dealing with keys present in one map but not the other in+-- 'merge'.+--+-- A tactic of type @ SimpleWhenMissing k x z @ is an abstract representation+-- of a function of type @ k -> x -> Maybe z @.+--+-- @since 0.5.9+type SimpleWhenMissing = WhenMissing Identity++-- | A tactic for dealing with keys present in both+-- maps in 'merge' or 'mergeA'.+--+-- A tactic of type @ WhenMatched f k x y z @ is an abstract representation+-- of a function of type @ k -> x -> y -> f (Maybe z) @.+--+-- @since 0.5.9+newtype WhenMatched f k x y z = WhenMatched+ { matchedKey :: k -> x -> y -> f (Maybe z) }++-- | Along with zipWithMaybeAMatched, witnesses the isomorphism between+-- @WhenMatched f k x y z@ and @k -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+runWhenMatched :: WhenMatched f k x y z -> k -> x -> y -> f (Maybe z)+runWhenMatched = matchedKey+{-# INLINE runWhenMatched #-}++-- | Along with traverseMaybeMissing, witnesses the isomorphism between+-- @WhenMissing f k x y@ and @k -> x -> f (Maybe y)@.+--+-- @since 0.5.9+runWhenMissing :: WhenMissing f k x y -> k -> x -> f (Maybe y)+runWhenMissing = missingKey+{-# INLINE runWhenMissing #-}++-- | @since 0.5.9+instance Functor f => Functor (WhenMatched f k x y) where+ fmap = mapWhenMatched+ {-# INLINE fmap #-}++-- | @since 0.5.9+instance (Monad f, Applicative f) => Category.Category (WhenMatched f k x) where+ id = zipWithMatched (\_ _ y -> y)+ f . g = zipWithMaybeAMatched $+ \k x y -> do+ res <- runWhenMatched g k x y+ case res of+ Nothing -> pure Nothing+ Just r -> runWhenMatched f k x r+ {-# INLINE id #-}+ {-# INLINE (.) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Applicative (WhenMatched f k x y) where+ pure x = zipWithMatched (\_ _ _ -> x)+ fs <*> xs = zipWithMaybeAMatched $ \k x y -> do+ res <- runWhenMatched fs k x y+ case res of+ Nothing -> pure Nothing+ Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y+ {-# INLINE pure #-}+ {-# INLINE (<*>) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Monad (WhenMatched f k x y) where+ m >>= f = zipWithMaybeAMatched $ \k x y -> do+ res <- runWhenMatched m k x y+ case res of+ Nothing -> pure Nothing+ Just r -> runWhenMatched (f r) k x y+ {-# INLINE (>>=) #-}++-- | Map covariantly over a @'WhenMatched' f k x y@.+--+-- @since 0.5.9+mapWhenMatched :: Functor f+ => (a -> b)+ -> WhenMatched f k x y a+ -> WhenMatched f k x y b+mapWhenMatched f (WhenMatched g) = WhenMatched $ \k x y -> fmap (fmap f) (g k x y)+{-# INLINE mapWhenMatched #-}++-- | A tactic for dealing with keys present in both maps in 'merge'.+--+-- A tactic of type @ SimpleWhenMatched k x y z @ is an abstract representation+-- of a function of type @ k -> x -> y -> Maybe z @.+--+-- @since 0.5.9+type SimpleWhenMatched = WhenMatched Identity++-- | When a key is found in both maps, apply a function to the+-- key and values and use the result in the merged map.+--+-- @+-- zipWithMatched :: (k -> x -> y -> z)+-- -> SimpleWhenMatched k x y z+-- @+--+-- @since 0.5.9+zipWithMatched :: Applicative f+ => (k -> x -> y -> z)+ -> WhenMatched f k x y z+zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y+{-# INLINE zipWithMatched #-}++-- | When a key is found in both maps, apply a function to the+-- key and values to produce an action and use its result in the merged map.+--+-- @since 0.5.9+zipWithAMatched :: Applicative f+ => (k -> x -> y -> f z)+ -> WhenMatched f k x y z+zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y+{-# INLINE zipWithAMatched #-}++-- | When a key is found in both maps, apply a function to the+-- key and values and maybe use the result in the merged map.+--+-- @+-- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)+-- -> SimpleWhenMatched k x y z+-- @+--+-- @since 0.5.9+zipWithMaybeMatched :: Applicative f+ => (k -> x -> y -> Maybe z)+ -> WhenMatched f k x y z+zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y+{-# INLINE zipWithMaybeMatched #-}++-- | When a key is found in both maps, apply a function to the+-- key and values, perform the resulting action, and maybe use+-- the result in the merged map.+--+-- This is the fundamental 'WhenMatched' tactic.+--+-- @since 0.5.9+zipWithMaybeAMatched :: (k -> x -> y -> f (Maybe z))+ -> WhenMatched f k x y z+zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y+{-# INLINE zipWithMaybeAMatched #-}++-- | Drop all the entries whose keys are missing from the other+-- map.+--+-- @+-- dropMissing :: SimpleWhenMissing k x y+-- @+--+-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)+--+-- but @dropMissing@ is much faster.+--+-- @since 0.5.9+dropMissing :: Applicative f => WhenMissing f k x y+dropMissing = WhenMissing+ { missingSubtree = const (pure Tip)+ , missingKey = \_ _ -> pure Nothing }+{-# INLINE dropMissing #-}++-- | Preserve, unchanged, the entries whose keys are missing from+-- the other map.+--+-- @+-- preserveMissing :: SimpleWhenMissing k x x+-- @+--+-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)+--+-- but @preserveMissing@ is much faster.+--+-- @since 0.5.9+preserveMissing :: Applicative f => WhenMissing f k x x+preserveMissing = WhenMissing+ { missingSubtree = pure+ , missingKey = \_ v -> pure (Just v) }+{-# INLINE preserveMissing #-}++-- | Force the entries whose keys are missing from+-- the other map and otherwise preserve them unchanged.+--+-- @+-- preserveMissing' :: SimpleWhenMissing k x x+-- @+--+-- prop> preserveMissing' = Merge.Lazy.mapMaybeMissing (\_ x -> Just $! x)+--+-- but @preserveMissing'@ is quite a bit faster.+--+-- @since 0.5.9+preserveMissing' :: Applicative f => WhenMissing f k x x+preserveMissing' = WhenMissing+ { missingSubtree = \t -> pure $! forceTree t `seq` t+ , missingKey = \_ v -> pure $! Just $! v }+{-# INLINE preserveMissing' #-}++-- Force all the values in a tree.+forceTree :: Map k a -> ()+forceTree (Bin _ _ v l r) = v `seq` forceTree l `seq` forceTree r `seq` ()+forceTree Tip = ()++-- | Map over the entries whose keys are missing from the other map.+--+-- @+-- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y+-- @+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+--+-- @since 0.5.9+mapMissing :: Applicative f => (k -> x -> y) -> WhenMissing f k x y+mapMissing f = WhenMissing+ { missingSubtree = \m -> pure $! mapWithKey f m+ , missingKey = \ k x -> pure $ Just (f k x) }+{-# INLINE mapMissing #-}++-- | Map over the entries whose keys are missing from the other map,+-- optionally removing some. This is the most powerful 'SimpleWhenMissing'+-- tactic, but others are usually more efficient.+--+-- @+-- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y+-- @+--+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))+--+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.+--+-- @since 0.5.9+mapMaybeMissing :: Applicative f => (k -> x -> Maybe y) -> WhenMissing f k x y+mapMaybeMissing f = WhenMissing+ { missingSubtree = \m -> pure $! mapMaybeWithKey f m+ , missingKey = \k x -> pure $! f k x }+{-# INLINE mapMaybeMissing #-}++-- | Filter the entries whose keys are missing from the other map.+--+-- @+-- filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing k x x+-- @+--+-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterMissing :: Applicative f+ => (k -> x -> Bool) -> WhenMissing f k x x+filterMissing f = WhenMissing+ { missingSubtree = \m -> pure $! filterWithKey f m+ , missingKey = \k x -> pure $! if f k x then Just x else Nothing }+{-# INLINE filterMissing #-}++-- | Filter the entries whose keys are missing from the other map+-- using some 'Applicative' action.+--+-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $+-- > \k x -> (\b -> guard b *> Just x) <$> f k x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterAMissing :: Applicative f+ => (k -> x -> f Bool) -> WhenMissing f k x x+filterAMissing f = WhenMissing+ { missingSubtree = \m -> filterWithKeyA f m+ , missingKey = \k x -> bool Nothing (Just x) <$> f k x }+{-# INLINE filterAMissing #-}++-- | This wasn't in Data.Bool until 4.7.0, so we define it here+bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True = t++-- | Traverse over the entries whose keys are missing from the other map.+--+-- @since 0.5.9+traverseMissing :: Applicative f+ => (k -> x -> f y) -> WhenMissing f k x y+traverseMissing f = WhenMissing+ { missingSubtree = traverseWithKey f+ , missingKey = \k x -> Just <$> f k x }+{-# INLINE traverseMissing #-}++-- | Traverse over the entries whose keys are missing from the other map,+-- optionally producing values to put in the result.+-- This is the most powerful 'WhenMissing' tactic, but others are usually+-- more efficient.+--+-- @since 0.5.9+traverseMaybeMissing :: Applicative f+ => (k -> x -> f (Maybe y)) -> WhenMissing f k x y+traverseMaybeMissing f = WhenMissing+ { missingSubtree = traverseMaybeWithKey f+ , missingKey = f }+{-# INLINE traverseMaybeMissing #-}++-- | Merge two maps.+--+-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched'+-- tactic and two maps. It uses the tactics to merge the maps.+-- Its behavior is best understood via its fundamental tactics,+-- 'mapMaybeMissing' and 'zipWithMaybeMatched'.+--+-- Consider+--+-- @+-- merge (mapMaybeMissing g1)+-- (mapMaybeMissing g2)+-- (zipWithMaybeMatched f)+-- m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'merge' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- This produces a 'Maybe' for each key:+--+-- @+-- keys = 0 1 2 3 4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'mapMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+--+-- When 'merge' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should typically use 'merge'+-- to define your custom combining functions.+--+--+-- Examples:+--+-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)+-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)+-- prop> differenceWith f = merge preserveMissing dropMissing (zipWithMatched f)+-- prop> symmetricDifference = merge preserveMissing preserveMissing (zipWithMaybeMatched $ \ _ _ _ -> Nothing)+-- prop> mapEachPiece f g h = merge (mapMissing f) (mapMissing g) (zipWithMatched h)+--+-- @since 0.5.9+merge :: Ord k+ => SimpleWhenMissing k a c -- ^ What to do with keys in @m1@ but not @m2@+ -> SimpleWhenMissing k b c -- ^ What to do with keys in @m2@ but not @m1@+ -> SimpleWhenMatched k a b c -- ^ What to do with keys in both @m1@ and @m2@+ -> Map k a -- ^ Map @m1@+ -> Map k b -- ^ Map @m2@+ -> Map k c+merge g1 g2 f m1 m2 = runIdentity $+ mergeA g1 g2 f m1 m2+{-# INLINE merge #-}++-- | An applicative version of 'merge'.+--+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'+-- tactic and two maps. It uses the tactics to merge the maps.+-- Its behavior is best understood via its fundamental tactics,+-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+-- (traverseMaybeMissing g2)+-- (zipWithMaybeAMatched f)+-- m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- @mergeA@ will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- Next, it will perform the actions in the @actions@ list in order from+-- left to right.+--+-- @+-- keys = 0 1 2 3 4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'traverseMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+-- * 'mapMaybeMissing' does not use the 'Applicative' context.+--+-- When 'mergeA' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should generally only use+-- 'mergeA' to define custom combining functions.+--+-- @since 0.5.9+mergeA+ :: (Applicative f, Ord k)+ => WhenMissing f k a c -- ^ What to do with keys in @m1@ but not @m2@+ -> WhenMissing f k b c -- ^ What to do with keys in @m2@ but not @m1@+ -> WhenMatched f k a b c -- ^ What to do with keys in both @m1@ and @m2@+ -> Map k a -- ^ Map @m1@+ -> Map k b -- ^ Map @m2@+ -> f (Map k c)+mergeA+ WhenMissing{missingSubtree = g1t, missingKey = g1k}+ WhenMissing{missingSubtree = g2t}+ (WhenMatched f) = go+ where+ go t1 Tip = g1t t1+ go Tip t2 = g2t t2+ go (Bin _ kx x1 l1 r1) t2 = case splitLookup kx t2 of+ (l2, mx2, r2) -> case mx2 of+ Nothing -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')+ l1l2 (g1k kx x1) r1r2+ Just x2 -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')+ l1l2 (f kx x1 x2) r1r2+ where+ !l1l2 = go l1 l2+ !r1r2 = go r1 r2+{-# INLINE mergeA #-}+++{--------------------------------------------------------------------+ MergeWithKey+--------------------------------------------------------------------}++-- | \(O(n+m)\). An unsafe general combining function.+--+-- __Warning__: This function can produce corrupt maps and its results+-- may depend on the internal structures of its inputs. Users should+-- prefer 'merge' or 'mergeA'.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'Map's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+-- values to the @combine@ function. Depending on the result, the key is either+-- present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+-- the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+-- the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@,+-- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@.++mergeWithKey :: Ord k+ => (k -> a -> b -> Maybe c)+ -> (Map k a -> Map k c)+ -> (Map k b -> Map k c)+ -> Map k a -> Map k b -> Map k c+mergeWithKey f g1 g2 = go+ where+ go Tip Tip = Tip+ go Tip t2 = g2 t2+ go t1 Tip = g1 t1+ go (Bin _ kx x l1 r1) t2 =+ case found of+ Nothing -> case g1 (singleton kx x) of+ Tip -> link2 l' r'+ (Bin _ _ x' Tip Tip) -> link kx x' l' r'+ _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"+ Just x2 -> case f kx x x2 of+ Nothing -> link2 l' r'+ Just x' -> link kx x' l' r'+ where+ (l2, found, r2) = splitLookup kx t2+ l' = go l1 l2+ r' = go r1 r2+{-# INLINE mergeWithKey #-}++{--------------------------------------------------------------------+ Submap+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+--+isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2+#if __GLASGOW_HASKELL__+{-# INLINABLE isSubmapOf #-}+#endif++{- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+ The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if+ all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++ > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])++ But the following are all 'False':++ > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])++ Note that @isSubmapOfBy (\_ _ -> True) m1 m2@ tests whether all the keys+ in @m1@ are also keys in @m2@.++-}+isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool+isSubmapOfBy f t1 t2+ = size t1 <= size t2 && submap' f t1 t2+#if __GLASGOW_HASKELL__+{-# INLINABLE isSubmapOfBy #-}+#endif++-- Test whether a map is a submap of another without the *initial*+-- size test. See Data.Set.Internal.isSubsetOfX for notes on+-- implementation and analysis.+submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool+submap' _ Tip _ = True+submap' _ _ Tip = False+submap' f (Bin 1 kx x _ _) t+ = case lookup kx t of+ Just y -> f x y+ Nothing -> False+submap' f (Bin _ kx x l r) t+ = case found of+ Nothing -> False+ Just y -> f x y+ && size l <= size lt && size r <= size gt+ && submap' f l lt && submap' f r gt+ where+ (lt,found,gt) = splitLookup kx t+#if __GLASGOW_HASKELL__+{-# INLINABLE submap' #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isProperSubmapOf m1 m2+ = isProperSubmapOfBy (==) m1 m2+#if __GLASGOW_HASKELL__+{-# INLINABLE isProperSubmapOf #-}+#endif++{- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @keys m1@ and @keys m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++ > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+++-}+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool+isProperSubmapOfBy f t1 t2+ = size t1 < size t2 && submap' f t1 t2+#if __GLASGOW_HASKELL__+{-# INLINABLE isProperSubmapOfBy #-}+#endif++{--------------------------------------------------------------------+ Filter and partition+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all values that satisfy the predicate.+--+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty++filter :: (a -> Bool) -> Map k a -> Map k a+filter p m+ = filterWithKey (\_ x -> p x) m++-- | \(O(n)\). Filter all keys that satisfy the predicate.+--+-- @+-- filterKeys p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- > filterKeys (> 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+--+-- @since 0.8++filterKeys :: (k -> Bool) -> Map k a -> Map k a+filterKeys p m = filterWithKey (\k _ -> p k) m++-- | \(O(n)\). Filter all keys\/values that satisfy the predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a+filterWithKey _ Tip = Tip+filterWithKey p t@(Bin _ kx x l r)+ | p kx x = if pl `ptrEq` l && pr `ptrEq` r+ then t+ else link kx x pl pr+ | otherwise = link2 pl pr+ where !pl = filterWithKey p l+ !pr = filterWithKey p r++-- | \(O(n)\). Filter keys and values using an 'Applicative'+-- predicate.+filterWithKeyA :: Applicative f => (k -> a -> f Bool) -> Map k a -> f (Map k a)+filterWithKeyA _ Tip = pure Tip+filterWithKeyA p t@(Bin _ kx x l r) =+ liftA3 combine (filterWithKeyA p l) (p kx x) (filterWithKeyA p r)+ where+ combine pl True pr+ | pl `ptrEq` l && pr `ptrEq` r = t+ | otherwise = link kx x pl pr+ combine pl False pr = link2 pl pr++-- | \(O(\log n)\). Take while a predicate on the keys holds.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'+-- takeWhileAntitone p = 'filterWithKey' (\k _ -> p k)+-- @+--+-- @since 0.5.8++takeWhileAntitone :: (k -> Bool) -> Map k a -> Map k a+takeWhileAntitone _ Tip = Tip+takeWhileAntitone p (Bin _ kx x l r)+ | p kx = link kx x l (takeWhileAntitone p r)+ | otherwise = takeWhileAntitone p l++-- | \(O(\log n)\). Drop while a predicate on the keys holds.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'+-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k))+-- @+--+-- @since 0.5.8++dropWhileAntitone :: (k -> Bool) -> Map k a -> Map k a+dropWhileAntitone _ Tip = Tip+dropWhileAntitone p (Bin _ kx x l r)+ | p kx = dropWhileAntitone p r+ | otherwise = link kx x (dropWhileAntitone p l) r++-- | \(O(\log n)\). Divide a map at the point where a predicate on the keys stops holding.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = partitionWithKey (\\k _ -> p k) xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map+-- at some /unspecified/ point where the predicate switches from holding to not+-- holding (where the predicate is seen to hold before the first key and to fail+-- after the last key).+--+-- @since 0.5.8++spanAntitone :: (k -> Bool) -> Map k a -> (Map k a, Map k a)+spanAntitone p0 m = toPair (go p0 m)+ where+ go _ Tip = Tip :*: Tip+ go p (Bin _ kx x l r)+ | p kx = let u :*: v = go p r in link kx x l u :*: v+ | otherwise = let u :*: v = go p l in u :*: link kx x v r++-- | \(O(n)\). Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partition :: (a -> Bool) -> Map k a -> (Map k a,Map k a)+partition p m+ = partitionWithKey (\_ x -> p x) m++-- | \(O(n)\). Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)+partitionWithKey p0 t0 = toPair $ go p0 t0+ where+ go _ Tip = (Tip :*: Tip)+ go p t@(Bin _ kx x l r)+ | p kx x = (if l1 `ptrEq` l && r1 `ptrEq` r+ then t+ else link kx x l1 r1) :*: link2 l2 r2+ | otherwise = link2 l1 r1 :*:+ (if l2 `ptrEq` l && r2 `ptrEq` r+ then t+ else link kx x l2 r2)+ where+ (l1 :*: l2) = go p l+ (r1 :*: r2) = go p r++-- | \(O(n)\). Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | \(O(n)\). Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b+mapMaybeWithKey _ Tip = Tip+mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of+ Just y -> link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)+ Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r)++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.5.8+traverseMaybeWithKey :: Applicative f+ => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)+traverseMaybeWithKey = go+ where+ go _ Tip = pure Tip+ go f (Bin _ kx x Tip Tip) = maybe Tip (\x' -> Bin 1 kx x' Tip Tip) <$> f kx x+ go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r)+ where+ combine !l' mx !r' = case mx of+ Nothing -> link2 l' r'+ Just x' -> link kx x' l' r'++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEither f m+ = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+ where+ go _ Tip = (Tip :*: Tip)+ go f (Bin _ kx x l r) = case f kx x of+ Left y -> link kx y l1 r1 :*: link2 l2 r2+ Right z -> link2 l1 r1 :*: link kx z l2 r2+ where+ (l1 :*: l2) = go f l+ (r1 :*: r2) = go f r++{--------------------------------------------------------------------+ Mapping+--------------------------------------------------------------------}+-- | \(O(n)\). Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Map k a -> Map k b+map f = go where+ go Tip = Tip+ go (Bin sx kx x l r) = Bin sx kx (f x) (go l) (go r)+-- We use a `go` function to allow `map` to inline. This makes+-- a big difference if someone uses `map (const x) m` instead+-- of `x <$ m`; it doesn't seem to do any harm.++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+"map/coerce" map coerce = coerce+ #-}+#endif++-- | \(O(n)\). Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (k -> a -> b) -> Map k a -> Map k b+mapWithKey _ Tip = Tip+mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+ mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+ mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+ mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif++-- | \(O(n)\).+-- @'traverseWithKey' f m == 'fromList' \<$\> 'traverse' (\\(k, v) -> (,) k \<$\> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing+traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)+traverseWithKey f = go+ where+ go Tip = pure Tip+ go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v+ go (Bin s k v l r) = liftA3 (flip (Bin s k)) (go l) (f k v) (go r)+{-# INLINE traverseWithKey #-}++-- | \(O(n)\). The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccum f a m+ = mapAccumWithKey (\a' _ x' -> f a' x') a m++-- | \(O(n)\). The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumWithKey f a t+ = mapAccumL f a t++-- | \(O(n)\). The function 'mapAccumL' threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumL _ a Tip = (a,Tip)+mapAccumL f a (Bin sx kx x l r) =+ let (a1,l') = mapAccumL f a l+ (a2,x') = f a1 kx x+ (a3,r') = mapAccumL f a2 r+ in (a3,Bin sx kx x' l' r')++-- | \(O(n)\). The function 'mapAccumRWithKey' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumRWithKey _ a Tip = (a,Tip)+mapAccumRWithKey f a (Bin sx kx x l r) =+ let (a1,r') = mapAccumRWithKey f a r+ (a2,x') = f a1 kx x+ (a3,l') = mapAccumRWithKey f a2 l+ in (a3,Bin sx kx x' l' r')++-- | \(O(n \log n)\).+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- If `f` is monotonically non-decreasing, this function takes \(O(n)\) time.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the value at the greatest of the+-- original keys is retained.+--+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")]) == fromList [(4, "b"), (6, "a")]+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"++mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a+mapKeys f m = finishB (foldlWithKey' (\b kx x -> insertB (f kx) x b) emptyB m)+#if __GLASGOW_HASKELL__+{-# INLINABLE mapKeys #-}+#endif++-- | \(O(n \log n)\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- If `f` is monotonically non-decreasing, this function takes \(O(n)\) time.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key. In this case the associated values will be+-- combined using @c@. The value at the greater of the two original keys+-- is used as the first argument to @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"+--+-- Also see the performance note on 'fromListWith'.++mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a+mapKeysWith c f m =+ finishB (foldlWithKey' (\b kx x -> insertWithB c (f kx) x b) emptyB m)+#if __GLASGOW_HASKELL__+{-# INLINABLE mapKeysWith #-}+#endif+++-- | \(O(n)\).+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- > ==> mapKeysMonotonic f s == mapKeys f s+-- > where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has better performance than 'mapKeys'.+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'mapKeys' if the+-- precondition may not hold.+--+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]+-- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True+-- > valid (mapKeysMonotonic (\ _ -> 1) (fromList [(5,"a"), (3,"b")])) == False++mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a+mapKeysMonotonic _ Tip = Tip+mapKeysMonotonic f (Bin sz k x l r) =+ Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)++{--------------------------------------------------------------------+ Folds+--------------------------------------------------------------------}++-- | \(O(n)\). Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr :: (a -> b -> b) -> b -> Map k a -> b+foldr f z = go z+ where+ go z' Tip = z'+ go z' (Bin _ _ x l r) = go (f x (go z' r)) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> Map k a -> b+foldr' f z = go z+ where+ go !z' Tip = z'+ go z' (Bin _ _ x l r) = go (f x $! go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+--+-- For example,+--+-- > elems = reverse . foldl (flip (:)) []+--+-- > let f len a = len + (length a)+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldl :: (a -> b -> a) -> a -> Map k b -> a+foldl f z = go z+ where+ go z' Tip = z'+ go z' (Bin _ _ x l r) = go (f (go z' l) x) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> Map k b -> a+foldl' f z = go z+ where+ go !z' Tip = z'+ go z' (Bin _ _ x l r) =+ let !z'' = go z' l+ in go (f z'' x) r+{-# INLINE foldl' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrWithKey f z = go z+ where+ go z' Tip = z'+ go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l+{-# INLINE foldrWithKey #-}++-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrWithKey' f z = go z+ where+ go !z' Tip = z'+ go z' (Bin _ kx x l r) = go (f kx x $! go z' r) l+{-# INLINE foldrWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+--+-- For example,+--+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []+--+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"+foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlWithKey f z = go z+ where+ go z' Tip = z'+ go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r+{-# INLINE foldlWithKey #-}++-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlWithKey' f z = go z+ where+ go !z' Tip = z'+ go z' (Bin _ kx x l r) =+ let !z'' = go z' l+ in go (f z'' kx x) r+{-# INLINE foldlWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that+--+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@+--+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.+--+-- @since 0.5.4+foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m+foldMapWithKey f = go+ where+ go Tip = mempty+ go (Bin 1 k v _ _) = f k v+ go (Bin _ k v l r) = go l `mappend` (f k v `mappend` go r)+{-# INLINE foldMapWithKey #-}++{--------------------------------------------------------------------+ List variations+--------------------------------------------------------------------}+-- | \(O(n)\).+-- Return all elements of the map in the ascending order of their keys.+-- Subject to list fusion.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: Map k a -> [a]+elems = foldr (:) []++-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list+-- fusion.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys :: Map k a -> [k]+keys = foldrWithKey (\k _ ks -> k : ks) []++-- | \(O(n)\). An alias for 'toAscList'. Return all key\/value pairs in the map+-- in ascending key order. Subject to list fusion.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: Map k a -> [(k,a)]+assocs m+ = toAscList m++-- | \(O(n)\). The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]+-- > keysSet empty == Data.Set.empty++keysSet :: Map k a -> Set.Set k+keysSet Tip = Set.Tip+keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r)++-- | \(O(n)\). The set of all elements of the map contained in 'Arg's.+--+-- > argSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [Arg 3 "b",Arg 5 "a"]+-- > argSet empty == Data.Set.empty+--+-- @since 0.6.6+argSet :: Map k a -> Set.Set (Arg k a)+argSet Tip = Set.Tip+argSet (Bin sz kx x l r) = Set.Bin sz (Arg kx x) (argSet l) (argSet r)++-- | \(O(n)\). Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Set.empty == empty++fromSet :: (k -> a) -> Set.Set k -> Map k a+fromSet _ Set.Tip = Tip+fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r)++-- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's.+--+-- > fromArgSet (Data.Set.fromList [Arg 3 "aaa", Arg 5 "aaaaa"]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromArgSet Data.Set.empty == empty+--+-- @since 0.6.6+fromArgSet :: Set.Set (Arg k a) -> Map k a+fromArgSet Set.Tip = Tip+fromArgSet (Set.Bin sz (Arg x v) l r) = Bin sz x v (fromArgSet l) (fromArgSet r)++{--------------------------------------------------------------------+ Lists+--------------------------------------------------------------------}++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.6.2+instance (Ord k) => GHCExts.IsList (Map k v) where+ type Item (Map k v) = (k,v)+ fromList = fromList+ toList = toList+#endif++-- | \(O(n \log n)\). Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: Ord k => [(k,a)] -> Map k a+fromList xs = finishB (Foldable.foldl' (\b (kx, x) -> insertB kx x b) emptyB xs)+{-# INLINE fromList #-} -- INLINE for fusion++-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")]+-- > fromListWith (++) [] == empty+--+-- Note the reverse ordering of @"cba"@ in the example.+--+-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@.+--+-- === Performance+--+-- You should ensure that the given @f@ is fast with this order of arguments.+--+-- Symmetric functions may be slow in one order, and fast in another.+-- For the common case of collecting values of matching keys in a list, as above:+--+-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument.+-- Thus:+--+-- > fromListWith (++) (replicate 1000000 (3, "x")) -- O(n), fast+-- > fromListWith (flip (++)) (replicate 1000000 (3, "x")) -- O(n²), extremely slow+--+-- because they evaluate as, respectively:+--+-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))] -- O(n)+-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")] -- O(n²)+--+-- Thus, to get good performance with an operation like @(++)@ while also preserving+-- the same order as in the input list, reverse the input:+--+-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")]+--+-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in:+--+-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples++fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a+fromListWith f xs =+ finishB (Foldable.foldl' (\b (kx, x) -> insertWithB f kx x b) emptyB xs)+{-# INLINE fromListWith #-} -- INLINE for fusion++-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty+--+-- Also see the performance note on 'fromListWith'.++fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromListWithKey f xs =+ finishB (Foldable.foldl' (\b (kx, x) -> insertWithB (f kx) kx x b) emptyB xs)+{-# INLINE fromListWithKey #-} -- INLINE for fusion++-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list fusion.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: Map k a -> [(k,a)]+toList = toAscList++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys are+-- in ascending order. Subject to list fusion.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: Map k a -> [(k,a)]+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys+-- are in descending order. Subject to list fusion.+--+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]++toDescList :: Map k a -> [(k,a)]+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.+-- They are important to convert unfused methods back, see mapFB in prelude.+foldrFB :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrFB = foldrWithKey+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlFB = foldlWithKey+{-# INLINE[0] foldlFB #-}++-- Inline assocs and toList, so that we need to fuse only toAscList.+{-# INLINE assocs #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to+-- elems,keys,to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to+-- inline it before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] elems #-}+{-# NOINLINE[0] keys #-}+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}+{-# RULES "Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}+{-# RULES "Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}+{-# RULES "Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}+{-# RULES "Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}+{-# RULES "Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}+{-# RULES "Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}+{-# RULES "Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}+#endif++{--------------------------------------------------------------------+ Building trees from ascending/descending lists can be done in linear time.++ Note that if [xs] is ascending that:+ fromAscList xs == fromList xs+ fromAscListWith f xs == fromListWith f xs+--------------------------------------------------------------------}+-- | \(O(n)\). Build a map from an ascending list in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False++fromAscList :: Eq k => [(k,a)] -> Map k a+fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs+{-# INLINE fromAscList #-} -- INLINE for fusion++-- | \(O(n)\). Build a map from a descending list in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- > fromDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]+-- > fromDescList [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False+--+-- @since 0.5.8++fromDescList :: Eq k => [(k,a)] -> Map k a+fromDescList xs = fromDescListWithKey (\_ x _ -> x) xs+{-# INLINE fromDescList #-} -- INLINE for fusion++-- | \(O(n)\). Build a map from an ascending list in linear time with a combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False++fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWith f xs+ = fromAscListWithKey (\_ x y -> f x y) xs+{-# INLINE fromAscListWith #-} -- INLINE for fusion++-- | \(O(n)\). Build a map from a descending list in linear time with a combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+--+-- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'.+--+-- @since 0.5.8++fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromDescListWith f xs+ = fromDescListWithKey (\_ x y -> f x y) xs+{-# INLINE fromDescListWith #-} -- INLINE for fusion++-- | \(O(n)\). Build a map from an ascending list in linear time with a+-- combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True+-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'.++fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWithKey f xs = ascLinkAll (Foldable.foldl' next Nada xs)+ where+ next stk (!ky, y) = case stk of+ Push kx x l stk'+ | ky == kx -> Push ky (f ky y x) l stk'+ | Tip <- l -> ascLinkTop stk' 1 (singleton kx x) ky y+ | otherwise -> Push ky y Tip stk+ Nada -> Push ky y Tip stk+{-# INLINE fromAscListWithKey #-} -- INLINE for fusion++-- | \(O(n)\). Build a map from a descending list in linear time with a+-- combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'.++fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromDescListWithKey f xs = descLinkAll (Foldable.foldl' next Nada xs)+ where+ next stk (!ky, y) = case stk of+ Push kx x r stk'+ | ky == kx -> Push ky (f ky y x) r stk'+ | Tip <- r -> descLinkTop ky y 1 (singleton kx x) stk'+ | otherwise -> Push ky y Tip stk+ Nada -> Push ky y Tip stk+{-# INLINE fromDescListWithKey #-} -- INLINE for fusion+++-- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True+-- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False++-- See Note [fromDistinctAscList implementation] in Data.Set.Internal.+fromDistinctAscList :: [(k,a)] -> Map k a+fromDistinctAscList xs = ascLinkAll (Foldable.foldl' next Nada xs)+ where+ next :: Stack k a -> (k, a) -> Stack k a+ next (Push kx x Tip stk) (!ky, y) = ascLinkTop stk 1 (singleton kx x) ky y+ next stk (!kx, x) = Push kx x Tip stk+{-# INLINE fromDistinctAscList #-} -- INLINE for fusion++ascLinkTop :: Stack k a -> Int -> Map k a -> k -> a -> Stack k a+ascLinkTop (Push kx x l@(Bin lsz _ _ _ _) stk) !rsz r ky y+ | lsz == rsz = ascLinkTop stk sz (Bin sz kx x l r) ky y+ where+ sz = lsz + rsz + 1+ascLinkTop stk !_ l kx x = Push kx x l stk++ascLinkAll :: Stack k a -> Map k a+ascLinkAll stk = foldl'Stack (\r kx x l -> link kx x l r) Tip stk+{-# INLINABLE ascLinkAll #-}++-- | \(O(n)\). Build a map from a descending list of distinct elements in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- strictly decreasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctDescList [(5,"a"), (3,"b")]) == True+-- > valid (fromDistinctDescList [(5,"a"), (5,"b"), (3,"b")]) == False+--+-- @since 0.5.8++-- See Note [fromDistinctAscList implementation] in Data.Set.Internal.+fromDistinctDescList :: [(k,a)] -> Map k a+fromDistinctDescList xs = descLinkAll (Foldable.foldl' next Nada xs)+ where+ next :: Stack k a -> (k, a) -> Stack k a+ next (Push ky y Tip stk) (!kx, x) = descLinkTop kx x 1 (singleton ky y) stk+ next stk (!ky, y) = Push ky y Tip stk+{-# INLINE fromDistinctDescList #-} -- INLINE for fusion++descLinkTop :: k -> a -> Int -> Map k a -> Stack k a -> Stack k a+descLinkTop kx x !lsz l (Push ky y r@(Bin rsz _ _ _ _) stk)+ | lsz == rsz = descLinkTop kx x sz (Bin sz ky y l r) stk+ where+ sz = lsz + rsz + 1+descLinkTop ky y !_ r stk = Push ky y r stk+{-# INLINABLE descLinkTop #-}++descLinkAll :: Stack k a -> Map k a+descLinkAll stk = foldl'Stack (\l kx x r -> link kx x l r) Tip stk+{-# INLINABLE descLinkAll #-}++data Stack k a = Push !k a !(Map k a) !(Stack k a) | Nada++foldl'Stack :: (b -> k -> a -> Map k a -> b) -> b -> Stack k a -> b+foldl'Stack f = go+ where+ go !z Nada = z+ go z (Push kx x t stk) = go (f z kx x t) stk+{-# INLINE foldl'Stack #-}++{-+-- Functions very similar to these were used to implement+-- hedge union, intersection, and difference algorithms that we no+-- longer use. These functions, however, seem likely to be useful+-- in their own right, so I'm leaving them here in case we end up+-- exporting them.++{--------------------------------------------------------------------+ [filterGt b t] filter all keys >[b] from tree [t]+ [filterLt b t] filter all keys <[b] from tree [t]+--------------------------------------------------------------------}+filterGt :: Ord k => k -> Map k v -> Map k v+filterGt !_ Tip = Tip+filterGt !b (Bin _ kx x l r) =+ case compare b kx of LT -> link kx x (filterGt b l) r+ EQ -> r+ GT -> filterGt b r+#if __GLASGOW_HASKELL__+{-# INLINABLE filterGt #-}+#endif++filterLt :: Ord k => k -> Map k v -> Map k v+filterLt !_ Tip = Tip+filterLt !b (Bin _ kx x l r) =+ case compare kx b of LT -> link kx x l (filterLt b r)+ EQ -> l+ GT -> filterLt b l+#if __GLASGOW_HASKELL__+{-# INLINABLE filterLt #-}+#endif+-}++{--------------------------------------------------------------------+ Split+--------------------------------------------------------------------}+-- | \(O(\log n)\). The expression (@'split' k map@) is a pair @(map1,map2)@ where+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.+-- Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)++split :: Ord k => k -> Map k a -> (Map k a,Map k a)+split !k0 t0 = toPair $ go k0 t0+ where+ go k t =+ case t of+ Tip -> Tip :*: Tip+ Bin _ kx x l r -> case compare k kx of+ LT -> let (lt :*: gt) = go k l in lt :*: link kx x gt r+ GT -> let (lt :*: gt) = go k r in link kx x l lt :*: gt+ EQ -> (l :*: r)+#if __GLASGOW_HASKELL__+{-# INLINABLE split #-}+#endif++-- | \(O(\log n)\). The expression (@'splitLookup' k map@) splits a map just+-- like 'split' but also returns @'lookup' k map@.+--+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)+splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)+splitLookup k0 m = case go k0 m of+ StrictTriple l mv r -> (l, mv, r)+ where+ go :: Ord k => k -> Map k a -> StrictTriple (Map k a) (Maybe a) (Map k a)+ go !k t =+ case t of+ Tip -> StrictTriple Tip Nothing Tip+ Bin _ kx x l r -> case compare k kx of+ LT -> let StrictTriple lt z gt = go k l+ !gt' = link kx x gt r+ in StrictTriple lt z gt'+ GT -> let StrictTriple lt z gt = go k r+ !lt' = link kx x l lt+ in StrictTriple lt' z gt+ EQ -> StrictTriple l (Just x) r+#if __GLASGOW_HASKELL__+{-# INLINABLE splitLookup #-}+#endif++-- | \(O(\log n)\). A variant of 'splitLookup' that indicates only whether the+-- key was present, rather than producing its value. This is used to+-- implement 'intersection' to avoid allocating unnecessary 'Just'+-- constructors.+splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)+splitMember k0 m = case go k0 m of+ StrictTriple l mv r -> (l, mv, r)+ where+ go :: Ord k => k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)+ go !k t =+ case t of+ Tip -> StrictTriple Tip False Tip+ Bin _ kx x l r -> case compare k kx of+ LT -> let StrictTriple lt z gt = go k l+ !gt' = link kx x gt r+ in StrictTriple lt z gt'+ GT -> let StrictTriple lt z gt = go k r+ !lt' = link kx x l lt+ in StrictTriple lt' z gt+ EQ -> StrictTriple l True r+#if __GLASGOW_HASKELL__+{-# INLINABLE splitMember #-}+#endif++data StrictTriple a b c = StrictTriple !a !b !c++{--------------------------------------------------------------------+ MapBuilder+--------------------------------------------------------------------}++-- See Note [SetBuilder] in Data.Set.Internal++data MapBuilder k a+ = BAsc !(Stack k a)+ | BMap !(Map k a)++-- Empty builder.+emptyB :: MapBuilder k a+emptyB = BAsc Nada++-- Insert a key and value. Replaces the old value if one already exists for+-- the key.+insertB :: Ord k => k -> a -> MapBuilder k a -> MapBuilder k a+insertB !ky y b = case b of+ BAsc stk -> case stk of+ Push kx x l stk' -> case compare ky kx of+ LT -> BMap (insert ky y (ascLinkAll stk))+ EQ -> BAsc (Push ky y l stk')+ GT -> case l of+ Tip -> BAsc (ascLinkTop stk' 1 (singleton kx x) ky y)+ Bin{} -> BAsc (Push ky y Tip stk)+ Nada -> BAsc (Push ky y Tip Nada)+ BMap m -> BMap (insert ky y m)+{-# INLINE insertB #-}++-- Insert a key and value. The new value is combined with the old value if one+-- already exists for the key.+insertWithB+ :: Ord k => (a -> a -> a) -> k -> a -> MapBuilder k a -> MapBuilder k a+insertWithB f !ky y b = case b of+ BAsc stk -> case stk of+ Push kx x l stk' -> case compare ky kx of+ LT -> BMap (insertWith f ky y (ascLinkAll stk))+ EQ -> BAsc (Push ky (f y x) l stk')+ GT -> case l of+ Tip -> BAsc (ascLinkTop stk' 1 (singleton kx x) ky y)+ Bin{} -> BAsc (Push ky y Tip stk)+ Nada -> BAsc (Push ky y Tip Nada)+ BMap m -> BMap (insertWith f ky y m)+{-# INLINE insertWithB #-}++-- Finalize the builder into a Map.+finishB :: MapBuilder k a -> Map k a+finishB (BAsc stk) = ascLinkAll stk+finishB (BMap m) = m+{-# INLINABLE finishB #-}++{--------------------------------------------------------------------+ Utility functions that maintain the balance properties of the tree.+ All constructors assume that all values in [l] < [k] and all values+ in [r] > [k], and that [l] and [r] are valid trees.++ In order of sophistication:+ [Bin sz k x l r] The type constructor.+ [bin k x l r] Maintains the correct size, assumes that both [l]+ and [r] are balanced with respect to each other.+ [balance k x l r] Restores the balance and size.+ Assumes that the original tree was balanced and+ that [l] or [r] has changed by at most one element.+ [link k x l r] Restores balance and size.++ Furthermore, we can construct a new tree from two trees. Both operations+ assume that all values in [l] < all values in [r] and that [l] and [r]+ are valid:+ [glue l r] Glues [l] and [r] together. Assumes that [l] and+ [r] are already balanced with respect to each other.+ [link2 l r] Merges two trees and restores balance.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+ Link+--------------------------------------------------------------------}+link :: k -> a -> Map k a -> Map k a -> Map k a+link kx x Tip r = insertMin kx x r+link kx x l Tip = insertMax kx x l+link kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)+ | delta*sizeL < sizeR = balanceL kz z (link kx x l lz) rz+ | delta*sizeR < sizeL = balanceR ky y ly (link kx x ry r)+ | otherwise = bin kx x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: k -> a -> Map k a -> Map k a+insertMax kx x t+ = case t of+ Tip -> singleton kx x+ Bin _ ky y l r+ -> balanceR ky y l (insertMax kx x r)++insertMin kx x t+ = case t of+ Tip -> singleton kx x+ Bin _ ky y l r+ -> balanceL ky y (insertMin kx x l) r++{--------------------------------------------------------------------+ [link2 l r]: merges two trees.+--------------------------------------------------------------------}+link2 :: Map k a -> Map k a -> Map k a+link2 Tip r = r+link2 l Tip = l+link2 l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)+ | delta*sizeL < sizeR = balanceL ky y (link2 l ly) ry+ | delta*sizeR < sizeL = balanceR kx x lx (link2 rx r)+ | otherwise = glue l r++{--------------------------------------------------------------------+ [glue l r]: glues two trees together.+ Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: Map k a -> Map k a -> Map k a+glue Tip r = r+glue l Tip = l+glue l@(Bin sl kl xl ll lr) r@(Bin sr kr xr rl rr)+ | sl > sr = let !(MaxView km m l') = maxViewSure kl xl ll lr in Bin (sl+sr) km m l' r+ | otherwise = let !(MinView km m r') = minViewSure kr xr rl rr in Bin (sl+sr) km m l r'++data MinView k a = MinView !k a !(Map k a)+data MaxView k a = MaxView !k a !(Map k a)++minViewSure :: k -> a -> Map k a -> Map k a -> MinView k a+minViewSure !k x l !r = case l of+ Tip -> MinView k x r+ Bin _ lk lx ll lr -> case minViewSure lk lx ll lr of+ MinView km xm l' -> MinView km xm (balanceR k x l' r)++maxViewSure :: k -> a -> Map k a -> Map k a -> MaxView k a+maxViewSure !k x !l r = case r of+ Tip -> MaxView k x l+ Bin _ rk rx rl rr -> case maxViewSure rk rx rl rr of+ MaxView km xm r' -> MaxView km xm (balanceL k x l r')++-- | \(O(\log n)\). Delete and find the minimal element.+--+-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])+-- > deleteFindMin empty Error: can not return the minimal element of an empty map++deleteFindMin :: Map k a -> ((k,a),Map k a)+deleteFindMin t = case minViewWithKey t of+ Nothing -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)+ Just res -> res++-- | \(O(\log n)\). Delete and find the maximal element.+--+-- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])+-- > deleteFindMax empty Error: can not return the maximal element of an empty map++deleteFindMax :: Map k a -> ((k,a),Map k a)+deleteFindMax t = case maxViewWithKey t of+ Nothing -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)+ Just res -> res++{--------------------------------------------------------------------+ Iterator+--------------------------------------------------------------------}++-- See Note [Iterator] in Data.Set.Internal++iterDown :: Map k a -> Stack k a -> Stack k a+iterDown (Bin _ kx x l r) stk = iterDown l (Push kx x r stk)+iterDown Tip stk = stk++-- Create an iterator from a Map, starting at the smallest key.+iterator :: Map k a -> Stack k a+iterator m = iterDown m Nada++-- Get the next key-value and the remaining iterator.+iterNext :: Stack k a -> Maybe (StrictPair (KeyValue k a) (Stack k a))+iterNext (Push kx x r stk) = Just $! KeyValue kx x :*: iterDown r stk+iterNext Nada = Nothing+{-# INLINE iterNext #-}++-- Whether there are no more key-values in the iterator.+iterNull :: Stack k a -> Bool+iterNull (Push _ _ _ _) = False+iterNull Nada = True++{--------------------------------------------------------------------+ [balance l x r] balances two trees with value x.+ The sizes of the trees should balance after decreasing the+ size of one of them. (a rotation).++ [delta] is the maximal relative difference between the sizes of+ two trees, it corresponds with the [w] in Adams' paper.+ [ratio] is the ratio between an outer and inner sibling of the+ heavier subtree in an unbalanced setting. It determines+ whether a double or single rotation should be performed+ to restore balance. It is corresponds with the inverse+ of $\alpha$ in Adam's article.++ Note that according to the Adam's paper:+ - [delta] should be larger than 4.646 with a [ratio] of 2.+ - [delta] should be larger than 3.745 with a [ratio] of 1.534.++ But the Adam's paper is erroneous:+ - It can be proved that for delta=2 and delta>=5 there does+ not exist any ratio that would work.+ - Delta=4.5 and ratio=2 does not work.++ That leaves two reasonable variants, delta=3 and delta=4,+ both with ratio=2.++ - A lower [delta] leads to a more 'perfectly' balanced tree.+ - A higher [delta] performs less rebalancing.++ In the benchmarks, delta=3 is faster on insert operations,+ and delta=4 has slightly better deletes. As the insert speedup+ is larger, we currently use delta=3.++--------------------------------------------------------------------}+delta,ratio :: Int+delta = 3+ratio = 2++-- The balance function is equivalent to the following:+--+-- balance :: k -> a -> Map k a -> Map k a -> Map k a+-- balance k x l r+-- | sizeL + sizeR <= 1 = Bin sizeX k x l r+-- | sizeR > delta*sizeL = rotateL k x l r+-- | sizeL > delta*sizeR = rotateR k x l r+-- | otherwise = Bin sizeX k x l r+-- where+-- sizeL = size l+-- sizeR = size r+-- sizeX = sizeL + sizeR + 1+--+-- rotateL :: a -> b -> Map a b -> Map a b -> Map a b+-- rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r+-- | otherwise = doubleL k x l r+--+-- rotateR :: a -> b -> Map a b -> Map a b -> Map a b+-- rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r+-- | otherwise = doubleR k x l r+--+-- singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b+-- singleL k1 x1 t1 (Bin _ k2 x2 t2 t3) = bin k2 x2 (bin k1 x1 t1 t2) t3+-- singleR k1 x1 (Bin _ k2 x2 t1 t2) t3 = bin k2 x2 t1 (bin k1 x1 t2 t3)+--+-- doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b+-- 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)+-- 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)+--+-- It is only written in such a way that every node is pattern-matched only once.++balance :: k -> a -> Map k a -> Map k a -> Map k a+balance k x l r = case (l, r) of+ (Bin ls _ _ _ _, Bin rs _ _ _ _)+ | rs <= delta*ls && ls <= delta*rs -> Bin (1+ls+rs) k x l r+ _ -> balance_ k x l r+{-# INLINE balance #-} -- See Note [Inlining balance] in Data.Set.Internal++balance_ :: k -> a -> Map k a -> Map k a -> Map k a+balance_ k x l r = case l of+ Tip -> case r of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+ (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+ (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+ (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+ | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+ | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++ (Bin ls lk lx ll lr) -> case r of+ Tip -> case (ll, lr) of+ (Tip, Tip) -> Bin 2 k x l Tip+ (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+ ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+ ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr))+ | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+ | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)+ (Bin rs rk rx rl rr)+ | rs > delta*ls -> case (rl, rr) of+ (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+ | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+ | 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)+ (_, _) -> error "Failure in Data.Map.balance"+ | {- ls > delta*rs -} otherwise -> case (ll, lr) of+ (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+ | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+ | 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)+ (_, _) -> error "Failure in Data.Map.balance"+{-# NOINLINE balance_ #-}++-- Functions balanceL and balanceR are specialised versions of balance.+-- balanceL only checks whether the left subtree is too big,+-- balanceR only checks whether the right subtree is too big.++-- balanceL is called when left subtree might have been inserted to or when+-- right subtree might have been deleted from.+balanceL :: k -> a -> Map k a -> Map k a -> Map k a+balanceL k x l r = case (l, r) of+ (Bin ls _ _ _ _, Bin rs _ _ _ _)+ | ls <= delta*rs -> Bin (1+ls+rs) k x l r+ _ -> balanceL_ k x l r+{-# INLINE balanceL #-} -- See Note [Inlining balance] in Data.Set.Internal++balanceL_ :: k -> a -> Map k a -> Map k a -> Map k a+balanceL_ k x l r = case r of+ Tip -> case l of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip+ (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+ (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+ (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))+ | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+ | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)++ (Bin rs _ _ _ _) -> case l of+ Tip -> Bin (1+rs) k x Tip r++ (Bin ls lk lx ll lr) -> case (ll, lr) of+ (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+ | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+ | 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)+ (_, _) -> error "Failure in Data.Map.balanceL_"+{-# NOINLINE balanceL_ #-}++-- balanceR is called when right subtree might have been inserted to or when+-- left subtree might have been deleted from.+balanceR :: k -> a -> Map k a -> Map k a -> Map k a+balanceR k x l r = case (l, r) of+ (Bin ls _ _ _ _, Bin rs _ _ _ _)+ | rs <= delta*ls -> Bin (1+ls+rs) k x l r+ _ -> balanceR_ k x l r+{-# INLINE balanceR #-} -- See Note [Inlining balance] in Data.Set.Internal++balanceR_ :: k -> a -> Map k a -> Map k a -> Map k a+balanceR_ k x l r = case l of+ Tip -> case r of+ Tip -> Bin 1 k x Tip Tip+ (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+ (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+ (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+ (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+ | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+ | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++ (Bin ls _ _ _ _) -> case r of+ Tip -> Bin (1+ls) k x l Tip++ (Bin rs rk rx rl rr) -> case (rl, rr) of+ (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+ | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+ | 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)+ (_, _) -> error "Failure in Data.Map.balanceR_"+{-# NOINLINE balanceR_ #-}+++{--------------------------------------------------------------------+ The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: k -> a -> Map k a -> Map k a -> Map k a+bin k x l r+ = Bin (size l + size r + 1) k x l r+{-# INLINE bin #-}+++{--------------------------------------------------------------------+ Eq+--------------------------------------------------------------------}++instance (Eq k,Eq a) => Eq (Map k a) where+ m1 == m2 = liftEq2 (==) (==) m1 m2+ {-# INLINABLE (==) #-}++-- | @since 0.5.9+instance Eq k => Eq1 (Map k) where+ liftEq = liftEq2 (==)+ {-# INLINE liftEq #-}++-- | @since 0.5.9+instance Eq2 Map where+ liftEq2 keq eq m1 m2 = size m1 == size m2 && sameSizeLiftEq2 keq eq m1 m2+ {-# INLINE liftEq2 #-}++-- Assumes the maps are of equal size to skip the final check+sameSizeLiftEq2+ :: (ka -> kb -> Bool) -> (a -> b -> Bool) -> Map ka a -> Map kb b -> Bool+sameSizeLiftEq2 keq eq m1 m2 =+ case runEqM (foldMapWithKey f m1) (iterator m2) of e :*: _ -> e+ where+ f kx x = EqM $ \it -> case iterNext it of+ Nothing -> False :*: it+ Just (KeyValue ky y :*: it') -> (keq kx ky && eq x y) :*: it'+{-# INLINE sameSizeLiftEq2 #-}++{--------------------------------------------------------------------+ Ord+--------------------------------------------------------------------}++instance (Ord k, Ord v) => Ord (Map k v) where+ compare m1 m2 = liftCmp2 compare compare m1 m2+ {-# INLINABLE compare #-}++-- | @since 0.5.9+instance Ord k => Ord1 (Map k) where+ liftCompare = liftCmp2 compare+ {-# INLINE liftCompare #-}++-- | @since 0.5.9+instance Ord2 Map where+ liftCompare2 = liftCmp2+ {-# INLINE liftCompare2 #-}++liftCmp2+ :: (ka -> kb -> Ordering)+ -> (a -> b -> Ordering)+ -> Map ka a+ -> Map kb b+ -> Ordering+liftCmp2 kcmp cmp m1 m2 = case runOrdM (foldMapWithKey f m1) (iterator m2) of+ o :*: it -> o <> if iterNull it then EQ else LT+ where+ f kx x = OrdM $ \it -> case iterNext it of+ Nothing -> GT :*: it+ Just (KeyValue ky y :*: it') -> (kcmp kx ky <> cmp x y) :*: it'+{-# INLINE liftCmp2 #-}++{--------------------------------------------------------------------+ Lifted instances+--------------------------------------------------------------------}++-- | @since 0.5.9+instance Show2 Map where+ liftShowsPrec2 spk slk spv slv d m =+ showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)+ where+ sp = liftShowsPrec2 spk slk spv slv+ sl = liftShowList2 spk slk spv slv++-- | @since 0.5.9+instance Show k => Show1 (Map k) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++-- | @since 0.5.9+instance (Ord k, Read k) => Read1 (Map k) where+ liftReadsPrec rp rl = readsData $+ readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+ where+ rp' = liftReadsPrec rp rl+ rl' = liftReadList rp rl++{--------------------------------------------------------------------+ Functor+--------------------------------------------------------------------}+instance Functor (Map k) where+ fmap f m = map f m+#ifdef __GLASGOW_HASKELL__+ _ <$ Tip = Tip+ a <$ (Bin sx kx _ l r) = Bin sx kx a (a <$ l) (a <$ r)+#endif++-- | Traverses in order of increasing key.+instance Traversable (Map k) where+ traverse f = traverseWithKey (\_ -> f)+ {-# INLINE traverse #-}++-- | Folds in order of increasing key.+instance Foldable.Foldable (Map k) where+ fold = go+ where go Tip = mempty+ go (Bin 1 _ v _ _) = v+ go (Bin _ _ v l r) = go l `mappend` (v `mappend` go r)+ {-# INLINABLE fold #-}+ foldr = foldr+ {-# INLINE foldr #-}+ foldl = foldl+ {-# INLINE foldl #-}+ foldMap f t = go t+ where go Tip = mempty+ go (Bin 1 _ v _ _) = f v+ go (Bin _ _ v l r) = go l `mappend` (f v `mappend` go r)+ {-# INLINE foldMap #-}+ foldl' = foldl'+ {-# INLINE foldl' #-}+ foldr' = foldr'+ {-# INLINE foldr' #-}+ length = size+ {-# INLINE length #-}+ null = null+ {-# INLINE null #-}+ toList = elems -- NB: Foldable.toList /= Map.toList+ {-# INLINE toList #-}+ elem = go+ where go !_ Tip = False+ go x (Bin _ _ v l r) = x == v || go x l || go x r+ {-# INLINABLE elem #-}+ maximum = start+ where start Tip = error "Data.Foldable.maximum (for Data.Map): empty map"+ start (Bin _ _ v l r) = go (go v l) r++ go !m Tip = m+ go m (Bin _ _ v l r) = go (go (max m v) l) r+ {-# INLINABLE maximum #-}+ minimum = start+ where start Tip = error "Data.Foldable.minimum (for Data.Map): empty map"+ start (Bin _ _ v l r) = go (go v l) r++ go !m Tip = m+ go m (Bin _ _ v l r) = go (go (min m v) l) r+ {-# INLINABLE minimum #-}+ sum = foldl' (+) 0+ {-# INLINABLE sum #-}+ product = foldl' (*) 1+ {-# INLINABLE product #-}++-- | @since 0.6.3.1+instance Bifoldable Map where+ bifold = go+ where go Tip = mempty+ go (Bin 1 k v _ _) = k `mappend` v+ go (Bin _ k v l r) = go l `mappend` (k `mappend` (v `mappend` go r))+ {-# INLINABLE bifold #-}+ bifoldr f g z = go z+ where go z' Tip = z'+ go z' (Bin _ k v l r) = go (f k (g v (go z' r))) l+ {-# INLINE bifoldr #-}+ bifoldl f g z = go z+ where go z' Tip = z'+ go z' (Bin _ k v l r) = go (g (f (go z' l) k) v) r+ {-# INLINE bifoldl #-}+ bifoldMap f g t = go t+ where go Tip = mempty+ go (Bin 1 k v _ _) = f k `mappend` g v+ go (Bin _ k v l r) = go l `mappend` (f k `mappend` (g v `mappend` go r))+ {-# INLINE bifoldMap #-}++instance (NFData k, NFData a) => NFData (Map k a) where+ rnf Tip = ()+ rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r++-- | @since 0.8+instance NFData k => NFData1 (Map k) where+ liftRnf rnfx = go+ where+ go Tip = ()+ go (Bin _ kx x l r) = rnf kx `seq` rnfx x `seq` go l `seq` go r++-- | @since 0.8+instance NFData2 Map where+ liftRnf2 rnfkx rnfx = go+ where+ go Tip = ()+ go (Bin _ kx x l r) = rnfkx kx `seq` rnfx x `seq` go l `seq` go r++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance (Ord k, Read k, Read e) => Read (Map k e) where+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}+instance (Show k, Show a) => Show (Map k a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}++-- | \(O(1)\). Decompose a map into pieces based on the structure of the underlying -- tree. This function is useful for consuming a map in parallel. -- -- No guarantee is made as to the sizes of the pieces; an internal, but
src/Data/Map/Internal/Debug.hs view
@@ -6,7 +6,7 @@ import Data.Map.Internal (Map (..), size, delta) import Control.Monad (guard) --- | /O(n)/. Show the tree that implements the map. The tree is shown+-- | \(O(n \log n)\). Show the tree that implements the map. The tree is shown -- in a compressed, hanging format. See 'showTreeWith'. showTree :: (Show k,Show a) => Map k a -> String showTree m@@ -15,7 +15,7 @@ showElem k x = show k ++ ":=" ++ show x -{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows+{- | \(O(n \log n)\). The expression (@'showTreeWith' showelem hang wide map@) shows the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If @wide@ is 'True', an extra wide version is shown.@@ -91,7 +91,7 @@ showsBars bars = case bars of [] -> id- _ -> showString (concat (reverse (tail bars))) . showString node+ _ : tl -> showString (concat (reverse tl)) . showString node node :: String node = "+--"@@ -103,7 +103,7 @@ {-------------------------------------------------------------------- Assertions --------------------------------------------------------------------}--- | /O(n)/. Test if the internal map structure is valid.+-- | \(O(n)\). Test if the internal map structure is valid. -- -- > valid (fromAscList [(3,"b"), (5,"a")]) == True -- > valid (fromAscList [(5,"a"), (3,"b")]) == False
− src/Data/Map/Internal/DeprecatedShowTree.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts, DataKinds #-}-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE MonoLocalBinds #-}-#endif-#if __GLASGOW_HASKELL__ < 710--- Why do we need this? Guess it doesn't matter; this is all--- going away soon.-{-# LANGUAGE Trustworthy #-}-#endif--#include "containers.h"---- | This module simply holds disabled copies of functions from--- Data.Map.Internal.Debug.-module Data.Map.Internal.DeprecatedShowTree where--import Data.Map.Internal (Map)-import Utils.Containers.Internal.TypeError---- | This function has moved to 'Data.Map.Internal.Debug.showTree'.-showTree :: Whoops "showTree has moved to Data.Map.Internal.Debug.showTree."- => Map k a -> String-showTree _ = undefined---- | This function has moved to 'Data.Map.Internal.Debug.showTreeWith'.-showTreeWith ::- Whoops "showTreeWith has moved to Data.Map.Internal.Debug.showTreeWith."- => (k -> a -> String) -> Bool -> Bool -> Map k a -> String-showTreeWith _ _ _ _ = undefined
src/Data/Map/Lazy.hs view
@@ -38,8 +38,9 @@ -- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>. -- -- This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:+-- Prelude functions, e.g. --+-- > import Data.Map.Lazy (Map) -- > import qualified Data.Map.Lazy as Map -- -- Note that the implementation is generally /left-biased/. Functions that take@@ -47,15 +48,6 @@ -- prefer the values in the first argument to those in the second. -- ----- == Detailed performance information------ The amortized running time is given for each operation, with /n/ referring to--- the number of entries in the map.------ Benchmarks comparing "Data.Map.Lazy" with other dictionary implementations--- can be found at https://github.com/haskell-perf/dictionaries.------ -- == Warning -- -- The size of a 'Map' must not exceed @'Prelude.maxBound' :: 'Prelude.Int'@.@@ -68,20 +60,42 @@ -- The implementation of 'Map' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: ----- * Stephen Adams, \"/Efficient sets: a balancing act/\",--- Journal of Functional Programming 3(4):553-562, October 1993,--- <http://www.swiss.ai.mit.edu/~adams/BB/>.+-- * Stephen Adams, \"/Efficient sets—a balancing act/\",+-- Journal of Functional Programming 3(4):553-562, October 1993,+-- <https://doi.org/10.1017/S0956796800000885>,+-- <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. -- * J. Nievergelt and E.M. Reingold, -- \"/Binary search trees of bounded balance/\", -- SIAM journal of computing 2(1), March 1973.+-- <https://doi.org/10.1137/0202005>.+-- * Yoichi Hirai and Kazuhiko Yamamoto,+-- \"/Balancing weight-balanced trees/\",+-- Journal of Functional Programming 21(3):287-307, 2011,+-- <https://doi.org/10.1017/S0956796811000104> -- -- Bounds for 'union', 'intersection', and 'difference' are as given -- by -- -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,--- \"/Just Join for Parallel Ordered Sets/\",--- <https://arxiv.org/abs/1602.02120v3>.+-- \"/Parallel Ordered Sets Using Join/\",+-- <https://arxiv.org/abs/1602.02120v4>. --+--+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map.+--+-- Operations like 'lookup', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.Map.Lazy" with other dictionary implementations+-- can be found at https://github.com/haskell-perf/dictionaries.+-- ----------------------------------------------------------------------------- module Data.Map.Lazy (@@ -92,6 +106,7 @@ , empty , singleton , fromSet+ , fromArgSet -- ** From Unordered Lists , fromList@@ -163,6 +178,9 @@ , intersectionWith , intersectionWithKey + -- ** Symmetric difference+ , symmetricDifference+ -- ** Disjoint , disjoint @@ -207,6 +225,7 @@ , keys , assocs , keysSet+ , argSet -- ** Lists , toList@@ -217,6 +236,7 @@ -- * Filter , filter+ , filterKeys , filterWithKey , restrictKeys , withoutKeys@@ -268,14 +288,9 @@ , maxViewWithKey -- * Debugging-#ifdef __GLASGOW_HASKELL__- , showTree- , showTreeWith-#endif , valid ) where import Data.Map.Internal-import Data.Map.Internal.DeprecatedShowTree (showTree, showTreeWith) import Data.Map.Internal.Debug (valid) import Prelude ()
src/Data/Map/Merge/Lazy.hs view
@@ -1,19 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}-#define USE_MAGIC_PROXY 1-#endif--#if USE_MAGIC_PROXY-{-# LANGUAGE MagicHash #-} #endif #include "containers.h"
src/Data/Map/Merge/Strict.hs view
@@ -1,19 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}-#define USE_MAGIC_PROXY 1-#endif--#if USE_MAGIC_PROXY-{-# LANGUAGE MagicHash #-} #endif #include "containers.h"
src/Data/Map/Strict.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-} #if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif@@ -44,8 +43,9 @@ -- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>. -- -- This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:+-- Prelude functions, e.g. --+-- > import Data.Map.Strict (Map) -- > import qualified Data.Map.Strict as Map -- -- Note that the implementation is generally /left-biased/. Functions that take@@ -53,15 +53,6 @@ -- prefer the values in the first argument to those in the second. -- ----- == Detailed performance information------ The amortized running time is given for each operation, with /n/ referring to--- the number of entries in the map.------ Benchmarks comparing "Data.Map.Strict" with other dictionary implementations--- can be found at https://github.com/haskell-perf/dictionaries.------ -- == Warning -- -- The size of a 'Map' must not exceed @maxBound::Int@. Violation of this@@ -80,21 +71,42 @@ -- The implementation of 'Map' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: ----- * Stephen Adams, \"/Efficient sets: a balancing act/\",--- Journal of Functional Programming 3(4):553-562, October 1993,--- <http://www.swiss.ai.mit.edu/~adams/BB/>.+-- * Stephen Adams, \"/Efficient sets—a balancing act/\",+-- Journal of Functional Programming 3(4):553-562, October 1993,+-- <https://doi.org/10.1017/S0956796800000885>,+-- <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. -- * J. Nievergelt and E.M. Reingold, -- \"/Binary search trees of bounded balance/\", -- SIAM journal of computing 2(1), March 1973.+-- <https://doi.org/10.1137/0202005>.+-- * Yoichi Hirai and Kazuhiko Yamamoto,+-- \"/Balancing weight-balanced trees/\",+-- Journal of Functional Programming 21(3):287-307, 2011,+-- <https://doi.org/10.1017/S0956796811000104> -- -- Bounds for 'union', 'intersection', and 'difference' are as given -- by -- -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,--- \"/Just Join for Parallel Ordered Sets/\",--- <https://arxiv.org/abs/1602.02120v3>.+-- \"/Parallel Ordered Sets Using Join/\",+-- <https://arxiv.org/abs/1602.02120v4>. -- --+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map.+--+-- Operations like 'lookup', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.Map.Strict" with other dictionary implementations+-- can be found at https://github.com/haskell-perf/dictionaries.+-- ----------------------------------------------------------------------------- -- See the notes at the beginning of Data.Map.Internal.@@ -108,6 +120,7 @@ , empty , singleton , fromSet+ , fromArgSet -- ** From Unordered Lists , fromList@@ -179,6 +192,9 @@ , intersectionWith , intersectionWithKey + -- ** Symmetric difference+ , symmetricDifference+ -- ** Disjoint , disjoint @@ -223,6 +239,7 @@ , keys , assocs , keysSet+ , argSet -- ** Lists , toList@@ -233,6 +250,7 @@ -- * Filter , filter+ , filterKeys , filterWithKey , restrictKeys , withoutKeys@@ -285,10 +303,6 @@ , maxViewWithKey -- * Debugging-#ifdef __GLASGOW_HASKELL__- , showTree- , showTreeWith-#endif , valid ) where
src/Data/Map/Strict/Internal.hs view
@@ -28,62 +28,44 @@ -- Authors importing this module are expected to track development -- closely. ----- = Description ----- An efficient implementation of ordered maps from keys to values--- (dictionaries).+-- = Finite Maps (strict interface internals) ----- API of this module is strict in both the keys and the values.--- If you need value-lazy maps, use "Data.Map.Lazy" instead.--- The 'Map' type is shared between the lazy and strict modules,--- meaning that the same 'Map' value can be passed to functions in--- both modules (although that is rarely needed).+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@. ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g. ----- > import qualified Data.Map.Strict as Map+-- == Implementation -- -- The implementation of 'Map' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: ----- * Stephen Adams, \"/Efficient sets: a balancing act/\",--- Journal of Functional Programming 3(4):553-562, October 1993,--- <http://www.swiss.ai.mit.edu/~adams/BB/>.+-- * Stephen Adams, \"/Efficient sets—a balancing act/\",+-- Journal of Functional Programming 3(4):553-562, October 1993,+-- <https://doi.org/10.1017/S0956796800000885>,+-- <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. -- * J. Nievergelt and E.M. Reingold, -- \"/Binary search trees of bounded balance/\", -- SIAM journal of computing 2(1), March 1973.+-- <https://doi.org/10.1137/0202005>.+-- * Yoichi Hirai and Kazuhiko Yamamoto,+-- \"/Balancing weight-balanced trees/\",+-- Journal of Functional Programming 21(3):287-307, 2011,+-- <https://doi.org/10.1017/S0956796811000104> -- -- Bounds for 'union', 'intersection', and 'difference' are as given -- by -- -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,--- \"/Just Join for Parallel Ordered Sets/\",--- <https://arxiv.org/abs/1602.02120v3>.------ Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'.------ /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of--- this condition is not detected and if the size limit is exceeded, its--- behaviour is undefined.------ Operation comments contain the operation time complexity in--- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).+-- \"/Parallel Ordered Sets Using Join/\",+-- <https://arxiv.org/abs/1602.02120v4>. ----- Be aware that the 'Functor', 'Traversable' and 'Data.Data.Data' instances--- are the same as for the "Data.Map.Lazy" module, so if they are used--- on strict maps, the resulting maps will be lazy. ----------------------------------------------------------------------------- -- See the notes at the beginning of Data.Map.Internal. module Data.Map.Strict.Internal (- -- * Strictness properties- -- $strictness- -- * Map type Map(..) -- instance Eq,Show,Read , L.Size@@ -142,6 +124,9 @@ , intersectionWith , intersectionWithKey + -- ** Symmetric difference+ , symmetricDifference+ -- ** Disjoint , disjoint @@ -226,7 +211,9 @@ , keys , assocs , keysSet+ , argSet , fromSet+ , fromArgSet -- ** Lists , toList@@ -248,6 +235,7 @@ -- * Filter , filter+ , filterKeys , filterWithKey , restrictKeys , withoutKeys@@ -299,14 +287,12 @@ , maxViewWithKey -- * Debugging-#if defined(__GLASGOW_HASKELL__)- , showTree- , showTreeWith-#endif , valid ) where -import Prelude hiding (lookup,map,filter,foldr,foldl,null,take,drop,splitAt)+import Utils.Containers.Internal.Prelude hiding+ (lookup,map,filter,foldr,foldl,foldl',null,take,drop,splitAt)+import Prelude () import Data.Map.Internal ( Map (..)@@ -324,12 +310,22 @@ , filterAMissing , merge , mergeA+ , ascLinkTop+ , ascLinkAll+ , descLinkTop+ , descLinkAll+ , Stack (..)+ , MapBuilder(..)+ , emptyB+ , insertB+ , finishB , (!) , (!?) , (\\)+ , argSet , assocs , atKeyImpl-#if MIN_VERSION_base(4,8,0)+#ifdef __GLASGOW_HASKELL__ , atKeyPlain #endif , balance@@ -350,6 +346,7 @@ , drop , dropWhileAntitone , filter+ , filterKeys , filterWithKey , findIndex , findMax@@ -364,7 +361,6 @@ , foldrWithKey , foldrWithKey' , glue- , insertMax , intersection , isProperSubmapOf , isProperSubmapOfBy@@ -374,6 +370,7 @@ , keysSet , link , lookup+ , findWithDefault , lookupGE , lookupGT , lookupIndex@@ -400,6 +397,7 @@ , splitAt , splitLookup , splitRoot+ , symmetricDifference , take , takeWhileAntitone , toList@@ -409,51 +407,24 @@ , unions , withoutKeys ) -#if defined(__GLASGOW_HASKELL__)-import Data.Map.Internal.DeprecatedShowTree (showTree, showTreeWith)-#endif import Data.Map.Internal.Debug (valid) import Control.Applicative (Const (..), liftA3)-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (Applicative (..), (<$>))-#endif+import Data.Semigroup (Arg (..)) import qualified Data.Set.Internal as Set import qualified Data.Map.Internal as L import Utils.Containers.Internal.StrictPair -import Data.Bits (shiftL, shiftR)-#if __GLASGOW_HASKELL__ >= 709+#ifdef __GLASGOW_HASKELL__ import Data.Coerce #endif -#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)+#ifdef __GLASGOW_HASKELL__ import Data.Functor.Identity (Identity (..)) #endif import qualified Data.Foldable as Foldable-#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable())-#endif --- $strictness------ This module satisfies the following strictness properties:------ 1. Key arguments are evaluated to WHNF;------ 2. Keys and values are evaluated to WHNF before they are stored in--- the map.------ Here's an example illustrating the first property:------ > delete undefined m == undefined------ Here are some examples that illustrate the second property:------ > map (\ v -> undefined) m == undefined -- m is not empty--- > mapKeys (\ k -> undefined) m == undefined -- m is not empty- -- [Note: Pointer equality for sharing] -- -- We use pointer equality to enhance sharing between the arguments@@ -466,36 +437,10 @@ -- worth the price. {--------------------------------------------------------------------- Query---------------------------------------------------------------------}---- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns--- the value at key @k@ or returns default value @def@--- when the key is not in the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'---- See Map.Internal.Note: Local 'go' functions and capturing-findWithDefault :: Ord k => a -> k -> Map k a -> a-findWithDefault def k = k `seq` go- where- go Tip = def- go (Bin _ kx x l r) = case compare k kx of- LT -> go l- GT -> go r- EQ -> x-#if __GLASGOW_HASKELL__-{-# INLINABLE findWithDefault #-}-#else-{-# INLINE findWithDefault #-}-#endif--{-------------------------------------------------------------------- Construction --------------------------------------------------------------------} --- | /O(1)/. A map with a single element.+-- | \(O(1)\). A map with a single element. -- -- > singleton 1 'a' == fromList [(1, 'a')] -- > size (singleton 1 'a') == 1@@ -507,7 +452,7 @@ {-------------------------------------------------------------------- Insertion --------------------------------------------------------------------}--- | /O(log n)/. Insert a new key and value in the map.+-- | \(O(\log n)\). Insert a new key and value in the map. -- If the key is already present in the map, the associated value is -- replaced with the supplied value. 'insert' is equivalent to -- @'insertWith' 'const'@.@@ -533,7 +478,7 @@ {-# INLINE insert #-} #endif --- | /O(log n)/. Insert with a function, combining new value and old value.+-- | \(O(\log n)\). Insert with a function, combining new value and old value. -- @'insertWith' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will@@ -542,6 +487,8 @@ -- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")] -- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'. insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWith = go@@ -575,7 +522,7 @@ {-# INLINE insertWithR #-} #endif --- | /O(log n)/. Insert with a function, combining key, new value and old value.+-- | \(O(\log n)\). Insert with a function, combining key, new value and old value. -- @'insertWithKey' f key value mp@ -- will insert the pair (key, value) into @mp@ if key does -- not exist in the map. If the key does exist, the function will@@ -586,6 +533,8 @@ -- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")] -- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")] -- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'. -- See Map.Internal.Note: Type of local 'go' function insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a@@ -626,7 +575,7 @@ {-# INLINE insertWithKeyR #-} #endif --- | /O(log n)/. Combines insert operation with old value retrieval.+-- | \(O(\log n)\). Combines insert operation with old value retrieval. -- The expression (@'insertLookupWithKey' f k x map@) -- is a pair where the first element is equal to (@'lookup' k map@) -- and the second element equal to (@'insertWithKey' f k x map@).@@ -641,6 +590,8 @@ -- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t -- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")]) -- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])+--+-- Also see the performance note on 'fromListWith'. -- See Map.Internal.Note: Type of local 'go' function insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a@@ -667,7 +618,7 @@ Deletion --------------------------------------------------------------------} --- | /O(log n)/. Update a value at a specific key with the result of the provided function.+-- | \(O(\log n)\). Update a value at a specific key with the result of the provided function. -- When the key is not -- a member of the map, the original map is returned. --@@ -683,7 +634,7 @@ {-# INLINE adjust #-} #endif --- | /O(log n)/. Adjust a value at a specific key. When the key is not+-- | \(O(\log n)\). Adjust a value at a specific key. When the key is not -- a member of the map, the original map is returned. -- -- > let f key x = (show key) ++ ":new " ++ x@@ -708,7 +659,7 @@ {-# INLINE adjustWithKey #-} #endif --- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@+-- | \(O(\log n)\). The expression (@'update' f k map@) updates the value @x@ -- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is -- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@. --@@ -725,7 +676,7 @@ {-# INLINE update #-} #endif --- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the+-- | \(O(\log n)\). The expression (@'updateWithKey' f k map@) updates the -- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing', -- the element is deleted. If it is (@'Just' y@), the key @k@ is bound -- to the new value @y@.@@ -754,8 +705,8 @@ {-# INLINE updateWithKey #-} #endif --- | /O(log n)/. Lookup and update. See also 'updateWithKey'.--- The function returns changed value, if it is updated.+-- | \(O(\log n)\). Look up and update. See also 'updateWithKey'.+-- This function returns the changed value, if it is updated. -- Returns the original key value if the map entry is deleted. -- -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing@@ -784,7 +735,7 @@ {-# INLINE updateLookupWithKey #-} #endif --- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- | \(O(\log n)\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alter' can be used to insert, delete, or update a value in a 'Map'. -- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@. --@@ -819,7 +770,7 @@ {-# INLINE alter #-} #endif --- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at @k@, or absence thereof.+-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at @k@, or absence thereof. -- 'alterF' can be used to inspect, insert, delete, or update a value in a 'Map'. -- In short: @'lookup' k \<$\> 'alterF' f k m = f ('lookup' k m)@. --@@ -872,11 +823,6 @@ -- `Control.Applicative.Const` and just doing a lookup. {-# RULES "alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m- #-}-#if MIN_VERSION_base(4,8,0)--- base 4.8 and above include Data.Functor.Identity, so we can--- save a pretty decent amount of time by handling it specially.-{-# RULES "alterF/Identity" forall k f . alterF f k = atKeyIdentity k f #-} @@ -884,13 +830,12 @@ atKeyIdentity k f t = Identity $ atKeyPlain Strict k (coerce f) t {-# INLINABLE atKeyIdentity #-} #endif-#endif {-------------------------------------------------------------------- Indexing --------------------------------------------------------------------} --- | /O(log n)/. Update the element at /index/. Calls 'error' when an+-- | \(O(\log n)\). Update the element at /index/. Calls 'error' when an -- invalid index is used. -- -- > updateAt (\ _ _ -> Just "x") 0 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]@@ -919,7 +864,7 @@ Minimal, Maximal --------------------------------------------------------------------} --- | /O(log n)/. Update the value at the minimal key.+-- | \(O(\log n)\). Update the value at the minimal key. -- -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"@@ -928,7 +873,7 @@ updateMin f m = updateMinWithKey (\_ x -> f x) m --- | /O(log n)/. Update the value at the maximal key.+-- | \(O(\log n)\). Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"@@ -938,7 +883,7 @@ = updateMaxWithKey (\_ x -> f x) m --- | /O(log n)/. Update the value at the minimal key.+-- | \(O(\log n)\). Update the value at the minimal key. -- -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] -- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"@@ -950,7 +895,7 @@ Just x' -> x' `seq` Bin sx kx x' Tip r updateMinWithKey f (Bin _ kx x l r) = balanceR kx x (updateMinWithKey f l) r --- | /O(log n)/. Update the value at the maximal key.+-- | \(O(\log n)\). Update the value at the maximal key. -- -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] -- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"@@ -982,9 +927,11 @@ {-------------------------------------------------------------------- Union with a combining function --------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function.+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'. unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a unionWith _f t1 Tip = t1@@ -998,11 +945,13 @@ {-# INLINABLE unionWith #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/.+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). -- Union with a combining function. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'. unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a unionWithKey _f t1 Tip = t1@@ -1020,7 +969,7 @@ Difference --------------------------------------------------------------------} --- | /O(n+m)/. Difference with a combining function.+-- | \(O(n+m)\). Difference with a combining function. -- When two equal keys are -- encountered, the combining function is applied to the values of these keys. -- If it returns 'Nothing', the element is discarded (proper set difference). If@@ -1036,7 +985,7 @@ {-# INLINABLE differenceWith #-} #endif --- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- | \(O(n+m)\). Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@.@@ -1056,7 +1005,7 @@ Intersection --------------------------------------------------------------------} --- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" @@ -1074,7 +1023,7 @@ {-# INLINABLE intersectionWith #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"@@ -1212,9 +1161,9 @@ MergeWithKey --------------------------------------------------------------------} --- | /O(n+m)/. An unsafe universal combining function.+-- | \(O(n+m)\). An unsafe universal combining function. ----- WARNING: This function can produce corrupt maps and its results+-- __Warning__: This function can produce corrupt maps and its results -- may depend on the internal structures of its inputs. Users should -- prefer 'Data.Map.Merge.Strict.merge' or -- 'Data.Map.Merge.Strict.mergeA'.@@ -1253,6 +1202,7 @@ -> Map k a -> Map k b -> Map k c mergeWithKey f g1 g2 = go where+ go Tip Tip = Tip go Tip t2 = g2 t2 go t1 Tip = g1 t1 go (Bin _ kx x l1 r1) t2 =@@ -1263,7 +1213,7 @@ _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)" Just x2 -> case f kx x x2 of Nothing -> link2 l' r'- Just x' -> link kx x' l' r'+ Just !x' -> link kx x' l' r' where (l2, found, r2) = splitLookup kx t2 l' = go l1 l2@@ -1274,7 +1224,7 @@ Filter and partition --------------------------------------------------------------------} --- | /O(n)/. Map values and collect the 'Just' results.+-- | \(O(n)\). Map values and collect the 'Just' results. -- -- > let f x = if x == "a" then Just "new a" else Nothing -- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"@@ -1282,7 +1232,7 @@ mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b mapMaybe f = mapMaybeWithKey (\_ x -> f x) --- | /O(n)/. Map keys\/values and collect the 'Just' results.+-- | \(O(n)\). Map keys\/values and collect the 'Just' results. -- -- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing -- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"@@ -1293,7 +1243,7 @@ Just y -> y `seq` link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r) Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r) --- | /O(n)/. Traverse keys\/values and collect the 'Just' results.+-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results. -- -- @since 0.5.8 @@ -1309,7 +1259,7 @@ Nothing -> link2 l' r' Just !x' -> link kx x' l' r' --- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. -- -- > let f a = if a < "c" then Left a else Right a -- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])@@ -1322,7 +1272,7 @@ mapEither f m = mapEitherWithKey (\_ x -> f x) m --- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results. -- -- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a) -- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])@@ -1345,7 +1295,7 @@ {-------------------------------------------------------------------- Mapping --------------------------------------------------------------------}--- | /O(n)/. Map a function over all values in the map.+-- | \(O(n)\). Map a function over all values in the map. -- -- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")] @@ -1365,7 +1315,7 @@ #-} #endif --- | /O(n)/. Map a function over all values in the map.+-- | \(O(n)\). Map a function over all values in the map. -- -- > let f key x = (show key) ++ ":" ++ x -- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]@@ -1394,8 +1344,8 @@ #-} #endif --- | /O(n)/.--- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (\v' -> v' \`seq\` (k,v')) <$> f k v) ('toList' m)@+-- | \(O(n)\).+-- @'traverseWithKey' f m == 'fromList' \<$\> 'traverse' (\\(k, v) -> (\v' -> v' \`seq\` (k,v')) \<$\> f k v) ('toList' m)@ -- That is, it behaves much like a regular 'traverse' except that the traversing -- function also has access to the key associated with a value and the values are -- forced before they are installed in the result map.@@ -1410,7 +1360,7 @@ go (Bin s k v l r) = liftA3 (\ l' !v' r' -> Bin s k v' l' r') (go l) (f k v) (go r) {-# INLINE traverseWithKey #-} --- | /O(n)/. The function 'mapAccum' threads an accumulating+-- | \(O(n)\). The function 'mapAccum' threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a b = (a ++ b, b ++ "X")@@ -1420,7 +1370,7 @@ mapAccum f a m = mapAccumWithKey (\a' _ x' -> f a' x') a m --- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating+-- | \(O(n)\). The function 'mapAccumWithKey' threads an accumulating -- argument through the map in ascending order of keys. -- -- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")@@ -1430,7 +1380,7 @@ mapAccumWithKey f a t = mapAccumL f a t --- | /O(n)/. The function 'mapAccumL' threads an accumulating+-- | \(O(n)\). The function 'mapAccumL' threads an accumulating -- argument through the map in ascending order of keys. mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumL _ a Tip = (a,Tip)@@ -1440,7 +1390,7 @@ (a3,r') = mapAccumL f a2 r in x' `seq` (a3,Bin sx kx x' l' r') --- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating+-- | \(O(n)\). The function 'mapAccumRWithKey' threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumRWithKey _ a Tip = (a,Tip)@@ -1450,9 +1400,11 @@ (a3,l') = mapAccumRWithKey f a2 l in x' `seq` (a3,Bin sx kx x' l' r') --- | /O(n*log n)/.+-- | \(O(n \log n)\). -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. --+-- If `f` is monotonically non-decreasing, this function takes \(O(n)\) time.+-- -- The size of the result may be smaller if @f@ maps two or more distinct -- keys to the same new key. In this case the associated values will be -- combined using @c@. The value at the greater of the two original keys@@ -1460,9 +1412,12 @@ -- -- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab" -- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"+--+-- Also see the performance note on 'fromListWith'. mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a-mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []+mapKeysWith c f m =+ finishB (foldlWithKey' (\b kx x -> insertWithB c (f kx) x b) emptyB m) #if __GLASGOW_HASKELL__ {-# INLINABLE mapKeysWith #-} #endif@@ -1471,7 +1426,7 @@ Conversions --------------------------------------------------------------------} --- | /O(n)/. Build a map from a set of keys and a function which for each key+-- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value. -- -- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]@@ -1481,87 +1436,90 @@ fromSet _ Set.Tip = Tip fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r) +-- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's.+--+-- > fromArgSet (Data.Set.fromList [Arg 3 "aaa", Arg 5 "aaaaa"]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromArgSet Data.Set.empty == empty++fromArgSet :: Set.Set (Arg k a) -> Map k a+fromArgSet Set.Tip = Tip+fromArgSet (Set.Bin sz (Arg x v) l r) = v `seq` Bin sz x v (fromArgSet l) (fromArgSet r)+ {-------------------------------------------------------------------- Lists --------------------------------------------------------------------}--- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- | \(O(n \log n)\). Build a map from a list of key\/value pairs. See also 'fromAscList'. -- If the list contains more than one value for the same key, the last value -- for the key is retained. ----- If the keys of the list are ordered, linear-time implementation is used,--- with the performance equal to 'fromDistinctAscList'.+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time. -- -- > fromList [] == empty -- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")] -- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")] --- For some reason, when 'singleton' is used in fromList or in--- create, it is not inlined, so we inline it manually. fromList :: Ord k => [(k,a)] -> Map k a-fromList [] = Tip-fromList [(kx, x)] = x `seq` Bin 1 kx x Tip Tip-fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = x0 `seq` fromList' (Bin 1 kx0 x0 Tip Tip) xs0- | otherwise = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0- where- not_ordered _ [] = False- not_ordered kx ((ky,_) : _) = kx >= ky- {-# INLINE not_ordered #-}-- fromList' t0 xs = Foldable.foldl' ins t0 xs- where ins t (k,x) = insert k x t-- go !_ t [] = t- go _ t [(kx, x)] = x `seq` insertMax kx x t- go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs- | otherwise = case create s xss of- (r, ys, []) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys- (r, _, ys) -> x `seq` fromList' (link kx x l r) ys-- -- The create is returning a triple (tree, xs, ys). Both xs and ys- -- represent not yet processed elements and only one of them can be nonempty.- -- If ys is nonempty, the keys in ys are not ordered with respect to tree- -- and must be inserted using fromList'. Otherwise the keys have been- -- ordered so far.- create !_ [] = (Tip, [], [])- create s xs@(xp : xss)- | s == 1 = case xp of (kx, x) | not_ordered kx xss -> x `seq` (Bin 1 kx x Tip Tip, [], xss)- | otherwise -> x `seq` (Bin 1 kx x Tip Tip, xss, [])- | otherwise = case create (s `shiftR` 1) xs of- res@(_, [], _) -> res- (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs)- (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)- | otherwise -> case create (s `shiftR` 1) yss of- (r, zs, ws) -> y `seq` (link ky y l r, zs, ws)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromList #-}-#endif+fromList xs =+ finishB (Foldable.foldl' (\b (kx, !x) -> insertB kx x b) emptyB xs)+{-# INLINE fromList #-} -- INLINE for fusion --- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. ----- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")] -- > fromListWith (++) [] == empty+--+-- Note the reverse ordering of @"cba"@ in the example.+--+-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@.+--+-- === Performance+--+-- You should ensure that the given @f@ is fast with this order of arguments.+--+-- Symmetric functions may be slow in one order, and fast in another.+-- For the common case of collecting values of matching keys in a list, as above:+--+-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument.+-- Thus:+--+-- > fromListWith (++) (replicate 1000000 (3, "x")) -- O(n), fast+-- > fromListWith (flip (++)) (replicate 1000000 (3, "x")) -- O(n²), extremely slow+--+-- because they evaluate as, respectively:+--+-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))] -- O(n)+-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")] -- O(n²)+--+-- Thus, to get good performance with an operation like @(++)@ while also preserving+-- the same order as in the input list, reverse the input:+--+-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")]+--+-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in:+--+-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a-fromListWith f xs- = fromListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromListWith #-}-#endif+fromListWith f xs =+ finishB (Foldable.foldl' (\b (kx, x) -> insertWithB f kx x b) emptyB xs)+{-# INLINE fromListWith #-} -- INLINE for fusion --- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'. ----- > let f k a1 a2 = (show k) ++ a1 ++ a2--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")] -- > fromListWithKey f [] == empty+--+-- Also see the performance note on 'fromListWith'. fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromListWithKey f xs- = Foldable.foldl' ins empty xs- where- ins t (k,x) = insertWithKey f k x t-#if __GLASGOW_HASKELL__-{-# INLINABLE fromListWithKey #-}-#endif+fromListWithKey f xs =+ finishB (Foldable.foldl' (\b (kx, x) -> insertWithB (f kx) kx x b) emptyB xs)+{-# INLINE fromListWithKey #-} -- INLINE for fusion {-------------------------------------------------------------------- Building trees from ascending/descending lists can be done in linear time.@@ -1575,9 +1533,12 @@ fromDescListWith f xs == fromListWith f xs --------------------------------------------------------------------} --- | /O(n)/. Build a map from an ascending list in linear time.--- /The precondition (input list is ascending) is not checked./+-- | \(O(n)\). Build a map from an ascending list in linear time. --+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+-- -- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")] -- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True@@ -1585,13 +1546,14 @@ fromAscList :: Eq k => [(k,a)] -> Map k a fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscList #-}-#endif+{-# INLINE fromAscList #-} -- INLINE for fusion --- | /O(n)/. Build a map from a descending list in linear time.--- /The precondition (input list is descending) is not checked./+-- | \(O(n)\). Build a map from a descending list in linear time. --+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+-- -- > fromDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")] -- > fromDescList [(5,"a"), (5,"b"), (3,"a")] == fromList [(3, "b"), (5, "b")] -- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True@@ -1599,144 +1561,150 @@ fromDescList :: Eq k => [(k,a)] -> Map k a fromDescList xs = fromDescListWithKey (\_ x _ -> x) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescList #-}-#endif+{-# INLINE fromDescList #-} -- INLINE for fusion --- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.--- /The precondition (input list is ascending) is not checked./+-- | \(O(n)\). Build a map from an ascending list in linear time with a combining function for equal keys. --+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+-- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] -- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True -- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'. fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a fromAscListWith f xs = fromAscListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscListWith #-}-#endif+{-# INLINE fromAscListWith #-} -- INLINE for fusion --- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys.--- /The precondition (input list is descending) is not checked./+-- | \(O(n)\). Build a map from a descending list in linear time with a combining function for equal keys. --+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+-- -- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")] -- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True -- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'. fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a fromDescListWith f xs = fromDescListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescListWith #-}-#endif+{-# INLINE fromDescListWith #-} -- INLINE for fusion --- | /O(n)/. Build a map from an ascending list in linear time with a+-- | \(O(n)\). Build a map from an ascending list in linear time with a -- combining function for equal keys.--- /The precondition (input list is ascending) is not checked./ --+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+-- -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 -- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")] -- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True -- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'. fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromAscListWithKey f xs- = fromDistinctAscList (combineEq f xs)+fromAscListWithKey f xs = ascLinkAll (Foldable.foldl' next Nada xs) where- -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]- combineEq _ xs'- = case xs' of- [] -> []- [x] -> [x]- (x:xx) -> combineEq' x xx-- combineEq' z [] = [z]- combineEq' z@(kz,zz) (x@(kx,xx):xs')- | kx==kz = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'- | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscListWithKey #-}-#endif+ next stk (!ky, y) = case stk of+ Push kx x l stk'+ | ky == kx -> let !y' = f ky y x in Push ky y' l stk'+ | Tip <- l -> y `seq` ascLinkTop stk' 1 (singleton kx x) ky y+ | otherwise -> push ky y Tip stk+ Nada -> push ky y Tip stk+ push kx !x = Push kx x+{-# INLINE fromAscListWithKey #-} -- INLINE for fusion --- | /O(n)/. Build a map from a descending list in linear time with a+-- | \(O(n)\). Build a map from a descending list in linear time with a -- combining function for equal keys.--- /The precondition (input list is descending) is not checked./ --+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+-- -- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2 -- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")] -- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True -- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'. fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromDescListWithKey f xs- = fromDistinctDescList (combineEq f xs)+fromDescListWithKey f xs = descLinkAll (Foldable.foldl' next Nada xs) where- -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]- combineEq _ xs'- = case xs' of- [] -> []- [x] -> [x]- (x:xx) -> combineEq' x xx-- combineEq' z [] = [z]- combineEq' z@(kz,zz) (x@(kx,xx):xs')- | kx==kz = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'- | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescListWithKey #-}-#endif+ next stk (!ky, y) = case stk of+ Push kx x r stk'+ | ky == kx -> let !y' = f ky y x in Push ky y' r stk'+ | Tip <- r -> y `seq` descLinkTop ky y 1 (singleton kx x) stk'+ | otherwise -> push ky y Tip stk+ Nada -> push ky y Tip stk+ push kx !x = Push kx x+{-# INLINE fromDescListWithKey #-} -- INLINE for fusion --- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.--- /The precondition is not checked./+-- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time. --+-- __Warning__: This function should be used only if the keys are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+-- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")] -- > valid (fromDistinctAscList [(3,"b"), (5,"a")]) == True -- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False --- For some reason, when 'singleton' is used in fromDistinctAscList or in--- create, it is not inlined, so we inline it manually.+-- See Note [fromDistinctAscList implementation] in Data.Set.Internal. fromDistinctAscList :: [(k,a)] -> Map k a-fromDistinctAscList [] = Tip-fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+fromDistinctAscList xs = ascLinkAll (Foldable.foldl' next Nada xs) where- go !_ t [] = t- go s l ((kx, x) : xs) =- case create s xs of- (r :*: ys) -> x `seq` let !t' = link kx x l r- in go (s `shiftL` 1) t' ys-- create !_ [] = (Tip :*: [])- create s xs@(x' : xs')- | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs')- | otherwise = case create (s `shiftR` 1) xs of- res@(_ :*: []) -> res- (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of- (r :*: zs) -> y `seq` (link ky y l r :*: zs)+ next :: Stack k a -> (k, a) -> Stack k a+ next (Push kx x Tip stk) (!ky, !y) = ascLinkTop stk 1 (singleton kx x) ky y+ next stk (!kx, !x) = Push kx x Tip stk+{-# INLINE fromDistinctAscList #-} -- INLINE for fusion --- | /O(n)/. Build a map from a descending list of distinct elements in linear time.--- /The precondition is not checked./+-- | \(O(n)\). Build a map from a descending list of distinct elements in linear time. --+-- __Warning__: This function should be used only if the keys are in+-- strictly decreasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+-- -- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")] -- > valid (fromDistinctDescList [(5,"a"), (3,"b")]) == True -- > valid (fromDistinctDescList [(5,"a"), (3,"b"), (3,"a")]) == False --- For some reason, when 'singleton' is used in fromDistinctDescList or in--- create, it is not inlined, so we inline it manually.+-- See Note [fromDistinctAscList implementation] in Data.Set.Internal. fromDistinctDescList :: [(k,a)] -> Map k a-fromDistinctDescList [] = Tip-fromDistinctDescList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0+fromDistinctDescList xs = descLinkAll (Foldable.foldl' next Nada xs) where- go !_ t [] = t- go s r ((kx, x) : xs) =- case create s xs of- (l :*: ys) -> x `seq` let !t' = link kx x l r- in go (s `shiftL` 1) t' ys+ next :: Stack k a -> (k, a) -> Stack k a+ next (Push ky y Tip stk) (!kx, !x) = descLinkTop kx x 1 (singleton ky y) stk+ next stk (!ky, !y) = Push ky y Tip stk+{-# INLINE fromDistinctDescList #-} -- INLINE for fusion - create !_ [] = (Tip :*: [])- create s xs@(x' : xs')- | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs')- | otherwise = case create (s `shiftR` 1) xs of- res@(_ :*: []) -> res- (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of- (l :*: zs) -> y `seq` (link ky y l r :*: zs)+{--------------------------------------------------------------------+ MapBuilder+--------------------------------------------------------------------}++-- Insert a key and value. The new value is combined with the old value if one+-- already exists for the key. Strict in the inserted value.+insertWithB+ :: Ord k => (a -> a -> a) -> k -> a -> MapBuilder k a -> MapBuilder k a+insertWithB f !ky y b = case b of+ BAsc stk -> case stk of+ Push kx x l stk' -> case compare ky kx of+ LT -> BMap (insertWith f ky y (ascLinkAll stk))+ EQ -> BAsc (push' ky (f y x) l stk')+ GT -> case l of+ Tip -> y `seq` BAsc (ascLinkTop stk' 1 (singleton kx x) ky y)+ Bin{} -> BAsc (push' ky y Tip stk)+ Nada -> BAsc (push' ky y Tip Nada)+ BMap m -> BMap (insertWith f ky y m)+ where+ push' kx !x = Push kx x+{-# INLINE insertWithB #-}
src/Data/Sequence.hs view
@@ -78,7 +78,7 @@ -- -- == Detailed performance information ----- An amortized running time is given for each operation, with /n/ referring+-- An amortized running time is given for each operation, with \(n\) referring -- to the length of the sequence and /i/ being the integral index used by -- some operations. These bounds hold even in a persistent (shared) setting. --@@ -127,9 +127,9 @@ -- as described in section 4.2 of -- -- * Ralf Hinze and Ross Paterson,--- [\"Finger trees: a simple general-purpose data structure\"]--- (http://staff.city.ac.uk/~ross/papers/FingerTree.html),--- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.+-- \"/Finger trees: a simple general-purpose data structure/\",+-- Journal of Functional Programming 16:2 (2006) pp 197-217.+-- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>. -- ----------------------------------------------------------------------------- @@ -250,7 +250,6 @@ import Prelude () #ifdef __HADDOCK_VERSION__ import Control.Monad (Monad (..))-import Control.Applicative (Applicative (..)) import Data.Functor (Functor (..)) #endif
src/Data/Sequence/Internal.hs view
@@ -4,11 +4,15 @@ #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} #endif #ifdef DEFINE_PATTERN_SYNONYMS {-# LANGUAGE PatternSynonyms #-}@@ -43,35 +47,21 @@ -- Authors importing this module are expected to track development -- closely. ----- = Description ----- General purpose finite sequences.--- Apart from being finite and having strict operations, sequences--- also differ from lists in supporting a wider variety of operations--- efficiently.+-- = Finite sequences (internals) ----- An amortized running time is given for each operation, with \( n \) referring--- to the length of the sequence and \( i \) being the integral index used by--- some operations. These bounds hold even in a persistent (shared) setting.+-- The @'Seq' a@ type represents a finite sequence of values of type @a@. --+--+-- == Implementation+-- -- The implementation uses 2-3 finger trees annotated with sizes, -- as described in section 4.2 of -- -- * Ralf Hinze and Ross Paterson,--- \"Finger trees: a simple general-purpose data structure\",--- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.--- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>------ /Note/: Many of these operations have the same names as similar--- operations on lists in the "Prelude". The ambiguity may be resolved--- using either qualification or the @hiding@ clause.------ /Warning/: The size of a 'Seq' must not exceed @maxBound::Int@. Violation--- of this condition is not detected and if the size limit is exceeded, the--- behaviour of the sequence is undefined. This is unlikely to occur in most--- applications, but some care may be required when using '><', '<*>', '*>', or--- '>>', particularly repeatedly and particularly in combination with--- 'replicate' or 'fromFunction'.+-- \"/Finger trees: a simple general-purpose data structure/\",+-- Journal of Functional Programming 16:2 (2006) pp 197-217.+-- <http://staff.city.ac.uk/~ross/papers/FingerTree.html>. -- -- @since 0.5.9 -----------------------------------------------------------------------------@@ -83,8 +73,6 @@ #else Seq (..), #endif- State(..),- execState, foldDigit, foldNode, foldWithIndexDigit,@@ -191,74 +179,57 @@ #endif ) where -import Prelude hiding (+import Utils.Containers.Internal.Prelude hiding ( Functor(..), #if MIN_VERSION_base(4,11,0) (<>), #endif-#if MIN_VERSION_base(4,8,0)- Applicative, (<$>), foldMap, Monoid,-#endif- null, length, lookup, take, drop, splitAt, foldl, foldl1, foldr, foldr1,+ (<$>), Monoid,+ null, length, lookup, take, drop, splitAt, scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3, unzip, takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)-import Control.Applicative (Applicative(..), (<$>), (<**>), Alternative,- liftA2, liftA3)+import Prelude ()+import Control.Applicative ((<$>), (<**>), Alternative,+ liftA3) import qualified Control.Applicative as Applicative-import Control.DeepSeq (NFData(rnf))+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf)) import Control.Monad (MonadPlus(..)) import Data.Monoid (Monoid(..)) import Data.Functor (Functor(..)) import Utils.Containers.Internal.State (State(..), execState)-import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr'), toList)+import Data.Foldable (foldr', toList) import qualified Data.Foldable as F -#if !(__GLASGOW_HASKELL__ >= 708)-import qualified Data.List-#endif--#if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Semigroup import Data.Functor.Classes-#endif import Data.Traversable-import Data.Typeable -- GHC specific stuff-#ifdef __GLASGOW_HASKELL__-import GHC.Exts (build)+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec, readListPrecDefault)+#endif+#ifdef __GLASGOW_HASKELL__+import GHC.Exts (build) import Data.Data import Data.String (IsString(..))-#endif-#if __GLASGOW_HASKELL__+import qualified Language.Haskell.TH.Syntax as TH+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH () import GHC.Generics (Generic, Generic1)-#endif -- Array stuff, with GHC.Arr on GHC-import Data.Array (Ix, Array)-import qualified Data.Array-#ifdef __GLASGOW_HASKELL__ import qualified GHC.Arr-#endif--import Utils.Containers.Internal.Coercions ((.#), (.^#))--- Coercion on GHC 7.8+-#if __GLASGOW_HASKELL__ >= 708 import Data.Coerce import qualified GHC.Exts #else+import qualified Data.List #endif --- Identity functor on base 4.8 (GHC 7.10+)-#if MIN_VERSION_base(4,8,0)-import Data.Functor.Identity (Identity(..))-#endif+import Data.Array (Ix, Array)+import qualified Data.Array -#if !MIN_VERSION_base(4,8,0)-import Data.Word (Word)-#endif+import Data.Functor.Identity (Identity(..)) import Utils.Containers.Internal.StrictPair (StrictPair (..), toPair) import Control.Monad.Zip (MonadZip (..))@@ -290,10 +261,8 @@ infixr 5 :<| infixl 5 :|> -#if __GLASGOW_HASKELL__ >= 801 {-# COMPLETE (:<|), Empty #-} {-# COMPLETE (:|>), Empty #-}-#endif -- | A bidirectional pattern synonym matching an empty sequence. --@@ -358,6 +327,41 @@ -- | General-purpose finite sequences. newtype Seq a = Seq (FingerTree (Elem a)) +#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+instance TH.Lift a => TH.Lift (Seq a) where+# if MIN_VERSION_template_haskell(2,16,0)+ liftTyped t = [|| coerceFT z ||]+# else+ lift t = [| coerceFT z |]+# endif+ where+ -- We rebalance the sequence to use only 3-nodes before lifting its+ -- underlying finger tree. This should minimize the size and depth of the+ -- tree generated at run-time. It also reduces the size of the splice,+ -- but I don't know how that affects the size of the resulting Core once+ -- all the types are added.+ Seq ft = zipWith (flip const) (replicate (length t) ()) t++ -- We remove the 'Elem' constructors to reduce the size of the splice+ -- and the number of types and coercions in the generated Core. Instead+ -- of, say,+ --+ -- Seq (Deep 3 (Two (Elem 1) (Elem 2)) EmptyT (One (Elem 3)))+ --+ -- we generate+ --+ -- coerceFT (Deep 3 (Two 1 2)) EmptyT (One 3)+ z :: FingerTree a+ z = coerce ft++-- | We use this to help the types work out for splices in the+-- Lift instance. Things get a bit yucky otherwise.+coerceFT :: FingerTree a -> Seq a+coerceFT = coerce++#endif+ instance Functor Seq where fmap = fmapSeq #ifdef __GLASGOW_HASKELL__@@ -370,49 +374,54 @@ {-# NOINLINE [1] fmapSeq #-} {-# RULES "fmapSeq/fmapSeq" forall f g xs . fmapSeq f (fmapSeq g xs) = fmapSeq (f . g) xs- #-}-#endif-#if __GLASGOW_HASKELL__ >= 709--- Safe coercions were introduced in 7.8, but did not work well with RULES yet.-{-# RULES "fmapSeq/coerce" fmapSeq coerce = coerce #-} #endif -getSeq :: Seq a -> FingerTree (Elem a)-getSeq (Seq xs) = xs- instance Foldable Seq where- foldMap f = foldMap (f .# getElem) .# getSeq- foldr f z = foldr (f .# getElem) z .# getSeq- foldl f z = foldl (f .^# getElem) z .# getSeq+#ifdef __GLASGOW_HASKELL__+ foldMap :: forall m a. Monoid m => (a -> m) -> Seq a -> m+ foldMap = coerce (foldMap :: (Elem a -> m) -> FingerTree (Elem a) -> m) -#if __GLASGOW_HASKELL__- {-# INLINABLE foldMap #-}- {-# INLINABLE foldr #-}- {-# INLINABLE foldl #-}-#endif+ foldr :: forall a b. (a -> b -> b) -> b -> Seq a -> b+ foldr = coerce (foldr :: (Elem a -> b -> b) -> b -> FingerTree (Elem a) -> b) - foldr' f z = foldr' (f .# getElem) z .# getSeq- foldl' f z = foldl' (f .^# getElem) z .# getSeq+ foldl :: forall b a. (b -> a -> b) -> b -> Seq a -> b+ foldl = coerce (foldl :: (b -> Elem a -> b) -> b -> FingerTree (Elem a) -> b) -#if __GLASGOW_HASKELL__- {-# INLINABLE foldr' #-}- {-# INLINABLE foldl' #-}-#endif+ foldr' :: forall a b. (a -> b -> b) -> b -> Seq a -> b+ foldr' = coerce (foldr' :: (Elem a -> b -> b) -> b -> FingerTree (Elem a) -> b) + foldl' :: forall b a. (b -> a -> b) -> b -> Seq a -> b+ foldl' = coerce (foldl' :: (b -> Elem a -> b) -> b -> FingerTree (Elem a) -> b)++ foldr1 :: forall a. (a -> a -> a) -> Seq a -> a+ foldr1 = coerce (foldr1 :: (Elem a -> Elem a -> Elem a) -> FingerTree (Elem a) -> Elem a)++ foldl1 :: forall a. (a -> a -> a) -> Seq a -> a+ foldl1 = coerce (foldl1 :: (Elem a -> Elem a -> Elem a) -> FingerTree (Elem a) -> Elem a)+#else+ foldMap f (Seq xs) = foldMap (f . getElem) xs++ foldr f z (Seq xs) = foldr (f . getElem) z xs++ foldl f z (Seq xs) = foldl (\z' x -> f z' (getElem x)) z xs++ foldr' f z (Seq xs) = foldr' (f . getElem) z xs++ foldl' f z (Seq xs) = foldl' (\z' x -> f z' (getElem x)) z xs+ foldr1 f (Seq xs) = getElem (foldr1 f' xs) where f' (Elem x) (Elem y) = Elem (f x y) foldl1 f (Seq xs) = getElem (foldl1 f' xs) where f' (Elem x) (Elem y) = Elem (f x y)+#endif -#if MIN_VERSION_base(4,8,0) length = length {-# INLINE length #-} null = null {-# INLINE null #-}-#endif instance Traversable Seq where #if __GLASGOW_HASKELL__@@ -464,7 +473,7 @@ (\a' b' c' d' -> Four (Elem a') (Elem b') (Elem c') (Elem d')) (f a) (f b)- (f c) <*> + (f c) <*> (f d) traverseDigitN :: Applicative f@@ -493,8 +502,11 @@ instance NFData a => NFData (Seq a) where rnf (Seq xs) = rnf xs +-- | @since 0.8+instance NFData1 Seq where+ liftRnf rnfx (Seq xs) = liftRnf (liftRnf rnfx) xs+ instance Monad Seq where- return = pure xs >>= f = foldl' add empty xs where add ys x = ys >< f x (>>) = (*>)@@ -516,9 +528,7 @@ pure = singleton xs *> ys = cycleNTimes (length xs) ys (<*>) = apSeq-#if MIN_VERSION_base(4,10,0) liftA2 = liftA2Seq-#endif xs <* ys = beforeSeq xs ys apSeq :: Seq (a -> b) -> Seq a -> Seq b@@ -600,7 +610,7 @@ (fmap (fmap (f lastx)) (nodeToDigit sf)) where lift_elem :: (a -> b -> c) -> a -> Elem b -> Elem c-#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ lift_elem = coerce #else lift_elem f x (Elem y) = Elem (f x y)@@ -782,8 +792,8 @@ squashR (Two12 n1 n2) m = node3 n1 n2 m --- | /O(m*n)/ (incremental) Takes an /O(m)/ function and a finger tree of size--- /n/ and maps the function over the tree leaves. Unlike the usual 'fmap', the+-- | \(O(mn)\) (incremental) Takes an \(O(m)\) function and a finger tree of size+-- \(n\) and maps the function over the tree leaves. Unlike the usual 'fmap', the -- function is applied to the "leaves" of the 'FingerTree' (i.e., given a -- @FingerTree (Elem a)@, it applies the function to elements of type @Elem -- a@), replacing the leaves with subtrees of at least the same height, e.g.,@@ -798,7 +808,7 @@ mapMulNode mul f (Node2 s a b) = Node2 (mul * s) (f a) (f b) mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c) --- | /O(log n)/ (incremental) Takes the extra flexibility out of a 'FingerTree'+-- | \(O(\log n)\) (incremental) Takes the extra flexibility out of a 'FingerTree' -- to make it a genuine 2-3 finger tree. The result of 'rigidify' will have -- only two and three digits at the top level and only one and two -- digits elsewhere. If the tree has fewer than four elements, 'rigidify'@@ -828,7 +838,7 @@ Three b c d -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c d) Four b c d e -> RigidFull $ Rigid s (node3 a b c) EmptyTh (node2 d e) --- | /O(log n)/ (incremental) Takes a tree whose left side has been rigidified+-- | \(O(\log n)\) (incremental) Takes a tree whose left side has been rigidified -- and finishes the job. rigidifyRight :: Int -> Digit23 (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> Rigidified (Elem a) @@ -845,7 +855,7 @@ Node2 _ a b -> RigidThree a b e Node3 _ a b c -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c e) --- | /O(log n)/ (incremental) Rejigger a finger tree so the digits are all ones+-- | \(O(\log n)\) (incremental) Rejigger a finger tree so the digits are all ones -- and twos. thin :: Sized a => FingerTree a -> Thin a -- Note that 'thin12' will produce a 'DeepTh' constructor immediately before@@ -899,10 +909,12 @@ (<|>) = (><) instance Eq a => Eq (Seq a) where- xs == ys = length xs == length ys && toList xs == toList ys+ xs == ys = liftEq (==) xs ys+ {-# INLINABLE (==) #-} instance Ord a => Ord (Seq a) where- compare xs ys = compare (toList xs) (toList ys)+ compare xs ys = liftCompare compare xs ys+ {-# INLINABLE compare #-} #ifdef TESTING instance Show a => Show (Seq a) where@@ -913,7 +925,6 @@ showString "fromList " . shows (toList xs) #endif -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.9 instance Show1 Seq where liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $@@ -921,15 +932,52 @@ -- | @since 0.5.9 instance Eq1 Seq where- liftEq eq xs ys = length xs == length ys && liftEq eq (toList xs) (toList ys)+ liftEq eq xs ys =+ sameSize xs ys && sameSizeLiftEqLists eq (toList xs) (toList ys)+ {-# INLINE liftEq #-} -- | @since 0.5.9 instance Ord1 Seq where- liftCompare cmp xs ys = liftCompare cmp (toList xs) (toList ys)-#endif+ liftCompare f xs ys = liftCmpLists f (toList xs) (toList ys)+ {-# INLINE liftCompare #-} +-- Note [Eq and Ord]+-- ~~~~~~~~~~~~~~~~~+-- Eq and Ord for Seq are implemented by converting to lists, which turns out+-- to be quite efficient.+-- However, we define our own functions to work with lists because the relevant+-- list functions in base have performance issues (liftEq and liftCompare are+-- recursive and cannot inline, (==) and compare are not INLINABLE and cannot+-- specialize).++-- Same as `length xs == length ys` but uses the structure invariants to skip+-- unnecessary cases.+sameSize :: Seq a -> Seq b -> Bool+sameSize (Seq t1) (Seq t2) = case (t1, t2) of+ (EmptyT, EmptyT) -> True+ (Single _, Single _) -> True+ (Deep v1 _ _ _, Deep v2 _ _ _) -> v1 == v2+ _ -> False++-- Assumes the lists are of equal size to skip some cases.+sameSizeLiftEqLists :: (a -> b -> Bool) -> [a] -> [b] -> Bool+sameSizeLiftEqLists eq = go+ where+ go (x:xs) (y:ys) = eq x y && go xs ys+ go _ _ = True+{-# INLINE sameSizeLiftEqLists #-}++liftCmpLists :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering+liftCmpLists cmp = go+ where+ go [] [] = EQ+ go [] (_:_) = LT+ go (_:_) [] = GT+ go (x:xs) (y:ys) = cmp x y <> go xs ys+{-# INLINE liftCmpLists #-}+ instance Read a => Read (Seq a) where-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP xs <- readPrec@@ -943,32 +991,25 @@ return (fromList xs,t) #endif -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.9 instance Read1 Seq where liftReadsPrec _rp readLst p = readParen (p > 10) $ \r -> do ("fromList",s) <- lex r (xs,t) <- readLst s pure (fromList xs, t)-#endif +-- | @mempty@ = 'empty' instance Monoid (Seq a) where mempty = empty-#if MIN_VERSION_base(4,9,0) mappend = (Semigroup.<>)-#else- mappend = (><)-#endif -#if MIN_VERSION_base(4,9,0)--- | @since 0.5.7+-- | @(<>)@ = '(><)'+--+-- @since 0.5.7 instance Semigroup.Semigroup (Seq a) where (<>) = (><) stimes = cycleNTimes . fromIntegral-#endif -INSTANCE_TYPEABLE1(Seq)- #if __GLASGOW_HASKELL__ instance Data a => Data (Seq a) where gfoldl f z s = case viewl s of@@ -1012,6 +1053,9 @@ -- | @since 0.6.1 deriving instance Generic (FingerTree a)++-- | @since 0.6.6+deriving instance TH.Lift a => TH.Lift (FingerTree a) #endif instance Sized a => Sized (FingerTree a) where@@ -1024,7 +1068,7 @@ instance Foldable FingerTree where foldMap _ EmptyT = mempty foldMap f' (Single x') = f' x'- foldMap f' (Deep _ pr' m' sf') = + foldMap f' (Deep _ pr' m' sf') = foldMapDigit f' pr' <> foldMapTree (foldMapNode f') m' <> foldMapDigit f' sf'@@ -1032,7 +1076,7 @@ foldMapTree :: Monoid m => (Node a -> m) -> FingerTree (Node a) -> m foldMapTree _ EmptyT = mempty foldMapTree f (Single x) = f x- foldMapTree f (Deep _ pr m sf) = + foldMapTree f (Deep _ pr m sf) = foldMapDigitN f pr <> foldMapTree (foldMapNodeN f) m <> foldMapDigitN f sf@@ -1101,16 +1145,16 @@ foldlNodeN f z t = foldl f z t {-# INLINE foldl #-} - foldr' _ z' EmptyT = z'- foldr' f' z' (Single x') = f' x' z'- foldr' f' z' (Deep _ pr' m' sf') =+ foldr' _ !z' EmptyT = z'+ foldr' f' !z' (Single x') = f' x' z'+ foldr' f' !z' (Deep _ pr' m' sf') = (foldrDigit' f' $! (foldrTree' (foldrNode' f') $! (foldrDigit' f' z') sf') m') pr' where foldrTree' :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b- foldrTree' _ z EmptyT = z- foldrTree' f z (Single x) = f x $! z- foldrTree' f z (Deep _ pr m sf) =- (foldr' f $! (foldrTree' (foldrNodeN' f) $! (foldr' f $! z) sf) m) pr+ foldrTree' _ !z EmptyT = z+ foldrTree' f !z (Single x) = f x z+ foldrTree' f !z (Deep _ pr m sf) =+ (foldr' f $! (foldrTree' (foldrNodeN' f) $! foldr' f z sf) m) pr foldrDigit' :: (a -> b -> b) -> b -> Digit a -> b foldrDigit' f z t = foldr' f z t@@ -1122,17 +1166,17 @@ foldrNodeN' f t z = foldr' f z t {-# INLINE foldr' #-} - foldl' _ z' EmptyT = z'- foldl' f' z' (Single x') = f' z' x'- foldl' f' z' (Deep _ pr' m' sf') =+ foldl' _ !z' EmptyT = z'+ foldl' f' !z' (Single x') = f' z' x'+ foldl' f' !z' (Deep _ pr' m' sf') = (foldlDigit' f' $! (foldlTree' (foldlNode' f') $! (foldlDigit' f' z') pr') m') sf' where foldlTree' :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b- foldlTree' _ z EmptyT = z- foldlTree' f z (Single xs) = f z xs- foldlTree' f z (Deep _ pr m sf) =+ foldlTree' _ !z EmptyT = z+ foldlTree' f !z (Single xs) = f z xs+ foldlTree' f !z (Deep _ pr m sf) = (foldl' f $! (foldlTree' (foldl' f) $! foldl' f z pr) m) sf foldlDigit' :: (b -> a -> b) -> b -> Digit a -> b@@ -1170,6 +1214,12 @@ rnf (Single x) = rnf x rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m +-- | @since 0.8+instance NFData1 FingerTree where+ liftRnf _ EmptyT = ()+ liftRnf rnfx (Single x) = rnfx x+ liftRnf rnfx (Deep _ pr m sf) = liftRnf rnfx pr `seq` liftRnf (liftRnf rnfx) m `seq` liftRnf rnfx sf+ {-# INLINE deep #-} deep :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a deep pr m sf = Deep (size pr + size m + size sf) pr m sf@@ -1203,6 +1253,9 @@ -- | @since 0.6.1 deriving instance Generic (Digit a)++-- | @since 0.6.6+deriving instance TH.Lift a => TH.Lift (Digit a) #endif foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b@@ -1227,16 +1280,16 @@ foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d {-# INLINE foldl #-} - foldr' f z (One a) = f a z- foldr' f z (Two a b) = f a $! f b z- foldr' f z (Three a b c) = f a $! f b $! f c z- foldr' f z (Four a b c d) = f a $! f b $! f c $! f d z+ foldr' f !z (One a) = f a z+ foldr' f !z (Two a b) = f a $! f b z+ foldr' f !z (Three a b c) = f a $! f b $! f c z+ foldr' f !z (Four a b c d) = f a $! f b $! f c $! f d z {-# INLINE foldr' #-} - foldl' f z (One a) = f z a- foldl' f z (Two a b) = (f $! f z a) b- foldl' f z (Three a b c) = (f $! (f $! f z a) b) c- foldl' f z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d+ foldl' f !z (One a) = f z a+ foldl' f !z (Two a b) = (f $! f z a) b+ foldl' f !z (Three a b c) = (f $! (f $! f z a) b) c+ foldl' f !z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d {-# INLINE foldl' #-} foldr1 _ (One a) = a@@ -1269,6 +1322,13 @@ rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d +-- | @since 0.8+instance NFData1 Digit where+ liftRnf rnfx (One a) = rnfx a+ liftRnf rnfx (Two a b) = rnfx a `seq` rnfx b+ liftRnf rnfx (Three a b c) = rnfx a `seq` rnfx b `seq` rnfx c+ liftRnf rnfx (Four a b c d) = rnfx a `seq` rnfx b `seq` rnfx c `seq` rnfx d+ instance Sized a => Sized (Digit a) where {-# INLINE size #-} size = foldl1 (+) . fmap size@@ -1304,6 +1364,9 @@ -- | @since 0.6.1 deriving instance Generic (Node a)++-- | @since 0.6.6+deriving instance TH.Lift a => TH.Lift (Node a) #endif foldNode :: (b -> b -> b) -> (a -> b) -> Node a -> b@@ -1322,12 +1385,12 @@ foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c {-# INLINE foldl #-} - foldr' f z (Node2 _ a b) = f a $! f b z- foldr' f z (Node3 _ a b c) = f a $! f b $! f c z+ foldr' f !z (Node2 _ a b) = f a $! f b z+ foldr' f !z (Node3 _ a b c) = f a $! f b $! f c z {-# INLINE foldr' #-} - foldl' f z (Node2 _ a b) = (f $! f z a) b- foldl' f z (Node3 _ a b c) = (f $! (f $! f z a) b) c+ foldl' f !z (Node2 _ a b) = (f $! f z a) b+ foldl' f !z (Node3 _ a b c) = (f $! (f $! f z a) b) c {-# INLINE foldl' #-} instance Functor Node where@@ -1344,6 +1407,11 @@ rnf (Node2 _ a b) = rnf a `seq` rnf b rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c +-- | @since 0.8+instance NFData1 Node where+ liftRnf rnfx (Node2 _ a b) = rnfx a `seq` rnfx b+ liftRnf rnfx (Node3 _ a b c) = rnfx a `seq` rnfx b `seq` rnfx c+ instance Sized (Node a) where size (Node2 v _ _) = v size (Node3 v _ _ _) = v@@ -1379,7 +1447,7 @@ size _ = 1 instance Functor Elem where-#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ -- This cuts the time for <*> by around a fifth. fmap = coerce #else@@ -1388,7 +1456,7 @@ instance Foldable Elem where foldr f z (Elem x) = f x z-#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ foldMap = coerce foldl = coerce foldl' = coerce@@ -1404,20 +1472,14 @@ instance NFData a => NFData (Elem a) where rnf (Elem x) = rnf x +-- | @since 0.8+instance NFData1 Elem where+ liftRnf rnfx (Elem x) = rnfx x+ ------------------------------------------------------- -- Applicative construction --------------------------------------------------------#if !MIN_VERSION_base(4,8,0)-newtype Identity a = Identity {runIdentity :: a} -instance Functor Identity where- fmap f (Identity x) = Identity (f x)--instance Applicative Identity where- pure = Identity- Identity f <*> Identity x = Identity (f x)-#endif- -- | 'applicativeTree' takes an Applicative-wrapped construction of a -- piece of a FingerTree, assumed to always have the same size (which -- is put in the second argument), and replicates it as many times as@@ -1426,7 +1488,7 @@ {-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-} {-# SPECIALIZE applicativeTree :: Int -> Int -> Identity a -> Identity (FingerTree a) #-} -- Special note: the Identity specialization automatically does node sharing,--- reducing memory usage of the resulting tree to /O(log n)/.+-- reducing memory usage of the resulting tree to \(O(\log n)\). applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a) applicativeTree n !mSize m = case n of 0 -> pure EmptyT@@ -1711,23 +1773,17 @@ | otherwise = error "replicateA takes a nonnegative integer argument" {-# SPECIALIZE replicateA :: Int -> State a b -> State a (Seq b) #-} --- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.+-- | 'replicateM' is the @Seq@ counterpart of+-- @Control.Monad.'Control.Monad.replicateM'@. -- -- > replicateM n x = sequence (replicate n x) -- -- For @base >= 4.8.0@ and @containers >= 0.5.11@, 'replicateM' -- is a synonym for 'replicateA'.-#if MIN_VERSION_base(4,8,0) replicateM :: Applicative m => Int -> m a -> m (Seq a) replicateM = replicateA-#else-replicateM :: Monad m => Int -> m a -> m (Seq a)-replicateM n x- | n >= 0 = Applicative.unwrapMonad (replicateA n (Applicative.WrapMonad x))- | otherwise = error "replicateM takes a nonnegative integer argument"-#endif --- | /O(/log/ k)/. @'cycleTaking' k xs@ forms a sequence of length @k@ by+-- | \(O(\log k)\). @'cycleTaking' k xs@ forms a sequence of length @k@ by -- repeatedly concatenating @xs@ with itself. @xs@ may only be empty if -- @k@ is 0. --@@ -1895,7 +1951,8 @@ (><) :: Seq a -> Seq a -> Seq a Seq xs >< Seq ys = Seq (appendTree0 xs ys) --- The appendTree/addDigits gunk below is machine generated+-- The appendTree/addDigits gunk below was originally machine generated via mkappend.hs,+-- but has since been manually edited to include strictness annotations. appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a) appendTree0 EmptyT xs =@@ -2186,9 +2243,10 @@ -- | @since 0.5.8 deriving instance Generic (ViewL a)-#endif -INSTANCE_TYPEABLE1(ViewL)+-- | @since 0.6.6+deriving instance TH.Lift a => TH.Lift (ViewL a)+#endif instance Functor ViewL where {-# INLINE fmap #-}@@ -2208,13 +2266,11 @@ foldl1 _ EmptyL = error "foldl1: empty view" foldl1 f (x :< xs) = foldl f x xs -#if MIN_VERSION_base(4,8,0) null EmptyL = True null (_ :< _) = False length EmptyL = 0 length (_ :< xs) = 1 + length xs-#endif instance Traversable ViewL where traverse _ EmptyL = pure EmptyL@@ -2254,9 +2310,10 @@ -- | @since 0.5.8 deriving instance Generic (ViewR a)-#endif -INSTANCE_TYPEABLE1(ViewR)+-- | @since 0.6.6+deriving instance TH.Lift a => TH.Lift (ViewR a)+#endif instance Functor ViewR where {-# INLINE fmap #-}@@ -2275,13 +2332,12 @@ foldr1 _ EmptyR = error "foldr1: empty view" foldr1 f (xs :> x) = foldr f x xs-#if MIN_VERSION_base(4,8,0)+ null EmptyR = True null (_ :> _) = False length EmptyR = 0 length (xs :> _) = length xs + 1-#endif instance Traversable ViewR where traverse _ EmptyR = pure EmptyR@@ -2362,7 +2418,7 @@ -- See note on unsigned arithmetic in splitAt | fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of Place _ (Elem x) -> x- | otherwise = + | otherwise = error $ "index out of bounds in call to: Data.Sequence.index " ++ show i -- | \( O(\log(\min(i,n-i))) \). The element at the specified position,@@ -2552,7 +2608,7 @@ -- -- @since 0.5.8 adjust' :: forall a . (a -> a) -> Int -> Seq a -> Seq a-#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ adjust' f i xs -- See note on unsigned arithmetic in splitAt | fromIntegral i < (fromIntegral (length xs) :: Word) =@@ -3160,7 +3216,7 @@ foldMapWithIndex f' (Seq xs') = foldMapWithIndexTreeE (lift_elem f') 0 xs' where lift_elem :: (Int -> a -> m) -> (Int -> Elem a -> m)-#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ lift_elem g = coerce g #else lift_elem g = \s (Elem a) -> g s a@@ -3357,7 +3413,7 @@ {-# INLINE mb #-} lift_elem :: (Int -> a) -> (Int -> Elem a)-#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ lift_elem g = coerce g #else lift_elem g = Elem . g@@ -3374,8 +3430,8 @@ #ifdef __GLASGOW_HASKELL__ fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a) where- -- The following definition uses (Ix i) constraing, which is needed for the- -- other fromArray definition.+ -- The following definition uses an (Ix i) constraint, which is needed for+ -- the other fromArray definition. _ = Data.Array.rangeSize (Data.Array.bounds a) #else fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a)@@ -4230,7 +4286,7 @@ -- it gets a bit hard to read. fromList = Seq . mkTree . map_elem where-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) mkTree :: forall a' . [Elem a'] -> FingerTree (Elem a') #else mkTree :: [Elem a] -> FingerTree (Elem a)@@ -4278,7 +4334,7 @@ where d2 = Three x1 x2 x3 d1 = Three (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9) (Node3 3 y0 y1 y2)-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) cont :: (Digit (Node (Elem a')), Digit (Elem a')) -> FingerTree (Node (Node (Elem a'))) -> FingerTree (Elem a') #endif cont (!r1, !r2) !sub =@@ -4305,7 +4361,7 @@ !n10 = Node3 (3*s) n1 n2 n3 mkTreeC ::-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) forall a b c . #endif (b -> FingerTree (Node a) -> c)@@ -4347,7 +4403,7 @@ mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LCons y6 xs)))))))))))))))) = mkTreeC cont2 (9*s) (getNodesC (3*s) (Node3 (3*s) y3 y4 y5) y6 xs) where-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) cont2 :: (b, Digit (Node (Node a)), Digit (Node a)) -> FingerTree (Node (Node (Node a))) -> c #endif cont2 (b, r1, r2) !sub =@@ -4392,7 +4448,7 @@ !n10 = Node3 (3*s) n1 n2 n3 map_elem :: [a] -> [Elem a]-#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ map_elem xs = coerce xs #else map_elem xs = Data.List.map Elem xs@@ -4402,7 +4458,7 @@ -- essentially: Free ((,) a) b. data ListFinal a cont = LFinal !cont | LCons !a (ListFinal a cont) -#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ instance GHC.Exts.IsList (Seq a) where type Item (Seq a) = a fromList = fromList@@ -4433,7 +4489,7 @@ fmapReverse f (Seq xs) = Seq (fmapReverseTree (lift_elem f) xs) where lift_elem :: (a -> b) -> (Elem a -> Elem b)-#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ lift_elem = coerce #else lift_elem g (Elem a) = Elem (g a)@@ -4667,6 +4723,8 @@ -- | @ 'mzipWith' = 'zipWith' @ -- -- @ 'munzip' = 'unzip' @+--+-- @since 0.5.10.1 instance MonadZip Seq where mzipWith = zipWith munzip = unzip@@ -4761,7 +4819,7 @@ -- This instance is only used at the very top of the tree; -- the rest of the elements are handled by unzipWithNodeElem instance UnzipWith Elem where-#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ unzipWith' = coerce #else unzipWith' f (Elem a) = case f a of (x, y) -> (Elem x, Elem y)
src/Data/Sequence/Internal/Sorting.hs view
@@ -76,7 +76,8 @@ foldWithIndexNode) import Utils.Containers.Internal.State (State(..), execState) -- | \( O(n \log n) \). 'sort' sorts the specified 'Seq' by the natural--- ordering of its elements. The sort is stable. If stability is not+-- ordering of its elements. The sort is stable, meaning the order of equal+-- elements is preserved. If stability is not -- required, 'unstableSort' can be slightly faster. -- -- @since 0.3.0@@ -84,7 +85,8 @@ sort = sortBy compare -- | \( O(n \log n) \). 'sortBy' sorts the specified 'Seq' according to the--- specified comparator. The sort is stable. If stability is not required,+-- specified comparator. The sort is stable, meaning the order of equal+-- elements is preserved. If stability is not required, -- 'unstableSortBy' can be slightly faster. -- -- @since 0.3.0@@ -96,11 +98,11 @@ (buildIQ cmp (\s (Elem x) -> IQ s x IQNil) 0 xs) -- | \( O(n \log n) \). 'sortOn' sorts the specified 'Seq' by comparing--- the results of a key function applied to each element. @'sortOn' f@ is+-- the results of a key function applied to each element. The sort is stable,+-- meaning the order of equal elements is preserved. @'sortOn' f@ is -- equivalent to @'sortBy' ('compare' ``Data.Function.on`` f)@, but has the -- performance advantage of only evaluating @f@ once for each element in the--- input list. This is called the decorate-sort-undecorate paradigm, or--- Schwartzian transform.+-- input 'Seq'. -- -- An example of using 'sortOn' might be to sort a 'Seq' of strings -- according to their length:@@ -151,8 +153,7 @@ -- comparing the results of a key function applied to each element. -- @'unstableSortOn' f@ is equivalent to @'unstableSortBy' ('compare' ``Data.Function.on`` f)@, -- but has the performance advantage of only evaluating @f@ once for each--- element in the input list. This is called the--- decorate-sort-undecorate paradigm, or Schwartzian transform.+-- element in the input 'Seq'. -- -- An example of using 'unstableSortOn' might be to sort a 'Seq' of strings -- according to their length:
src/Data/Set.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif @@ -23,19 +23,19 @@ -- For a walkthrough of the most commonly used functions see the -- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>. --+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- > import Data.Set (Set)+-- > import qualified Data.Set as Set+-- -- Note that the implementation is generally /left-biased/. Functions that take -- two sets as arguments and combine them, such as `union` and `intersection`, -- prefer the entries in the first argument to those in the second. Of course, -- this bias can only be observed when equality is an equivalence relation -- instead of structural equality. ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g. ----- > import Data.Set (Set)--- > import qualified Data.Set as Set------ -- == Warning -- -- The size of the set must not exceed @maxBound::Int@. Violation of@@ -48,29 +48,44 @@ -- The implementation of 'Set' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: ----- * Stephen Adams, \"/Efficient sets: a balancing act/\",+-- * Stephen Adams, \"/Efficient sets—a balancing act/\", -- Journal of Functional Programming 3(4):553-562, October 1993,--- <http://www.swiss.ai.mit.edu/~adams/BB/>.+-- <https://doi.org/10.1017/S0956796800000885>,+-- <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. -- * J. Nievergelt and E.M. Reingold, -- \"/Binary search trees of bounded balance/\", -- SIAM journal of computing 2(1), March 1973.+-- <https://doi.org/10.1137/0202005>.+-- * Yoichi Hirai and Kazuhiko Yamamoto,+-- \"/Balancing weight-balanced trees/\",+-- Journal of Functional Programming 21(3):287-307, 2011,+-- <https://doi.org/10.1017/S0956796811000104> -- -- Bounds for 'union', 'intersection', and 'difference' are as given -- by -- -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,--- \"/Just Join for Parallel Ordered Sets/\",--- <https://arxiv.org/abs/1602.02120v3>.+-- \"/Parallel Ordered Sets Using Join/\",+-- <https://arxiv.org/abs/1602.02120v4>. --+--+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the set.+--+-- Operations like 'member', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input sets respectively.+-- ----------------------------------------------------------------------------- module Data.Set ( -- * Set type-#if !defined(TESTING)- Set -- instance Eq,Ord,Show,Read,Data,Typeable-#else- Set(..)-#endif+ Set -- instance Eq,Ord,Show,Read,Data -- * Construction , empty@@ -111,8 +126,11 @@ , difference , (\\) , intersection+ , intersections+ , symmetricDifference , cartesianProduct , disjointUnion+ , Intersection(..) -- * Filter , S.filter@@ -141,8 +159,8 @@ , S.foldr , S.foldl -- ** Strict folds- , foldr'- , foldl'+ , S.foldr'+ , S.foldl' -- ** Legacy folds , fold @@ -170,14 +188,6 @@ , showTree , showTreeWith , valid--#if defined(TESTING)- -- Internals (for testing)- , bin- , balanced- , link- , merge-#endif ) where import Data.Set.Internal as S
src/Data/Set/Internal.hs view
@@ -1,14 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} #endif @@ -36,43 +33,40 @@ -- Authors importing this module are expected to track development -- closely. ----- = Description ----- An efficient implementation of sets.+-- = Finite Sets (internals) ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.+-- The @'Set' e@ type represents a set of elements of type @e@. Most operations+-- require that @e@ be an instance of the 'Ord' class. A 'Set' is strict in its+-- elements. ----- > import Data.Set (Set)--- > import qualified Data.Set as Set --+-- == Implementation+-- -- The implementation of 'Set' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: ----- * Stephen Adams, \"/Efficient sets: a balancing act/\",+-- * Stephen Adams, \"/Efficient sets—a balancing act/\", -- Journal of Functional Programming 3(4):553-562, October 1993,--- <http://www.swiss.ai.mit.edu/~adams/BB/>.+-- <https://doi.org/10.1017/S0956796800000885>,+-- <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. -- * J. Nievergelt and E.M. Reingold, -- \"/Binary search trees of bounded balance/\", -- SIAM journal of computing 2(1), March 1973.+-- <https://doi.org/10.1137/0202005>.+-- * Yoichi Hirai and Kazuhiko Yamamoto,+-- \"/Balancing weight-balanced trees/\",+-- Journal of Functional Programming 21(3):287-307, 2011,+-- <https://doi.org/10.1017/S0956796811000104> -- -- Bounds for 'union', 'intersection', and 'difference' are as given -- by -- -- * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,--- \"/Just Join for Parallel Ordered Sets/\",--- <https://arxiv.org/abs/1602.02120v3>.+-- \"/Parallel Ordered Sets Using Join/\",+-- <https://arxiv.org/abs/1602.02120v4>. ----- Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'. Of course, left-biasing can only be observed--- when equality is an equivalence relation instead of structural--- equality. ----- /Warning/: The size of the set must not exceed @maxBound::Int@. Violation of--- this condition is not detected and if the size limit is exceeded, the--- behavior of the set is completely undefined.--- -- @since 0.5.9 ----------------------------------------------------------------------------- @@ -124,7 +118,7 @@ module Data.Set.Internal ( -- * Set type- Set(..) -- instance Eq,Ord,Show,Read,Data,Typeable+ Set(..) -- instance Eq,Ord,Show,Read,Data , Size -- * Operators@@ -156,9 +150,13 @@ , unions , difference , intersection+ , intersections+ , symmetricDifference , cartesianProduct , disjointUnion+ , Intersection(..) + -- * Filter , filter , takeWhileAntitone@@ -230,44 +228,34 @@ , merge ) where -import Prelude hiding (filter,foldl,foldr,null,map,take,drop,splitAt)+import Utils.Containers.Internal.Prelude hiding+ (filter,foldl,foldl',foldr,null,map,take,drop,splitAt)+import Prelude () import Control.Applicative (Const(..)) import qualified Data.List as List-import Data.Bits (shiftL, shiftR)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup(stimes))-#endif-#if !(MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>)))-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (stimesIdempotentMonoid)+import Data.Semigroup (Semigroup(..), stimesIdempotentMonoid, stimesIdempotent) import Data.Functor.Classes-#endif-#if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity)-#endif import qualified Data.Foldable as Foldable-#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable (foldMap))-#endif-import Data.Typeable-import Control.DeepSeq (NFData(rnf))+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf))+import Data.List.NonEmpty (NonEmpty(..)) import Utils.Containers.Internal.StrictPair import Utils.Containers.Internal.PtrEquality+import Utils.Containers.Internal.EqOrdUtil (EqM(..), OrdM(..)) +#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+import Text.Read ( readPrec, Read (..), Lexeme (..), parens, prec+ , lexP, readListPrecDefault )+#endif #if __GLASGOW_HASKELL__ import GHC.Exts ( build, lazy )-#if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as GHCExts-#endif-import Text.Read ( readPrec, Read (..), Lexeme (..), parens, prec- , lexP, readListPrecDefault ) import Data.Data+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+import Data.Coerce (coerce) #endif @@ -276,7 +264,7 @@ --------------------------------------------------------------------} infixl 9 \\ -- --- | /O(m*log(n\/m+1)), m <= n/. See 'difference'.+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). See 'difference'. (\\) :: Ord a => Set a -> Set a -> Set a m1 \\ m2 = difference m1 m2 #if __GLASGOW_HASKELL__@@ -294,25 +282,26 @@ type Size = Int -#if __GLASGOW_HASKELL__ >= 708+#ifdef __GLASGOW_HASKELL__ type role Set nominal++-- | @since 0.6.6+deriving instance Lift a => Lift (Set a) #endif +-- | @mempty@ = 'empty' instance Ord a => Monoid (Set a) where mempty = empty mconcat = unions-#if !(MIN_VERSION_base(4,9,0))- mappend = union-#else mappend = (<>) --- | @since 0.5.7+-- | @(<>)@ = 'union'+--+-- @since 0.5.7 instance Ord a => Semigroup (Set a) where (<>) = union stimes = stimesIdempotentMonoid-#endif - -- | Folds in order of increasing key. instance Foldable.Foldable Set where fold = go@@ -333,7 +322,6 @@ {-# INLINE foldl' #-} foldr' = foldr' {-# INLINE foldr' #-}-#if MIN_VERSION_base(4,8,0) length = size {-# INLINE length #-} null = null@@ -352,9 +340,7 @@ {-# INLINABLE sum #-} product = foldl' (*) 1 {-# INLINABLE product #-}-#endif - #if __GLASGOW_HASKELL__ {--------------------------------------------------------------------@@ -384,19 +370,19 @@ {-------------------------------------------------------------------- Query --------------------------------------------------------------------}--- | /O(1)/. Is this the empty set?+-- | \(O(1)\). Is this the empty set? null :: Set a -> Bool null Tip = True null (Bin {}) = False {-# INLINE null #-} --- | /O(1)/. The number of elements in the set.+-- | \(O(1)\). The number of elements in the set. size :: Set a -> Int size Tip = 0 size (Bin sz _ _ _) = sz {-# INLINE size #-} --- | /O(log n)/. Is the element in the set?+-- | \(O(\log n)\). Is the element in the set? member :: Ord a => a -> Set a -> Bool member = go where@@ -411,7 +397,7 @@ {-# INLINE member #-} #endif --- | /O(log n)/. Is the element not in the set?+-- | \(O(\log n)\). Is the element not in the set? notMember :: Ord a => a -> Set a -> Bool notMember a t = not $ member a t #if __GLASGOW_HASKELL__@@ -420,7 +406,7 @@ {-# INLINE notMember #-} #endif --- | /O(log n)/. Find largest element smaller than the given one.+-- | \(O(\log n)\). Find largest element smaller than the given one. -- -- > lookupLT 3 (fromList [3, 5]) == Nothing -- > lookupLT 5 (fromList [3, 5]) == Just 3@@ -440,7 +426,7 @@ {-# INLINE lookupLT #-} #endif --- | /O(log n)/. Find smallest element greater than the given one.+-- | \(O(\log n)\). Find smallest element greater than the given one. -- -- > lookupGT 4 (fromList [3, 5]) == Just 5 -- > lookupGT 5 (fromList [3, 5]) == Nothing@@ -460,7 +446,7 @@ {-# INLINE lookupGT #-} #endif --- | /O(log n)/. Find largest element smaller or equal to the given one.+-- | \(O(\log n)\). Find largest element smaller or equal to the given one. -- -- > lookupLE 2 (fromList [3, 5]) == Nothing -- > lookupLE 4 (fromList [3, 5]) == Just 3@@ -483,7 +469,7 @@ {-# INLINE lookupLE #-} #endif --- | /O(log n)/. Find smallest element greater or equal to the given one.+-- | \(O(\log n)\). Find smallest element greater or equal to the given one. -- -- > lookupGE 3 (fromList [3, 5]) == Just 3 -- > lookupGE 4 (fromList [3, 5]) == Just 5@@ -509,12 +495,12 @@ {-------------------------------------------------------------------- Construction --------------------------------------------------------------------}--- | /O(1)/. The empty set.+-- | \(O(1)\). The empty set. empty :: Set a empty = Tip {-# INLINE empty #-} --- | /O(1)/. Create a singleton set.+-- | \(O(1)\). Create a singleton set. singleton :: a -> Set a singleton x = Bin 1 x Tip Tip {-# INLINE singleton #-}@@ -522,7 +508,7 @@ {-------------------------------------------------------------------- Insertion, Deletion --------------------------------------------------------------------}--- | /O(log n)/. Insert an element in a set.+-- | \(O(\log n)\). Insert an element in a set. -- If the set already contains an element equal to the given value, -- it is replaced with the new value. @@ -577,7 +563,7 @@ {-# INLINE insertR #-} #endif --- | /O(log n)/. Delete an element from a set.+-- | \(O(\log n)\). Delete an element from a set. -- See Note: Type of local 'go' function delete :: Ord a => a -> Set a -> Set a@@ -599,7 +585,7 @@ {-# INLINE delete #-} #endif --- | /O(log n)/ @('alterF' f x s)@ can delete or insert @x@ in @s@ depending on+-- | \(O(\log n)\) @('alterF' f x s)@ can delete or insert @x@ in @s@ depending on -- whether an equal element is found in @s@. -- -- In short:@@ -633,9 +619,7 @@ #-} #endif -#if MIN_VERSION_base(4,8,0) {-# SPECIALIZE alterF :: Ord a => (Bool -> Identity Bool) -> a -> Set a -> Identity (Set a) #-}-#endif data AlteredSet a -- | The needle is present in the original set.@@ -668,7 +652,7 @@ {-------------------------------------------------------------------- Subset --------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/.+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). -- @(s1 \`isProperSubsetOf\` s2)@ indicates whether @s1@ is a -- proper subset of @s2@. --@@ -683,7 +667,7 @@ #endif --- | /O(m*log(n\/m + 1)), m <= n/.+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). -- @(s1 \`isSubsetOf\` s2)@ indicates whether @s1@ is a subset of @s2@. -- -- @@@ -704,7 +688,7 @@ -- -- This function is structured very much like `difference`, `union`, -- and `intersection`. Whereas the bounds proofs for those in Blelloch--- et al needed to accound for both "split work" and "merge work", we+-- et al needed to account for both "split work" and "merge work", we -- only have to worry about split work here, which is the same as in -- those functions. isSubsetOfX :: Ord a => Set a -> Set a -> Bool@@ -738,7 +722,7 @@ {-------------------------------------------------------------------- Disjoint --------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. Check whether two sets are disjoint+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Check whether two sets are disjoint -- (i.e., their intersection is empty). -- -- > disjoint (fromList [2,4,6]) (fromList [1,3]) == True@@ -767,23 +751,29 @@ Minimal, Maximal --------------------------------------------------------------------} --- We perform call-pattern specialization manually on lookupMin--- and lookupMax. Otherwise, GHC doesn't seem to do it, which is--- unfortunate if, for example, someone uses findMin or findMax.+-- Note [Inline lookupMin]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- The core of lookupMin is implemented as lookupMinSure, a recursive function+-- that does not involve Maybes. lookupMin wraps the result of lookupMinSure in+-- a Just. We inline lookupMin so that GHC optimizations can eliminate the Maybe+-- if it is matched on at the call site. lookupMinSure :: a -> Set a -> a lookupMinSure x Tip = x lookupMinSure _ (Bin _ x l _) = lookupMinSure x l --- | /O(log n)/. The minimal element of a set.+-- | \(O(\log n)\). The minimal element of the set. Returns 'Nothing' if the set+-- is empty. -- -- @since 0.5.9 lookupMin :: Set a -> Maybe a lookupMin Tip = Nothing lookupMin (Bin _ x l _) = Just $! lookupMinSure x l+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin] --- | /O(log n)/. The minimal element of a set.+-- | \(O(\log n)\). The minimal element of the set. Calls 'error' if the set is+-- empty. findMin :: Set a -> a findMin t | Just r <- lookupMin t = r@@ -793,27 +783,30 @@ lookupMaxSure x Tip = x lookupMaxSure _ (Bin _ x _ r) = lookupMaxSure x r --- | /O(log n)/. The maximal element of a set.+-- | \(O(\log n)\). The maximal element of the set. Returns 'Nothing' if the set+-- is empty. -- -- @since 0.5.9 lookupMax :: Set a -> Maybe a lookupMax Tip = Nothing lookupMax (Bin _ x _ r) = Just $! lookupMaxSure x r+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin] --- | /O(log n)/. The maximal element of a set.+-- | \(O(\log n)\). The maximal element of the set. Calls 'error' if the set is+-- empty. findMax :: Set a -> a findMax t | Just r <- lookupMax t = r | otherwise = error "Set.findMax: empty set has no maximal element" --- | /O(log n)/. Delete the minimal element. Returns an empty set if the set is empty.+-- | \(O(\log n)\). Delete the minimal element. Returns an empty set if the set is empty. deleteMin :: Set a -> Set a deleteMin (Bin _ _ Tip r) = r deleteMin (Bin _ x l r) = balanceR x (deleteMin l) r deleteMin Tip = Tip --- | /O(log n)/. Delete the maximal element. Returns an empty set if the set is empty.+-- | \(O(\log n)\). Delete the maximal element. Returns an empty set if the set is empty. deleteMax :: Set a -> Set a deleteMax (Bin _ _ l Tip) = l deleteMax (Bin _ x l r) = balanceL x l (deleteMax r)@@ -829,7 +822,7 @@ {-# INLINABLE unions #-} #endif --- | /O(m*log(n\/m + 1)), m <= n/. The union of two sets, preferring the first set when+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). The union of two sets, preferring the first set when -- equal elements are encountered. union :: Ord a => Set a -> Set a -> Set a union t1 Tip = t1@@ -849,7 +842,7 @@ {-------------------------------------------------------------------- Difference --------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. Difference of two sets.+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Difference of two sets. -- -- Return elements of the first set not existing in the second set. --@@ -870,7 +863,7 @@ {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. The intersection of two sets.+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). The intersection of two sets. -- Elements of the result come from the first set, so for example -- -- > import qualified Data.Set as S@@ -897,10 +890,75 @@ {-# INLINABLE intersection #-} #endif +-- | The intersection of a series of sets. Intersections are performed+-- left-to-right.+--+-- @since 0.8+intersections :: Ord a => NonEmpty (Set a) -> Set a+intersections (s0 :| ss)+ | null s0 = empty+ | otherwise = List.foldr go id ss s0+ where+ go s r acc+ | null acc' = empty+ | otherwise = r acc'+ where+ acc' = intersection acc s+{-# INLINABLE intersections #-}++-- | @Set@s form a 'Semigroup' under 'intersection'.+--+-- @since 0.8+newtype Intersection a = Intersection { getIntersection :: Set a }+ deriving (Show, Eq, Ord)++instance (Ord a) => Semigroup (Intersection a) where+ (Intersection a) <> (Intersection b) = Intersection $ intersection a b+ {-# INLINABLE (<>) #-}++ stimes = stimesIdempotent+ {-# INLINABLE stimes #-}++ sconcat =+#ifdef __GLASGOW_HASKELL__+ coerce intersections+#else+ Intersection . intersections . fmap getIntersection+#endif+ {-# INLINABLE sconcat #-}+ {--------------------------------------------------------------------+ Symmetric difference+--------------------------------------------------------------------}++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- The symmetric difference of two sets.+--+-- The result contains elements that appear in exactly one of the two sets.+--+-- @+-- symmetricDifference (fromList [0,2,4,6]) (fromList [0,3,6,9]) == fromList [2,3,4,9]+-- @+--+-- @since 0.8+symmetricDifference :: Ord a => Set a -> Set a -> Set a+symmetricDifference Tip t2 = t2+symmetricDifference t1 Tip = t1+symmetricDifference (Bin _ x l1 r1) t2+ | found = merge l1l2 r1r2+ | otherwise = link x l1l2 r1r2+ where+ !(l2, found, r2) = splitMember x t2+ !l1l2 = symmetricDifference l1 l2+ !r1r2 = symmetricDifference r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE symmetricDifference #-}+#endif++{-------------------------------------------------------------------- Filter and partition --------------------------------------------------------------------}--- | /O(n)/. Filter all elements that satisfy the predicate.+-- | \(O(n)\). Filter all elements that satisfy the predicate. filter :: (a -> Bool) -> Set a -> Set a filter _ Tip = Tip filter p t@(Bin _ x l r)@@ -912,7 +970,7 @@ !l' = filter p l !r' = filter p r --- | /O(n)/. Partition the set into two sets, one with all elements that satisfy+-- | \(O(n)\). Partition the set into two sets, one with all elements that satisfy -- the predicate and one with all elements that don't satisfy the predicate. -- See also 'split'. partition :: (a -> Bool) -> Set a -> (Set a,Set a)@@ -933,27 +991,31 @@ Map ----------------------------------------------------------------------} --- | /O(n*log n)/.+-- | \(O(n \log n)\). -- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. --+-- If `f` is monotonically non-decreasing, this function takes \(O(n)\) time.+-- -- It's worth noting that the size of the result may be smaller if, -- for some @(x,y)@, @x \/= y && f x == f y@ map :: Ord b => (a->b) -> Set a -> Set b-map f = fromList . List.map f . toList+map f t = finishB (foldl' (\b x -> insertB (f x) b) emptyB t) #if __GLASGOW_HASKELL__ {-# INLINABLE map #-} #endif --- | /O(n)/. The---+-- | \(O(n)\). -- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.--- /The precondition is not checked./ -- Semi-formally, we have: -- -- > and [x < y ==> f x < f y | x <- ls, y <- ls] -- > ==> mapMonotonic f s == map f s -- > where ls = toList s+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'map' if the+-- precondition may not hold. mapMonotonic :: (a->b) -> Set a -> Set b mapMonotonic _ Tip = Tip@@ -962,16 +1024,15 @@ {-------------------------------------------------------------------- Fold --------------------------------------------------------------------}--- | /O(n)/. Fold the elements in the set using the given right-associative--- binary operator. This function is an equivalent of 'foldr' and is present--- for compatibility only.+-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator. ----- /Please note that fold will be deprecated in the future and removed./+{-# DEPRECATED fold "Use Data.Set.foldr instead" #-} fold :: (a -> b -> b) -> b -> Set a -> b fold = foldr {-# INLINE fold #-} --- | /O(n)/. Fold the elements in the set using the given right-associative+-- | \(O(n)\). Fold the elements in the set using the given right-associative -- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@. -- -- For example,@@ -984,7 +1045,7 @@ go z' (Bin _ x l r) = go (f x (go z' r)) l {-# INLINE foldr #-} --- | /O(n)/. A strict version of 'foldr'. Each application of the operator is+-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldr' :: (a -> b -> b) -> b -> Set a -> b@@ -994,7 +1055,7 @@ go z' (Bin _ x l r) = go (f x $! go z' r) l {-# INLINE foldr' #-} --- | /O(n)/. Fold the elements in the set using the given left-associative+-- | \(O(n)\). Fold the elements in the set using the given left-associative -- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@. -- -- For example,@@ -1007,7 +1068,7 @@ go z' (Bin _ x l r) = go (f (go z' l) x) r {-# INLINE foldl #-} --- | /O(n)/. A strict version of 'foldl'. Each application of the operator is+-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is -- evaluated before using the result in the next application. This -- function is strict in the starting value. foldl' :: (a -> b -> a) -> a -> Set b -> a@@ -1022,7 +1083,7 @@ {-------------------------------------------------------------------- List variations --------------------------------------------------------------------}--- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order.+-- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order. -- Subject to list fusion. elems :: Set a -> [a] elems = toAscList@@ -1030,7 +1091,8 @@ {-------------------------------------------------------------------- Lists --------------------------------------------------------------------}-#if __GLASGOW_HASKELL__ >= 708++#ifdef __GLASGOW_HASKELL__ -- | @since 0.5.6.2 instance (Ord a) => GHCExts.IsList (Set a) where type Item (Set a) = a@@ -1038,15 +1100,15 @@ toList = toList #endif --- | /O(n)/. Convert the set to a list of elements. Subject to list fusion.+-- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion. toList :: Set a -> [a] toList = toAscList --- | /O(n)/. Convert the set to an ascending list of elements. Subject to list fusion.+-- | \(O(n)\). Convert the set to an ascending list of elements. Subject to list fusion. toAscList :: Set a -> [a] toAscList = foldr (:) [] --- | /O(n)/. Convert the set to a descending list of elements. Subject to list+-- | \(O(n)\). Convert the set to a descending list of elements. Subject to list -- fusion. toDescList :: Set a -> [a] toDescList = foldl (flip (:)) []@@ -1080,51 +1142,13 @@ {-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-} #endif --- | /O(n*log n)/. Create a set from a list of elements.+-- | \(O(n \log n)\). Create a set from a list of elements. ----- If the elements are ordered, a linear-time implementation is used,--- with the performance equal to 'fromDistinctAscList'.---- For some reason, when 'singleton' is used in fromList or in--- create, it is not inlined, so we inline it manually.+-- If the elements are in non-decreasing order, this function takes \(O(n)\)+-- time. fromList :: Ord a => [a] -> Set a-fromList [] = Tip-fromList [x] = Bin 1 x Tip Tip-fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0- | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0- where- not_ordered _ [] = False- not_ordered x (y : _) = x >= y- {-# INLINE not_ordered #-}-- fromList' t0 xs = Foldable.foldl' ins t0 xs- where ins t x = insert x t-- go !_ t [] = t- go _ t [x] = insertMax x t- go s l xs@(x : xss) | not_ordered x xss = fromList' l xs- | otherwise = case create s xss of- (r, ys, []) -> go (s `shiftL` 1) (link x l r) ys- (r, _, ys) -> fromList' (link x l r) ys-- -- The create is returning a triple (tree, xs, ys). Both xs and ys- -- represent not yet processed elements and only one of them can be nonempty.- -- If ys is nonempty, the keys in ys are not ordered with respect to tree- -- and must be inserted using fromList'. Otherwise the keys have been- -- ordered so far.- create !_ [] = (Tip, [], [])- create s xs@(x : xss)- | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss)- else (Bin 1 x Tip Tip, xss, [])- | otherwise = case create (s `shiftR` 1) xs of- res@(_, [], _) -> res- (l, [y], zs) -> (insertMax y l, [], zs)- (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys)- | otherwise -> case create (s `shiftR` 1) yss of- (r, zs, ws) -> (link y l r, zs, ws)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromList #-}-#endif+fromList xs = finishB (Foldable.foldl' (flip insertB) emptyB xs)+{-# INLINE fromList #-} -- INLINE for fusion {-------------------------------------------------------------------- Building trees from ascending/descending lists can be done in linear time.@@ -1132,99 +1156,189 @@ Note that if [xs] is ascending that: fromAscList xs == fromList xs --------------------------------------------------------------------}--- | /O(n)/. Build a set from an ascending list in linear time.--- /The precondition (input list is ascending) is not checked./+-- | \(O(n)\). Build a set from an ascending list in linear time.+--+-- __Warning__: This function should be used only if the elements are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold. fromAscList :: Eq a => [a] -> Set a-fromAscList xs = fromDistinctAscList (combineEq xs)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscList #-}-#endif+fromAscList xs = ascLinkAll (Foldable.foldl' next Nada xs)+ where+ next stk !y = case stk of+ Push x l stk'+ | y == x -> Push y l stk'+ | Tip <- l -> ascLinkTop stk' 1 (singleton x) y+ | otherwise -> Push y Tip stk+ Nada -> Push y Tip stk+{-# INLINE fromAscList #-} -- INLINE for fusion --- | /O(n)/. Build a set from a descending list in linear time.--- /The precondition (input list is descending) is not checked./+-- | \(O(n)\). Build a set from a descending list in linear time. --+-- __Warning__: This function should be used only if the elements are in+-- non-increasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+-- -- @since 0.5.8 fromDescList :: Eq a => [a] -> Set a-fromDescList xs = fromDistinctDescList (combineEq xs)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescList #-}-#endif---- [combineEq xs] combines equal elements with [const] in an ordered list [xs]------ TODO: combineEq allocates an intermediate list. It *should* be better to--- make fromAscListBy and fromDescListBy the fundamental operations, and to--- implement the rest using those.-combineEq :: Eq a => [a] -> [a]-combineEq [] = []-combineEq (x : xs) = combineEq' x xs+fromDescList xs = descLinkAll (Foldable.foldl' next Nada xs) where- combineEq' z [] = [z]- combineEq' z (y:ys)- | z == y = combineEq' z ys- | otherwise = z : combineEq' y ys+ next stk !y = case stk of+ Push x r stk'+ | y == x -> Push y r stk'+ | Tip <- r -> descLinkTop y 1 (singleton x) stk'+ | otherwise -> Push y Tip stk+ Nada -> Push y Tip stk+{-# INLINE fromDescList #-} -- INLINE for fusion --- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.--- /The precondition (input list is strictly ascending) is not checked./+-- | \(O(n)\). Build a set from an ascending list of distinct elements in linear time.+--+-- __Warning__: This function should be used only if the elements are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold. --- For some reason, when 'singleton' is used in fromDistinctAscList or in--- create, it is not inlined, so we inline it manually.+-- See Note [fromDistinctAscList implementation] fromDistinctAscList :: [a] -> Set a-fromDistinctAscList [] = Tip-fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0+fromDistinctAscList xs = ascLinkAll (Foldable.foldl' next Nada xs) where- go !_ t [] = t- go s l (x : xs) = case create s xs of- (r :*: ys) -> let !t' = link x l r- in go (s `shiftL` 1) t' ys+ next :: Stack a -> a -> Stack a+ next (Push x Tip stk) !y = ascLinkTop stk 1 (singleton x) y+ next stk !x = Push x Tip stk+{-# INLINE fromDistinctAscList #-} -- INLINE for fusion - create !_ [] = (Tip :*: [])- create s xs@(x : xs')- | s == 1 = (Bin 1 x Tip Tip :*: xs')- | otherwise = case create (s `shiftR` 1) xs of- res@(_ :*: []) -> res- (l :*: (y:ys)) -> case create (s `shiftR` 1) ys of- (r :*: zs) -> (link y l r :*: zs)+ascLinkTop :: Stack a -> Int -> Set a -> a -> Stack a+ascLinkTop (Push x l@(Bin lsz _ _ _) stk) !rsz r y+ | lsz == rsz = ascLinkTop stk sz (Bin sz x l r) y+ where+ sz = lsz + rsz + 1+ascLinkTop stk !_ r y = Push y r stk --- | /O(n)/. Build a set from a descending list of distinct elements in linear time.--- /The precondition (input list is strictly descending) is not checked./+ascLinkAll :: Stack a -> Set a+ascLinkAll stk = foldl'Stack (\r x l -> link x l r) Tip stk+{-# INLINABLE ascLinkAll #-} --- For some reason, when 'singleton' is used in fromDistinctDescList or in--- create, it is not inlined, so we inline it manually.+-- | \(O(n)\). Build a set from a descending list of distinct elements in linear time. --+-- __Warning__: This function should be used only if the elements are in+-- strictly decreasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+-- -- @since 0.5.8++-- See Note [fromDistinctAscList implementation] fromDistinctDescList :: [a] -> Set a-fromDistinctDescList [] = Tip-fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0+fromDistinctDescList xs = descLinkAll (Foldable.foldl' next Nada xs) where- go !_ t [] = t- go s r (x : xs) = case create s xs of- (l :*: ys) -> let !t' = link x l r- in go (s `shiftL` 1) t' ys+ next :: Stack a -> a -> Stack a+ next (Push y Tip stk) !x = descLinkTop x 1 (singleton y) stk+ next stk !y = Push y Tip stk+{-# INLINE fromDistinctDescList #-} -- INLINE for fusion - create !_ [] = (Tip :*: [])- create s xs@(x : xs')- | s == 1 = (Bin 1 x Tip Tip :*: xs')- | otherwise = case create (s `shiftR` 1) xs of- res@(_ :*: []) -> res- (r :*: (y:ys)) -> case create (s `shiftR` 1) ys of- (l :*: zs) -> (link y l r :*: zs)+descLinkTop :: a -> Int -> Set a -> Stack a -> Stack a+descLinkTop x !lsz l (Push y r@(Bin rsz _ _ _) stk)+ | lsz == rsz = descLinkTop x sz (Bin sz y l r) stk+ where+ sz = lsz + rsz + 1+descLinkTop y !_ r stk = Push y r stk +descLinkAll :: Stack a -> Set a+descLinkAll stk = foldl'Stack (\l x r -> link x l r) Tip stk+{-# INLINABLE descLinkAll #-}++data Stack a = Push !a !(Set a) !(Stack a) | Nada++foldl'Stack :: (b -> a -> Set a -> b) -> b -> Stack a -> b+foldl'Stack f = go+ where+ go !z Nada = z+ go z (Push x t stk) = go (f z x t) stk+{-# INLINE foldl'Stack #-}+ {--------------------------------------------------------------------- Eq converts the set to a list. In a lazy setting, this- actually seems one of the faster methods to compare two trees- and it is certainly the simplest :-)+ Iterator --------------------------------------------------------------------}++-- Note [Iterator]+-- ~~~~~~~~~~~~~~~+-- Iteration, using a Stack as an iterator, is an efficient way to consume a Set+-- one element at a time. Alternately, this may be done by toAscList. toAscList+-- when consumed via List.foldr will rewrite to Set.foldr (thanks to rewrite+-- rules), which is quite efficient. However, sometimes that is not possible,+-- such as in the second arg of '==' or 'compare', where manifesting the list+-- cons cells is unavoidable and makes things slower.+--+-- Concretely, compare on Set Int using toAscList takes ~21% more time compared+-- to using Iterator, on GHC 9.6.3.+--+-- The heart of this implementation is the `iterDown` function. It walks down+-- the left spine of the tree, pushing the value and right child on the stack,+-- until a Tip is reached. The next value is now at the top of the stack. To get+-- to the value after that, `iterDown` is called again with the right child and+-- the remaining stack.++iterDown :: Set a -> Stack a -> Stack a+iterDown (Bin _ x l r) stk = iterDown l (Push x r stk)+iterDown Tip stk = stk++-- Create an iterator from a Set, starting at the smallest element.+iterator :: Set a -> Stack a+iterator s = iterDown s Nada++-- Get the next element and the remaining iterator.+iterNext :: Stack a -> Maybe (StrictPair a (Stack a))+iterNext (Push x r stk) = Just $! x :*: iterDown r stk+iterNext Nada = Nothing+{-# INLINE iterNext #-}++-- Whether there are no more elements in the iterator.+iterNull :: Stack a -> Bool+iterNull (Push _ _ _) = False+iterNull Nada = True++{--------------------------------------------------------------------+ Eq+--------------------------------------------------------------------}+ instance Eq a => Eq (Set a) where- t1 == t2 = (size t1 == size t2) && (toAscList t1 == toAscList t2)+ s1 == s2 = liftEq (==) s1 s2+ {-# INLINABLE (==) #-} +-- | @since 0.5.9+instance Eq1 Set where+ liftEq eq s1 s2 = size s1 == size s2 && sameSizeLiftEq eq s1 s2+ {-# INLINE liftEq #-}++-- Assumes the sets are of equal size to skip the final check.+sameSizeLiftEq :: (a -> b -> Bool) -> Set a -> Set b -> Bool+sameSizeLiftEq eq s1 s2 =+ case runEqM (foldMap f s1) (iterator s2) of e :*: _ -> e+ where+ f x = EqM $ \it -> case iterNext it of+ Nothing -> False :*: it+ Just (y :*: it') -> eq x y :*: it'+{-# INLINE sameSizeLiftEq #-}+ {-------------------------------------------------------------------- Ord --------------------------------------------------------------------} instance Ord a => Ord (Set a) where- compare s1 s2 = compare (toAscList s1) (toAscList s2)+ compare s1 s2 = liftCmp compare s1 s2+ {-# INLINABLE compare #-} +-- | @since 0.5.9+instance Ord1 Set where+ liftCompare = liftCmp+ {-# INLINE liftCompare #-}++liftCmp :: (a -> b -> Ordering) -> Set a -> Set b -> Ordering+liftCmp cmp s1 s2 = case runOrdM (foldMap f s1) (iterator s2) of+ o :*: it -> o <> if iterNull it then EQ else LT+ where+ f x = OrdM $ \it -> case iterNext it of+ Nothing -> GT :*: it+ Just (y :*: it') -> cmp x y :*: it'+{-# INLINE liftCmp #-}+ {-------------------------------------------------------------------- Show --------------------------------------------------------------------}@@ -1232,28 +1346,16 @@ showsPrec p xs = showParen (p > 10) $ showString "fromList " . shows (toList xs) -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.9-instance Eq1 Set where- liftEq eq m n =- size m == size n && liftEq eq (toList m) (toList n)---- | @since 0.5.9-instance Ord1 Set where- liftCompare cmp m n =- liftCompare cmp (toList m) (toList n)---- | @since 0.5.9 instance Show1 Set where liftShowsPrec sp sl d m = showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)-#endif {-------------------------------------------------------------------- Read --------------------------------------------------------------------} instance (Read a, Ord a) => Read (Set a) where-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP xs <- readPrec@@ -1268,12 +1370,6 @@ #endif {--------------------------------------------------------------------- Typeable/Data---------------------------------------------------------------------}--INSTANCE_TYPEABLE1(Set)--{-------------------------------------------------------------------- NFData --------------------------------------------------------------------} @@ -1281,10 +1377,17 @@ rnf Tip = () rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r +-- | @since 0.8+instance NFData1 Set where+ liftRnf rnfx = go+ where+ go Tip = ()+ go (Bin _ y l r) = rnfx y `seq` go l `seq` go r+ {-------------------------------------------------------------------- Split --------------------------------------------------------------------}--- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@+-- | \(O(\log n)\). The expression (@'split' x set@) is a pair @(set1,set2)@ -- where @set1@ comprises the elements of @set@ less than @x@ and @set2@ -- comprises the elements of @set@ greater than @x@. split :: Ord a => a -> Set a -> (Set a,Set a)@@ -1300,7 +1403,7 @@ EQ -> (l :*: r) {-# INLINABLE splitS #-} --- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- | \(O(\log n)\). Performs a 'split' but also returns whether the pivot -- element was found in the original set. splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a) splitMember _ Tip = (Tip, False, Tip)@@ -1321,7 +1424,7 @@ Indexing --------------------------------------------------------------------} --- | /O(log n)/. Return the /index/ of an element, which is its zero-based+-- | \(O(\log n)\). Return the /index/ of an element, which is its zero-based -- index in the sorted sequence of elements. The index is a number from /0/ up -- to, but not including, the 'size' of the set. Calls 'error' when the element -- is not a 'member' of the set.@@ -1347,7 +1450,7 @@ {-# INLINABLE findIndex #-} #endif --- | /O(log n)/. Lookup the /index/ of an element, which is its zero-based index in+-- | \(O(\log n)\). Look up the /index/ of an element, which is its zero-based index in -- the sorted sequence of elements. The index is a number from /0/ up to, but not -- including, the 'size' of the set. --@@ -1372,7 +1475,7 @@ {-# INLINABLE lookupIndex #-} #endif --- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based+-- | \(O(\log n)\). Retrieve an element by its /index/, i.e. by its zero-based -- index in the sorted sequence of elements. If the /index/ is out of range (less -- than zero, greater or equal to 'size' of the set), 'error' is called. --@@ -1392,7 +1495,7 @@ where sizeL = size l --- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in+-- | \(O(\log n)\). Delete the element at /index/, i.e. by its zero-based index in -- the sorted sequence of elements. If the /index/ is out of range (less than zero, -- greater or equal to 'size' of the set), 'error' is called. --@@ -1414,7 +1517,7 @@ where sizeL = size l --- | Take a given number of elements in order, beginning+-- | \(O(\log n)\). Take a given number of elements in order, beginning -- with the smallest ones. -- -- @@@ -1435,7 +1538,7 @@ EQ -> l where sizeL = size l --- | Drop a given number of elements in order, beginning+-- | \(O(\log n)\). Drop a given number of elements in order, beginning -- with the smallest ones. -- -- @@@ -1456,7 +1559,7 @@ EQ -> insertMin x r where sizeL = size l --- | /O(log n)/. Split a set at a particular index.+-- | \(O(\log n)\). Split a set at a particular index. -- -- @ -- splitAt !n !xs = ('take' n xs, 'drop' n xs)@@ -1477,7 +1580,7 @@ EQ -> l :*: insertMin x r where sizeL = size l --- | /O(log n)/. Take while a predicate on the elements holds.+-- | \(O(\log n)\). Take while a predicate on the elements holds. -- The user is responsible for ensuring that for all elements @j@ and @k@ in the set, -- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. --@@ -1494,7 +1597,7 @@ | p x = link x l (takeWhileAntitone p r) | otherwise = takeWhileAntitone p l --- | /O(log n)/. Drop while a predicate on the elements holds.+-- | \(O(\log n)\). Drop while a predicate on the elements holds. -- The user is responsible for ensuring that for all elements @j@ and @k@ in the set, -- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'. --@@ -1511,7 +1614,7 @@ | p x = dropWhileAntitone p r | otherwise = link x (dropWhileAntitone p l) r --- | /O(log n)/. Divide a set at the point where a predicate on the elements stops holding.+-- | \(O(\log n)\). Divide a set at the point where a predicate on the elements stops holding. -- The user is responsible for ensuring that for all elements @j@ and @k@ in the set, -- @j \< k ==\> p j \>= p k@. --@@ -1535,7 +1638,56 @@ | p x = let u :*: v = go p r in link x l u :*: v | otherwise = let u :*: v = go p l in u :*: link x v r +{--------------------------------------------------------------------+ SetBuilder+--------------------------------------------------------------------} +-- Note [SetBuilder]+-- ~~~~~~~~~~~~~~~~~+-- SetBuilder serves as an accumulator for element-by-element construction of+-- a Set. It can be used in folds to construct sets. This plays nicely with list+-- fusion if the structure folded over is a list, as in fromList and friends.+--+-- As long as the elements are in non-decreasing order, insertB accumulates them+-- in a Stack, just as fromDistinctAscList does. On encountering an element out+-- of order, it builds a Set from the Stack and switches to using insert for all+-- future elements. This gives us construction in O(n) if the elements are+-- already sorted. If not, the worst case remains O(n log n).+--+-- More complicated implementations are possible, such as repeatedly+-- accumulating runs of increasing elements in Stacks (not just once) and+-- union-ing with an accumulated Set, but this makes the worst case somewhat+-- slower (~10%).++data SetBuilder a+ = BAsc !(Stack a)+ | BSet !(Set a)++-- Empty builder.+emptyB :: SetBuilder a+emptyB = BAsc Nada++-- Insert an element. Replaces the old element if an equal element already+-- exists.+insertB :: Ord a => a -> SetBuilder a -> SetBuilder a+insertB !y b = case b of+ BAsc stk -> case stk of+ Push x l stk' -> case compare y x of+ LT -> BSet (insert y (ascLinkAll stk))+ EQ -> BAsc (Push y l stk')+ GT -> case l of+ Tip -> BAsc (ascLinkTop stk' 1 (singleton x) y)+ Bin{} -> BAsc (Push y Tip stk)+ Nada -> BAsc (Push y Tip Nada)+ BSet m -> BSet (insert y m)+{-# INLINE insertB #-}++-- Finalize the builder into a Set.+finishB :: SetBuilder a -> Set a+finishB (BAsc stk) = ascLinkAll stk+finishB (BSet s) = s+{-# INLINABLE finishB #-}+ {-------------------------------------------------------------------- Utility functions that maintain the balance properties of the tree. All constructors assume that all values in [l] < [x] and all values@@ -1603,10 +1755,10 @@ glue Tip r = r glue l Tip = l glue l@(Bin sl xl ll lr) r@(Bin sr xr rl rr)- | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in balanceR m l' r- | otherwise = let !(m :*: r') = minViewSure xr rl rr in balanceL m l r'+ | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in Bin (sl+sr) m l' r+ | otherwise = let !(m :*: r') = minViewSure xr rl rr in Bin (sl+sr) m l r' --- | /O(log n)/. Delete and find the minimal element.+-- | \(O(\log n)\). Delete and find the minimal element. -- -- > deleteFindMin set = (findMin set, deleteMin set) @@ -1615,7 +1767,7 @@ | Just r <- minView t = r | otherwise = (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip) --- | /O(log n)/. Delete and find the maximal element.+-- | \(O(\log n)\). Delete and find the maximal element. -- -- > deleteFindMax set = (findMax set, deleteMax set) deleteFindMax :: Set a -> (a,Set a)@@ -1631,7 +1783,7 @@ case go xl ll lr of xm :*: l' -> xm :*: balanceR x l' r --- | /O(log n)/. Retrieves the minimal key of the set, and the set+-- | \(O(\log n)\). Retrieves the minimal key of the set, and the set -- stripped of that element, or 'Nothing' if passed an empty set. minView :: Set a -> Maybe (a, Set a) minView Tip = Nothing@@ -1645,7 +1797,7 @@ case go xr rl rr of xm :*: r' -> xm :*: balanceL x l r' --- | /O(log n)/. Retrieves the maximal key of the set, and the set+-- | \(O(\log n)\). Retrieves the maximal key of the set, and the set -- stripped of that element, or 'Nothing' if passed an empty set. maxView :: Set a -> Maybe (a, Set a) maxView Tip = Nothing@@ -1661,14 +1813,14 @@ [ratio] is the ratio between an outer and inner sibling of the heavier subtree in an unbalanced setting. It determines whether a double or single rotation should be performed- to restore balance. It is correspondes with the inverse+ to restore balance. It is corresponds with the inverse of $\alpha$ in Adam's article. Note that according to the Adam's paper: - [delta] should be larger than 4.646 with a [ratio] of 2. - [delta] should be larger than 3.745 with a [ratio] of 1.534. - But the Adam's paper is errorneous:+ But the Adam's paper is erroneous: - it can be proved that for delta=2 and delta>=5 there does not exist any ratio that would work - delta=4.5 and ratio=2 does not work@@ -1725,10 +1877,29 @@ -- balanceL only checks whether the left subtree is too big, -- balanceR only checks whether the right subtree is too big. +-- Note [Inlining balance]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- Benchmarks show that we benefit from inlining balanceL and balanceR, but+-- we don't want to cause code bloat from inlining these large functions.+-- As a compromise, we inline only one case: that of two Bins already balanced+-- with respect to each other.+--+-- This is the most common case for typical scenarios. For instance, for n+-- inserts there may be O(n log n) calls to balanceL/balanceR but at most O(n)+-- of them actually require rebalancing. So, inlining this common case provides+-- most of the potential benefits of inlining the full function.+ -- balanceL is called when left subtree might have been inserted to or when -- right subtree might have been deleted from. balanceL :: a -> Set a -> Set a -> Set a-balanceL x l r = case r of+balanceL x l r = case (l, r) of+ (Bin ls _ _ _, Bin rs _ _ _)+ | ls <= delta*rs -> Bin (1+ls+rs) x l r+ _ -> balanceL_ x l r+{-# INLINE balanceL #-} -- See Note [Inlining balance]++balanceL_ :: a -> Set a -> Set a -> Set a+balanceL_ x l r = case r of Tip -> case l of Tip -> Bin 1 x Tip Tip (Bin _ _ Tip Tip) -> Bin 2 x l Tip@@ -1741,19 +1912,24 @@ (Bin rs _ _ _) -> case l of Tip -> Bin (1+rs) x Tip r - (Bin ls lx ll lr)- | ls > delta*rs -> case (ll, lr) of+ (Bin ls lx ll lr) -> case (ll, lr) of (Bin lls _ _ _, Bin lrs lrx lrl lrr) | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r) | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)- (_, _) -> error "Failure in Data.Map.balanceL"- | otherwise -> Bin (1+ls+rs) x l r-{-# NOINLINE balanceL #-}+ (_, _) -> error "Failure in Data.Set.balanceL_"+{-# NOINLINE balanceL_ #-} -- balanceR is called when right subtree might have been inserted to or when -- left subtree might have been deleted from. balanceR :: a -> Set a -> Set a -> Set a-balanceR x l r = case l of+balanceR x l r = case (l, r) of+ (Bin ls _ _ _, Bin rs _ _ _)+ | rs <= delta*ls -> Bin (1+ls+rs) x l r+ _ -> balanceR_ x l r+{-# INLINE balanceR #-} -- See Note [Inlining balance]++balanceR_ :: a -> Set a -> Set a -> Set a+balanceR_ x l r = case l of Tip -> case r of Tip -> Bin 1 x Tip Tip (Bin _ _ Tip Tip) -> Bin 2 x Tip r@@ -1766,14 +1942,12 @@ (Bin ls _ _ _) -> case r of Tip -> Bin (1+ls) x l Tip - (Bin rs rx rl rr)- | rs > delta*ls -> case (rl, rr) of+ (Bin rs rx rl rr) -> case (rl, rr) of (Bin rls rlx rll rlr, Bin rrs _ _ _) | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)- (_, _) -> error "Failure in Data.Map.balanceR"- | otherwise -> Bin (1+ls+rs) x l r-{-# NOINLINE balanceR #-}+ (_, _) -> error "Failure in Data.Set.balanceR_"+{-# NOINLINE balanceR_ #-} {-------------------------------------------------------------------- The bin constructor maintains the size of the tree@@ -1788,7 +1962,7 @@ Utilities --------------------------------------------------------------------} --- | /O(1)/. Decompose a set into pieces based on the structure of the underlying+-- | \(O(1)\). Decompose a set into pieces based on the structure of the underlying -- tree. This function is useful for consuming a set in parallel. -- -- No guarantee is made as to the sizes of the pieces; an internal, but@@ -1816,7 +1990,7 @@ {-# INLINE splitRoot #-} --- | Calculate the power set of a set: the set of all its subsets.+-- | \(O(2^n \log n)\). Calculate the power set of a set: the set of all its subsets. -- -- @ -- t ``member`` powerSet s == t ``isSubsetOf`` s@@ -1830,11 +2004,22 @@ -- @ -- -- @since 0.5.11++-- Proof of complexity: step executes n times. At the ith step,+-- "insertMin x `mapMonotonic` pxs" takes O(2^i log i) time since pxs has size+-- 2^i - 1 and we insertMin into its elements which are sets of size <= i.+-- "insertMin (singleton x)" and "`glue` pxs" are cheaper operations that both+-- take O(i) time. Over n steps, we have a total cost of+--+-- O(\sum_{i=1}^{n-1} 2^i log i)+-- = O(log n * \sum_{i=1}^{n-1} 2^i)+-- = O(2^n log n)+ powerSet :: Set a -> Set (Set a) powerSet xs0 = insertMin empty (foldr' step Tip xs0) where step x pxs = insertMin (singleton x) (insertMin x `mapMonotonic` pxs) `glue` pxs --- | /O(m*n)/ (conjectured). Calculate the Cartesian product of two sets.+-- | \(O(nm)\). Calculate the Cartesian product of two sets. -- -- @ -- cartesianProduct xs ys = fromList $ liftA2 (,) (toList xs) (toList ys)@@ -1849,11 +2034,7 @@ -- -- @since 0.5.11 cartesianProduct :: Set a -> Set b -> Set (a, b)--- I don't know for sure if this implementation (slightly modified from one--- that Edward Kmett hacked together) is optimal. TODO: try to prove or--- refute it.------ We could definitely get big-O optimal (O(m * n)) in a rather simple way:+-- The obvious big-O optimal (O(nm)) implementation would be -- -- cartesianProduct _as Tip = Tip -- cartesianProduct as bs = fromDistinctAscList@@ -1862,8 +2043,31 @@ -- Unfortunately, this is much slower in practice, at least when the sets are -- constructed from ascending lists. I tried doing the same thing using a -- known-length (perfect balancing) variant of fromDistinctAscList, but it--- still didn't come close to the performance of Kmett's version in my very--- informal tests.+-- still didn't come close to the performance of the implementation we use in my+-- very informal tests.+--+-- The implementation we use (slightly modified from one that Edward Kmett+-- hacked together) is also optimal but performs better in practice. We map+-- each element a in as to a set made up of (a,b) for every element b in bs,+-- taking O(nm) overall. Then we merge these sets up the tree of as, which takes+-- O(n log m). A brief sketch of proof for the latter:+--+-- Consider all nodes in the tree at the same distance from the root to be at+-- the same "level". The nodes farthest from the root are at level 0, with+-- levels increasing by 1 towards the root. Being a balanced tree, there are+-- O(n/2^i) nodes at level i. At every node at level i, we merge the merged left+-- set, current set, and merged right set into a set of size O(2^i*m) in+-- O(log (2^i*m)) = O(i + log m) time. Over all levels, we do a total work of+--+-- O(\sum_{i=0}^{root_level} n * (i + log m) / 2^i)+-- = O( \sum_{i=0}^{root_level} n * i / 2^i+-- + \sum_{i=0}^{root_level} n * log m / 2^i)+-- = O( n * \sum_{i=0}^{root_level} i/2^i+-- + n * log m * \sum_{i=0}^{root_level} 1/2^i)+-- = O( n * \sum_{i=0}^{inf} i/2^i+-- + n * log m * \sum_{i=0}^{inf} 1/2^i)+--+-- The sum terms converge, and we get O(n log m). -- When the second argument has at most one element, we can be a little -- clever.@@ -1878,21 +2082,15 @@ -- This is used to define cartesianProduct. newtype MergeSet a = MergeSet { getMergeSet :: Set a } -#if (MIN_VERSION_base(4,9,0)) instance Semigroup (MergeSet a) where MergeSet xs <> MergeSet ys = MergeSet (merge xs ys)-#endif instance Monoid (MergeSet a) where mempty = MergeSet empty -#if (MIN_VERSION_base(4,9,0)) mappend = (<>)-#else- mappend (MergeSet xs) (MergeSet ys) = MergeSet (merge xs ys)-#endif --- | Calculate the disjoint union of two sets.+-- | \(O(n+m)\). Calculate the disjoint union of two sets. -- -- @ disjointUnion xs ys = map Left xs ``union`` map Right ys @ --@@ -1910,14 +2108,14 @@ {-------------------------------------------------------------------- Debugging --------------------------------------------------------------------}--- | /O(n)/. Show the tree that implements the set. The tree is shown+-- | \(O(n \log n)\). Show the tree that implements the set. The tree is shown -- in a compressed, hanging format. showTree :: Show a => Set a -> String showTree s = showTreeWith True False s -{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows+{- | \(O(n \log n)\). The expression (@showTreeWith hang wide map@) shows the tree that implements the set. If @hang@ is @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If @wide@ is 'True', an extra wide version is shown.@@ -1992,7 +2190,7 @@ showsBars bars = case bars of [] -> id- _ -> showString (concat (reverse (tail bars))) . showString node+ _ : tl -> showString (concat (reverse tl)) . showString node node :: String node = "+--"@@ -2004,7 +2202,7 @@ {-------------------------------------------------------------------- Assertions --------------------------------------------------------------------}--- | /O(n)/. Test if the internal set structure is valid.+-- | \(O(n)\). Test if the internal set structure is valid. valid :: Ord a => Set a -> Bool valid t = balanced t && ordered t && validsize t@@ -2035,3 +2233,56 @@ Bin sz _ l r -> case (realsize l,realsize r) of (Just n,Just m) | n+m+1 == sz -> Just sz _ -> Nothing++--------------------------------------------------------------------++-- Note [fromDistinctAscList implementation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- fromDistinctAscList is implemented by building up perfectly balanced trees+-- while we consume elements from the list one by one. A stack of+-- (root, perfectly balanced left branch) pairs is maintained, in increasing+-- order of size from top to bottom. The stack reflects the binary+-- representation of the total number of elements in it, with every level having+-- a power of 2 number of elements.+--+-- When we get an element from the list, we check the (root, left branch) at the+-- top of the stack.+-- If the tree there is not empty, we push the element with an empty left child+-- on the stack.+-- If the tree is empty, the root is packed into a singleton tree to act as a+-- right branch for trees higher up the stack. It is linked with left branches+-- in the stack, but only when they have equal size. This preserves the+-- perfectly balanced property. When there is a size mismatch, the tree is+-- too small to link. It is pushed on the stack as a left branch with the new+-- element as root, awaiting a right branch which will make it large enough to+-- be linked further.+--+-- When we are out of elements, we link the (root, left branch)s in the stack+-- top to bottom to get the final tree.+--+-- How long does this take? We do O(1) work per element excluding the links.+-- Over n elements, we build trees with at most n nodes total, and each link is+-- done in O(1) using `Bin`. The final linking of the stack is done in O(log n)+-- using `link` (proof below). The total time is thus O(n).+--+-- Additionally, the implemention is written using foldl' over the input list,+-- which makes it participate as a good consumer in list fusion.+--+-- fromDistinctDescList is implemented similarly, adapted for left and right+-- sides being swapped.+--+-- ~~~+--+-- A `link` operation links trees L and R with a root in+-- O(|log(size(L)) - log(size(R))|). Let's say there are m (root, tree) in the+-- stack, the size of the ith tree being 2^{k_i} - 1. We also know that+-- k_i > k_j for i > j, and n = \sum_{i=1}^m 2^{k_i}. With this information, we+-- can calculate the total time to link everything on the stack:+--+-- O(\sum_{i=2}^m |log(2^{k_i} - 1) - log(\sum_{j=1}^{i-1} 2^{k_j})|)+-- = O(\sum_{i=2}^m log(2^{k_i} - 1) - log(\sum_{j=1}^{i-1} 2^{k_j}))+-- = O(\sum_{i=2}^m log(2^{k_i} - 1) - log(2^{k_{i-1}}))+-- = O(\sum_{i=2}^m k_i - k_{i-1})+-- = O(k_m - k_1)+-- = O(log n)
src/Data/Tree.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE Trustworthy #-} #endif @@ -31,6 +33,7 @@ -- * Trees and Forests Tree(..) , Forest+ , PostOrder(..) -- * Construction , unfoldTree@@ -44,6 +47,10 @@ , foldTree , flatten , levels+ , leaves+ , edges+ , pathsToRoot+ , pathsFromRoot -- * Ascii Drawings , drawTree@@ -51,43 +58,41 @@ ) where -#if MIN_VERSION_base(4,8,0)+import Utils.Containers.Internal.Prelude as Prelude+import Prelude ()+import Data.Bits ((.&.)) import Data.Foldable (toList)-import Control.Applicative (Applicative(..), liftA2)-#else-import Control.Applicative (Applicative(..), liftA2, (<$>))-import Data.Foldable (Foldable(foldMap), toList)-import Data.Monoid (Monoid(..))-import Data.Traversable (Traversable(traverse))-#endif-+import qualified Data.Foldable as Foldable+import Data.List.NonEmpty (NonEmpty(..))+import Data.Traversable (foldMapDefault) import Control.Monad (liftM) import Control.Monad.Fix (MonadFix (..), fix) import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList, ViewL(..), ViewR(..), viewl, viewr)-import Data.Typeable-import Control.DeepSeq (NFData(rnf))+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf)) #ifdef __GLASGOW_HASKELL__ import Data.Data (Data) import GHC.Generics (Generic, Generic1)+import qualified GHC.Exts+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH () #endif import Control.Monad.Zip (MonadZip (..)) -#if MIN_VERSION_base(4,8,0)-import Data.Coerce+#ifdef __GLASGOW_HASKELL__+import Data.Coerce (coerce) #endif--#if MIN_VERSION_base(4,9,0) import Data.Functor.Classes-#endif-#if (!MIN_VERSION_base(4,11,0)) && MIN_VERSION_base(4,9,0)++#if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup (..)) #endif -#if !MIN_VERSION_base(4,8,0)-import Data.Functor ((<$))+#if MIN_VERSION_base(4,18,0)+import qualified Data.Foldable1 as Foldable1 #endif -- | Non-empty, possibly infinite, multi-way trees; also known as /rose trees/.@@ -103,6 +108,7 @@ , Data , Generic -- ^ @since 0.5.8 , Generic1 -- ^ @since 0.5.8+ , Lift -- ^ @since 0.6.6 ) #else deriving (Eq, Ord, Read, Show)@@ -112,7 +118,6 @@ -- reasons. type Forest a = [Tree a] -#if MIN_VERSION_base(4,9,0) -- | @since 0.5.9 instance Eq1 Tree where liftEq eq = leq@@ -147,19 +152,15 @@ (fr, s9) <- liftReadList rd rdl s8 ("}", s10) <- lex s9 pure (Node a fr, s10)-#endif -INSTANCE_TYPEABLE1(Tree)- instance Functor Tree where fmap = fmapTree x <$ Node _ ts = Node x (map (x <$) ts) fmapTree :: (a -> b) -> Tree a -> Tree b fmapTree f (Node x ts) = Node (f x) (map (fmapTree f) ts)-#if MIN_VERSION_base(4,8,0)--- Safe coercions were introduced in 4.7.0, but I am not sure if they played--- well enough with RULES to do what we want.++#ifdef __GLASGOW_HASKELL__ {-# NOINLINE [1] fmapTree #-} {-# RULES "fmapTree/coerce" fmapTree coerce = coerce@@ -170,17 +171,14 @@ pure x = Node x [] Node f tfs <*> tx@(Node x txs) = Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs)-#if MIN_VERSION_base(4,10,0) liftA2 f (Node x txs) ty@(Node y tys) = Node (f x y) (map (f x <$>) tys ++ map (\tx -> liftA2 f tx ty) txs)-#endif Node x txs <* ty@(Node _ tys) = Node x (map (x <$) tys ++ map (<* ty) txs) Node _ txs *> ty@(Node y tys) = Node y (tys ++ map (*> ty) txs) instance Monad Tree where- return = pure Node x ts >>= f = case f x of Node x' ts' -> Node x' (ts' ++ map (>>= f) ts) @@ -194,22 +192,130 @@ = Node a (zipWith (\i _ -> mfixTree ((!! i) . subForest . f)) [0..] children) +-- | Traverses in pre-order. instance Traversable Tree where- traverse f (Node x ts) = liftA2 Node (f x) (traverse (traverse f) ts)+ traverse f = go+ where go (Node x ts) = liftA2 Node (f x) (traverse go ts)+ {-# INLINE traverse #-} +-- | Folds in pre-order.++-- See Note [Implemented Foldable Tree functions] instance Foldable Tree where- foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts+ fold = foldMap id+ {-# INLINABLE fold #-} -#if MIN_VERSION_base(4,8,0)+ foldMap = foldMapDefault+ {-# INLINE foldMap #-}++ foldr f z = \t -> go t z -- Use a lambda to allow inlining with two arguments+ where+ go (Node x ts) = f x . foldr (\t k -> go t . k) id ts+ -- This is equivalent to the following simpler definition, but has been found to optimize+ -- better in benchmarks:+ -- go (Node x ts) z' = f x (foldr go z' ts)+ {-# INLINE foldr #-}++ foldl' f = go+ where go !z (Node x ts) = foldl' go (f z x) ts+ {-# INLINE foldl' #-}++ foldr1 = foldrMap1 id++ foldl1 = foldlMap1 id+ null _ = False {-# INLINE null #-}- toList = flatten- {-# INLINE toList #-}++ elem = any . (==)+ {-# INLINABLE elem #-}++ maximum = foldlMap1' id max+ {-# INLINABLE maximum #-}++ minimum = foldlMap1' id min+ {-# INLINABLE minimum #-}++ sum = foldlMap1' id (+)+ {-# INLINABLE sum #-}++ product = foldlMap1' id (*)+ {-# INLINABLE product #-}++#if MIN_VERSION_base(4,18,0)+-- | Folds in pre-order.+--+-- @since 0.6.7++-- See Note [Implemented Foldable1 Tree functions]+instance Foldable1.Foldable1 Tree where+ foldMap1 f = go+ where+ -- We'd like to write+ --+ -- go (Node x (t : ts)) = f x <> Foldable1.foldMap1 go (t :| ts)+ --+ -- but foldMap1 for NonEmpty isn't very good, so we don't. See+ -- https://github.com/haskell/containers/pull/921#issuecomment-1410398618+ go (Node x []) = f x+ go (Node x (t : ts)) =+ f x <> Foldable1.foldrMap1 go (\t' z -> go t' <> z) (t :| ts)+ {-# INLINE foldMap1 #-}++ foldMap1' f = foldlMap1' f (\z x -> z <> f x)+ {-# INLINE foldMap1' #-}++ toNonEmpty (Node x ts) = x :| concatMap toList ts++ maximum = Foldable.maximum+ {-# INLINABLE maximum #-}++ minimum = Foldable.minimum+ {-# INLINABLE minimum #-}++ foldrMap1 = foldrMap1++ foldlMap1' = foldlMap1'++ foldlMap1 = foldlMap1 #endif +foldrMap1 :: (a -> b) -> (a -> b -> b) -> Tree a -> b+foldrMap1 f g = go+ where+ go (Node x []) = f x+ go (Node x (t:ts)) = g x (foldrMap1NE go (\t' z -> foldr g z t') t ts)+{-# INLINE foldrMap1 #-}++-- This is foldrMap1 for Data.List.NonEmpty, but is not available before+-- base 4.18.+foldrMap1NE :: (a -> b) -> (a -> b -> b) -> a -> [a] -> b+foldrMap1NE f g = go+ where+ go x [] = f x+ go x (x':xs) = g x (go x' xs)+{-# INLINE foldrMap1NE #-}++foldlMap1' :: (a -> b) -> (b -> a -> b) -> Tree a -> b+foldlMap1' f g = -- Use a lambda to allow inlining with two arguments+ \(Node x ts) -> foldl' (foldl' g) (f x) ts+{-# INLINE foldlMap1' #-}++foldlMap1 :: (a -> b) -> (b -> a -> b) -> Tree a -> b+foldlMap1 f g = -- Use a lambda to allow inlining with two arguments+ \(Node x ts) -> foldl (foldl g) (f x) ts+{-# INLINE foldlMap1 #-}+ instance NFData a => NFData (Tree a) where rnf (Node x ts) = rnf x `seq` rnf ts +-- | @since 0.8+instance NFData1 Tree where+ liftRnf rnfx = go+ where+ go (Node x ts) = rnfx x `seq` liftRnf go ts++-- | @since 0.5.10.1 instance MonadZip Tree where mzipWith f (Node a as) (Node b bs) = Node (f a b) (mzipWith (mzipWith f) as bs)@@ -268,6 +374,8 @@ -- | Returns the elements of a tree in pre-order. --+-- @flatten == Data.Foldable.'toList'@+-- -- @ -- -- a@@ -279,8 +387,7 @@ -- -- > flatten (Node 1 [Node 2 [], Node 3 []]) == [1,2,3] flatten :: Tree a -> [a]-flatten t = squish t []- where squish (Node x ts) xs = x:Prelude.foldr squish xs ts+flatten = toList -- | Returns the list of nodes at each level of the tree. --@@ -301,7 +408,7 @@ takeWhile (not . null) $ iterate (concatMap subForest) [t] --- | Fold a tree into a "summary" value in depth-first order.+-- | Fold a tree into a "summary" value. -- -- For each node in the tree, apply @f@ to the @rootLabel@ and the result -- of applying @f@ to each @subForest@.@@ -336,13 +443,14 @@ foldTree f = go where go (Node x ts) = f x (map go ts) --- | Build a (possibly infinite) tree from a seed value in breadth-first order.+-- | Build a (possibly infinite) tree from a seed value. -- -- @unfoldTree f b@ constructs a tree by starting with the tree -- @Node { rootLabel=b, subForest=[] }@ and repeatedly applying @f@ to each -- 'rootLabel' value in the tree's leaves to generate its 'subForest'. ----- For a monadic version see 'unfoldTreeM_BF'.+-- For a monadic version, see 'unfoldTreeM' (depth-first) and+-- 'unfoldTreeM_BF' (breadth-first). -- -- ==== __Examples__ --@@ -373,12 +481,12 @@ unfoldTree :: (b -> (a, [b])) -> b -> Tree a unfoldTree f b = let (a, bs) = f b in Node a (unfoldForest f bs) --- | Build a (possibly infinite) forest from a list of seed values in--- breadth-first order.+-- | Build a (possibly infinite) forest from a list of seed values. -- -- @unfoldForest f seeds@ invokes 'unfoldTree' on each seed value. ----- For a monadic version see 'unfoldForestM_BF'.+-- For a monadic version, see 'unfoldForestM' (depth-first) and+-- 'unfoldForestM_BF' (breadth-first). -- unfoldForest :: (b -> (a, [b])) -> [b] -> [Tree a] unfoldForest f = map (unfoldTree f)@@ -390,7 +498,7 @@ ts <- unfoldForestM f bs return (Node a ts) --- | Monadic forest builder, in depth-first order+-- | Monadic forest builder, in depth-first order. unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m ([Tree a]) unfoldForestM f = Prelude.mapM (unfoldTreeM f) @@ -398,8 +506,9 @@ -- -- See 'unfoldTree' for more info. ----- Implemented using an algorithm adapted from /Breadth-First Numbering: Lessons--- from a Small Exercise in Algorithm Design/, by Chris Okasaki, /ICFP'00/.+-- Implemented using an algorithm adapted from+-- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/,+-- by Chris Okasaki, /ICFP'00/. unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a) unfoldTreeM_BF f b = liftM getElement $ unfoldForestQ f (singleton b) where@@ -407,12 +516,13 @@ x :< _ -> x EmptyL -> error "unfoldTreeM_BF" --- | Monadic forest builder, in breadth-first order+-- | Monadic forest builder, in breadth-first order. -- -- See 'unfoldForest' for more info. ----- Implemented using an algorithm adapted from /Breadth-First Numbering: Lessons--- from a Small Exercise in Algorithm Design/, by Chris Okasaki, /ICFP'00/.+-- Implemented using an algorithm adapted from+-- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/,+-- by Chris Okasaki, /ICFP'00/. unfoldForestM_BF :: Monad m => (b -> m (a, [b])) -> [b] -> m ([Tree a]) unfoldForestM_BF f = liftM toList . unfoldForestQ f . fromList @@ -432,3 +542,345 @@ splitOnto as (_:bs) q = case viewr q of q' :> a -> splitOnto (a:as) bs q' EmptyR -> error "unfoldForestQ"++-- | \(O(n)\). The leaves of the tree in left-to-right order.+--+-- A leaf is a node with no children.+--+-- ==== __Examples__+--+-- >>> :{+-- leaves $+-- Node 1+-- [ Node 2+-- [ Node 4 []+-- , Node 5 []+-- ]+-- , Node 3+-- [ Node 6 []+-- ]+-- ]+-- :}+-- [4,5,6]+-- >>> leaves (Node "root" [])+-- ["root"]+--+-- @since 0.8+leaves :: Tree a -> [a]+#ifdef __GLASGOW_HASKELL__+leaves t = GHC.Exts.build $ \cons nil ->+ let go (Node x []) z = cons x z+ go (Node _ ts) z = foldr go z ts+ in go t nil+{-# INLINE leaves #-} -- Inline for list fusion+#else+leaves t =+ let go (Node x []) z = x:z+ go (Node _ ts) z = foldr go z ts+ in go t []+#endif++-- | \(O(n)\). The edges of the tree as parent-child pairs in pre-order.+--+-- A tree with \(n\) nodes has \(n-1\) edges.+--+-- ==== __Examples__+--+-- >>> :{+-- edges $+-- Node 1+-- [ Node 2+-- [ Node 4 []+-- , Node 5 []+-- ]+-- , Node 3+-- [ Node 6 []+-- ]+-- ]+-- :}+-- [(1,2),(2,4),(2,5),(1,3),(3,6)]+-- >>> edges (Node "root" [])+-- []+--+-- @since 0.8+edges :: Tree a -> [(a, a)]+#ifdef __GLASGOW_HASKELL__+edges (Node x0 ts0) = GHC.Exts.build $ \cons nil ->+ let go p = foldr (\(Node x ts) z -> cons (p, x) (go x z ts))+ in go x0 nil ts0+{-# INLINE edges #-} -- Inline for list fusion+#else+edges (Node x0 ts0) =+ let go p = foldr (\(Node x ts) z -> (p, x) : go x z ts)+ in go x0 [] ts0+#endif++-- | \(O(n)\). Labels on the paths from each node to the root.+--+-- ==== __Examples__+--+-- >>> :{+-- pathsToRoot $+-- Node 1+-- [ Node 2 []+-- , Node 3 []+-- ]+-- :}+-- Node {rootLabel = 1 :| [], subForest = [Node {rootLabel = 2 :| [1], subForest = []},Node {rootLabel = 3 :| [1], subForest = []}]}+-- >>> pathsToRoot (Node "root" [])+-- Node {rootLabel = "root" :| [], subForest = []}+--+-- @since 0.8+pathsToRoot :: Tree a -> Tree (NonEmpty a)+pathsToRoot = go []+ where+ go ps (Node x ts) = Node (x :| ps) (map (go (x:ps)) ts)++-- | Labels on the paths from the root to each node.+--+-- If the path orientation is not important, consider using 'pathsToRoot'+-- instead because it is more efficient.+--+-- ==== __Examples__+--+-- >>> :{+-- pathsFromRoot $+-- Node 1+-- [ Node 2 []+-- , Node 3 []+-- ]+-- :}+-- Node {rootLabel = 1 :| [], subForest = [Node {rootLabel = 1 :| [2], subForest = []},Node {rootLabel = 1 :| [3], subForest = []}]}+-- >>> pathsFromRoot (Node "root" [])+-- Node {rootLabel = "root" :| [], subForest = []}+--+-- @since 0.8++-- See Note [pathsFromRoot implementation]+pathsFromRoot :: Tree a -> Tree (NonEmpty a)+pathsFromRoot (Node x0 ts0) = Node (x0 :| []) (map (go (singletonBQ x0)) ts0)+ where+ go !q (Node x ts) = Node (toNonEmptyBQ q') (map (go q') ts)+ where+ !q' = snocBQ q x++-- An implementation of Chris Okasaki's banker's queue.+-- Invariant: length front >= length rear+data BQ a = BQ+ a -- head+ {-# UNPACK #-} !Word -- length front + length rear+ [a] -- front+ ![a] -- rear (reversed)++singletonBQ :: a -> BQ a+singletonBQ x = BQ x 0 [] []++snocBQ :: BQ a -> a -> BQ a+snocBQ (BQ x0 n f r) x+ | doReverse = BQ x0 (n+1) (f ++ reverse (x:r)) []+ | otherwise = BQ x0 (n+1) f (x:r)+ where+ doReverse = (n+2) .&. (n+1) == 0+ -- We reverse whenever the length of r would exceed that of f.+ -- This happens every time n+2 is a power of 2.++toNonEmptyBQ :: BQ a -> NonEmpty a+toNonEmptyBQ (BQ x0 _ f r) = case r of+ [] -> x0 :| f -- optimization, no need to rebuild f+ _ -> x0 :| (f ++ reverse r)++-- | A newtype over 'Tree' that folds and traverses in post-order.+--+-- @since 0.8+newtype PostOrder a = PostOrder { unPostOrder :: Tree a }+#ifdef __GLASGOW_HASKELL__+ deriving (Eq, Ord, Read, Show, Data, Generic, Generic1, Lift)+#else+ deriving (Eq, Ord, Read, Show)+#endif++instance Functor PostOrder where+#ifdef __GLASGOW_HASKELL__+ fmap = (coerce :: ((a -> b) -> Tree a -> Tree b)+ -> (a -> b) -> PostOrder a -> PostOrder b)+ fmapTree+ (<$) = (coerce :: (b -> Tree a -> Tree b)+ -> b -> PostOrder a -> PostOrder b)+ (<$)+#else+ fmap f = PostOrder . fmapTree f . unPostOrder+ (<$) x = PostOrder . (x <$) . unPostOrder+#endif++-- See Note [Implemented Foldable Tree functions]+instance Foldable PostOrder where+ fold = foldMap id+ {-# INLINABLE fold #-}++ foldMap = foldMapDefault+ {-# INLINE foldMap #-}++ foldr f z0 = \(PostOrder t) -> go t z0 -- Use a lambda to inline with two arguments+ where+ go (Node x ts) z = foldr go (f x z) ts+ {-# INLINE foldr #-}++ foldl' f z0 = \(PostOrder t) -> go z0 t -- Use a lambda to inline with two arguments+ where+ go !z (Node x ts) =+ let !z' = foldl' go z ts+ in f z' x+ {-# INLINE foldl' #-}++ foldr1 = foldrMap1PostOrder id++ foldl1 = foldlMap1PostOrder id++ null _ = False+ {-# INLINE null #-}++ elem = any . (==)+ {-# INLINABLE elem #-}++ maximum = foldlMap1'PostOrder id max+ {-# INLINABLE maximum #-}++ minimum = foldlMap1'PostOrder id min+ {-# INLINABLE minimum #-}++ sum = foldlMap1'PostOrder id (+)+ {-# INLINABLE sum #-}++ product = foldlMap1'PostOrder id (*)+ {-# INLINABLE product #-}++instance Traversable PostOrder where+ traverse f = \(PostOrder t) -> PostOrder <$> go t+ where+ go (Node x ts) = liftA2 (flip Node) (traverse go ts) (f x)+ {-# INLINE traverse #-}++#if MIN_VERSION_base(4,18,0)+-- See Note [Implemented Foldable1 Tree functions]+instance Foldable1.Foldable1 PostOrder where+ foldMap1 f = \(PostOrder t) -> go t -- Use a lambda to inline with one argument+ where+ go (Node x []) = f x+ go (Node x (t:ts)) =+ Foldable1.foldrMap1 go (\t' z' -> go t' <> z') (t :| ts) <> f x+ {-# INLINE foldMap1 #-}++ foldMap1' f = foldlMap1'PostOrder f (\z x -> z <> f x)+ {-# INLINE foldMap1' #-}++ toNonEmpty (PostOrder t0) = go t0 []+ where+ go (Node x []) z = x :| z+ go (Node x (t:ts)) z =+ go t (foldr (\t' z' -> foldr (:) z' (PostOrder t')) (x:z) ts)++ maximum = Foldable.maximum+ {-# INLINABLE maximum #-}++ minimum = Foldable.minimum+ {-# INLINABLE minimum #-}++ foldrMap1 = foldrMap1PostOrder++ foldlMap1' = foldlMap1'PostOrder++ foldlMap1 = foldlMap1PostOrder+#endif++foldrMap1PostOrder :: (a -> b) -> (a -> b -> b) -> PostOrder a -> b+foldrMap1PostOrder f g = \(PostOrder (Node x ts)) ->+ foldr (\t z -> foldr g z (PostOrder t)) (f x) ts+{-# INLINE foldrMap1PostOrder #-}++foldlMap1PostOrder :: (a -> b) -> (b -> a -> b) -> PostOrder a -> b+foldlMap1PostOrder f g = \(PostOrder t) -> go t+ where+ go (Node x []) = f x+ go (Node x (t:ts)) =+ g (foldl (\z t' -> foldl g z (PostOrder t')) (go t) ts) x+{-# INLINE foldlMap1PostOrder #-}++foldlMap1'PostOrder :: (a -> b) -> (b -> a -> b) -> PostOrder a -> b+foldlMap1'PostOrder f g = \(PostOrder t) -> go t+ where+ go (Node x []) = f x+ go (Node x (t:ts)) =+ let !z' = foldl' (\z t' -> foldl' g z (PostOrder t')) (go t) ts+ in g z' x+{-# INLINE foldlMap1'PostOrder #-}++--------------------------------------------------------------------------------++-- Note [Implemented Foldable Tree functions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Implemented:+--+-- foldMap, foldr, foldl': Basic functions.+-- fold, elem: Implemented same as the default definition, but INLINABLE to+-- allow specialization.+-- foldr1, foldl1, null, maximum, minimum: Implemented more efficiently than+-- defaults since trees are non-empty.+-- sum, product: Implemented as strict left folds. Defaults use the lazy foldMap+-- before base 4.15.1.+--+-- Not implemented:+--+-- foldMap', toList, length: Defaults perform well.+-- foldr', foldl: Unlikely to be used.++-- Note [Implemented Foldable1 Tree functions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Implemented:+--+-- foldMap, foldrMap1, foldlMap1': Basic functions+-- foldMap1': Implemented same as the default definition, but INLINABLE to+-- allow specialization.+-- toNonEmpty, foldlMap1: Implemented more efficiently than default.+-- maximum, minimum: Uses Foldable's implementation.+--+-- Not implemented:+--+-- fold1, head: Defaults perform well.+-- foldrMap1': Unlikely to be used.++-- Note [pathsFromRoot implementation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We use Okasaki's banker's queue for pathsFromRoot because it has some+-- desirable properties when the result is consumed lazily.+--+-- 1. Fully evaluating a node's NonEmpty takes O(d) time, where d is+-- the depth of the node. This is optimal.+-- 2. The elements in the NonEmpty are yielded lazily. Note that the worst case+-- time to yield an element is not O(1), i.e. it is only amortized O(1).+-- More than O(1) work is done when the next element requires forcing (++)+-- suspensions or reversing a rear list. For example, yielding the head has+-- to force O(log d) (++) and so takes O(log d) time.+-- 3. It builds up some beneficial sharing. It is not possible to share the+-- results since the lists have different ends, but we can share some+-- intermediate structures. Consider m sibling nodes at depth d. The front+-- list is shared between them in (front ++ rear1), (front ++ rear2), ...+-- (front + rearm). Forcing a prefix of front in one list can take arbitrary+-- amounts of time per element (total bounded by O(d)), but once it is+-- forced, front is memoized and doing the same for any of the siblings will+-- take O(1) per element.+--+-- Alternatives:+--+-- * Implement it like pathsToRoot and reverse the NonEmptys. This does satisfy+-- point 1 above. On 2 there's a trade-off, it costs a full O(d) to access the+-- head and O(1) per element after that. On 3 it compares poorly because there+-- is no sharing. Accessing the heads of m siblings will take O(dm) compared+-- to the current O(d + m).+-- * Use Okasaki's real-time queues. This would guarantee O(1) per element, but+-- has worse constant-factor overall and does not seem worth the trouble.+--+-- GHC base also uses a banker's queue for Data.List.inits. inits is similar+-- in nature to pathsFromRoot since a list is a tree where each node has one or+-- zero children.
src/Utils/Containers/Internal/BitQueue.hs view
@@ -44,23 +44,10 @@ , toListQ ) where -#if !MIN_VERSION_base(4,8,0)-import Data.Word (Word)-#endif import Utils.Containers.Internal.BitUtil (shiftLL, shiftRL, wordSize) import Data.Bits ((.|.), (.&.), testBit)-#if MIN_VERSION_base(4,8,0) import Data.Bits (countTrailingZeros)-#else-import Data.Bits (popCount)-#endif -#if !MIN_VERSION_base(4,8,0)-countTrailingZeros :: Word -> Int-countTrailingZeros x = popCount ((x .&. (-x)) - 1)-{-# INLINE countTrailingZeros #-}-#endif- -- A bit queue builder. We represent a double word using two words -- because we don't currently have access to proper double words. data BitQueueB = BQB {-# UNPACK #-} !Word@@ -109,7 +96,7 @@ lo' = (lo1 `shiftRL` zeros) .|. (hi1 `shiftLL` (wordSize - zeros)) hi' = hi1 `shiftRL` zeros --- Test if the queue is empty, which occurs when theres+-- Test if the queue is empty, which occurs when there's -- nothing left but a guard bit in the least significant -- place. nullQ :: BitQueue -> Bool
src/Utils/Containers/Internal/BitUtil.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} #endif #include "containers.h"@@ -31,79 +29,34 @@ -- closely. module Utils.Containers.Internal.BitUtil- ( bitcount- , highestBitMask- , shiftLL+ ( shiftLL , shiftRL , wordSize+ , iShiftRL ) where -#if !MIN_VERSION_base(4,8,0)-import Data.Bits ((.|.), xor)-#endif-import Data.Bits (popCount, unsafeShiftL, unsafeShiftR-#if MIN_VERSION_base(4,8,0)- , countLeadingZeros-#endif- )-#if MIN_VERSION_base(4,7,0)-import Data.Bits (finiteBitSize)-#else-import Data.Bits (bitSize)-#endif--#if !MIN_VERSION_base (4,8,0)-import Data.Word (Word)+import Data.Bits (unsafeShiftL, unsafeShiftR, finiteBitSize)+#ifdef __GLASGOW_HASKELL__+import GHC.Exts (Int(..), uncheckedIShiftRL#) #endif -{----------------------------------------------------------------------- [bitcount] as posted by David F. Place to haskell-cafe on April 11, 2006,- based on the code on- http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan,- where the following source is given:- Published in 1988, the C Programming Language 2nd Ed. (by Brian W.- Kernighan and Dennis M. Ritchie) mentions this in exercise 2-9. On April- 19, 2006 Don Knuth pointed out to me that this method "was first published- by Peter Wegner in CACM 3 (1960), 322. (Also discovered independently by- Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)"-----------------------------------------------------------------------}--bitcount :: Int -> Word -> Int-bitcount a x = a + popCount x-{-# INLINE bitcount #-}---- The highestBitMask implementation is based on--- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2--- which has been put in the public domain.---- | Return a word where only the highest bit is set.-highestBitMask :: Word -> Word-#if MIN_VERSION_base(4,8,0)-highestBitMask w = shiftLL 1 (wordSize - 1 - countLeadingZeros w)-#else-highestBitMask x1 = let x2 = x1 .|. x1 `shiftRL` 1- x3 = x2 .|. x2 `shiftRL` 2- x4 = x3 .|. x3 `shiftRL` 4- x5 = x4 .|. x4 `shiftRL` 8- x6 = x5 .|. x5 `shiftRL` 16-#if !(defined(__GLASGOW_HASKELL__) && WORD_SIZE_IN_BITS==32)- x7 = x6 .|. x6 `shiftRL` 32- in x7 `xor` (x7 `shiftRL` 1)-#else- in x6 `xor` (x6 `shiftRL` 1)-#endif-#endif-{-# INLINE highestBitMask #-}- -- Right and left logical shifts.+--+-- Precondition for defined behavior: 0 <= shift amount < wordSize shiftRL, shiftLL :: Word -> Int -> Word shiftRL = unsafeShiftR shiftLL = unsafeShiftL {-# INLINE wordSize #-} wordSize :: Int-#if MIN_VERSION_base(4,7,0) wordSize = finiteBitSize (0 :: Word)++-- Right logical shift.+--+-- Precondition for defined behavior: 0 <= shift amount < wordSize+iShiftRL :: Int -> Int -> Int+#ifdef __GLASGOW_HASKELL__+iShiftRL (I# x#) (I# sh#) = I# (uncheckedIShiftRL# x# sh#) #else-wordSize = bitSize (0 :: Word)+iShiftRL x sh = fromIntegral (unsafeShiftR (fromIntegral x :: Word) sh) #endif
− src/Utils/Containers/Internal/Coercions.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}--#include "containers.h"--module Utils.Containers.Internal.Coercions where--#if __GLASGOW_HASKELL__ >= 708-import Data.Coerce-#endif--infixl 8 .#-#if __GLASGOW_HASKELL__ >= 708-(.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c-(.#) f _ = coerce f-#else-(.#) :: (b -> c) -> (a -> b) -> a -> c-(.#) = (.)-#endif-{-# INLINE (.#) #-}--infix 9 .^#---- | Coerce the second argument of a function. Conceptually,--- can be thought of as:------ @--- (f .^# g) x y = f x (g y)--- @------ However it is most useful when coercing the arguments to--- 'foldl':------ @--- foldl f b . fmap g = foldl (f .^# g) b--- @-#if __GLASGOW_HASKELL__ >= 708-(.^#) :: Coercible c b => (a -> c -> d) -> (b -> c) -> (a -> b -> d)-(.^#) f _ = coerce f-#else-(.^#) :: (a -> c -> d) -> (b -> c) -> (a -> b -> d)-(f .^# g) x y = f x (g y)-#endif-{-# INLINE (.^#) #-}
+ src/Utils/Containers/Internal/EqOrdUtil.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}+module Utils.Containers.Internal.EqOrdUtil+ ( EqM(..)+ , OrdM(..)+ ) where++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup(..))+#endif+import Utils.Containers.Internal.StrictPair++newtype EqM a = EqM { runEqM :: a -> StrictPair Bool a }++-- | Composes left-to-right, short-circuits on False+instance Semigroup (EqM a) where+ f <> g = EqM $ \x -> case runEqM f x of+ r@(e :*: x') -> if e then runEqM g x' else r++instance Monoid (EqM a) where+ mempty = EqM (True :*:)+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif++newtype OrdM a = OrdM { runOrdM :: a -> StrictPair Ordering a }++-- | Composes left-to-right, short-circuits on non-EQ+instance Semigroup (OrdM a) where+ f <> g = OrdM $ \x -> case runOrdM f x of+ r@(o :*: x') -> case o of+ EQ -> runOrdM g x'+ _ -> r++instance Monoid (OrdM a) where+ mempty = OrdM (EQ :*:)+#if !MIN_VERSION_base(4,11,0)+ mappend = (<>)+#endif
+ src/Utils/Containers/Internal/Prelude.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+-- | This hideous module lets us avoid dealing with the fact that+-- @liftA2@ and @foldl'@ were not previously exported from the standard prelude.+module Utils.Containers.Internal.Prelude+ ( module Prelude+ , Applicative (..)+ , Foldable (..)+#ifdef __MHS__+ , Traversable(..)+ , any, concatMap+#endif+ )+ where++#ifdef __MHS__+import Prelude hiding (elem, foldr, foldl, foldr1, foldl1, maximum, minimum, product, sum, null, length, mapM, any, concatMap)+import Data.Traversable+import Data.List.NonEmpty(NonEmpty)+import Data.Foldable(any, concatMap)+#else+import Prelude hiding (Applicative(..), Foldable(..))+#endif+import Control.Applicative(Applicative(..))+import Data.Foldable (Foldable(elem, foldMap, foldr, foldl, foldl', foldr1, foldl1, maximum, minimum, product, sum, null, length))
src/Utils/Containers/Internal/PtrEquality.hs view
@@ -6,16 +6,10 @@ {-# OPTIONS_HADDOCK hide #-} -- | Really unsafe pointer equality-module Utils.Containers.Internal.PtrEquality (ptrEq, hetPtrEq) where+module Utils.Containers.Internal.PtrEquality (ptrEq) where #ifdef __GLASGOW_HASKELL__-import GHC.Exts ( reallyUnsafePtrEquality# )-import Unsafe.Coerce ( unsafeCoerce )-#if __GLASGOW_HASKELL__ < 707-import GHC.Exts ( (==#) )-#else-import GHC.Exts ( Int#, isTrue# )-#endif+import GHC.Exts ( isTrue#, reallyUnsafePtrEquality# ) #endif -- | Checks if two pointers are equal. Yes means yes;@@ -23,29 +17,13 @@ -- WHNF before comparison to get moderately reliable results. ptrEq :: a -> a -> Bool --- | Checks if two pointers are equal, without requiring--- them to have the same type. The values should be forced--- to at least WHNF before comparison to get moderately--- reliable results.-hetPtrEq :: a -> b -> Bool- #ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ < 707-ptrEq x y = reallyUnsafePtrEquality# x y ==# 1#-hetPtrEq x y = unsafeCoerce reallyUnsafePtrEquality# x y ==# 1#-#else ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)-hetPtrEq x y = isTrue# (unsafeCoerce (reallyUnsafePtrEquality# :: x -> x -> Int#) x y)-#endif- #else -- Not GHC ptrEq _ _ = False-hetPtrEq _ _ = False #endif {-# INLINE ptrEq #-}-{-# INLINE hetPtrEq #-} infix 4 `ptrEq`-infix 4 `hetPtrEq`
src/Utils/Containers/Internal/State.hs view
@@ -5,14 +5,10 @@ -- | A clone of Control.Monad.State.Strict. module Utils.Containers.Internal.State where -import Prelude hiding (-#if MIN_VERSION_base(4,8,0)- Applicative-#endif- )--import Control.Monad (ap)-import Control.Applicative (Applicative(..), liftA)+import Control.Monad (ap, liftM2)+import Control.Applicative (liftA)+import Utils.Containers.Internal.Prelude+import Prelude () newtype State s a = State {runState :: s -> (s, a)} @@ -20,9 +16,7 @@ fmap = liftA instance Monad (State s) where- {-# INLINE return #-} {-# INLINE (>>=) #-}- return = pure m >>= k = State $ \ s -> case runState m s of (s', x) -> runState (k x) s' @@ -30,6 +24,9 @@ {-# INLINE pure #-} pure x = State $ \ s -> (s, x) (<*>) = ap+ m *> n = State $ \s -> case runState m s of+ (s', _) -> runState n s'+ liftA2 = liftM2 execState :: State s a -> s -> a execState m x = snd (runState m x)
src/Utils/Containers/Internal/StrictMaybe.hs view
@@ -6,10 +6,8 @@ -- | Strict 'Maybe' module Utils.Containers.Internal.StrictMaybe (MaybeS (..), maybeS, toMaybe, toMaybeS) where--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable (..))-import Data.Monoid (Monoid (..))+#ifdef __MHS__+import Data.Foldable #endif data MaybeS a = NothingS | JustS !a
src/Utils/Containers/Internal/StrictPair.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif
− src/Utils/Containers/Internal/TypeError.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleInstances, FlexibleContexts, UndecidableInstances,- KindSignatures, TypeFamilies, CPP #-}--#if !defined(TESTING)-# if __GLASGOW_HASKELL__ >= 710-{-# LANGUAGE Safe #-}-# else-{-# LANGUAGE Trustworthy #-}-#endif-#endif---- | Unsatisfiable constraints for functions being removed.--module Utils.Containers.Internal.TypeError where-import GHC.TypeLits---- | The constraint @Whoops s@ is unsatisfiable for every 'Symbol' @s@.--- Under GHC 8.0 and above, trying to use a function with a @Whoops s@--- constraint will lead to a pretty type error explaining how to fix--- the problem. Under earlier GHC versions, it will produce an extremely--- ugly type error within which the desired message is buried.------ ==== Example------ @--- oldFunction :: Whoops "oldFunction is gone now. Use newFunction."--- => Int -> IntMap a -> IntMap a--- @-class Whoops (a :: Symbol)--#if __GLASGOW_HASKELL__ >= 800-instance TypeError ('Text a) => Whoops a-#endif---- Why don't we just use------ type Whoops a = TypeError ('Text a) ?------ When GHC sees the type signature of oldFunction, it will see that it--- has an unsatisfiable constraint and reject it out of hand.------ It seems possible to hack around that with a type family:------ type family Whoops a where--- Whoops a = TypeError ('Text a)------ but I don't really trust that to work reliably. What we actually--- do is pretty much guaranteed to work. Despite the fact that there--- is a totally polymorphic instance in scope, GHC will refrain from--- reducing the constraint because it knows someone could (theoretically)--- define an overlapping instance of Whoops. It doesn't commit to--- the polymorphic one until it has to, at the call site.