packages feed

containers 0.7 → 0.8.1

raw patch · 46 files changed

Files

changelog.md view
@@ -1,5 +1,415 @@ # Changelog for [`containers` package](http://github.com/haskell/containers) +## 0.8.1  *October 2026*++### Additions++* Add `compareSize` for `IntSet` and `IntMap`. (Soumik Sarkar)+  ([#1135](https://github.com/haskell/containers/pull/1135),+  [#1139](https://github.com/haskell/containers/pull/1139))++* Add `mapMaybe` for `Seq`, `Set` and `IntSet`. (Phil Hazelden)+  ([#1159](https://github.com/haskell/containers/pull/1159))++* Add `fromSetA`, `fromSetMaybe`, and `fromSetMaybeA` for `Map` and `IntMap`.+  (L0neGamer, Soumik Sarkar)+  ([#1163](https://github.com/haskell/containers/pull/1163),+  [#1165](https://github.com/haskell/containers/pull/1165),+  [#1234](https://github.com/haskell/containers/pull/1234))++* Export `Tree` field selectors from `Data.Graph`. (Soumik Sarkar)+  ([#1144](https://github.com/haskell/containers/pull/1144))++* Add `upsert`, `fromListUpsert`, `fromAscListUpsert`, and `fromDescListUpsert`+  for `Map` and `IntMap`. (Soumik Sarkar)+  ([#1145](https://github.com/haskell/containers/pull/1145),+  [#1190](https://github.com/haskell/containers/pull/1190),+  [#1199](https://github.com/haskell/containers/pull/1199))++* Add `pop` for `Map`, `Set`, `IntMap`, `IntSet`. (Soumik Sarkar)+  ([#1152](https://github.com/haskell/containers/pull/1152))++* Add `Data.Sequence.toList`. (Soumik Sarkar)+  ([#1192](https://github.com/haskell/containers/pull/1192))++* Add `fromDescList` for `IntSet` and `IntMap` (Soumik Sarkar)+  ([#1194](https://github.com/haskell/containers/pull/1194))++* Add `takeR`, `dropR` and `splitAtR` for `Seq`. (Phil Crissman)+  (see [#159](https://github.com/haskell/containers/issues/159))+  ([#1222](https://github.com/haskell/containers/pull/1222))++* Add `mapAssocsMonotonic` for `Map`. (Soumik Sarkar)+  ([#1230](https://github.com/haskell/containers/pull/1230))++* Add `Data.Set.Merge`, a merge API for `Set`s. (Soumik Sarkar)+  ([#1169](https://github.com/haskell/containers/pull/1169))++* Add `Data.Map.Merge.Set.Lazy` and `Data.Map.Merge.Set.Strict`, an API to+  merge a `Map` and a `Set` into a `Map`. (Soumik Sarkar)+  ([#1227](https://github.com/haskell/containers/pull/1227))++* Add the `dropMatched` and `whenMissing` merge strategies for `Map` and+  `IntMap`. Add `filterA` for `Set`. (Soumik Sarkar)+  ([#1240](https://github.com/haskell/containers/pull/1240),+  [#1185](https://github.com/haskell/containers/pull/1185))++### Performance improvements++* Improve performance of `Data.IntMap.fromAscList` and+  `Data.IntSet.fromAscList`. (Soumik Sarkar)+  ([#1123](https://github.com/haskell/containers/pull/1123))++* Improve performance of `Data.IntMap.fromList` and `Data.IntSet.fromList`.+  (Soumik Sarkar)+  ([#1129](https://github.com/haskell/containers/pull/1129),+  [#1137](https://github.com/haskell/containers/pull/1137))++* Improved performance for `Data.IntMap.restrictKeys` and+  `Data.IntMap.withoutKeys`. (Soumik Sarkar)+  ([#1131](https://github.com/haskell/containers/pull/1131))++* Minor performance improvements for `IntMap` and `IntSet` by skipping some+  unnecessary checks. (Soumik Sarkar)+  ([#1136](https://github.com/haskell/containers/pull/1136))++* Improve performance of folds over `IntMap` and `IntSet`. (Soumik Sarkar)+  ([#1149](https://github.com/haskell/containers/pull/1149))++* Improve performance of mapping for keys for `IntMap` and `IntSet`.+  (Soumik Sarkar)+  ([#1148](https://github.com/haskell/containers/pull/1148))++* Improve performance of `graphFromEdges`. (Soumik Sarkar)+  ([#1151](https://github.com/haskell/containers/pull/1151))++* Improve performance of `Map`-`Map` and `Set`-`Set` operations.+  (Soumik Sarkar)+  ([#1141](https://github.com/haskell/containers/pull/1141))++* Improve performance of `Set` intersection. (Soumik Sarkar)+  ([#1170](https://github.com/haskell/containers/pull/1170),+  [#1172](https://github.com/haskell/containers/pull/1172))++* Improve performance of `nubOrdOn` and `nubIntOn`. (Soumik Sarkar)+  ([#1206](https://github.com/haskell/containers/pull/1206),+  [#1228](https://github.com/haskell/containers/pull/1228),+  [#1229](https://github.com/haskell/containers/pull/1229))++* Use a different strategy for `Data.Set.alterF`, improving performance in+  typical scenarios. (Soumik Sarkar)+  ([#1215](https://github.com/haskell/containers/pull/1215))++* Reduce allocations when using `Data.Map.alterF`. (Soumik Sarkar)+  ([#1219](https://github.com/haskell/containers/pull/1219))++* Improve performance of `Data.Tree`'s `leaves`, `edges`, and `foldr` for+  `PostOrder`. (Soumik Sarkar)+  ([#1245](https://github.com/haskell/containers/pull/1245))++* Allow specialization of `Data.Tree`'s `unfoldTreeM`, `unfoldForestM`,+  `unfoldTreeM_BF`, and `unfoldForestM_BF`. (Soumik Sarkar)+  ([#1257](https://github.com/haskell/containers/pull/1257))++* Improve performance of `Data.Tree.PostOrder`'s `foldl`, `foldr'`, `foldlMap1`,+  `foldrMap1'`. (Soumik Sarkar)+  ([#1259](https://github.com/haskell/containers/pull/1259))++### Documentation++* Update contributing instructions. (Soumik Sarkar)+  ([#1125](https://github.com/haskell/containers/pull/1125),+  [#1150](https://github.com/haskell/containers/pull/1150),+  [#1225](https://github.com/haskell/containers/pull/1225))++* Add and improve documentation (Jonathan Knowles, Soumik Sarkar, Tom Smeding,+  Alexey Kuleshevich, RikuMinamiyama, Steve Shuck)+  ([#1127](https://github.com/haskell/containers/pull/1127),+  [#1138](https://github.com/haskell/containers/pull/1138),+  [#1140](https://github.com/haskell/containers/pull/1140),+  [#1143](https://github.com/haskell/containers/pull/1143),+  [#1158](https://github.com/haskell/containers/pull/1158),+  [#1164](https://github.com/haskell/containers/pull/1164),+  [#1161](https://github.com/haskell/containers/pull/1161),+  [#1168](https://github.com/haskell/containers/pull/1168),+  [#1179](https://github.com/haskell/containers/pull/1179),+  [#1189](https://github.com/haskell/containers/pull/1189),+  [#1204](https://github.com/haskell/containers/pull/1204),+  [#1218](https://github.com/haskell/containers/pull/1218),+  [#1216](https://github.com/haskell/containers/pull/1216),+  [#1231](https://github.com/haskell/containers/pull/1231),+  [#1235](https://github.com/haskell/containers/pull/1235))++### Miscellaneous/internal++* Fix bounds for `deepseq`. (Soumik Sarkar)+  ([#1119](https://github.com/haskell/containers/pull/1119))++* Remove redundant `mappend` definitions in preparation for+  [CLC #328](https://github.com/haskell/core-libraries-committee/issues/328).+  (Soumik Sarkar)+  ([#1142](https://github.com/haskell/containers/pull/1142))++* CI maintenance and improvements. (Soumik Sarkar, Lennart Augustsson)+  ([#1147](https://github.com/haskell/containers/pull/1147),+  [#1173](https://github.com/haskell/containers/pull/1173),+  [#1177](https://github.com/haskell/containers/pull/1177),+  [#1183](https://github.com/haskell/containers/pull/1183),+  [#1180](https://github.com/haskell/containers/pull/1180),+  [#1196](https://github.com/haskell/containers/pull/1196),+  [#1207](https://github.com/haskell/containers/pull/1207),+  [#1224](https://github.com/haskell/containers/pull/1224),+  [#1236](https://github.com/haskell/containers/pull/1236),+  [#1249](https://github.com/haskell/containers/pull/1249))++* Miscellaneous internal improvements. (Soumik Sarkar, Simon Hengel, konsumlamm)+  ([#1126](https://github.com/haskell/containers/pull/1126),+  [#1167](https://github.com/haskell/containers/pull/1167),+  [#1175](https://github.com/haskell/containers/pull/1175),+  [#1211](https://github.com/haskell/containers/pull/1211),+  [#1210](https://github.com/haskell/containers/pull/1210),+  [#1212](https://github.com/haskell/containers/pull/1212),+  [#1213](https://github.com/haskell/containers/pull/1213),+  [#1217](https://github.com/haskell/containers/pull/1217),+  [#1223](https://github.com/haskell/containers/pull/1223),+  [#1246](https://github.com/haskell/containers/pull/1246),+  [#970](https://github.com/haskell/containers/pull/970))++* Additional exports from `Data.Set.Internal`. (Frank Staals)+  ([#1178](https://github.com/haskell/containers/pull/1178))++* Test and benchmark improvements. (Soumik Sarkar, Alexandre Esteves)+  ([#1181](https://github.com/haskell/containers/pull/1181),+  [#1182](https://github.com/haskell/containers/pull/1182),+  [#1188](https://github.com/haskell/containers/pull/1188),+  [#1191](https://github.com/haskell/containers/pull/1191),+  [#1198](https://github.com/haskell/containers/pull/1198),+  [#1197](https://github.com/haskell/containers/pull/1197),+  [#1203](https://github.com/haskell/containers/pull/1203),+  [#1254](https://github.com/haskell/containers/pull/1254),+  [#1255](https://github.com/haskell/containers/pull/1255))++* Use template-haskell-lift for GHC>=9.14 (Teo Camarasu)+  ([#1162](https://github.com/haskell/containers/pull/1162))++* Drop redundant Applicative constraints. (Soumik Sarkar)+  ([#1193](https://github.com/haskell/containers/pull/1193))++* Drop symlinks to make development easier on Windows. (AndreasPK)+  ([#886](https://github.com/haskell/containers/pull/886))++* Expose unfoldings of some functions to make it possible to force-inline them.+  (Soumik Sarkar)+  ([#1252](https://github.com/haskell/containers/pull/1252))++## 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@@ -10,14 +420,21 @@   * `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)+  tomjaguarpaw, Alice Rixte, Tom Smeding)  ### Other/internal @@ -26,6 +443,9 @@  * 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@@ -76,17 +496,41 @@  ## 0.6.6 -* Drop support for GHC versions before 8.0.2.+### 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.+  duplication. (David Feuer) -### New instances+* Migrate from test-framework to tasty. (Bodigrim) -* 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`).+* 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@@ -310,13 +754,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)   ```@@ -390,7 +834,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.) @@ -445,7 +889,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@@ -495,7 +939,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.7-license: BSD3+version: 0.8.1+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,25 +22,35 @@     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 ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 ||-      ==9.4.5 || ==9.6.2 || ==9.8.1+      ==9.4.8 || ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.4 || ==9.14.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.10 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.6, template-haskell+    build-depends:+        base >= 4.10 && < 5+      , array >= 0.5.2.0+      , deepseq >= 1.4.3.0 && < 1.6+    -- template-haskell-lift was added as a boot library in GHC-9.14+    -- once we no longer wish to backport releases to older major releases,+    -- this conditional can be dropped+    if impl(ghc >= 9.14)+       build-depends: template-haskell-lift >= 0.1 && <0.2+    elif 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 @@ -53,6 +65,7 @@         Data.IntMap.Merge.Lazy         Data.IntMap.Merge.Strict         Data.IntSet.Internal+        Data.IntSet.Internal.IntTreeCommons         Data.IntSet         Data.Map         Data.Map.Lazy@@ -60,29 +73,27 @@         Data.Map.Strict.Internal         Data.Map.Strict         Data.Map.Merge.Strict+        Data.Map.Merge.Set.Internal+        Data.Map.Merge.Set.Lazy+        Data.Map.Merge.Set.Strict         Data.Map.Internal         Data.Map.Internal.Debug         Data.Set.Internal+        Data.Set.Merge         Data.Set         Data.Graph         Data.Sequence         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.Strict         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      include-dirs: include
include/containers.h view
@@ -6,13 +6,13 @@ #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 -#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) #define DEFINE_PATTERN_SYNONYMS 1 #endif
src/Data/Containers/ListUtils.hs view
@@ -33,7 +33,7 @@ import qualified Data.IntSet as IntSet import Data.IntSet (IntSet) #ifdef __GLASGOW_HASKELL__-import GHC.Exts ( build )+import GHC.Exts (build, oneShot) #endif  -- *** Ord-based nubbing ***@@ -72,9 +72,8 @@ -- -- @since 0.6.0.1 nubOrdOn :: Ord b => (a -> b) -> [a] -> [a]--- For some reason we need to write an explicit lambda here to allow this--- to inline when only applied to a function.-nubOrdOn f = \xs -> nubOrdOnExcluding f Set.empty xs+nubOrdOn f =  -- Inline with 1 arg+  \xs -> nubOrdOnExcluding f Set.empty xs {-# INLINE nubOrdOn #-}  -- Splitting nubOrdOn like this means that we don't have to worry about@@ -82,12 +81,17 @@ nubOrdOnExcluding :: Ord b => (a -> b) -> Set b -> [a] -> [a] nubOrdOnExcluding f = go   where-    go _ [] = []-    go s (x:xs)-      | fx `Set.member` s = go s xs-      | otherwise = x : go (Set.insert fx s) xs+    go !_ [] = []+    go !s (x:xs) = case tryInsertSet fx s of+      Nothing -> go s xs+      Just !s' -> -- See Note [Eager set insertions]+        x : go s' xs       where !fx = f x +tryInsertSet :: Ord a => a -> Set a -> Maybe (Set a)+tryInsertSet = Set.alterF (\found -> if found then Nothing else Just True)+{-# INLINE tryInsertSet #-}+ #ifdef __GLASGOW_HASKELL__ -- We want this inlinable to specialize to the necessary Ord instance. {-# INLINABLE [1] nubOrdOnExcluding #-}@@ -110,14 +114,17 @@            -> (Set b -> r)            -> Set b            -> r-nubOrdOnFB f c x r s-  | fx `Set.member` s = r s-  | otherwise = x `c` r (Set.insert fx s)-  where !fx = f x-{-# INLINABLE [0] nubOrdOnFB #-}+nubOrdOnFB f c =  -- Inline with 2 args+  \x r -> oneShot (\ !s ->+    let !y = f x+    in case tryInsertSet y s of+         Nothing -> r s+         Just !s' -> -- See Note [Eager set insertions]+           x `c` r s')+{-# INLINE [0] nubOrdOnFB #-}  constNubOn :: a -> b -> a-constNubOn x _ = x+constNubOn x !_ = x {-# INLINE [0] constNubOn #-} #endif @@ -153,9 +160,8 @@ -- -- @since 0.6.0.1 nubIntOn :: (a -> Int) -> [a] -> [a]--- For some reason we need to write an explicit lambda here to allow this--- to inline when only applied to a function.-nubIntOn f = \xs -> nubIntOnExcluding f IntSet.empty xs+nubIntOn f =  -- Inline with 1 arg+  \xs -> nubIntOnExcluding f IntSet.empty xs {-# INLINE nubIntOn #-}  -- Splitting nubIntOn like this means that we don't have to worry about@@ -163,10 +169,12 @@ nubIntOnExcluding :: (a -> Int) -> IntSet -> [a] -> [a] nubIntOnExcluding f = go   where-    go _ [] = []-    go s (x:xs)+    go !_ [] = []+    go !s (x:xs)       | fx `IntSet.member` s = go s xs-      | otherwise = x : go (IntSet.insert fx s) xs+      | otherwise =+          let !s' = IntSet.insert fx s -- See Note [Eager set insertions]+          in x : go s' xs       where !fx = f x  #ifdef __GLASGOW_HASKELL__@@ -189,9 +197,25 @@            -> (IntSet -> r)            -> IntSet            -> r-nubIntOnFB f c x r s-  | fx `IntSet.member` s = r s-  | otherwise = x `c` r (IntSet.insert fx s)-  where !fx = f x-{-# INLINABLE [0] nubIntOnFB #-}+nubIntOnFB f c =  -- Inline with 2 args+  \x r -> oneShot (\ !s ->+    let !y = f x+    in if y `IntSet.member` s+       then r s+       else let !s' = IntSet.insert y s -- See Note [Eager set insertions]+            in x `c` r s')+{-# INLINE [0] nubIntOnFB #-} #endif++-- Note [Eager set insertions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- In nubOrd and nubInt we insert new elements into the set eagerly. This means+-- that we perform a bit of work before we yield the current element which is+-- not strictly necessary.+--+-- The lazier option would be to create a thunk for the new set, which would get+-- forced by the membership check in the next step. However, a thunk has a small+-- overhead, and the small costs of thunks at every step adds up to a noticeable+-- amount of time and allocations overall. So, we avoid this and perform the+-- insertions eagerly instead.
src/Data/Graph.hs view
@@ -1,18 +1,23 @@ {-# LANGUAGE CPP #-}+#include "containers.h" {-# LANGUAGE BangPatterns #-} #if __GLASGOW_HASKELL__-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-}-{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Safe #-} {-# LANGUAGE TemplateHaskellQuotes #-}+#if !MIN_VERSION_array(0,5,7)+{-# LANGUAGE Trustworthy #-}+#endif+#endif+#ifdef DEFINE_PATTERN_SYNONYMS+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} #endif--#include "containers.h"+#ifdef USE_ST_MONAD+{-# LANGUAGE RankNTypes #-}+#endif  ----------------------------------------------------------------------------- -- |@@ -36,8 +41,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>. -- ----------------------------------------------------------------------------- @@ -78,7 +86,7 @@      -- * Strongly Connected Components     , SCC(..-#ifdef __GLASGOW_HASKELL__+#ifdef DEFINE_PATTERN_SYNONYMS       , CyclicSCC #endif       )@@ -89,10 +97,12 @@      -- ** Conversion     , flattenSCC+    , flattenSCC1     , flattenSCCs      -- * Trees-    , module Data.Tree+    , Tree(..)+    , Forest      ) where @@ -100,25 +110,25 @@ import Prelude () #if USE_ST_MONAD import Control.Monad.ST-import Data.Array.ST.Safe (newArray, readArray, writeArray)+import Data.Array.ST (newArray, readArray, writeArray) # if USE_UNBOXED_ARRAYS-import Data.Array.ST.Safe (STUArray)+import Data.Array.ST (STUArray) # else-import Data.Array.ST.Safe (STArray)+import Data.Array.ST (STArray) # endif #else import Data.IntSet (IntSet) import qualified Data.IntSet as Set #endif-import Data.Tree (Tree(Node), Forest)+import Data.Tree (Tree(..), Forest)+import qualified Data.Tree as Tree  -- std interfaces 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 Data.Maybe+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf)) import Data.Array #if USE_UNBOXED_ARRAYS import qualified Data.Array.Unboxed as UA@@ -136,9 +146,13 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Generics (Generic, Generic1) import Data.Data (Data)+#  if __GLASGOW_HASKELL__ >= 914+import Language.Haskell.TH.Lift (Lift)+#  else import Language.Haskell.TH.Syntax (Lift(..)) -- See Note [ Template Haskell Dependencies ] import Language.Haskell.TH ()+#  endif #endif  -- Make sure we don't use Integer by mistake.@@ -157,12 +171,13 @@   | NECyclicSCC {-# UNPACK #-} !(NonEmpty vertex)   -- ^ A maximal set of mutually reachable vertices.   ---  -- @since 0.7.0+  -- @since 0.7   deriving ( Eq   -- ^ @since 0.5.9            , Show -- ^ @since 0.5.9            , Read -- ^ @since 0.5.9            ) +#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@@ -170,6 +185,7 @@   CyclicSCC (x : xs) = NECyclicSCC (x :| xs)  {-# COMPLETE AcyclicSCC, CyclicSCC #-}+#endif  #ifdef __GLASGOW_HASKELL__ -- | @since 0.5.9@@ -182,7 +198,7 @@ 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)+#if __GLASGOW_HASKELL__ > 808 -- | @since 0.6.6 deriving instance Lift vertex => Lift (SCC vertex) #else@@ -206,19 +222,26 @@ instance Read1 SCC where   liftReadsPrec rp rl = readsData $     readsUnaryWith rp "AcyclicSCC" AcyclicSCC <>-    readsUnaryWith (liftReadsPrec rp rl) "NECyclicSCC" NECyclicSCC <>-    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 (NECyclicSCC vs) = foldr c n vs +  toList = flattenSCC+ #if MIN_VERSION_base(4,18,0)--- | @since 0.7.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 @@ -234,6 +257,11 @@     rnf (AcyclicSCC v) = rnf v     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)@@ -246,10 +274,23 @@ 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 (NECyclicSCC vs) = NE.toList vs+flattenSCC (NECyclicSCC (v :| vs)) = v : vs+-- Note: Best to avoid NE.toList, it is too lazy. +-- | 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. --@@ -488,23 +529,30 @@     max_v           = length edges0 - 1     bounds0         = (0,max_v) :: (Vertex, Vertex)     sorted_edges    = L.sortBy lt edges0-    edges1          = zipWith (,) [0..] sorted_edges -    graph           = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_,    _, ks) <- edges1]-    key_map         = array bounds0 [(,) v k                       | (,) v (_,    k, _ ) <- edges1]-    vertex_map      = array bounds0 edges1+    graph = listArray bounds0 [keysToVertices ks | (_, _, ks) <- sorted_edges]+    key_map = listArray bounds0 [k | (_, k, _) <- sorted_edges]+    vertex_map = listArray bounds0 sorted_edges      (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 -    -- key_vertex :: key -> Maybe Vertex-    --  returns Nothing for non-interesting vertices-    key_vertex k   = findVertex 0 max_v+    keysToVertices = foldr f []+      where+        f k vs =+          let v = keyVertexGo k+          in if v < 0 then vs else v:vs++    key_vertex k =+      let v = keyVertexGo k+      in if v < 0 then Nothing else Just v++    -- Binary search. Returns -1 when not found.+    keyVertexGo k = findVertex 0 max_v                    where-                     findVertex a b | a > b-                              = Nothing+                     findVertex a b | a > b = -1                      findVertex a b = case compare k (key_map ! mid) of                                    LT -> findVertex a (mid-1)-                                   EQ -> Just mid+                                   EQ -> mid                                    GT -> findVertex (mid+1) b                               where                                 mid = a + (b - a) `div` 2@@ -529,9 +577,8 @@ -- bundling together the functions generate, prune, and chop for efficiency -- reasons. dfs :: Graph -> [Vertex] -> [Tree Vertex]-dfs g vs0 = run (bounds g) $ go vs0-  where-    go :: [Vertex] -> SetM s [Tree Vertex]+dfs !g vs0 = run (bounds g) $ \contains include ->+  let     go [] = pure []     go (v:vs) = do       visited <- contains v@@ -542,74 +589,54 @@         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 */ @@ -623,15 +650,6 @@ -- Algorithm 1: depth first search numbering ------------------------------------------------------------ -preorder' :: Tree a -> [a] -> [a]-preorder' (Node a ts) = (a :) . preorderF' ts--preorderF' :: [Tree a] -> [a] -> [a]-preorderF' ts = foldr (.) id $ map preorder' ts--preorderF :: [Tree a] -> [a]-preorderF ts = preorderF' ts []- tabulate        :: Bounds -> [Vertex] -> UArray Vertex Int tabulate bnds vs = UA.array bnds (zipWith (flip (,)) [1..] vs) -- Why zipWith (flip (,)) instead of just using zip with the@@ -640,21 +658,12 @@ -- list argument.  preArr          :: Bounds -> [Tree Vertex] -> UArray Vertex Int-preArr bnds      = tabulate bnds . preorderF+preArr bnds      = tabulate bnds . concatMap Tree.flatten  ------------------------------------------------------------ -- Algorithm 2: topological sorting ------------------------------------------------------------ -postorder :: Tree a -> [a] -> [a]-postorder (Node a ts) = postorderF ts . (a :)--postorderF   :: [Tree a] -> [a] -> [a]-postorderF ts = foldr (.) id $ map postorder ts--postOrd :: Graph -> [Vertex]-postOrd g = postorderF (dff g) []- -- | \(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.@@ -662,16 +671,22 @@ -- 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+topSort :: Graph -> [Vertex]+topSort = reversePostOrder' . dff +-- Generates the result list at once. This is more efficient that being lazy if+-- we will consume the full result anyway.+reversePostOrder' :: [Tree a] -> [a]+reversePostOrder' =+  F.foldl' (\xs t -> F.foldl' (flip (:)) xs (Tree.PostOrder t)) []+ -- | \(O(V+E)\). Reverse ordering of `topSort`. -- -- See note in 'topSort'. -- -- @since 0.6.4 reverseTopSort :: Graph -> [Vertex]-reverseTopSort = postOrd+reverseTopSort = concatMap (F.toList . Tree.PostOrder) . dff  ------------------------------------------------------------ -- Algorithm 3: connected components@@ -697,8 +712,8 @@ -- >   == [Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []}]}]} -- >      ,Node {rootLabel = 3, subForest = []}] -scc  :: Graph -> [Tree Vertex]-scc g = dfs g (reverse (postOrd (transposeG g)))+scc :: Graph -> [Tree Vertex]+scc g = dfs g (reversePostOrder' (dff (transposeG g)))  ------------------------------------------------------------ -- Algorithm 5: Classifying edges@@ -740,7 +755,7 @@ -- -- > reachable (buildG (0,2) [(0,1), (1,2)]) 0 == [0,1,2] reachable :: Graph -> Vertex -> [Vertex]-reachable g v = preorderF (dfs g [v])+reachable g v = concatMap Tree.flatten (dfs g [v])  -- | \(O(V+E)\). Returns @True@ if the second vertex reachable from the first. --
src/Data/IntMap.hs view
@@ -1,15 +1,8 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif #ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE Safe #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.IntMap@@ -19,81 +12,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,3669 +1,4549 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# 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.------ = 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--    , 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--    -- * 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--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))-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 Data.IntSet.Internal (Key)-import qualified Data.IntSet.Internal as IntSet-import Utils.Containers.Internal.BitUtil-import Utils.Containers.Internal.StrictPair--#ifdef __GLASGOW_HASKELL__-import Data.Coerce-import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),-                  DataType, mkDataType, gcast1)-import GHC.Exts (build)-import qualified GHC.Exts as GHCExts-import Text.Read-import Language.Haskell.TH.Syntax (Lift)--- See Note [ Template Haskell Dependencies ]-import Language.Haskell.TH ()-#endif-import qualified Control.Category as Category----- 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---- | @since 0.6.6-deriving instance Lift a => Lift (IntMap a)--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-    mappend = (<>)---- | @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 _ 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' #-}-  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 #-}---- | 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) | 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) | 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(\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 _ 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(\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 _ 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(\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 _ 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(\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 _ 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"------ 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 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")])------ 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 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 (Bin p m l r)-  | 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 (Bin p m l r)-  | 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 (Bin p m l r)-  | 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(\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(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")]------ 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.------ > 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(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-  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 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' &#8211;--- 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' &#8211;--- 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-"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"------ 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@.--- /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(\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 m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then bin p m (go predicate l) r-        else go predicate r-    _ -> go predicate t-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = bin p m 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 m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then go predicate l-        else bin p m l (go predicate r)-    _ -> go predicate t-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = go predicate' r-      | otherwise         = bin p m (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 m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then-          case go predicate l of-            (lt :*: gt) ->-              let !lt' = bin p m lt r-              in (lt', gt)-        else-          case go predicate r of-            (lt :*: gt) ->-              let !gt' = bin p m l gt-              in (lt, gt')-    _ -> case go predicate t of-          (lt :*: gt) -> (lt, gt)-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt-      | otherwise         = case go predicate' l of (lt :*: gt) -> lt :*: bin p m 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 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 p m l r-      | m < 0 ->-        if k >= 0 -- handle negative numbers.-        then-          case go k l of-            (lt :*: gt) ->-              let !lt' = bin p m lt r-              in (lt', gt)-        else-          case go k r of-            (lt :*: gt) ->-              let !gt' = bin p m l gt-              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 :*: bin p m gt r-      | otherwise = case go k' r of (lt :*: gt) -> bin p m 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 m l r-        | m < 0 ->-          if k >= 0 -- handle negative numbers.-          then mapLT (flip (bin p m) r) (go k l)-          else mapGT (bin p m 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 (flip (bin p m) r) (go k' l)-      | otherwise = mapLT (bin p m 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)\). 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---------------------------------------------------------------------}--#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.------ > 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")]------ 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.--- /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")]------ 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.--- /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.------ 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-  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---- | @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--{---------------------------------------------------------------------  Ord---------------------------------------------------------------------}--instance Ord a => Ord (IntMap a) where-    compare m1 m2 = compare (toList m1) (toList m2)---- | @since 0.5.9-instance Ord1 IntMap where-  liftCompare cmp m n =-    liftCompare (liftCompare cmp) (toList m) (toList n)--{---------------------------------------------------------------------  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)---- | @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-#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---- | @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 :: 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 \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 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-      _ : tl -> showString (concat (reverse tl)) . showString node--node :: String-node = "+--"--withBar, withEmpty :: [String] -> [String]-withBar bars   = "|  ":bars-withEmpty bars = "   ":bars+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++-----------------------------------------------------------------------------+-- |+-- 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+    , compareSize+    , member+    , notMember+    , lookup+    , findWithDefault+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , disjoint++    -- * Construction+    , empty+    , singleton+    , fromSet+    , fromSetA+    , fromSetMaybe+    , fromSetMaybeA++    -- ** Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- ** Delete\/Update+    , delete+    , pop+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , upsert+    , 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+    , dropMatched+    , 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+    , whenMissing++    -- ** 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++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey+    , fromListUpsert++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromAscListUpsert+    , fromDistinctAscList+    , fromDescList+    , fromDescListUpsert++    -- * 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+    , bin+    , binCheckL+    , binCheckR+    , MonoState(..)+    , Stack(..)+    , ascLinkTop+    , ascLinkAll+    , descInsert+    , descLinkTop+    , descLinkAll+    , IntMapBuilder(..)+    , BStack(..)+    , emptyB+    , insertB+    , finishB+    , moveToB+    , MoveResult(..)+    , treeFromIntSetTip++    -- * 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', foldMap, null)+import Prelude ()++import Data.IntSet.Internal (IntSet)+import qualified Data.IntSet.Internal as IntSet+import Data.IntSet.Internal.IntTreeCommons+  ( Key+  , Prefix(..)+  , nomatch+  , left+  , signBranch+  , mask+  , branchMask+  , branchPrefix+  , TreeTreeBranch(..)+  , treeTreeBranch+  , i2w+  , Order(..)+  )+import Utils.Containers.Internal.BitUtil (shiftLL, shiftRL, iShiftRL, wordSize)+import Utils.Containers.Internal.Strict+  (StrictPair(..), StrictTriple(..), toPair)++#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+#  if __GLASGOW_HASKELL__ >= 914+import Language.Haskell.TH.Lift (Lift)+#  else+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#  endif+#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.+--+--+-- As an example, consider that on a 32-bit system we have a Bin with Prefix+--+-- 0b00000000000100100000011000000000+--                         ^ mask bit+--   ^^^^^^^^^^^^^^^^^^^^^^ shared prefix+--+-- The key+-- 0b00000000000100100000010000010100 belongs under this Bin, since it matches+-- the shared prefix. The mask bit is 0, so it belongs in the left child and not+-- the right.+--+-- The key+-- 0b00000000000100000000010000010100 does not belong under this Bin, since it+-- does not match the shared prefix.++-- See Note [Okasaki-Gill] for how the implementation here relates to the one in+-- Okasaki and Gill's paper.++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+deriving instance Lift a => Lift (IntMap a)+#endif++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- __Note__: This function is partial. Prefer '!?'.+--+-- > 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+#if !MIN_VERSION_base(4,11,0)+    mappend = (<>)+#endif++-- | @(<>)@ = '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 = foldMap id+  {-# INLINABLE fold #-}+  foldr = foldr+  {-# INLINE foldr #-}+  foldl = foldl+  {-# INLINE foldl #-}+  foldMap = foldMap+  {-# 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 entries in the map.+--+-- __Note__: Unlike @Data.Map.'Data.Map.Lazy.size'@, this is /not/ \(O(1)\).+--+-- > size empty                                   == 0+-- > size (singleton 1 'a')                       == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3+--+-- See also: 'compareSize'+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,c))\). Compare the number of entries in the map to an @Int@.+--+-- @compareSize m c@ returns the same result as @compare ('size' m) c@ but is+-- more efficient when @c@ is smaller than the size of the map.+--+-- @since 0.8.1+compareSize :: IntMap a -> Int -> Ordering+compareSize Nil c0 = compare 0 c0+compareSize _ c0 | c0 <= 0 = GT+compareSize t c0 = compare 0 (go t (c0 - 1))+  where+    go (Bin _ _ _) 0 = -1+    go (Bin _ l r) c+      | c' < 0 = c'+      | otherwise = go r c'+      where+        c' = go l (c - 1)+    go _ c = c++-- | \(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+--------------------------------------------------------------------}+-- | Given maps @bc@ and @ab@, relate the keys of @ab@ to the values of @bc@,+-- by using the values of @ab@ as keys for lookups in @bc@.+--+-- 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    = binCheckL p (delete k l) r+  | otherwise   = binCheckR p l (delete k r)+delete k t@(Tip ky _)+  | k == ky       = Nil+  | otherwise     = t+delete _k Nil = Nil++-- | \(O(\min(n,W))\). Pop an entry from the map.+--+-- Returns @Nothing@ if the key is not in the map. Otherwise returns @Just@ the+-- value at the key and a map with the entry removed.+--+-- @+-- pop 1 (fromList [(0,"a"),(2,"b"),(4,"c")]) == Nothing+-- pop 2 (fromList [(0,"a"),(2,"b"),(4,"c")]) == Just ("b",fromList [(0,"a"),(4,"c")])+-- @+--+-- @since 0.8.1+pop :: Key -> IntMap a -> Maybe (a, IntMap a)+pop k0 t0 = case go k0 t0 of+  Popped (Just y) t -> Just (y, t)+  _ -> Nothing+  where+    go !k (Bin p l r)+      | nomatch k p = Popped Nothing Nil+      | left k p = case go k l of+          Popped y@(Just _) l' -> Popped y (binCheckL p l' r)+          q -> q+      | otherwise = case go k r of+          Popped y@(Just _) r' -> Popped y (binCheckR p l r')+          q -> q+    go !k (Tip ky y)+      | k == ky = Popped (Just y) Nil+      | otherwise = Popped Nothing Nil+    go !_ Nil = Popped Nothing Nil++-- See Note [Popped impl] in Data.Map.Internal+data Popped k a = Popped+#if __GLASGOW_HASKELL__ >= 906+  {-# UNPACK #-}+#endif+  !(Maybe a)+  !(IntMap a)++-- | \(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      = binCheckL p (updateWithKey f k l) r+  | otherwise     = binCheckR 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))\). Update the value at a key or insert a value if the key is+-- not in the map.+--+-- @+-- let inc = maybe 1 (+1)+-- upsert inc 100 (fromList [(100,1),(300,2)]) == fromList [(100,2),(300,2)]+-- upsert inc 200 (fromList [(100,1),(300,2)]) == fromList [(100,1),(200,1),(300,2)]+-- @+--+-- @since 0.8.1+upsert :: (Maybe a -> a) -> Key -> IntMap a -> IntMap a+upsert f !k t@(Bin p l r)+  | nomatch k p = linkKey k (Tip k (f Nothing)) p t+  | left k p = Bin p (upsert f k l) r+  | otherwise = Bin p l (upsert f k r)+upsert f !k t@(Tip ky y)+  | k == ky = Tip ky (f (Just y))+  | otherwise = link k (Tip k (f Nothing)) ky t+upsert f !k Nil = Tip k (f Nothing)++-- | \(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")+--+-- See also: 'pop'++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,binCheckL p l' r)+  | otherwise     = let !(found,r') = updateLookupWithKey f k r+                    in (found,binCheckR 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    = binCheckL p (alter f k l) r+  | otherwise   = binCheckR 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)@.+--+-- '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@.+--+-- === Examples+--+-- @+-- -- Lookup the value at the key, and also remove the existing value or set a new value.+-- lookupAndSet :: Key -> Maybe a -> IntMap a -> (Maybe a, IntMap a)+-- lookupAndSet k new = alterF (\\old -> (old, new)) k+-- @+--+-- @+-- -- Delete the value at the key. If it is absent the result is Nothing.+-- mustDelete :: Key -> IntMap a -> Maybe (IntMap a)+-- mustDelete = alterF (Nothing <$)+-- @+--+-- @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+{-# INLINE alterF #-}++{--------------------------------------------------------------------+  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+{-# INLINE unions #-} -- Inline for list fusion++-- | 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+{-# INLINE unionsWith #-} -- Inline for list fusion++-- | \(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 = unionWithKey (\_ x y -> f x y)+{-# INLINE unionWith #-}++-- | \(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 f' id id m1 m2+  where+    f' (Tip k1 x1) (Tip _k2 x2) = Tip k1 (f k1 x1 x2)+    f' _ _ = error "not Tip"+{-# INLINABLE unionWithKey #-} -- See Note [INLINABLE to expose unfoldings]++{--------------------------------------------------------------------+  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 = differenceWithKey (\_ x y -> f x y)+{-# INLINE differenceWith #-}++-- | \(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+{-# INLINABLE differenceWithKey #-} -- See Note [INLINABLE to expose unfoldings]++-- | \(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 -> IntMap a+withoutKeys t1@(Bin p1 l1 r1) t2@(IntSet.Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> binCheckL p1 (withoutKeys l1 t2) r1+  ABR -> binCheckR 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 _ _ _) (IntSet.Tip p2 bm2) = withoutKeysTip t1 p2 bm2+withoutKeys t1@(Bin _ _ _) IntSet.Nil = t1+withoutKeys t1@(Tip k1 _) t2+    | k1 `IntSet.member` t2 = Nil+    | otherwise = t1+withoutKeys Nil _ = Nil++withoutKeysTip :: IntMap a -> Int -> IntSet.BitMap -> IntMap a+withoutKeysTip t@(Bin p l r) !p2 !bm2+  | IntSet.suffixOf (unPrefix p) /= 0 =+      if IntSet.prefixOf (unPrefix p) == p2+      then restrictBM t (complement bm2)+      else t+  | nomatch p2 p = t+  | left p2 p    = binCheckL p (withoutKeysTip l p2 bm2) r+  | otherwise    = binCheckR p l (withoutKeysTip r p2 bm2)+withoutKeysTip t@(Tip kx _) !p2 !bm2+  | IntSet.prefixOf kx == p2 && IntSet.bitmapOf kx .&. bm2 /= 0 = Nil+  | otherwise = t+withoutKeysTip 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 -> 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 _ _ _) (IntSet.Tip p2 bm2) = restrictKeysTip t1 p2 bm2+restrictKeys (Bin _ _ _) IntSet.Nil = Nil+restrictKeys t1@(Tip k1 _) t2+    | k1 `IntSet.member` t2 = t1+    | otherwise = Nil+restrictKeys Nil _ = Nil++restrictKeysTip :: IntMap a -> Int -> IntSet.BitMap -> IntMap a+restrictKeysTip t@(Bin p l r) !p2 !bm2+  | IntSet.suffixOf (unPrefix p) /= 0 =+      if IntSet.prefixOf (unPrefix p) == p2+      then restrictBM t bm2+      else Nil+  | nomatch p2 p = Nil+  | left p2 p    = restrictKeysTip l p2 bm2+  | otherwise    = restrictKeysTip r p2 bm2+restrictKeysTip t@(Tip kx _) !p2 !bm2+  | IntSet.prefixOf kx == p2 && IntSet.bitmapOf kx .&. bm2 /= 0 = t+  | otherwise = Nil+restrictKeysTip Nil !_ !_ = Nil++-- Must be called on an IntMap whose keys fit in the given IntSet BitMap's Tip.+-- Keeps keys that match the BitMap.+-- Returns early as an optimization, i.e. if the tree can be entirely kept or+-- discarded there is no need to recursively visit the children.+restrictBM :: IntMap a -> IntSet.BitMap -> IntMap a+restrictBM t@(Bin p l r) !bm+  | bm' == 0 = Nil+  | bm' == -1 = t+  | otherwise = bin p (restrictBM l bm) (restrictBM r bm)+  where+    -- Here we care about the "submask" of bm corresponding the current Bin's+    -- range. So we create bm', where this submask is at the lowest position and+    -- and all other bits are set to the highest bit of the submask (using an+    -- arithmetic shiftR). Now bm' is 0 when the submask is empty and -1 when+    -- the submask is full.+    px = IntSet.suffixOf (unPrefix p)+    px1 = px - 1+    min_ = px .&. px1+    max_ = px .|. px1+    sh = (wordSize - 1) - max_+    bm' = (w2i bm `unsafeShiftL` sh) `unsafeShiftR` (sh + min_)+restrictBM t@(Tip k _) !bm+  | IntSet.bitmapOf k .&. bm /= 0 = t+  | otherwise = Nil+restrictBM Nil !_ = Nil++w2i :: Word -> Int+w2i = fromIntegral++-- | \(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 = intersectionWithKey (\_ x y -> f x y)+{-# INLINE intersectionWith #-}++-- | \(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 f' (const Nil) (const Nil) m1 m2+  where+    f' (Tip k1 x1) (Tip _k2 x2) = Tip k1 (f k1 x1 x2)+    f' _ _ = error "not Tip"+-- See Note [INLINABLE to expose unfoldings]+{-# INLINABLE intersectionWithKey #-}++{--------------------------------------------------------------------+  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 -> binCheckL p1 (symmetricDifference l1 t2) r1+    ABR -> binCheckR p1 l1 (symmetricDifference r1 t2)+    BAL -> binCheckL p2 (symmetricDifference t1 l2) r2+    BAR -> binCheckR 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 = binCheckL p2 (go l2) r2+      | otherwise = binCheckR 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+        combine (Tip k1 x1) (Tip _k2 x2) =+          case f k1 x1 x2 of+            Nothing -> Nil+            Just x -> Tip k1 x+        combine _ _ = error "not Tip"+        {-# 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 Monad f => Functor (WhenMissing f x) where+  fmap = mapWhenMissing+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance 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 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 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 (>>=) #-}++-- | Create a @WhenMissing@ from two functions.+--+-- @whenMissing@ must be called with two functions @f@ and @g@ such that+-- @g = 'traverseMaybeWithKey' f@. @g@ may be a more efficient way of applying+-- @f@ to all key-value pairs in an @IntMap@.+--+-- __Warning__: It is the caller's responsibility to ensure the above property.+--+-- === __Examples__+--+-- @+-- preserveMissing :: Applicative f => WhenMissing f x x+-- preserveMissing = whenMissing f g+--   where+--     f _k x = pure (Just x)+--     g m = pure m+--     -- Note that this satisfies g = traverseMaybeWithKey f+-- @+--+-- @+-- import Data.Functor.Const (Const(..))+-- import Data.Monoid (All(..))+--+-- -- For a usage of this, see examples on mergeA+-- isEmpty :: WhenMissing (Const All) x y+-- isEmpty = whenMissing f g+--   where+--     f _k _x = Const (All False)+--     g m = Const (All (null m))+--     -- Note that this satisfies g = traverseMaybeWithKey f+-- @+--+-- @since 0.8.1+whenMissing+  :: (Key -> x -> f (Maybe y))+  -> (IntMap x -> f (IntMap y))+  -> WhenMissing f x y+whenMissing = flip WhenMissing++-- | Map covariantly over a @'WhenMissing' f x@.+--+-- @since 0.5.9+mapWhenMissing+  :: 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 => 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 (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 => 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, drop the key and values.+--+-- @since 0.8.1+dropMatched :: Applicative f => WhenMatched f x y z+dropMatched = WhenMatched (\_ _ _ -> pure Nothing)+{-# INLINE dropMatched #-}++-- | 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)+{-# INLINE traverseMaybeWithKey #-}++-- | Merge two maps.+--+-- 'merge' takes two 'SimpleWhenMissing' tactics, a 'SimpleWhenMatched' 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+-- @+--+-- @+-- g1 k x = if k == 2 then Just ("1" ++ x) else Nothing+-- g2 k x = if k == 3 then Just ("2" ++ x) else Nothing+-- f k x y = if k == 6 then Just ("3" ++ x ++ y) else Nothing+-- m1 = fromList [(2,"a"), (4,"b"), (6,"c"), (8,"d"), (10,"e"), (12,"f")]+-- m2 = fromList [(3,"g"), (6,"h"), (9,"i"), (12,"j")]+-- @+--+-- 'merge' will pass the keys and values to @g1@, @g2@, or @f@ as appropriate,+-- producing a @Maybe@ for each element.+--+-- @+-- m1:      [ (2, "a"),            (4, "b"),    (6, "c"), (8, "d"),           (10, "e"),    (12, "f")]+-- m2:      [            (3, "g"),              (6, "h"),           (9, "i"),               (12, "j")]+-- result:  [ g1 2 "a",  g2 3 "g", g1 4 "b", f 6 "c" "h", g1 8 "d", g2 9 "i", g1 10 "e", f 12 "f" "j"]+--        = [Just "1a", Just "2g",  Nothing,  Just "3ch",  Nothing,  Nothing,   Nothing,      Nothing]+-- @+--+-- The result map contains the @Just@ values.+--+-- >>> merge (mapMaybeMissing g1) (mapMaybeMissing g2) (zipWithMaybeMatched f) m1 m2+-- fromList [(2,"1a"), (3,"2g"), (6,"3ch")]+--+-- 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'.+--+-- Behaves just like 'merge' while allowing @Applicative@ effects. Effects are+-- performed in increasing order of keys.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+--        (traverseMaybeMissing g2)+--        (zipWithMaybeAMatched f)+--        m1+--        m2+-- @+--+-- @+-- g1 k x = let z = if k == 2 then Just ("1" ++ x) else Nothing+--          in z <$ putStrLn ("g1 " ++ show (k, x))+-- g2 k x = let z = if k == 3 then Just ("2" ++ x) else Nothing+--          in z <$ putStrLn ("g2 " ++ show (k, x))+-- f k x y = let z = if k == 6 then Just ("3" ++ x ++ y) else Nothing+--           in z <$ putStrLn ("f " ++ show (k, x, y))+-- m1 = fromList [(2,"a"), (4,"b"), (6,"c"), (8,"d"), (10,"e"), (12,"f")]+-- m2 = fromList [(3,"g"), (6,"h"), (9,"i"), (12,"j")]+-- @+--+-- As with 'merge', the result map is @[(2,"1a"), (3,"2g"), (6,"3ch")]@.+-- Additionally, @g1@, @g2@, and @f@ perform @IO@ effects, printing in+-- increasing order of key.+--+-- >>> mergeA (traverseMaybeMissing g1) (traverseMaybeMissing g2) (zipWithMaybeAMatched f) m1 m2+-- g1 (2,"a")+-- g2 (3,"g")+-- g1 (4,"b")+-- f (6,"c","h")+-- g1 (8,"d")+-- g2 (9,"i")+-- g1 (10,"e")+-- f (12,"f","j")+-- fromList [(2,"1a"),(3,"2g"),(6,"3ch")]+--+-- 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.+--+-- === __Examples__+--+-- @+-- data Pair a = Pair !a !a deriving Functor+--+-- instance Applicative Pair where+--    pure x = Pair x x+--    liftA2 f (Pair x1 y1) (Pair x2 y2) = Pair (f x1 x2) (f y1 y2)+--+-- -- | Calculate the left-biased union and intersection of two maps.+-- unionIntersection :: IntMap a -> IntMap a -> (IntMap a, IntMap a)+-- unionIntersection m1 m2 =+--   case mergeA preserveAndDropMissing preserveAndDropMissing preserveLeftMatched m1 m2 of+--     Pair mu mi -> (mu, mi)+--   where+--     -- use Pair to build the union and intersection together+--     preserveAndDropMissing = 'whenMissing' (\\_k x -> Pair (Just x) Nothing) (\\m -> Pair m empty)+--     preserveLeftMatched = 'zipWithMaybeAMatched' (\\_k x1 _x2 -> Pair (Just x1) (Just x1))+-- @+--+-- @+-- import Data.Functor.Const (Const(..))+-- import Data.Monoid (All(..))+--+-- -- | Whether the keys of the first map are a subset of the keys of the second map.+-- keysAreSubsetOf :: IntMap a -> IntMap b -> Bool+-- keysAreSubsetOf m1 m2 =+--   getAll (getConst (mergeA isEmpty 'dropMissing' 'dropMatched' m1 m2))+--   where+--     isEmpty = 'whenMissing' (\\_k _x -> Const (All False)) (\\m -> Const (All (null m)))+-- @+--+-- @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+        p = branchPrefix k1 k2+    {-# 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 -> binCheckR p l (go f r)+            _ -> go f t+  where+    go f' (Bin p l r) = binCheckL 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 -> binCheckL p (go f l) r+            _ -> go f t+  where+    go f' (Bin p l r) = binCheckR 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 (binCheckL p l' r)+    _ -> go t+  where+    go (Bin p l r) =+        case go r of View k a r' -> View k a (binCheckR 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 (binCheckR p l r')+    _ -> go t+  where+    go (Bin p l r) =+        case go l of View k a l' -> View k a (binCheckL 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.+--+-- Calls 'error' if the map is empty.+--+-- __Note__: This function is partial. Prefer 'maxViewWithKey'.+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.+--+-- Calls 'error' if the map is empty.+--+-- __Note__: This function is partial. Prefer 'minViewWithKey'.+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.+--+-- __Note__: This function is partial. Prefer 'lookupMin'.+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.+--+-- __Note__: This function is partial. Prefer 'lookupMax'.+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' &#8211;+-- 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' &#8211;+-- 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@.+--+-- If `f` is monotonically non-decreasing or monotonically non-increasing, 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 :: (Key->Key) -> IntMap a -> IntMap a+mapKeys f t = finishB (foldlWithKey' (\b kx x -> insertB (f kx) x b) emptyB t)+{-# INLINABLE mapKeys #-} -- See Note [INLINABLE to expose unfoldings]++-- | \(O(n \min(n,W))\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- If `f` is monotonically non-decreasing or monotonically non-increasing, 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@.+--+-- > 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 t =+  finishB (foldlWithKey' (\b kx x -> insertWithB c (f kx) x b) emptyB t)+{-# INLINABLE mapKeysWith #-} -- See Note [INLINABLE to expose unfoldings]++-- | \(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 t =+  ascLinkAll (foldlWithKey' (\s kx x -> ascInsert s (f kx) x) MSNada t)+{-# INLINABLE mapKeysMonotonic #-} -- See Note [INLINABLE to expose unfoldings]++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Keep 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 = filterWithKey (\_ x -> p x)+{-# INLINE filter #-}++-- | \(O(n)\). Keep 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)+{-# INLINE filterKeys #-}++-- | \(O(n)\). Keep 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)+{-# INLINABLE filterWithKey #-} -- See Note [INLINABLE to expose unfoldings]++-- | \(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 = partitionWithKey (\_ x -> p x)+{-# INLINE partition #-}++-- | \(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 binCheckL p (go predicate l) r+        else go predicate r+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = binCheckR 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 binCheckR p l (go predicate r)+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = go predicate' r+      | otherwise               = binCheckL 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' = binCheckL p lt r+              in (lt', gt)+        else+          case go predicate r of+            (lt :*: gt) ->+              let !gt' = binCheckR 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) -> binCheckR p l lt :*: gt+      | otherwise+      = case go predicate' l of (lt :*: gt) -> lt :*: binCheckL 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' = binCheckL p lt r+              in (lt', gt)+        else+          case go k r of+            (lt :*: gt) ->+              let !gt' = binCheckR 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 :*: binCheckL p gt r+      | otherwise = case go k' r of (lt :*: gt) -> binCheckR p l lt :*: gt+    go k' t'@(Tip ky _)+      | k' > ky   = (t' :*: Nil)+      | k' < ky   = (Nil :*: t')+      | otherwise = (Nil :*: Nil)+    go _ Nil = (Nil :*: Nil)+++type SplitLookup a = StrictTriple (IntMap a) (Maybe a) (IntMap a)++mapLT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a+mapLT f (TripleS lt fnd gt) = TripleS (f lt) fnd gt+{-# INLINE mapLT #-}++mapGT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a+mapGT f (TripleS lt fnd gt) = TripleS 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 (\l' -> binCheckL p l' r) (go k l)+          else mapGT (binCheckR p l) (go k r)+      _ -> go k t+  of TripleS lt fnd gt -> (lt, fnd, gt)+  where+    go !k' t'@(Bin p l r)+      | nomatch k' p =+          if k' < unPrefix p+          then TripleS Nil Nothing t'+          else TripleS t' Nothing Nil+      | left k' p = mapGT (\l' -> binCheckL p l' r) (go k' l)+      | otherwise  = mapLT (binCheckR p l) (go k' r)+    go k' t'@(Tip ky y)+      | k' > ky   = TripleS t'  Nothing  Nil+      | k' < ky   = TripleS Nil Nothing  t'+      | otherwise = TripleS Nil (Just y) Nil+    go _ Nil      = TripleS 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++-- See Note [IntMap folds]+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+    Nil -> z+    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 _ Nil          = error "foldr.go: Nil"+    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.++-- See Note [IntMap folds]+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+    Nil -> z+    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 !_ Nil         = error "foldr'.go: Nil"+    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++-- See Note [IntMap folds]+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+    Nil -> z+    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 _ Nil          = error "foldl.go: Nil"+    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.++-- See Note [IntMap folds]+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+    Nil -> z+    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 !_ Nil         = error "foldl'.go: Nil"+    go z' (Tip _ x)   = f z' x+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++-- See Note [IntMap folds]+foldMap :: Monoid m => (a -> m) -> IntMap a -> m+foldMap f = \t -> -- Use lambda to be inlinable with two arguments.+  case t of+    Nil -> mempty+    Bin p l r+#if MIN_VERSION_base(4,11,0)+      | signBranch p -> go r <> go l+      | otherwise -> go l <> go r+#else+      | signBranch p -> go r `mappend` go l+      | otherwise -> go l `mappend` go r+#endif+    _ -> go t+  where+    go Nil = error "foldMap.go: Nil"+    go (Tip _ x) = f x+#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+{-# INLINE foldMap #-}++-- | \(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)"++-- See Note [IntMap folds]+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+    Nil -> z+    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 _ Nil          = error "foldrWithKey.go: Nil"+    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.++-- See Note [IntMap folds]+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+    Nil -> z+    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 !_ Nil         = error "foldrWithKey'.go: Nil"+    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)"++-- See Note [IntMap folds]+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+    Nil -> z+    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 _ Nil          = error "foldlWithKey.go: Nil"+    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.++-- See Note [IntMap folds]+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+    Nil -> z+    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 !_ Nil         = error "foldlWithKey'.go: Nil"+    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++-- See Note [IntMap folds]+foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m+foldMapWithKey f = \t -> -- Use lambda to be inlinable with two arguments.+  case t of+    Nil -> mempty+    Bin p l r+#if MIN_VERSION_base(4,11,0)+      | signBranch p -> go r <> go l+      | otherwise -> go l <> go r+#else+      | signBranch p -> go r `mappend` go l+      | otherwise -> go l `mappend` go r+#endif+    _ -> go t+  where+    go Nil = error "foldMap.go: Nil"+    go (Tip kx x) = f kx x+#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+{-# 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+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 an 'IntSet' 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 :: (Key -> a) -> IntSet -> IntMap a+#ifdef __GLASGOW_HASKELL__+fromSet =+  (coerce :: ((Key -> Identity a) -> IntSet -> Identity (IntMap a))+          -> (Key -> a) -> IntSet -> IntMap a)+    fromSetA+#else+fromSet f = runIdentity . fromSetA (pure . f)+#endif++-- | \(O(n)\). Build a map from an 'IntSet' of keys and a function which for+-- each key computes its value, while within an 'Applicative' context.+--+-- The @Applicative@ actions are sequenced in order of increasing key.+--+-- > let f k = if k == 0 then Nothing else Just (6 `div` k)+-- > fromSetA f (Data.Set.fromList [1,2,3,4]) == Just (fromList [(1,6),(2,3),(3,2),(4,1)])+-- > fromSetA f (Data.Set.fromList [0,1,2]) == Nothing+--+-- @since 0.8.1+fromSetA :: Applicative f => (Key -> f a) -> IntSet -> f (IntMap a)+fromSetA _ IntSet.Nil = pure Nil+fromSetA f (IntSet.Bin p l r)+  | signBranch p = liftA2 (flip (Bin p)) (fromSetA f r) (fromSetA f l)+  | otherwise = liftA2 (Bin p) (fromSetA f l) (fromSetA f r)+fromSetA f (IntSet.Tip kx bm) =+  treeFromIntSetTip (\kx' -> Tip kx' <$> f kx') (\p -> liftA2 (Bin p)) kx bm+{-# INLINABLE fromSetA #-}++-- | \(O(n)\). Build a map from an 'IntSet' of keys and a function which for each+-- key optionally computes its value.+--+-- > let f k = if even k then Just (replicate k 'a') else Nothing+-- > fromSetMaybe f (Data.IntSet.fromList [1,2,3,4]) == fromList [(2,"aa"), (4,"aaaa")]+--+-- @since 0.8.1+fromSetMaybe :: (Key -> Maybe a) -> IntSet -> IntMap a+#ifdef __GLASGOW_HASKELL__+fromSetMaybe =+  (coerce :: ((Key -> Identity (Maybe a)) -> IntSet -> Identity (IntMap a))+          -> (Key -> Maybe a) -> IntSet -> IntMap a)+    fromSetMaybeA+#else+fromSetMaybe f s = runIdentity (fromSetMaybeA (Identity . f) s)+#endif++-- | \(O(n)\). Build a map from an 'IntSet' of keys and a function which for+-- each key optionally computes its value in an 'Applicative' context.+--+-- The @Applicative@ actions are sequenced in order of increasing key.+--+-- @since 0.8.1+fromSetMaybeA :: Applicative f => (Key -> f (Maybe a)) -> IntSet -> f (IntMap a)+fromSetMaybeA f = go+  where+   go IntSet.Nil = pure Nil+   go (IntSet.Bin p l r)+     | signBranch p = liftA2 (flip (bin p)) (go r) (go l)+     | otherwise = liftA2 (bin p) (go l) (go r)+   go (IntSet.Tip kx bm) =+     treeFromIntSetTip+       (\kx' -> maybe Nil (Tip kx') <$> f kx')+       (\p -> liftA2 (bin p))+       kx+       bm+{-# INLINABLE fromSetMaybeA #-}++-- Internal helper used by fromSet and friends.+treeFromIntSetTip :: (Int -> a) -> (Prefix -> a -> a -> a) -> Int -> Word -> a+treeFromIntSetTip tipf binf kx bm = buildTree 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 !prefix !bmask bits = case bits of+      0 -> tipf prefix+      _ -> case bits `iShiftRL` 1 of+        bits2+          | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->+              buildTree (prefix + bits2) (bmask `shiftRL` bits2) bits2+          | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->+              buildTree prefix bmask bits2+          | otherwise ->+             binf (Prefix (prefix .|. bits2))+                  (buildTree prefix bmask bits2)+                  (buildTree (prefix + bits2) (bmask `shiftRL` bits2) bits2)+{-# INLINE treeFromIntSetTip #-}++{--------------------------------------------------------------------+  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.+-- 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 sorted order, ascending or descending, 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 :: [(Key,a)] -> IntMap a+fromList xs = finishB (Foldable.foldl' (\b (kx,x) -> insertB kx x b) emptyB xs)+{-# INLINE fromList #-} -- Inline for list fusion++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function.+--+-- If the keys are in sorted order, ascending or descending, 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@.+--+-- See also: 'fromListUpsert'+--+-- === 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+{-# INLINE fromListWith #-} -- Inline for list fusion++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function.+--+-- If the keys are in sorted order, ascending or descending, 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'.+--+-- See also: 'fromListUpsert'++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWithKey f xs =+  finishB (Foldable.foldl' (\b (kx,x) -> insertWithB (f kx) kx x b) emptyB xs)+{-# INLINE fromListWithKey #-} -- Inline for list fusion++-- | \(O(n \min(n,W)\). Build a map from a list of key\/value pairs with a+-- combining function.+--+-- If the keys are in sorted order, ascending or descending, this function+-- takes \(O(n)\) time.+--+-- The result is equivalent to performing an @upsert@ for every key\/value in+-- the list.+--+-- @+-- fromListUpsert f = foldl' (\\m (k, x) -> 'upsert' (f x) k m) 'empty'+-- @+--+-- > let f x = maybe [x] (x:)+-- > fromListUpsert f [(5,'a'), (5,'b'), (3,'c'), (3,'d'), (5,'e')] == fromList [(3,"dc"), (5,"eba")]+--+-- @since 0.8.1+fromListUpsert :: (a -> Maybe b -> b) -> [(Key, a)] -> IntMap b+fromListUpsert f xs =+  finishB (Foldable.foldl' (\b (kx, x) -> upsertB (f x) kx b) emptyB xs)+{-# INLINE fromListUpsert #-}  -- INLINE for fusion++-- | \(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 xs =+  ascLinkAll (Foldable.foldl' (\s (ky, y) -> ascInsert s ky y) MSNada xs)+{-# INLINE fromAscList #-} -- Inline for list fusion++-- | \(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'.+--+-- See also: 'fromAscListUpsert'++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWith f xs = fromAscListWithKey (\_ x y -> f x y) xs+{-# INLINE fromAscListWith #-} -- Inline for list fusion++-- | \(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"), (3,"a"), (5,"a"), (5,"b"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromAscListWithKey f [] == empty+--+-- Also see the performance note on 'fromListWith'.+--+-- See also: 'fromAscListUpsert'++-- See Note [fromAscList implementation]+fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWithKey f xs = ascLinkAll (Foldable.foldl' next MSNada xs)+  where+    next s (!ky, y) = case s of+      MSNada -> MSPush ky y Nada+      MSPush kx x stk+        | kx == ky -> MSPush ky (f ky y x) stk+        | otherwise -> let m = branchMask kx ky+                       in MSPush ky y (ascLinkTop stk kx (Tip kx x) m)+{-# INLINE fromAscListWithKey #-} -- Inline for list 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 'fromListUpsert'+-- if the precondition may not hold.+--+-- > let f x = maybe [x] (x:)+-- > fromAscListUpsert f [(3,'a'), (3,'b'), (5,'c'), (5,'d'), (5,'e')] == fromList [(3,"ba"), (5,"edc")]+--+-- @since 0.8.1+fromAscListUpsert :: (a -> Maybe b -> b) -> [(Key, a)] -> IntMap b+fromAscListUpsert f xs = ascLinkAll (Foldable.foldl' next MSNada xs)+  where+    next s (!ky, y) = case s of+      MSNada -> MSPush ky (f y Nothing) Nada+      MSPush kx x stk+        | kx == ky -> MSPush ky (f y (Just x)) stk+        | otherwise ->+            let m = branchMask kx ky+            in MSPush ky (f y Nothing) (ascLinkTop stk kx (Tip kx x) m)+{-# INLINE fromAscListUpsert #-} -- Inline for list fusion++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+--+-- @fromDistinctAscList = 'fromAscList'@+--+-- See warning on 'fromAscList'.+--+-- This definition exists for backwards compatibility. It offers no advantage+-- over @fromAscList@.+fromDistinctAscList :: [(Key,a)] -> IntMap a+-- Note: There is nothing we can optimize compared to fromAscList.+-- The adjacent key equals check (kx == ky) might seem unnecessary for+-- fromDistinctAscList, but it guards branchMask which has undefined behavior+-- under that case. We could error on kx == ky instead, but that isn't any+-- better.+fromDistinctAscList = fromAscList+{-# INLINE fromDistinctAscList #-} -- Inline for list fusion++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in descending order.+--+-- __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")]+--+-- @since 0.8.1+fromDescList :: [(Key,a)] -> IntMap a+fromDescList xs =+  descLinkAll (Foldable.foldl' (\s (ky, y) -> descInsert ky y s) MSNada xs)+{-# INLINE fromDescList #-} -- Inline for list 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 'fromListUpsert'+-- if the precondition may not hold.+--+-- > let f x = maybe [x] (x:)+-- > fromDescListUpsert f [(5,'a'), (5,'b'), (5,'c'), (3,'d'), (3,'e')] == fromList [(3,"ed"), (5,"cba")]+--+-- @since 0.8.1+fromDescListUpsert :: (a -> Maybe b -> b) -> [(Key, a)] -> IntMap b+fromDescListUpsert f xs = descLinkAll (Foldable.foldl' next MSNada xs)+  where+    next s (!ky, y) = case s of+      MSNada -> MSPush ky (f y Nothing) Nada+      MSPush kx x stk+        | kx == ky -> MSPush ky (f y (Just x)) stk+        | otherwise ->+            let m = branchMask kx ky+            in MSPush ky (f y Nothing) (descLinkTop kx (Tip kx x) m stk)+{-# INLINE fromDescListUpsert #-} -- Inline for list fusion++data Stack a+  = Nada+  | Push {-# UNPACK #-} !Int !(IntMap a) !(Stack a)++data MonoState a+  = MSNada+  | MSPush {-# UNPACK #-} !Key a !(Stack a)++-- Insert an entry. The key must be >= the last inserted key. If it is equal+-- to the previous key, the previous value is replaced.+ascInsert :: MonoState a -> Int -> a -> MonoState a+ascInsert s !ky y = case s of+  MSNada -> MSPush ky y Nada+  MSPush kx x stk+    | kx == ky -> MSPush ky y stk+    | otherwise -> let m = branchMask kx ky+                   in MSPush ky y (ascLinkTop stk kx (Tip kx x) m)+{-# INLINE ascInsert #-}++ascLinkTop :: Stack a -> Int -> IntMap a -> Int -> Stack a+ascLinkTop stk !rk r !rm = case stk of+  Nada -> Push rm r stk+  Push m l stk'+    | i2w m < i2w rm -> let p = mask rk m+                        in ascLinkTop stk' rk (Bin p l r) rm+    | otherwise -> Push rm r stk++ascLinkAll :: MonoState a -> IntMap a+ascLinkAll s = case s of+  MSNada -> Nil+  MSPush kx x stk -> ascLinkStack stk kx (Tip kx x)+{-# INLINABLE ascLinkAll #-}++ascLinkStack :: Stack a -> Int -> IntMap a -> IntMap a+ascLinkStack stk !rk r = case stk of+  Nada -> r+  Push m l stk'+    | signBranch p -> Bin p r l+    | otherwise -> ascLinkStack stk' rk (Bin p l r)+    where+      p = mask rk m++-- Insert an entry. The key must be <= the last inserted key. If it is equal+-- to the previous key, the previous value is replaced.+descInsert :: Int -> a -> MonoState a -> MonoState a+descInsert !ky y s = case s of+  MSNada -> MSPush ky y Nada+  MSPush kx x stk+    | kx == ky -> MSPush ky y stk+    | otherwise -> let m = branchMask kx ky+                   in MSPush ky y (descLinkTop kx (Tip kx x) m stk)+{-# INLINE descInsert #-}++descLinkTop :: Int -> IntMap a -> Int -> Stack a -> Stack a+descLinkTop !lk l !lm stk = case stk of+  Nada -> Push lm l stk+  Push m r stk'+    | i2w m < i2w lm -> let p = mask lk m+                        in descLinkTop lk (Bin p l r) lm stk'+    | otherwise -> Push lm l stk++descLinkAll :: MonoState a -> IntMap a+descLinkAll s = case s of+  MSNada -> Nil+  MSPush kx x stk -> descLinkStack kx (Tip kx x) stk+{-# INLINABLE descLinkAll #-}++descLinkStack :: Int -> IntMap a -> Stack a -> IntMap a+descLinkStack !lk l stk = case stk of+  Nada -> l+  Push m r stk'+    | signBranch p -> Bin p r l+    | otherwise -> descLinkStack lk (Bin p l r) stk'+    where+      p = mask lk m++{--------------------------------------------------------------------+  IntMapBuilder+--------------------------------------------------------------------}++-- Note [IntMapBuilder]+-- ~~~~~~~~~~~~~~~~~~~~+-- IntMapBuilder serves as an accumulator for element-by-element construction+-- of an IntMap. It can be used in folds to construct IntMaps. This plays nicely+-- with list fusion when the structure folded over is a list, as in fromList and+-- friends.+--+-- An IntMapBuilder is either empty (BNil) or has the recently inserted Tip+-- together with a stack of trees (BTip). The structure is effectively a+-- [zipper](https://en.wikipedia.org/wiki/Zipper_(data_structure)). It always+-- has its "focus" at the last inserted entry. To insert a new entry, we need+-- to move the focus to the new entry. To do this we move up the stack to the+-- lowest common ancestor of the current position and the position of the+-- new key (implemented as moveUpB), then down to the position of the new key+-- (implemented as moveDownB).+--+-- When we are done inserting entries, we link the trees up the stack and get+-- the final result.+--+-- The advantage of this implementation is that we take the shortest path in+-- the tree from one key to the next. Unlike `insert`, we don't need to move+-- up to the root after every insertion. This is very beneficial when we have+-- runs of sorted keys, without many keys already in the tree in that range.+-- If the keys are fully sorted, inserting them all takes O(n) time instead+-- of O(n min(n,W)). But these benefits come at a small cost: when moving up+-- the tree we have to check at every point if it is time to move down. These+-- checks are absent in `insert`. So, in case we need to move up quite a lot,+-- repeated `insert` is slightly faster, but the trade-off is worthwhile since+-- such cases are pathological.++data IntMapBuilder a+  = BNil+  | BTip {-# UNPACK #-} !Int a !(BStack a)++-- BLeft: the IntMap is the left child+-- BRight: the IntMap is the right child+data BStack a+  = BNada+  | BLeft {-# UNPACK #-} !Prefix !(IntMap a) !(BStack a)+  | BRight {-# UNPACK #-} !Prefix !(IntMap a) !(BStack a)++-- Empty builder.+emptyB :: IntMapBuilder a+emptyB = BNil++-- Insert a key and value. Replaces the old value if one already exists for+-- the key.+insertB :: Key -> a -> IntMapBuilder a -> IntMapBuilder a+insertB !ky y b = case b of+  BNil -> BTip ky y BNada+  BTip kx x stk -> case moveToB ky kx x stk of+    MoveResult _ stk' -> BTip ky y stk'+{-# INLINE insertB #-}++-- Insert a key and value. The new value is combined with the old value if one+-- already exists for the key.+insertWithB :: (a -> a -> a) -> Key -> a -> IntMapBuilder a -> IntMapBuilder a+insertWithB f !ky y b = case b of+  BNil -> BTip ky y BNada+  BTip kx x stk -> case moveToB ky kx x stk of+    MoveResult m stk' -> case m of+      Nothing -> BTip ky y stk'+      Just x' -> BTip ky (f y x') stk'+{-# INLINE insertWithB #-}++-- Upsert a key-value. The given function is used to generate the value based+-- on the existing value for the key.+upsertB :: (Maybe a -> a) -> Key -> IntMapBuilder a -> IntMapBuilder a+upsertB f !ky b = case b of+  BNil -> BTip ky (f Nothing) BNada+  BTip kx x stk -> case moveToB ky kx x stk of+    MoveResult m stk' -> BTip ky (f m) stk'+{-# INLINE upsertB #-}++-- GHC >=9.6 supports unpacking sums, so we unpack the Maybe and avoid+-- allocating Justs. GHC optimizes the workers for moveUpB and moveDownB to+-- return (# (# (# #) | a #), BStack a #).+data MoveResult a+  = MoveResult+#if __GLASGOW_HASKELL__ >= 906+      {-# UNPACK #-}+#endif+      !(Maybe a)+      !(BStack a)++moveToB :: Key -> Key -> a -> BStack a -> MoveResult a+moveToB !ky !kx x !stk+  | kx == ky = MoveResult (Just x) stk+  | otherwise = moveUpB ky kx (Tip kx x) stk+-- Don't inline this; there is no benefit according to benchmarks.+{-# NOINLINE moveToB #-}++moveUpB :: Key -> Key -> IntMap a -> BStack a -> MoveResult a+moveUpB !ky !kx !tx stk = case stk of+  BNada -> MoveResult Nothing (linkB ky kx tx BNada)+  BLeft p l stk'+    | nomatch ky p -> moveUpB ky kx (Bin p l tx) stk'+    | left ky p -> moveDownB ky l (BRight p tx stk')+    | otherwise -> MoveResult Nothing (linkB ky kx tx stk)+  BRight p r stk'+    | nomatch ky p -> moveUpB ky kx (Bin p tx r) stk'+    | left ky p -> MoveResult Nothing (linkB ky kx tx stk)+    | otherwise -> moveDownB ky r (BLeft p tx stk')++moveDownB :: Key -> IntMap a -> BStack a -> MoveResult a+moveDownB !ky tx !stk = case tx of+  Bin p l r+    | nomatch ky p -> MoveResult Nothing (linkB ky (unPrefix p) tx stk)+    | left ky p -> moveDownB ky l (BRight p r stk)+    | otherwise -> moveDownB ky r (BLeft p l stk)+  Tip kx x+    | kx == ky -> MoveResult (Just x) stk+    | otherwise -> MoveResult Nothing (linkB ky kx tx stk)+  Nil -> error "moveDownB Tip"++linkB :: Key -> Key -> IntMap a -> BStack a -> BStack a+linkB ky kx tx stk+  | i2w ky < i2w kx = BRight p tx stk+  | otherwise = BLeft p tx stk+  where+    p = branchPrefix ky kx+{-# INLINE linkB #-}++-- Finalize the builder into a Map.+finishB :: IntMapBuilder a -> IntMap a+finishB b = case b of+  BNil -> Nil+  BTip kx x stk -> finishUpB (Tip kx x) stk+{-# INLINABLE finishB #-}++finishUpB :: IntMap a -> BStack a -> IntMap a+finishUpB !t stk = case stk of+  BNada -> t+  BLeft p l stk' -> finishUpB (Bin p l t) stk'+  BRight p r stk' -> finishUpB (Bin p t r) stk'++{--------------------------------------------------------------------+  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+  | i2w k1 < i2w k2 = Bin p t1 t2+  | otherwise = Bin p t2 t1+  where+    p = branchPrefix k1 k2+{-# INLINE link #-}++{--------------------------------------------------------------------+  @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 #-}++-- binCheckL only checks that the left subtree is non-empty+binCheckL :: Prefix -> IntMap a -> IntMap a -> IntMap a+binCheckL _ Nil r = r+binCheckL p l r = Bin p l r+{-# INLINE binCheckL #-}++-- binCheckR only checks that the right subtree is non-empty+binCheckR :: Prefix -> IntMap a -> IntMap a -> IntMap a+binCheckR _ l Nil = l+binCheckR p l r = Bin p l r+{-# INLINE binCheckR #-}++{--------------------------------------------------------------------+  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.++-- Note [fromAscList implementation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- fromAscList is an implementation that builds up the result bottom-up+-- in linear time. It maintains a state (MonoState) that gets updated with+-- key-value pairs from the input list one at a time. The state contains the+-- last key-value pair, and a stack of pending trees.+--+-- For a new key-value pair, the branchMask with the previous key is computed.+-- This represents the depth of the lowest common ancestor that the tree with+-- the previous key, say tl, and the tree with the new key, tr, must have in+-- the final result. Since the keys are in ascending order we expect no more+-- keys in tl, and we can build it by moving up the stack and linking trees. We+-- know when to stop by the branchMask value. We must not link higher than that+-- depth, otherwise instead of tl we will build the parent of tl prematurely+-- before tr is ready. Once the linking is done, tl will be at the top of the+-- stack.+--+-- We also store the branchMask of a tree with its future right sibling in the+-- stack. This is an optimization, benchmarks show that this is faster than+-- recomputing the branchMask values when linking trees.+--+-- In the end, we link all the trees remaining in the stack. There is a small+-- catch: negative keys appear in the input before non-negative keys (if they+-- both appear), but the tree with negative keys and the tree with non-negative+-- keys must be the right and left child of the root respectively. So we check+-- for this and link them accordingly.+--+-- The implementation is defined as a foldl' over the input list, which makes+-- it a good consumer in list fusion.++-- Note [IntMap folds]+-- ~~~~~~~~~~~~~~~~~~~+-- Folds on IntMap are defined in a particular way for a few reasons.+--+-- foldl' :: (a -> b -> a) -> a -> IntMap b -> a+-- foldl' f z = \t ->+--   case t of+--     Nil -> z+--     Bin p l r+--       | signBranch p -> go (go z r) l+--       | otherwise -> go (go z l) r+--     _ -> go z t+--   where+--     go !_ Nil         = error "foldl'.go: Nil"+--     go z' (Tip _ x)   = f z' x+--     go z' (Bin _ l r) = go (go z' l) r+-- {-# INLINE foldl' #-}+--+-- 1. We first check if the Bin separates negative and positive keys, and fold+--    over the children accordingly. This check is not inside `go` because it+--    can only happen at the top level and we don't need to check every Bin.+-- 2. We also check for Nil at the top level instead of, say, `go z Nil = z`.+--    That's because `Nil` is also allowed only at the top-level, but more+--    importantly it allows for better optimizations if the `Nil` branch errors+--    in `go`. For example, if we have+--      maximum :: Ord a => IntMap a -> Maybe a+--      maximum = foldl' (\m x -> Just $! maybe x (max x) m) Nothing+--    because `go` certainly returns a `Just` (or errors), CPR analysis will+--    optimize it to return `(# a #)` instead of `Maybe a`. This makes it+--    satisfy the conditions for SpecConstr, which generates two specializations+--    of `go` for `Nothing` and `Just` inputs. Now both `Maybe`s have been+--    optimized out of `go`.+-- 3. The `Tip` is not matched on at the top-level to avoid using `f` more than+--    once. This allows `f` to be inlined into `go` even if `f` is big, since+--    it's likely to be the only place `f` is used, and not inlining `f` means+--    missing out on optimizations. See GHC #25259 for more on this.++-- Note [INLINABLE to expose unfoldings]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We have many functions that could be inlined (i.e. not recursive at the top+-- level) but we mark a function with the INLINE pragma only if believe that+-- it will simplify after inlining and improve performance in most situations.+-- Otherwise, inlining just increases code size and compilation times. Fold+-- functions are good examples of functions we surely want to INLINE.+--+-- For the rest, depending on the function, e.g. if it closes over a+-- user-supplied function, it may improve performance to inline it in certain+-- situations. We want to allow the user to force inlining with GHC.Exts.inline+-- in such situations, so we mark the function as INLINABLE to make its+-- unfolding available in the interface file.+--+-- For reference see+-- https://downloads.haskell.org/ghc/9.14.1/docs/users_guide/exts/pragmas.html#inlinable-pragma.+--+-- Note that the user's ability to inline is limited to the body of the+-- function.+--+-- unionWith f = unionWithKey (\_k x y -> f x y)+-- {-# INLINABLE unionWith #-}+-- unionWithKey f = ...large rhs...+-- {-# INLINABLE unionWithKey #-}+--+-- Writing `GHC.Exts.inline unionWith` doesn't also inline the body of+-- unionWithKey. If the user wants that, they have to use unionWithKey instead.
− 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,10 +1,8 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.IntMap.Lazy@@ -28,7 +26,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 +36,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,39 +44,84 @@ -- 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     , singleton-    , fromSet      -- ** From Unordered Lists     , fromList     , fromListWith     , fromListWithKey+    , fromListUpsert -    -- ** From Ascending Lists+    -- ** From Ordered Lists     , fromAscList     , fromAscListWith     , fromAscListWithKey+    , fromAscListUpsert     , fromDistinctAscList+    , fromDescList+    , fromDescListUpsert +    -- * From @IntSet@+    , fromSet+    , fromSetA+    , fromSetMaybe+    , fromSetMaybeA+     -- * Insertion     , insert     , insertWith@@ -97,10 +130,12 @@      -- * Deletion\/Update     , delete+    , pop     , adjust     , adjustWithKey     , update     , updateWithKey+    , upsert     , updateLookupWithKey     , alter     , alterF@@ -121,6 +156,7 @@     -- ** Size     , IM.null     , size+    , compareSize      -- * Combine @@ -142,6 +178,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -192,6 +231,7 @@      -- * Filter     , IM.filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -218,12 +258,8 @@     -- * Min\/Max     , lookupMin     , lookupMax-    , findMin-    , findMax     , deleteMin     , deleteMax-    , deleteFindMin-    , deleteFindMax     , updateMin     , updateMax     , updateMinWithKey@@ -232,15 +268,10 @@     , maxView     , minViewWithKey     , maxViewWithKey--#ifdef __GLASGOW_HASKELL__-    -- * Debugging-    , showTree-    , showTreeWith-#endif+    , findMin+    , findMax+    , deleteFindMin+    , deleteFindMax     ) 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,10 +1,8 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.IntMap.Merge.Lazy@@ -42,6 +40,7 @@     , merge      -- *** @WhenMatched@ tactics+    , dropMatched     , zipWithMaybeMatched     , zipWithMatched @@ -73,6 +72,7 @@     , traverseMaybeMissing     , traverseMissing     , filterAMissing+    , whenMissing      -- *** Covariant maps for tactics     , mapWhenMissing
src/Data/IntMap/Merge/Strict.hs view
@@ -1,11 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.IntMap.Merge.Strict@@ -43,6 +41,7 @@     , merge      -- *** @WhenMatched@ tactics+    , dropMatched     , zipWithMaybeMatched     , zipWithMatched @@ -74,6 +73,7 @@     , traverseMaybeMissing     , traverseMissing     , filterAMissing+    , Internal.whenMissing      -- ** Covariant maps for tactics     , mapWhenMissing@@ -96,9 +96,11 @@   , WhenMatched (..)   , mergeA   , filterAMissing+  , dropMatched   , runWhenMatched   , runWhenMissing   )+import qualified Data.IntMap.Internal as Internal import Data.IntMap.Strict.Internal import Prelude hiding (filter, map, foldl, foldr)
src/Data/IntMap/Strict.hs view
@@ -1,11 +1,8 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.IntMap.Strict@@ -36,7 +33,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 +43,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,41 +60,86 @@ -- 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     , singleton-    , fromSet      -- ** From Unordered Lists     , fromList     , fromListWith     , fromListWithKey+    , fromListUpsert -    -- ** From Ascending Lists+    -- ** From Ordered Lists     , fromAscList     , fromAscListWith     , fromAscListWithKey+    , fromAscListUpsert     , fromDistinctAscList+    , fromDescList+    , fromDescListUpsert +    -- * From @IntSet@+    , fromSet+    , fromSetA+    , fromSetMaybe+    , fromSetMaybeA+     -- * Insertion     , insert     , insertWith@@ -116,10 +148,12 @@      -- * Deletion\/Update     , delete+    , pop     , adjust     , adjustWithKey     , update     , updateWithKey+    , upsert     , updateLookupWithKey     , alter     , alterF@@ -140,6 +174,7 @@     -- ** Size     , null     , size+    , compareSize      -- * Combine @@ -161,6 +196,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -211,6 +249,7 @@      -- * Filter     , filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -237,12 +276,8 @@     -- * Min\/Max     , lookupMin     , lookupMax-    , findMin-    , findMax     , deleteMin     , deleteMax-    , deleteFindMin-    , deleteFindMax     , updateMin     , updateMax     , updateMinWithKey@@ -251,12 +286,10 @@     , maxView     , minViewWithKey     , maxViewWithKey--#ifdef __GLASGOW_HASKELL__-    -- * Debugging-    , showTree-    , showTreeWith-#endif+    , findMin+    , findMax+    , deleteFindMin+    , deleteFindMax     ) where  import Data.IntMap.Strict.Internal
src/Data/IntMap/Strict/Internal.hs view
@@ -1,11 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-} -{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}--#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.IntMap.Strict.Internal@@ -15,54 +10,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 +37,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,27 +53,30 @@  module Data.IntMap.Strict.Internal (     -- * Map type-#if !defined(TESTING)     IntMap, Key          -- instance Eq,Show-#else-    IntMap(..), Key          -- instance Eq,Show-#endif      -- * Construction     , empty     , singleton     , fromSet+    , fromSetA+    , fromSetMaybe+    , fromSetMaybeA      -- ** From Unordered Lists     , fromList     , fromListWith     , fromListWithKey+    , fromListUpsert -    -- ** From Ascending Lists+    -- ** From Ordered Lists     , fromAscList     , fromAscListWith     , fromAscListWithKey+    , fromAscListUpsert     , fromDistinctAscList+    , fromDescList+    , fromDescListUpsert      -- * Insertion     , insert@@ -116,10 +86,12 @@      -- * Deletion\/Update     , delete+    , pop     , adjust     , adjustWithKey     , update     , updateWithKey+    , upsert     , updateLookupWithKey     , alter     , alterF@@ -140,6 +112,7 @@     -- ** Size     , null     , size+    , compareSize      -- * Combine @@ -161,6 +134,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -211,6 +187,7 @@      -- * Filter     , filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -251,34 +228,37 @@     , maxView     , minViewWithKey     , maxViewWithKey--#ifdef __GLASGOW_HASKELL__-    -- * Debugging-    , showTree-    , showTreeWith-#endif     ) where  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, nomatch, left, signBranch, branchMask) import Data.IntMap.Internal   ( IntMap (..)-  , Key-  , mask-  , branchMask-  , nomatch-  , zero-  , natFromInt-  , intFromNat   , bin-  , binCheckLeft-  , binCheckRight+  , binCheckL+  , binCheckR   , link-  , linkWithMask+  , linkKey+  , MonoState(..)+  , Stack(..)+  , ascLinkTop+  , ascLinkAll+  , descInsert+  , descLinkTop+  , descLinkAll+  , IntMapBuilder(..)+  , BStack(..)+  , emptyB+  , insertB+  , finishB+  , moveToB+  , MoveResult(..)+  , treeFromIntSetTip    , (\\)   , (!)@@ -286,6 +266,7 @@   , empty   , assocs   , filter+  , filterKeys   , filterWithKey   , findMin   , findMax@@ -302,6 +283,7 @@   , mergeWithKey'   , compose   , delete+  , pop   , deleteMin   , deleteMax   , deleteFindMax@@ -315,6 +297,7 @@   , isSubmapOf   , isSubmapOfBy   , lookup+  , findWithDefault   , lookupLE   , lookupGE   , lookupLT@@ -338,9 +321,11 @@   , spanAntitone   , restrictKeys   , size+  , compareSize   , split   , splitLookup   , splitRoot+  , symmetricDifference   , toAscList   , toDescList   , toList@@ -348,35 +333,15 @@   , unions   , withoutKeys   )-#ifdef __GLASGOW_HASKELL__-import Data.IntMap.Internal.DeprecatedDebug (showTree, showTreeWith)-#endif+import Data.IntSet.Internal (IntSet) import qualified Data.IntSet.Internal as IntSet-import Utils.Containers.Internal.BitUtil-import Utils.Containers.Internal.StrictPair+import Utils.Containers.Internal.Strict (StrictPair(..), toPair) import qualified Data.Foldable as Foldable--{---------------------------------------------------------------------  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'+import Data.Functor.Identity (Identity (..)) --- 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+#ifdef __GLASGOW_HASKELL__+import Data.Coerce+#endif  {--------------------------------------------------------------------   Construction@@ -406,10 +371,10 @@ 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@@ -451,10 +416,10 @@ 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@@ -482,10 +447,10 @@   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)@@ -517,10 +482,10 @@ 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@@ -551,10 +516,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    -> binCheckL p (updateWithKey f k l) r+      | otherwise   -> binCheckR p l (updateWithKey f k r)     Tip ky y       | k==ky         -> case f k y of                            Just !y' -> Tip ky y'@@ -562,7 +527,27 @@       | otherwise     -> t     Nil -> Nil --- | \(O(\min(n,W))\). Lookup and update.+-- | \(O(\min(n,W))\). Update the value at a key or insert a value if the key is+-- not in the map.+--+-- @+-- let inc = maybe 1 (+1)+-- upsert inc 100 (fromList [(100,1),(300,2)]) == fromList [(100,2),(300,2)]+-- upsert inc 200 (fromList [(100,1),(300,2)]) == fromList [(100,1),(200,1),(300,2)]+-- @+--+-- @since 0.8.1+upsert :: (Maybe a -> a) -> Key -> IntMap a -> IntMap a+upsert f !k t@(Bin p l r)+  | nomatch k p = linkKey k (Tip k $! f Nothing) p t+  | left k p = Bin p (upsert f k l) r+  | otherwise = Bin p l (upsert f k r)+upsert f !k t@(Tip ky y)+  | k == ky = Tip ky $! f (Just y)+  | otherwise = link k (Tip k $! f Nothing) ky t+upsert f !k Nil = Tip k $! f Nothing++-- | \(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.@@ -577,10 +562,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 :*: binCheckL p l' r)+          | otherwise   -> let (found :*: r') = go f k r in (found :*: binCheckR p l r')         Tip ky y           | k==ky         -> case f k y of                                Just !y' -> (Just y :*: Tip ky y')@@ -596,12 +581,12 @@ 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    -> binCheckL p (alter f k l) r+      | otherwise   -> binCheckR p l (alter f k r)     Tip ky y       | k==ky         -> case f (Just y) of                            Just !x -> Tip ky x@@ -613,32 +598,31 @@                            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:------ @--- 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'. --+-- === Examples+--+-- @+-- -- Lookup the value at the key, and also remove the existing value or set a new value.+-- lookupAndSet :: Key -> Maybe a -> IntMap a -> (Maybe a, IntMap a)+-- lookupAndSet k new = alterF (\\old -> (old, new)) k+-- @+--+-- @+-- -- Delete the value at the key. If it is absent the result is Nothing.+-- mustDelete :: Key -> IntMap a -> Maybe (IntMap a)+-- mustDelete = alterF (Nothing <$)+-- @+-- -- @since 0.5.8  alterF :: Functor f@@ -649,7 +633,7 @@     Nothing -> maybe m (const (delete k m)) mv     Just !v' -> insert k v' m   where mv = lookup k m-+{-# INLINE alterF #-}  {--------------------------------------------------------------------   Union@@ -662,18 +646,21 @@ unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a unionsWith f ts   = Foldable.foldl' (unionWith f) empty ts+{-# INLINE unionsWith #-} -- Inline for list fusion --- | \(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+unionWith f = unionWithKey (\_ x y -> f x y)+{-# INLINE unionWith #-} --- | \(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")]@@ -682,23 +669,30 @@  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+  = mergeWithKey' Bin f' id id m1 m2+  where+    f' (Tip k1 x1) (Tip _k2 x2) = Tip k1 $! f k1 x1 x2+    f' _ _ = error "not Tip"+-- See Note [INLINABLE to expose unfoldings] in Data.IntMap.Internal+{-# INLINABLE unionWithKey #-}  {--------------------------------------------------------------------   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")]) -- >     == 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+differenceWith f = differenceWithKey (\_ x y -> f x y)+{-# INLINE differenceWith #-} --- | \(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@.@@ -710,38 +704,48 @@ differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a differenceWithKey f m1 m2   = mergeWithKey f id (const Nil) m1 m2+-- See Note [INLINABLE to expose unfoldings] in Data.IntMap.Internal+{-# INLINABLE differenceWithKey #-}  {--------------------------------------------------------------------   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"  intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c-intersectionWith f m1 m2-  = intersectionWithKey (\_ x y -> f x y) m1 m2+intersectionWith f = intersectionWithKey (\_ x y -> f x y)+{-# INLINE intersectionWith #-} --- | \(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"  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' bin f' (const Nil) (const Nil) m1 m2+  where+    f' (Tip k1 x1) (Tip _k2 x2) = Tip k1 $! f k1 x1 x2+    f' _ _ = error "not Tip"+-- See Note [INLINABLE to expose unfoldings] in Data.IntMap.Internal+{-# INLINABLE intersectionWithKey #-}  {--------------------------------------------------------------------   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. --@@ -775,9 +779,11 @@ 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+  where+        combine (Tip k1 x1) (Tip _k2 x2) = case f k1 x1 x2 of+          Nothing -> Nil+          Just !x -> Tip k1 x+        combine _ _ = error "not Tip"         {-# INLINE combine #-} {-# INLINE mergeWithKey #-} @@ -785,39 +791,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 -> binCheckR 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) = binCheckL 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 -> binCheckL 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) = binCheckR 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"@@ -825,7 +831,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"@@ -844,9 +850,9 @@ 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 #-}@@ -864,9 +870,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@@ -880,7 +886,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) =@@ -910,9 +916,9 @@   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.@@ -924,9 +930,10 @@     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)+{-# INLINE traverseMaybeWithKey #-}  -- | \(O(n)\). The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys.@@ -956,15 +963,15 @@   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) @@ -975,21 +982,24 @@   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@. --+-- If `f` is monotonically non-decreasing or monotonically non-increasing, 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@.@@ -1000,7 +1010,10 @@ -- 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) []+mapKeysWith c f t =+  finishB (foldlWithKey' (\b kx x -> insertWithB c (f kx) x b) emptyB t)+-- See Note [INLINABLE to expose unfoldings] in Data.IntMap.Internal+{-# INLINABLE mapKeysWith #-}  {--------------------------------------------------------------------   Filter@@ -1019,8 +1032,8 @@ -- > 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@@ -1051,8 +1064,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@@ -1065,50 +1078,103 @@   Conversions --------------------------------------------------------------------} --- | \(O(n)\). Build a map from a set of keys and a function which for each key--- computes its value.+-- | \(O(n)\). Build a map from an 'IntSet' 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)+fromSet :: (Key -> a) -> IntSet -> IntMap a+#ifdef __GLASGOW_HASKELL__+fromSet =+  (coerce :: ((Key -> Identity a) -> IntSet -> Identity (IntMap a))+          -> (Key -> a) -> IntSet -> IntMap a)+    fromSetA+#else+fromSet f = runIdentity . fromSetA (pure . f)+#endif +-- | \(O(n)\). Build a map from an 'IntSet' of keys and a function which for+-- each key computes its value, while within an 'Applicative' context.+--+-- The @Applicative@ actions are sequenced in order of increasing key.+--+-- > let f k = if k == 0 then Nothing else Just (6 `div` k)+-- > fromSetA f (Data.Set.fromList [1,2,3,4]) == Just (fromList [(1,6),(2,3),(3,2),(4,1)])+-- > fromSetA f (Data.Set.fromList [0,1,2]) == Nothing+--+-- @since 0.8.1+fromSetA :: Applicative f => (Key -> f a) -> IntSet -> f (IntMap a)+fromSetA _ IntSet.Nil = pure Nil+fromSetA f (IntSet.Bin p l r)+  | signBranch p = liftA2 (flip (Bin p)) (fromSetA f r) (fromSetA f l)+  | otherwise = liftA2 (Bin p) (fromSetA f l) (fromSetA f r)+fromSetA f (IntSet.Tip kx bm) =+  treeFromIntSetTip+    (\kx' -> (Tip kx' $!) <$> f kx')+    (\p -> liftA2 (Bin p))+    kx+    bm+{-# INLINABLE fromSetA #-}++-- | \(O(n)\). Build a map from an 'IntSet' of keys and a function which for each+-- key optionally computes its value.+--+-- > let f k = if even k then Just (replicate k 'a') else Nothing+-- > fromSetMaybe f (Data.IntSet.fromList [1,2,3,4]) == fromList [(2,"aa"), (4,"aaaa")]+--+-- @since 0.8.1+fromSetMaybe :: (Key -> Maybe a) -> IntSet -> IntMap a+#ifdef __GLASGOW_HASKELL__+fromSetMaybe =+  (coerce :: ((Key -> Identity (Maybe a)) -> IntSet -> Identity (IntMap a))+          -> (Key -> Maybe a) -> IntSet -> IntMap a)+    fromSetMaybeA+#else+fromSetMaybe f s = runIdentity (fromSetMaybeA (Identity . f) s)+#endif++-- | \(O(n)\). Build a map from an 'IntSet' of keys and a function which for+-- each key optionally computes its value in an 'Applicative' context.+--+-- The @Applicative@ actions are sequenced in order of increasing key.+--+-- @since 0.8.1+fromSetMaybeA :: Applicative f => (Key -> f (Maybe a)) -> IntSet -> f (IntMap a)+fromSetMaybeA f = go+  where+   go IntSet.Nil = pure Nil+   go (IntSet.Bin p l r)+     | signBranch p = liftA2 (flip (bin p)) (go r) (go l)+     | otherwise = liftA2 (bin p) (go l) (go r)+   go (IntSet.Tip kx bm) =+     treeFromIntSetTip+       (\kx' -> maybe Nil (Tip kx' $!) <$> f kx')+       (\p -> liftA2 (bin p))+       kx+       bm+{-# INLINABLE fromSetMaybeA #-}+ {--------------------------------------------------------------------   Lists --------------------------------------------------------------------} -- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs. --+-- If the keys are in sorted order, ascending or descending, 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 :: [(Key,a)] -> IntMap a-fromList xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x)  = insert k x t+fromList xs = finishB (Foldable.foldl' (\b (kx,!x) -> insertB kx x b) emptyB xs)+{-# INLINE fromList #-} -- Inline for list fusion --- | \(O(n \min(n,W))\). Build 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. --+-- If the keys are in sorted order, ascending or descending, this function+-- takes \(O(n)\) time.+-- -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")] -- > fromListWith (++) [] == empty --@@ -1116,6 +1182,8 @@ -- -- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@. --+-- See also: 'fromListUpsert'+-- -- === Performance -- -- You should ensure that the given @f@ is fast with this order of arguments.@@ -1146,125 +1214,209 @@ fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a fromListWith f xs   = fromListWithKey (\_ x y -> f x y) xs+{-# INLINE fromListWith #-} -- Inline for list fusion --- | \(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. --+-- If the keys are in sorted order, ascending or descending, 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'.+--+-- See also: 'fromListUpsert'  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+fromListWithKey f xs =+  finishB (Foldable.foldl' (\b (kx,x) -> insertWithB (f kx) kx x b) emptyB xs)+{-# INLINE fromListWithKey #-} -- Inline for list fusion +-- | \(O(n \min(n,W)\). Build a map from a list of key\/value pairs with a+-- combining function.+--+-- If the keys are in sorted order, ascending or descending, this function+-- takes \(O(n)\) time.+--+-- The result is equivalent to performing an @upsert@ for every key\/value in+-- the list.+--+-- @+-- fromListUpsert f = foldl' (\\m (k, x) -> 'upsert' (f x) k m) 'empty'+-- @+--+-- > let f x = maybe [x] (x:)+-- > fromListUpsert f [(5,'a'), (5,'b'), (3,'c'), (3,'d'), (5,'e')] == fromList [(3,"dc"), (5,"eba")]+--+-- @since 0.8.1+fromListUpsert :: (a -> Maybe b -> b) -> [(Key, a)] -> IntMap b+fromListUpsert f xs =+  finishB (Foldable.foldl' (\b (kx, x) -> upsertB (f x) kx b) emptyB xs)+{-# INLINE fromListUpsert #-}  -- INLINE for fusion+ -- | \(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 #-}+fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs+{-# INLINE fromAscList #-} -- Inline for list fusion  -- | \(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'.+--+-- See also: 'fromAscListUpsert'  fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a-fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)-{-# NOINLINE fromAscListWith #-}+fromAscListWith f xs = fromAscListWithKey (\_ x y -> f x y) xs+{-# INLINE fromAscListWith #-} -- Inline for list fusion  -- | \(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")]+-- __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"), (3,"a"), (5,"a"), (5,"b"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromAscListWithKey f [] == empty+-- -- Also see the performance note on 'fromListWith'.+--+-- See also: 'fromAscListUpsert' +-- See Note [fromAscList implementation] in Data.IntMap.Internal. fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a-fromAscListWithKey f = fromMonoListWithKey Nondistinct f-{-# NOINLINE fromAscListWithKey #-}+fromAscListWithKey f xs = ascLinkAll (Foldable.foldl' next MSNada xs)+  where+    next s (!ky, y) = case s of+      MSNada -> msPush' ky y Nada+      MSPush kx x stk+        | kx == ky -> msPush' ky (f ky y x) stk+        | otherwise -> let m = branchMask kx ky+                       in msPush' ky y (ascLinkTop stk kx (Tip kx x) m)+    msPush' ky !y = MSPush ky y+{-# INLINE fromAscListWithKey #-} -- Inline for list 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 'fromListUpsert'+-- if the precondition may not hold.+--+-- > let f x = maybe [x] (x:)+-- > fromAscListUpsert f [(3,'a'), (3,'b'), (5,'c'), (5,'d'), (5,'e')] == fromList [(3,"ba"), (5,"edc")]+--+-- @since 0.8.1+fromAscListUpsert :: (a -> Maybe b -> b) -> [(Key, a)] -> IntMap b+fromAscListUpsert f xs = ascLinkAll (Foldable.foldl' next MSNada xs)+  where+    next s (!ky, y) = case s of+      MSNada -> msPush' ky (f y Nothing) Nada+      MSPush kx x stk+        | kx == ky -> msPush' ky (f y (Just x)) stk+        | otherwise ->+            let m = branchMask kx ky+            in msPush' ky (f y Nothing) (ascLinkTop stk kx (Tip kx x) m)+    msPush' ky !y = MSPush ky y+{-# INLINE fromAscListUpsert #-} -- Inline for list fusion+ -- | \(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 = 'fromAscList'@+--+-- See warning on 'fromAscList'.+--+-- This definition exists for backwards compatibility. It offers no advantage+-- over @fromAscList@. fromDistinctAscList :: [(Key,a)] -> IntMap a-fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)-{-# NOINLINE fromDistinctAscList #-}+-- See Note on Data.IntMap.Internal.fromDistinctAscList.+fromDistinctAscList = fromAscList+{-# INLINE fromDistinctAscList #-} -- Inline for list fusion --- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys--- and a combining function.+-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in descending order. ----- 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.+-- __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. ----- Also see the performance note on 'fromListWith'.+-- > fromDescList [(5,"a"), (3,"b")]          == fromList [(3,"b"), (5,"a")]+-- > fromDescList [(5,"a"), (5,"b"), (3,"b")] == fromList [(3,"b"), (5,"b")]+--+-- @since 0.8.1+fromDescList :: [(Key,a)] -> IntMap a+fromDescList xs =+  descLinkAll (Foldable.foldl' (\s (!ky, !y) -> descInsert ky y s) MSNada xs)+{-# INLINE fromDescList #-} -- Inline for list fusion -fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a-fromMonoListWithKey distinct f = go+-- | \(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 'fromListUpsert'+-- if the precondition may not hold.+--+-- > let f x = maybe [x] (x:)+-- > fromDescListUpsert f [(5,'a'), (5,'b'), (5,'c'), (3,'d'), (3,'e')] == fromList [(3,"ed"), (5,"cba")]+--+-- @since 0.8.1+fromDescListUpsert :: (a -> Maybe b -> b) -> [(Key, a)] -> IntMap b+fromDescListUpsert f xs = descLinkAll (Foldable.foldl' next MSNada xs)   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'+    next s (!ky, y) = case s of+      MSNada -> msPush' ky (f y Nothing) Nada+      MSPush kx x stk+        | kx == ky -> msPush' ky (f y (Just x)) stk+        | otherwise ->+            let m = branchMask kx ky+            in msPush' ky (f y Nothing) (descLinkTop kx (Tip kx x) m stk)+    msPush' ky !y = MSPush ky y+{-# INLINE fromDescListUpsert #-} -- Inline for list fusion -    -- `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 #-}+{--------------------------------------------------------------------+  IntMapBuilder+--------------------------------------------------------------------} -data Inserted a = Inserted !(IntMap a) ![(Key,a)]+-- 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 :: (a -> a -> a) -> Key -> a -> IntMapBuilder a -> IntMapBuilder a+insertWithB f !ky y b = case b of+  BNil -> btip' ky y BNada+  BTip kx x stk -> case moveToB ky kx x stk of+    MoveResult m stk' -> case m of+      Nothing -> btip' ky y stk'+      Just x' -> btip' ky (f y x') stk'+  where+    btip' kx !x = BTip kx x+{-# INLINE insertWithB #-} -data Distinct = Distinct | Nondistinct+-- Upsert a key-value. The given function is used to generate the value based+-- on the existing value for the key.+upsertB :: (Maybe a -> a) -> Key -> IntMapBuilder a -> IntMapBuilder a+upsertB f !ky b = case b of+  BNil -> btip' ky (f Nothing) BNada+  BTip kx x stk -> case moveToB ky kx x stk of+    MoveResult m stk' -> btip' ky (f m) stk'+  where+    btip' kx !x = BTip kx x+{-# INLINE upsertB #-}
src/Data/IntSet.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.IntSet@@ -17,7 +15,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 +28,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,18 +52,46 @@ -- 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@@ -79,12 +101,14 @@             , fromRange             , fromAscList             , fromDistinctAscList+            , fromDescList              -- * Insertion             , insert              -- * Deletion             , delete+            , pop              -- * Generalized insertion/deletion             , alterF@@ -98,6 +122,7 @@             , lookupGE             , IS.null             , size+            , compareSize             , isSubsetOf             , isProperSubsetOf             , disjoint@@ -108,6 +133,9 @@             , difference             , (\\)             , intersection+            , intersections+            , symmetricDifference+            , Intersection(..)              -- * Filter             , IS.filter@@ -117,6 +145,8 @@             , dropWhileAntitone             , spanAntitone +            , mapMaybe+             , split             , splitMember             , splitRoot@@ -128,6 +158,7 @@             -- * Folds             , IS.foldr             , IS.foldl+            , IS.foldMap             -- ** Strict folds             , IS.foldr'             , IS.foldl'@@ -135,14 +166,16 @@             , fold              -- * Min\/Max-            , findMin-            , findMax+            , lookupMin+            , lookupMax             , deleteMin             , deleteMax-            , deleteFindMin-            , deleteFindMax             , maxView             , minView+            , findMin+            , findMax+            , deleteFindMin+            , deleteFindMax              -- * Conversion @@ -155,21 +188,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,1825 +1,2274 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# 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.------ = 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-    , fromRange-    , insert-    , delete-    , alterF--    -- * Combine-    , union-    , unions-    , difference-    , intersection--    -- * Filter-    , filter-    , partition--    , takeWhileAntitone-    , dropWhileAntitone-    , spanAntitone--    , 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)-import Data.Semigroup (Semigroup(stimes))-#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup (Semigroup((<>)))-#endif-import Data.Semigroup (stimesIdempotentMonoid)-import Utils.Containers.Internal.Prelude hiding-  (filter, foldr, foldl, foldl', null, map)-import Prelude ()--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 !(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 -}---- 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--#ifdef __GLASGOW_HASKELL__--- | @since 0.6.6-deriving instance Lift IntSet-#endif--instance Monoid IntSet where-    mempty  = empty-    mconcat = unions-    mappend = (<>)---- | @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 + 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(\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 _ 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(\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 _ 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(\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 _ 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(\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 _ 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--{-# 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(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))\). 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 m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then bin p m (go predicate l) r-        else go predicate r-    _ -> go predicate t-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = bin p m 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 m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then go predicate l-        else bin p m l (go predicate r)-    _ -> go predicate t-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = go predicate' r-      | otherwise         = bin p m (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 m l r-      | m < 0 ->-        if predicate 0 -- handle negative numbers.-        then-          case go predicate l of-            (lt :*: gt) ->-              let !lt' = bin p m lt r-              in (lt', gt)-        else-          case go predicate r of-            (lt :*: gt) ->-              let !gt' = bin p m l gt-              in (lt, gt')-    _ -> case go predicate t of-          (lt :*: gt) -> (lt, gt)-  where-    go predicate' (Bin p m l r)-      | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt-      | otherwise         = case go predicate' l of (lt :*: gt) -> lt :*: bin p m 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 m l r-      | m < 0 ->-        if x >= 0  -- handle negative numbers.-        then-          case go x l of-            (lt :*: gt) ->-              let !lt' = bin p m lt r-              in (lt', gt)-        else-          case go x r of-            (lt :*: gt) ->-              let !gt' = bin p m l gt-              in (lt, gt')-    _ -> case go x t of-          (lt :*: gt) -> (lt, gt)-  where-    go !x' t'@(Bin p m l r)-        | nomatch x' p m = if x' < p then (Nil :*: t') else (t' :*: Nil)-        | zero x' m      = case go x' l of (lt :*: gt) -> lt :*: bin p m gt r-        | otherwise      = case go x' r of (lt :*: gt) -> bin p m 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 m l r-      | m < 0 ->-        if x >= 0 -- handle negative numbers.-        then-          case go x l of-            (lt, fnd, gt) ->-              let !lt' = bin p m lt r-              in (lt', fnd, gt)-        else-          case go x r of-            (lt, fnd, gt) ->-              let !gt' = bin p m l gt-              in (lt, fnd, gt')-    _ -> go x t-  where-    go x' t'@(Bin p m l r)-        | nomatch x' p m = if x' < p then (Nil, False, t') else (t', False, Nil)-        | zero x' m =-          case go x' l of-            (lt, fnd, gt) ->-              let !gt' = bin p m gt r-              in (lt, fnd, gt')-        | otherwise =-          case go x' r of-            (lt, fnd, gt) ->-              let !lt' = bin p m 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 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' &#8211;--- 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' &#8211;--- 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---------------------------------------------------------------------}--#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 = mask lx m-      in if m < 0  -- handle negative numbers-         then Bin 0 m (goR 0) (goL 0)-         else Bin p m (goL (p .|. m)) (goR (p .|. m))-  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 :: Prefix -> 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-              p' = p `xor` m-              l' = Bin p' m l (goFull p (shr1 m))-          in go l' (p + m)-    -- goR p0 = fromList [p0 .. rx]-    -- Expected: p0 is a prefix of rx-    goR :: Prefix -> 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 p' m (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 :: Prefix -> Mask -> IntSet-    goFull p m-      | m < suffixBitMask = Tip p (complement 0)-      | otherwise         = Bin p m (goFull p (shr1 m)) (goFull (p .|. m) (shr1 m))-    lbm :: Prefix -> Prefix-    lbm p = intFromNat (lowestBitMask (natFromInt p))-    {-# INLINE lbm #-}-    shr1 :: Mask -> Mask-    shr1 m = intFromNat (natFromInt m `shiftRL` 1)-    {-# INLINE shr1 #-}---- | \(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--{---------------------------------------------------------------------  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 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 (_ : 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 :: 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-suffixBitMask = finiteBitSize (undefined::Word) - 1-{-# 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-takeWhileAntitoneBits :: Int -> (Int -> Bool) -> Nat -> Nat--{-# INLINE lowestBitSet #-}-{-# INLINE highestBitSet #-}-{-# INLINE foldlBits #-}-{-# INLINE foldl'Bits #-}-{-# INLINE foldrBits #-}-{-# INLINE foldr'Bits #-}-{-# INLINE takeWhileAntitoneBits #-}--#if defined(__GLASGOW_HASKELL__) && (WORD_SIZE_IN_BITS==32 || WORD_SIZE_IN_BITS==64)-indexOfTheOnlyBit :: Nat -> Int-{-# INLINE indexOfTheOnlyBit #-}-#if 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--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)--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 _ m l r) | m < 0 = [r, l]-                        | otherwise = [l, r]+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveLift #-}+{-# 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+    , compareSize+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , isSubsetOf+    , isProperSubsetOf+    , disjoint++    -- * Construction+    , empty+    , singleton+    , fromRange+    , insert+    , delete+    , pop+    , alterF++    -- * Combine+    , union+    , unions+    , difference+    , intersection+    , intersections+    , symmetricDifference+    , Intersection(..)++    -- * Filter+    , filter+    , partition++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe++    , 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+    , fromDescList++    -- * Debugging+    , showTree+    , showTreeWith++    -- * Internals+    , suffixBitMask+    , prefixBitMask+    , prefixOf+    , suffixOf+    , 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.Strict+  (StrictPair(..), StrictTriple(..), toPair)+import Data.IntSet.Internal.IntTreeCommons+  ( Key+  , Prefix(..)+  , nomatch+  , left+  , signBranch+  , mask+  , branchMask+  , branchPrefix+  , 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 __GLASGOW_HASKELL__ >= 914+import Language.Haskell.TH.Lift (Lift)+#  else+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#  endif+#endif++import qualified Data.Foldable as Foldable++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 of+--   (WORD_SIZE - lg(WORD_SIZE)) bits followed by lg(WORD_SIZE) 0s 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 _ bm, bm is never 0.+--+--+-- As an example, consider that on a 32-bit system we have a Bin with Prefix+--+-- 0b00000000000100100000011000000000+--                         ^ mask bit+--   ^^^^^^^^^^^^^^^^^^^^^^ shared prefix+--+-- The key+-- 0b00000000000100100000010000010100 belongs under this Bin, since it matches+-- the shared prefix. The mask bit is 0, so it belongs in the left child and not+-- the right.+--+-- The key+-- 0b00000000000100000000010000010100 does not belong under this Bin, since it+-- does not match the shared prefix.+--+--+-- Now consider that we have a (Tip kx bm) with kx and bm as+--+-- 0b00000000001010000000000001000000  0b00000000000100000100000000000100+--                                                  ^     ^           ^+--                                                 20    14           2  -- suffixes+--   ^^^^^^^^^^^^^^^^^^^^^^^^^^^ shared prefix+--+-- This Tip has 3 keys, which can be recovered by bitwise-or-ing the prefix and+-- the suffixes:+--+-- 0b00000000001010000000000001000010+-- 0b00000000001010000000000001001110+-- 0b00000000001010000000000001010100++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+deriving instance Lift IntSet+#endif++-- | @mempty@ = 'empty'+instance Monoid IntSet where+    mempty  = empty+    mconcat = unions+#if !MIN_VERSION_base(4,11,0)+    mappend = (<>)+#endif++-- | @(<>)@ = '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.+--+-- __Note__: Unlike @Data.Set.'Data.Set.size'@, this is /not/ \(O(1)\).+--+-- See also: 'compareSize'+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,c))\). Compare the number of elements in the set to an @Int@.+--+-- @compareSize m c@ returns the same result as @compare ('size' m) c@ but is+-- more efficient when @c@ is smaller than the size of the set.+--+-- @since 0.8.1+compareSize :: IntSet -> Int -> Ordering+compareSize Nil c0 = compare 0 c0+compareSize _ c0 | c0 <= 0 = GT+compareSize t c0 = compare 0 (go t (c0 - 1))+  where+    go (Bin _ _ _) 0 = -1+    go (Bin _ l r) c+      | c' < 0 = c'+      | otherwise = go r c'+      where+        c' = go l (c - 1)+    go (Tip _ bm) c = c + 1 - popCount bm+    go Nil !_ = error "compareSize.go: Nil"++-- | \(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.+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    = binCheckL p (deleteBM kx bm l) r+  | otherwise    = binCheckR 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))\). Pop an element from the set.+--+-- Returns @Nothing@ if the element is not a member of the set. Otherwise+-- returns @Just@ the set with the element removed.+--+-- @+-- pop 1 (fromList [0,2,4]) == Nothing+-- pop 2 (fromList [0,2,4]) == Just (fromList [0,4])+-- @+--+-- @since 0.8.1+pop :: Key -> IntSet -> Maybe IntSet+pop x0 t0 = case go x0 t0 of+  True :*: t -> Just t+  _ -> Nothing+  where+    -- We use `StrictPair Bool IntSet` instead of a sum to avoid allocations.+    -- See Note [Popped impl] in Data.Map.Internal+    go !x (Bin p l r)+      | nomatch x p = False :*: Nil+      | left x p = case go x l of+          True :*: l' -> True :*: binCheckL p l' r+          q -> q+      | otherwise = case go x r of+          True :*: r' -> True :*: binCheckR p l r'+          q -> q+    go !x (Tip ky bmy)+      | prefixOf x == ky && bmx .&. bmy /= 0 = True :*: tip ky (bmx `xor` bmy)+      | otherwise = False :*: Nil+      where+        bmx = bitmapOf x+    go !_ Nil = False :*: 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".+--+-- === Examples+--+-- @+-- -- Get whether the element is a member, and also insert or remove it.+-- getAndSet :: Key -> Bool -> IntSet -> (Bool, IntSet)+-- getAndSet x new = alterF (\\old -> (old, new)) x+-- @+--+-- @+-- -- Delete the element. If it is absent the result is Nothing.+-- mustDelete :: Key -> IntSet -> Maybe IntSet+-- mustDelete = alterF (\\b -> if b then Just False else Nothing)+-- @+--+-- @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 = if member_ then s else insert k s+    deleted = if member_ then delete k s else s+    choose True  = inserted+    choose False = deleted+#ifdef __GLASGOW_HASKELL__+{-# INLINE [2] alterF #-}++{-# RULES+"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s+ #-}+#endif++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of sets.+unions :: Foldable f => f IntSet -> IntSet+unions xs+  = Foldable.foldl' union empty xs+{-# INLINE unions #-} -- Inline for list fusion++-- | \(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 -> binCheckL p1 (difference l1 t2) r1+  ABR -> binCheckR 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 -> binCheckL p1 (symmetricDifference l1 t2) r1+    ABR -> binCheckR p1 l1 (symmetricDifference r1 t2)+    BAL -> binCheckL p2 (symmetricDifference t1 l2) r2+    BAR -> binCheckR 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 = binCheckL p2 (go l2) r2+      | otherwise = binCheckR 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)\). Keep 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 \min(n,W))\). Map elements and collect the 'Just' results.+--+-- If the function is monotonically non-decreasing or monotonically+-- non-increasing, 'mapMaybe' takes \(O(n)\) time.+--+-- @since 0.8.1+mapMaybe :: (Key -> Maybe Key) -> IntSet -> IntSet+mapMaybe f t = finishB (foldl' go emptyB t)+  where go b x = case f x of+          Nothing -> b+          Just x' -> insertB x' b+-- See Note [INLINABLE to expose unfoldings] in Data.IntMap.Internal+{-# INLINABLE mapMaybe #-}++-- | \(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 binCheckL p (go predicate l) r+        else go predicate r+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = binCheckR 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 binCheckR p l (go predicate r)+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = go predicate' r+      | otherwise               = binCheckL 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' = binCheckL p lt r+              in (lt', gt)+        else+          case go predicate r of+            (lt :*: gt) ->+              let !gt' = binCheckR 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) -> binCheckR p l lt :*: gt+      | otherwise               = case go predicate' l of (lt :*: gt) -> lt :*: binCheckL 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' = binCheckL p lt r+              in (lt', gt)+        else+          case go x r of+            (lt :*: gt) ->+              let !gt' = binCheckR 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 :*: binCheckL p gt r+        | otherwise    = case go x' r of (lt :*: gt) -> binCheckR 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+            TripleS lt fnd gt ->+              let !lt' = binCheckL p lt r+              in (lt', fnd, gt)+        else+          case go x r of+            TripleS lt fnd gt ->+              let !gt' = binCheckR p l gt+              in (lt, fnd, gt')+    _ -> case go x t of+      TripleS lt fnd gt -> (lt, fnd, gt)+  where+    go !x' t'@(Bin p l r)+        | nomatch x' p = if x' < unPrefix p+                         then TripleS Nil False t'+                         else TripleS t' False Nil+        | left x' p =+          case go x' l of+            TripleS lt fnd gt -> TripleS lt fnd (binCheckL p gt r)+        | otherwise =+          case go x' r of+            TripleS lt fnd gt -> TripleS (binCheckR p l lt) fnd gt+    go x' t'@(Tip kx' bm)+        | kx' > x'          = TripleS Nil False t'+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = TripleS t' False Nil+        | otherwise = let !lt = tip kx' (bm .&. lowerBitmap)+                          !found = (bm .&. bitmapOfx') /= 0+                          !gt = tip kx' (bm .&. higherBitmap)+                      in TripleS lt found gt+            where bitmapOfx' = bitmapOf x'+                  lowerBitmap = bitmapOfx' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOfx')+    go _ Nil = TripleS 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, binCheckL p l' r)+            _ -> Just (go t)+  where+    go (Bin p l r) = case go r of (result, r') -> (result, binCheckR 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, binCheckR p l r')+            _ -> Just (go t)+  where+    go (Bin p l r) = case go l of (result, l') -> (result, binCheckL 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.+--+-- Calls 'error' if the set is empty.+--+-- __Note__: This function is partial. Prefer 'minView'.+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.+--+-- Calls 'error' if the set is empty.+--+-- __Note__: This function is partial. Prefer 'maxView'.+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.+--+-- __Note__: This function is partial. Prefer 'lookupMin'.+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.+--+-- __Note__: This function is partial. Prefer 'lookupMax'.+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' &#8211;+-- 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' &#8211;+-- 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@.+--+-- If `f` is monotonically non-decreasing or monotonically non-increasing, 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 :: (Key -> Key) -> IntSet -> IntSet+map f t = finishB (foldl' (\b x -> insertB (f x) b) emptyB t)+-- See Note [INLINABLE to expose unfoldings] in Data.IntMap.Internal+{-# INLINABLE map #-}++-- | \(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+mapMonotonic :: (Key -> Key) -> IntSet -> IntSet+mapMonotonic f t = ascLinkAll (foldl' (\s x -> ascInsert s (f x)) MSNada t)+-- See Note [INLINABLE to expose unfoldings] in Data.IntMap.Internal+{-# INLINABLE mapMonotonic #-}++{--------------------------------------------------------------------+  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++-- See Note [IntMap folds] in Data.IntMap.Internal+foldr :: (Key -> b -> b) -> b -> IntSet -> b+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Nil -> z+    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 _ Nil          = error "foldr.go: Nil"+    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.++-- See Note [IntMap folds] in Data.IntMap.Internal+foldr' :: (Key -> b -> b) -> b -> IntSet -> b+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Nil -> z+    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 !_ Nil         = error "foldr'.go: Nil"+    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++-- See Note [IntMap folds] in Data.IntMap.Internal+foldl :: (a -> Key -> a) -> a -> IntSet -> a+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Nil -> z+    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 _ Nil          = error "foldl.go: Nil"+    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.++-- See Note [IntMap folds] in Data.IntMap.Internal+foldl' :: (a -> Key -> a) -> a -> IntSet -> a+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Nil -> z+    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 !_ Nil         = error "foldl'.go: Nil"+    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++-- See Note [IntMap folds] in Data.IntMap.Internal+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+    Nil -> mempty+    _ -> 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 = error "foldMap.go: Nil"+{-# 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.+--+-- If the keys are in sorted order, ascending or descending, this function+-- takes \(O(n)\) time.+fromList :: [Key] -> IntSet+fromList xs = finishB (Foldable.foldl' (flip insertB) emptyB xs)+{-# INLINE fromList #-} -- Inline for list fusion++-- | \(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 p = branchPrefix lx rx+      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.++-- See Note [fromAscList implementation] in Data.IntMap.Internal.+fromAscList :: [Key] -> IntSet+fromAscList xs = ascLinkAll (Foldable.foldl' ascInsert MSNada xs)+{-# INLINE fromAscList #-} -- Inline for list fusion++-- | \(O(n)\). Build a set from an ascending list of distinct elements.+--+-- @fromDistinctAscList = 'fromAscList'@+--+-- See warning on 'fromAscList'.+--+-- This definition exists for backwards compatibility. It offers no advantage+-- over @fromAscList@.+fromDistinctAscList :: [Key] -> IntSet+-- See note on Data.IntMap.Internal.fromDisinctAscList.+fromDistinctAscList = fromAscList+{-# INLINE fromDistinctAscList #-} -- Inline for list fusion++-- | \(O(n)\). Build a set from an descending list of elements.+--+-- __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.8.1++-- See Note [fromAscList implementation] in Data.IntMap.Internal.+fromDescList :: [Key] -> IntSet+fromDescList xs = descLinkAll (Foldable.foldl' descInsert MSNada xs)+{-# INLINE fromDescList #-} -- Inline for list fusion++data Stack+  = Nada+  | Push {-# UNPACK #-} !Int !IntSet !Stack++data MonoState+  = MSNada+  | MSPush {-# UNPACK #-} !Int {-# UNPACK #-} !BitMap !Stack++-- Insert an element. The element must be >= the last inserted element.+ascInsert :: MonoState -> Int -> MonoState+ascInsert s !ky = case s of+  MSNada -> MSPush py bmy Nada+  MSPush px bmx stk+    | px == py -> MSPush py (bmx .|. bmy) stk+    | otherwise -> let m = branchMask px py+                   in MSPush py bmy (ascLinkTop stk px (Tip px bmx) m)+  where+    py = prefixOf ky+    bmy = bitmapOf ky+{-# INLINE ascInsert #-}++ascLinkTop :: Stack -> Int -> IntSet -> Int -> Stack+ascLinkTop stk !rk r !rm = case stk of+  Nada -> Push rm r stk+  Push m l stk'+    | i2w m < i2w rm -> let p = mask rk m+                        in ascLinkTop stk' rk (Bin p l r) rm+    | otherwise -> Push rm r stk++ascLinkAll :: MonoState -> IntSet+ascLinkAll s = case s of+  MSNada -> Nil+  MSPush px bmx stk -> ascLinkStack stk px (Tip px bmx)+{-# INLINABLE ascLinkAll #-}++ascLinkStack :: Stack -> Int -> IntSet -> IntSet+ascLinkStack stk !rk r = case stk of+  Nada -> r+  Push m l stk'+    | signBranch p -> Bin p r l+    | otherwise -> ascLinkStack stk' rk (Bin p l r)+    where+      p = mask rk m++-- Insert an element. The element must be <= the last inserted element.+descInsert :: MonoState -> Int -> MonoState+descInsert s !ky = case s of+  MSNada -> MSPush py bmy Nada+  MSPush px bmx stk+    | px == py -> MSPush py (bmx .|. bmy) stk+    | otherwise -> let m = branchMask px py+                   in MSPush py bmy (descLinkTop px (Tip px bmx) m stk)+  where+    py = prefixOf ky+    bmy = bitmapOf ky+{-# INLINE descInsert #-}++descLinkTop :: Int -> IntSet -> Int -> Stack -> Stack+descLinkTop !lk l !lm stk = case stk of+  Nada -> Push lm l stk+  Push m r stk'+    | i2w m < i2w lm -> let p = mask lk m+                        in descLinkTop lk (Bin p l r) lm stk'+    | otherwise -> Push lm l stk++descLinkAll :: MonoState -> IntSet+descLinkAll s = case s of+  MSNada -> Nil+  MSPush px bmx stk -> descLinkStack px (Tip px bmx) stk+{-# INLINABLE descLinkAll #-}++descLinkStack :: Int -> IntSet -> Stack -> IntSet+descLinkStack !lk l stk = case stk of+  Nada -> l+  Push m r stk'+    | signBranch p -> Bin p r l+    | otherwise -> descLinkStack lk (Bin p l r) stk'+    where+      p = mask lk m++{--------------------------------------------------------------------+  IntSetBuilder+--------------------------------------------------------------------}++-- See Note [IntMapBuilder] in Data.IntMap.Internal.++data IntSetBuilder+  = BNil+  | BTip {-# UNPACK #-} !Int {-# UNPACK #-} !BitMap !BStack++-- BLeft: the IntMap is the left child+-- BRight: the IntMap is the right child+data BStack+  = BNada+  | BLeft {-# UNPACK #-} !Prefix !IntSet !BStack+  | BRight {-# UNPACK #-} !Prefix !IntSet !BStack++-- Empty builder.+emptyB :: IntSetBuilder+emptyB = BNil++-- Insert an element.+insertB :: Key -> IntSetBuilder -> IntSetBuilder+insertB !ky b = case b of+  BNil -> BTip py bmy BNada+  BTip px bmx stk+    | px == py -> BTip py (bmx .|. bmy) stk+    | otherwise -> insertUpB py bmy px (Tip px bmx) stk+  where+    py = prefixOf ky+    bmy = bitmapOf ky+{-# INLINE insertB #-}++insertUpB :: Int -> BitMap -> Int -> IntSet -> BStack -> IntSetBuilder+insertUpB !py !bmy !px !tx stk = case stk of+  BNada -> BTip py bmy (linkB py px tx BNada)+  BLeft p l stk'+    | nomatch py p -> insertUpB py bmy px (Bin p l tx) stk'+    | left py p -> insertDownB py bmy l (BRight p tx stk')+    | otherwise -> BTip py bmy (linkB py px tx stk)+  BRight p r stk'+    | nomatch py p -> insertUpB py bmy px (Bin p tx r) stk'+    | left py p -> BTip py bmy (linkB py px tx stk)+    | otherwise -> insertDownB py bmy r (BLeft p tx stk')++insertDownB :: Int -> BitMap -> IntSet -> BStack -> IntSetBuilder+insertDownB !py !bmy tx !stk = case tx of+  Bin p l r+    | nomatch py p -> BTip py bmy (linkB py (unPrefix p) tx stk)+    | left py p -> insertDownB py bmy l (BRight p r stk)+    | otherwise -> insertDownB py bmy r (BLeft p l stk)+  Tip px bmx+    | px == py -> BTip py (bmx .|. bmy) stk+    | otherwise -> BTip py bmy (linkB py px tx stk)+  Nil -> error "insertDownB Tip"++linkB :: Key -> Key -> IntSet -> BStack -> BStack+linkB ky kx tx stk+  | i2w ky < i2w kx = BRight p tx stk+  | otherwise = BLeft p tx stk+  where+    p = branchPrefix ky kx+{-# INLINE linkB #-}++-- Finalize the builder into an IntSet.+finishB :: IntSetBuilder -> IntSet+finishB b = case b of+  BNil -> Nil+  BTip px bmx stk -> finishUpB (Tip px bmx) stk+{-# INLINABLE finishB #-}++finishUpB :: IntSet -> BStack -> IntSet+finishUpB !t stk = case stk of+  BNada -> t+  BLeft p l stk' -> finishUpB (Bin p l t) stk'+  BRight p r stk' -> finishUpB (Bin p t r) stk'++{--------------------------------------------------------------------+  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+  | i2w k1 < i2w k2 = Bin p t1 t2+  | otherwise = Bin p t2 t1+  where+    p = branchPrefix k1 k2+{-# INLINE link #-}++{--------------------------------------------------------------------+  @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 #-}++-- binCheckL only checks that the left subtree is non-empty+binCheckL :: Prefix -> IntSet -> IntSet -> IntSet+binCheckL _ Nil r = r+binCheckL p l r = Bin p l r+{-# INLINE binCheckL #-}++-- binCheckR only checks that the right subtree is non-empty+binCheckR :: Prefix -> IntSet -> IntSet -> IntSet+binCheckR _ l Nil = l+binCheckR p l r = Bin p l r+{-# INLINE binCheckR #-}++{--------------------------------------------------------------------+  @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,194 @@+{-# 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+  , branchPrefix+  , i2w+  , Order(..)+  ) where++import Data.Bits (Bits(..), countLeadingZeros)+import Utils.Containers.Internal.BitUtil (iShiftRL)++#ifdef __GLASGOW_HASKELL__+#  if __GLASGOW_HASKELL__ >= 914+import Language.Haskell.TH.Lift (Lift)+#  else+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#  endif+#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 @Int@ @i@ up to the switching bit @m@.+mask :: Int -> Int -> Prefix+mask i m = Prefix ((i .&. negate m) .|. m)+{-# INLINE mask #-}++-- | The first switching bit where the two @Int@s disagree.+--+-- Precondition for defined behavior: i1 /= i2+branchMask :: Int -> Int -> Int+branchMask i1 i2 = iShiftRL (minBound :: Int) (countLeadingZeros (i1 `xor` i2))+{-# INLINE branchMask #-}++-- | The shared prefix of two @Int@s.+--+-- Precondition for defined behavior: i1 /= i2+branchPrefix :: Int -> Int -> Prefix+branchPrefix i1 i2 = Prefix ((i1 .|. i2) .&. m)+  where+    m = unsafeShiftR (minBound :: Int) (countLeadingZeros (i1 `xor` i2))+{-# INLINE branchPrefix #-}++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,14 +1,8 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif- #ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DataKinds, FlexibleContexts, MonoLocalBinds #-}+{-# LANGUAGE Safe #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Map@@ -18,94 +12,95 @@ -- 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@. Most operations require that @k@+-- have an instance of the 'Ord' class. 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 and don't handle untrusted keys, 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+--+-- The @'Ord' k@ instance is expected to be lawful and define a total order.+-- Unless otherwise specified, operations expect equality on keys to be+-- extensional: if keys @k1@ and @k2@ satisfy @k1 == k2@, they are considered+-- identical. For instance, if only one key must be retained by an operation, it+-- is free to select either.+--+--+-- == 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,4373 +1,4644 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#if defined(__GLASGOW_HASKELL__)-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeFamilies #-}-#endif-#define USE_MAGIC_PROXY 1--#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-    , argSet-    , fromSet-    , fromArgSet--    -- ** 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-#ifdef __GLASGOW_HASKELL__-    , atKeyPlain-#endif-    , bin-    , balance-    , balanceL-    , balanceR-    , delta-    , insertMax-    , link-    , link2-    , glue-    , fromDistinctAscList_linkTop-    , fromDistinctAscList_linkAll-    , fromDistinctDescList_linkTop-    , fromDistinctDescList_linkAll-    , MaybeS(..)-    , Identity(..)-    , FromDistinctMonoState(..)-    , Stack(..)-    , foldl'Stack--    -- 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))-import Data.Bits (shiftL, shiftR)-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-#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 Text.Read hiding (lift)-import Data.Data-import qualified Control.Category as Category-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--#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--instance (Ord k) => Monoid (Map k v) where-    mempty  = empty-    mconcat = unions-    mappend = (<>)--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)\). 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"------ 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)\). 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- #-}---- 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)\). 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---- | \(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---------------------------------------------------------------------}--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"--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---- | \(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--{---------------------------------------------------------------------  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.------ @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 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\/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-"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"------ 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) []-#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)\). 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--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--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 of the list are ordered, a linear-time implementation is used.------ > 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,"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---- | \(O(n \log n)\). 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 :: 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------ 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-#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------ 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)-  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------ 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)-  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.---- See Note [fromDistinctAscList implementation] in Data.Set.Internal.-fromDistinctAscList :: [(k,a)] -> Map k a-fromDistinctAscList = fromDistinctAscList_linkAll . Foldable.foldl' next (State0 Nada)-  where-    next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a-    next (State0 stk) (!kx, x) = fromDistinctAscList_linkTop (Bin 1 kx x Tip Tip) stk-    next (State1 l stk) (kx, x) = State0 (Push kx x l stk)-{-# INLINE fromDistinctAscList #-}  -- INLINE for fusion--fromDistinctAscList_linkTop :: Map k a -> Stack k a -> FromDistinctMonoState k a-fromDistinctAscList_linkTop r@(Bin rsz _ _ _ _) (Push kx x l@(Bin lsz _ _ _ _) stk)-  | rsz == lsz = fromDistinctAscList_linkTop (bin kx x l r) stk-fromDistinctAscList_linkTop l stk = State1 l stk-{-# INLINABLE fromDistinctAscList_linkTop #-}--fromDistinctAscList_linkAll :: FromDistinctMonoState k a -> Map k a-fromDistinctAscList_linkAll (State0 stk)    = foldl'Stack (\r kx x l -> link kx x l r) Tip stk-fromDistinctAscList_linkAll (State1 r0 stk) = foldl'Stack (\r kx x l -> link kx x l r) r0 stk-{-# INLINABLE fromDistinctAscList_linkAll #-}---- | \(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.---- See Note [fromDistinctAscList implementation] in Data.Set.Internal.-fromDistinctDescList :: [(k,a)] -> Map k a-fromDistinctDescList = fromDistinctDescList_linkAll . Foldable.foldl' next (State0 Nada)-  where-    next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a-    next (State0 stk) (!kx, x) = fromDistinctDescList_linkTop (Bin 1 kx x Tip Tip) stk-    next (State1 r stk) (kx, x) = State0 (Push kx x r stk)-{-# INLINE fromDistinctDescList #-}  -- INLINE for fusion--fromDistinctDescList_linkTop :: Map k a -> Stack k a -> FromDistinctMonoState k a-fromDistinctDescList_linkTop l@(Bin lsz _ _ _ _) (Push kx x r@(Bin rsz _ _ _ _) stk)-  | lsz == rsz = fromDistinctDescList_linkTop (bin kx x l r) stk-fromDistinctDescList_linkTop r stk = State1 r stk-{-# INLINABLE fromDistinctDescList_linkTop #-}--fromDistinctDescList_linkAll :: FromDistinctMonoState k a -> Map k a-fromDistinctDescList_linkAll (State0 stk)    = foldl'Stack (\l kx x r -> link kx x l r) Tip stk-fromDistinctDescList_linkAll (State1 l0 stk) = foldl'Stack (\l kx x r -> link kx x l r) l0 stk-{-# INLINABLE fromDistinctDescList_linkAll #-}--data FromDistinctMonoState k a-  = State0 !(Stack k a)-  | State1 !(Map k a) !(Stack k a)--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--{---------------------------------------------------------------------  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)--{---------------------------------------------------------------------  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--{---------------------------------------------------------------------  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--{---------------------------------------------------------------------  Read---------------------------------------------------------------------}-instance (Ord k, Read k, Read e) => Read (Map k e) where-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__)+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+#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]+-- ~~~~~~~~~~~~~~~~~~~~+-- We mark some functions INLINE where it is more beneficial than INLINABLE.+-- There is a price to pay -- code growth. The code INLINED is therefore usually+-- only the tree navigation, other work such as rebalancing is not INLINED.+--+-- 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+    , pop+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , upsert+    , 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+    , dropMatched+    , 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+    , whenMissing++    -- ** Deprecated general combining function++    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic+    , mapAssocsMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , argSet+    , fromSet+    , fromSetA+    , fromSetMaybe+    , fromSetMaybeA+    , fromArgSet++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey+    , fromListUpsert++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromAscListUpsert+    , fromDistinctAscList+    , fromDescList+    , fromDescListWith+    , fromDescListWithKey+    , fromDescListUpsert+    , 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+    , bin+    , balance+    , balanceL+    , balanceR+    , delta+    , insertMax+    , link+    , link2+    , glue+    , ascLinkTop+    , ascLinkAll+    , descLinkTop+    , descLinkAll+    , 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.Strict+  (StrictPair(..), StrictTriple(..), toPair)+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)+#  if __GLASGOW_HASKELL__ >= 914+import Language.Haskell.TH.Lift (Lift)+#  else+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#  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.+--+-- __Note__: This function is partial. Prefer '!?'.+--+-- > 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+{-# INLINE (!) #-}++-- | \(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+{-# INLINE (!?) #-}++-- | Same as 'difference'.+(\\) :: Ord k => Map k a -> Map k b -> Map k a+m1 \\ m2 = difference m1 m2+{-# INLINE (\\) #-}++{--------------------------------------------------------------------+  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+#if !MIN_VERSION_base(4,11,0)+    mappend = (<>)+#endif++-- | @(<>)@ = '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+{-# INLINABLE lookup #-}++-- | \(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+{-# INLINABLE member #-}++-- | \(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+{-# INLINABLE notMember #-}++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+{-# INLINABLE find #-}++-- | \(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+{-# INLINABLE findWithDefault #-}++-- | \(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+{-# INLINABLE lookupLT #-}++-- | \(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+{-# INLINABLE lookupGT #-}++-- | \(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+{-# INLINABLE lookupLE #-}++-- | \(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+{-# INLINABLE lookupGE #-}++{--------------------------------------------------------------------+  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+{-# INLINABLE insert #-}++#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+{-# INLINABLE insertR #-}++-- | \(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++{-# INLINABLE insertWith #-}++-- | 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+{-# INLINABLE insertWithR #-}++-- | \(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+{-# INLINABLE insertWithKey #-}++-- | 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+{-# INLINABLE insertWithKeyR #-}++-- | \(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)+{-# INLINABLE insertLookupWithKey #-}++{--------------------------------------------------------------------+  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+{-# INLINABLE delete #-}++-- | \(O(\log n)\). Pop an entry from the map.+--+-- Returns @Nothing@ if the key is not in the map. Otherwise returns @Just@ the+-- value at the key and a map with the entry removed.+--+-- @+-- pop 1 (fromList [(0,"a"),(2,"b"),(4,"c")]) == Nothing+-- pop 2 (fromList [(0,"a"),(2,"b"),(4,"c")]) == Just ("b",fromList [(0,"a"),(4,"c")])+-- @+--+-- @since 0.8.1+pop :: Ord k => k -> Map k a -> Maybe (a, Map k a)+pop k0 t0 = case go k0 t0 of+  Popped (Just y) t -> Just (y, t)+  _ -> Nothing+  where+    -- See Note [Popped impl]+    go !k (Bin _ kx x l r) = case compare k kx of+      LT -> case go k l of+        Popped y@(Just _) l' -> Popped y (balanceR kx x l' r)+        q -> q+      EQ -> Popped (Just x) (glue l r)+      GT -> case go k r of+        Popped y@(Just _) r' -> Popped y (balanceL kx x l r')+        q -> q+    go !_ Tip = Popped Nothing Tip+{-# INLINABLE pop #-}++-- Note [Popped impl]+-- ~~~~~~~~~~~~~~~~~~+-- Popped is implemented as a pair, though a sum makes more sense:+--   data Popped k a = NotPopped | Popped a !(Map k a)+-- This is because GHC optimizes a return value of `Popped k a` to+-- `(# Maybe a, Map k a #)`, avoiding all Popped allocations in `pop`.+-- GHC cannot do this with a sum type yet, see GHC #14259. Manually using+-- unboxed sums avoids the allocations but GHC loses strictness information,+-- see #25988.+--+-- On GHC>=9.6 we unbox the Maybe and avoid that allocation too, so `pop`'s `go`+-- returns `(# (# (# #) | a #), Map k a #)`.++data Popped k a = Popped+#if __GLASGOW_HASKELL__ >= 906+  {-# UNPACK #-}+#endif+  !(Maybe a)+  !(Map k a)++-- | \(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)+{-# INLINABLE adjust #-}++-- | \(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+{-# INLINABLE adjustWithKey #-}++-- | \(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)+{-# INLINABLE update #-}++-- | \(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+{-# INLINABLE updateWithKey #-}++-- | \(O(\log n)\). Update the value at a key or insert a value if the key is+-- not in the map.+--+-- @+-- let inc = maybe 1 (+1)+-- upsert inc \'a\' (fromList [(\'a\',1),(\'c\',2)]) == fromList [(\'a\',2),(\'c\',2)]+-- upsert inc \'b\' (fromList [(\'a\',1),(\'c\',2)]) == fromList [(\'a\',1),(\'b\',1),(\'c\',2)]+-- @+--+-- @since 0.8.1+upsert :: Ord k => (Maybe a -> a) -> k -> Map k a -> Map k a+upsert f !k (Bin sz kx x l r) =+  case compare k kx of+    LT -> balanceL kx x (upsert f k l) r+    EQ -> Bin sz kx (f (Just x)) l r+    GT -> balanceR kx x l (upsert f k r)+upsert f !k Tip = singleton k (f Nothing)+{-# INLINABLE upsert #-}++-- | \(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 also: 'pop'++-- 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)+{-# INLINABLE updateLookupWithKey #-}++-- | \(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+{-# INLINABLE alter #-}++-- 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)@.+--+-- '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@.+--+-- === Examples+--+-- @+-- -- Lookup the value at the key, and also remove the existing value or set a new value.+-- lookupAndSet :: Ord k => k -> Maybe a -> Map k a -> (Maybe a, Map k a)+-- lookupAndSet k new = alterF (\\old -> (old, new)) k+-- @+--+-- @+-- -- Delete the value at the key. If it is absent the result is Nothing.+-- mustDelete :: Ord k => k -> Map k a -> Maybe (Map k a)+-- mustDelete = alterF (Nothing <$)+-- @+--+-- @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++#ifdef __GLASGOW_HASKELL__+{-# INLINE [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 _ -> deleteAlong 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++-- On GHC >=9.6 we can unpack sum types, so we unbox the Maybe to avoid the+-- allocation.+data TraceResult a = TraceResult+#if __GLASGOW_HASKELL__ >= 906+  {-# UNPACK #-}+#endif+  !(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)+{-# INLINABLE lookupTrace #-}++-- 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.+deleteAlong :: BitQueue -> Map k a -> Map k a+deleteAlong !_ Tip = Tip+deleteAlong !q (Bin _ ky y l r) =+  case unconsQ q of+    Just (False, tl) -> balanceR ky y (deleteAlong tl l) r+    Just (True, tl) -> balanceL ky y l (deleteAlong tl r)+    Nothing -> glue l r++-- 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 (alter (coerce f) k t)+{-# INLINABLE atKeyIdentity #-}+#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.+--+-- __Note__: This function is partial. Prefer 'lookupIndex'.+--+-- > 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+{-# INLINABLE findIndex #-}++-- | \(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+{-# INLINABLE lookupIndex #-}++-- | \(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.+--+-- __Note__: This function is partial.+--+-- > 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 -> linkL 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 -> linkR 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 :*: linkR kx x lr r+          GT -> case go (i - sizeL - 1) r of+                  rl :*: rr -> linkL 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.+--+-- __Note__: This function is partial.+--+-- > 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.+--+-- __Note__: This function is partial.+--+-- > 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.+--+-- __Note__: This function is partial. Prefer 'lookupMin'.+--+-- > 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.+--+-- __Note__: This function is partial. Prefer 'lookupMax'.+--+-- > 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+{-# INLINE unions #-} -- Inline for list fusion++-- | 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+{-# INLINABLE unionsWith #-}++-- | \(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+{-# INLINABLE union #-}++{--------------------------------------------------------------------+  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+{-# INLINABLE unionWith #-}++-- | \(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+{-# INLINABLE unionWithKey #-}++{--------------------------------------------------------------------+  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+{-# INLINABLE difference #-}++-- | \(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+{-# INLINABLE withoutKeys #-}++-- | \(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)+{-# INLINABLE differenceWith #-}++-- | \(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)+{-# INLINABLE differenceWithKey #-}+++{--------------------------------------------------------------------+  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+{-# INLINABLE intersection #-}++-- | \(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+{-# INLINABLE restrictKeys #-}++-- | \(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+{-# INLINABLE intersectionWith #-}++-- | \(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+{-# INLINABLE intersectionWithKey #-}++{--------------------------------------------------------------------+  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+{-# INLINABLE symmetricDifference #-}++{--------------------------------------------------------------------+  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+--------------------------------------------------------------------}+-- | Given maps @bc@ and @ab@, relate the keys of @ab@ to the values of @bc@,+-- by using the values of @ab@ as keys for lookups in @bc@.+--+-- 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 Monad f => Functor (WhenMissing f k x) where+  fmap = mapWhenMissing+  {-# INLINE fmap #-}++-- | @since 0.5.9+instance 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 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 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 (>>=) #-}++-- | Create a @WhenMissing@ from two functions.+--+-- @whenMissing@ must be called with two functions @f@ and @g@ such that+-- @g = 'traverseMaybeWithKey' f@. @g@ may be a more efficient way of applying+-- @f@ to all key-value pairs in a @Map@.+--+-- __Warning__: It is the caller's responsibility to ensure the above property.+--+-- === __Examples__+--+-- @+-- preserveMissing :: Applicative f => WhenMissing f k x x+-- preserveMissing = whenMissing f g+--   where+--     f _k x = pure (Just x)+--     g m = pure m+--     -- Note that this satisfies g = traverseMaybeWithKey f+-- @+--+-- @+-- import Data.Functor.Const (Const(..))+-- import Data.Monoid (All(..))+--+-- -- For a usage of this, see examples on mergeA+-- isEmpty :: WhenMissing (Const All) k x y+-- isEmpty = whenMissing f g+--   where+--     f _k _x = Const (All False)+--     g m = Const (All (null m))+--     -- Note that this satisfies g = traverseMaybeWithKey f+-- @+--+-- @since 0.8.1+whenMissing+  :: (k -> x -> f (Maybe y)) -> (Map k x -> f (Map k y)) -> WhenMissing f k x y+whenMissing = flip WhenMissing++-- | Map covariantly over a @'WhenMissing' f k x@.+--+-- @since 0.5.9+mapWhenMissing :: 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 => 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 (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 => 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, drop the key and values.+--+-- @since 0.8.1+dropMatched :: Applicative f => WhenMatched f k x y z+dropMatched = WhenMatched (\_ _ _ -> pure Nothing)+{-# INLINE dropMatched #-}++-- | 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 'SimpleWhenMissing' tactics, a 'SimpleWhenMatched'+-- 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+-- @+--+-- @+-- g1 k x = if k == 2 then Just ("1" ++ x) else Nothing+-- g2 k x = if k == 3 then Just ("2" ++ x) else Nothing+-- f k x y = if k == 6 then Just ("3" ++ x ++ y) else Nothing+-- m1 = fromList [(2,"a"), (4,"b"), (6,"c"), (8,"d"), (10,"e"), (12,"f")]+-- m2 = fromList [(3,"g"), (6,"h"), (9,"i"), (12,"j")]+-- @+--+-- 'merge' will pass the keys and values to @g1@, @g2@, or @f@ as appropriate,+-- producing a @Maybe@ for each element.+--+-- @+-- m1:      [ (2, "a"),            (4, "b"),    (6, "c"), (8, "d"),           (10, "e"),    (12, "f")]+-- m2:      [            (3, "g"),              (6, "h"),           (9, "i"),               (12, "j")]+-- result:  [ g1 2 "a",  g2 3 "g", g1 4 "b", f 6 "c" "h", g1 8 "d", g2 9 "i", g1 10 "e", f 12 "f" "j"]+--        = [Just "1a", Just "2g",  Nothing,  Just "3ch",  Nothing,  Nothing,   Nothing,      Nothing]+-- @+--+-- The result map contains the @Just@ values.+--+-- >>> merge (mapMaybeMissing g1) (mapMaybeMissing g2) (zipWithMaybeMatched f) m1 m2+-- fromList [(2,"1a"), (3,"2g"), (6,"3ch")]+--+-- 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'.+--+-- Behaves just like 'merge' while allowing @Applicative@ effects. Effects are+-- performed in increasing order of keys.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+--        (traverseMaybeMissing g2)+--        (zipWithMaybeAMatched f)+--        m1+--        m2+-- @+--+-- @+-- g1 k x = let z = if k == 2 then Just ("1" ++ x) else Nothing+--          in z <$ putStrLn ("g1 " ++ show (k, x))+-- g2 k x = let z = if k == 3 then Just ("2" ++ x) else Nothing+--          in z <$ putStrLn ("g2 " ++ show (k, x))+-- f k x y = let z = if k == 6 then Just ("3" ++ x ++ y) else Nothing+--           in z <$ putStrLn ("f " ++ show (k, x, y))+-- m1 = fromList [(2,"a"), (4,"b"), (6,"c"), (8,"d"), (10,"e"), (12,"f")]+-- m2 = fromList [(3,"g"), (6,"h"), (9,"i"), (12,"j")]+-- @+--+-- As with 'merge', the result map is @[(2,"1a"), (3,"2g"), (6,"3ch")]@.+-- Additionally, @g1@, @g2@, and @f@ perform @IO@ effects, printing in+-- increasing order of key.+--+-- >>> mergeA (traverseMaybeMissing g1) (traverseMaybeMissing g2) (zipWithMaybeAMatched f) m1 m2+-- g1 (2,"a")+-- g2 (3,"g")+-- g1 (4,"b")+-- f (6,"c","h")+-- g1 (8,"d")+-- g2 (9,"i")+-- g1 (10,"e")+-- f (12,"f","j")+-- fromList [(2,"1a"),(3,"2g"),(6,"3ch")]+--+-- 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.+--+-- === __Examples__+--+-- @+-- data Pair a = Pair !a !a deriving Functor+--+-- instance Applicative Pair where+--    pure x = Pair x x+--    liftA2 f (Pair x1 y1) (Pair x2 y2) = Pair (f x1 x2) (f y1 y2)+--+-- -- | Calculate the left-biased union and intersection of two maps.+-- unionIntersection :: Ord k => Map k a -> Map k a -> (Map k a, Map k a)+-- unionIntersection m1 m2 =+--   case mergeA preserveAndDropMissing preserveAndDropMissing preserveLeftMatched m1 m2 of+--     Pair mu mi -> (mu, mi)+--   where+--     -- use Pair to build the union and intersection together+--     preserveAndDropMissing = 'whenMissing' (\\_k x -> Pair (Just x) Nothing) (\\m -> Pair m empty)+--     preserveLeftMatched = 'zipWithMaybeAMatched' (\\_k x1 _x2 -> Pair (Just x1) (Just x1))+-- @+--+-- @+-- import Data.Functor.Const (Const(..))+-- import Data.Monoid (All(..))+--+-- -- | Whether the keys of the first map are a subset of the keys of the second map.+-- keysAreSubsetOf :: Ord k => Map k a -> Map k b -> Bool+-- keysAreSubsetOf m1 m2 =+--   getAll (getConst (mergeA isEmpty 'dropMissing' 'dropMatched' m1 m2))+--   where+--     isEmpty = 'whenMissing' (\\_k _x -> Const (All False)) (\\m -> Const (All (null m)))+-- @+--+-- @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+{-# INLINABLE isSubmapOf #-}++{- | \(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+{-# INLINABLE isSubmapOfBy #-}++-- 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+{-# INLINABLE submap' #-}++-- | \(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+{-# INLINABLE isProperSubmapOf #-}++{- | \(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+{-# INLINABLE isProperSubmapOfBy #-}++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | \(O(n)\). Keep 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)\). Keep 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)\). Keep 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 = linkL 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 = linkR 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 linkL kx x l u :*: v+      | otherwise = let u :*: v = go p l in u :*: linkR 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'+{-# INLINABLE traverseMaybeWithKey #-}++-- | \(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)+{-# INLINABLE mapKeys #-}++-- | \(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)+{-# INLINABLE mapKeysWith #-}+++-- | \(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 f = mapAssocsMonotonic (\k x -> (f k, x))++-- | \(O(n)\). Map over keys and values with a function @f@ that is+-- monotonically strictly increasing in the keys. That is, for keys @kx@ and+-- @ky@ and values @x@ and @y@, if @kx@ < @ky@ then+-- @fst (f kx x)@ < @fst (f ky y)@.+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing in the key. This precondition is not checked.+--+-- @since 0.8.1+mapAssocsMonotonic :: (k1 -> a1 -> (k2, a2)) -> Map k1 a1 -> Map k2 a2+mapAssocsMonotonic f = go+  where+    go Tip = Tip+    go (Bin sz k1 x1 l r) = case f k1 x1 of+      (k2, x2) -> Bin sz k2 x2 (go l) (go r)+-- See Note [INLINABLE to expose unfoldings] in Data.IntMap.Internal+{-# INLINABLE mapAssocsMonotonic #-}++{--------------------------------------------------------------------+  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 [(3,"aaa"), (5,"aaaaa")]++fromSet :: (k -> a) -> Set k -> Map k a+#ifdef __GLASGOW_HASKELL__+fromSet =+  (coerce :: ((k -> Identity a) -> Set k -> Identity (Map k a))+          -> (k -> a) -> Set k -> Map k a)+    fromSetA+#else+fromSet f = runIdentity . fromSetA (pure . f)+#endif++-- | \(O(n)\). Build a map from a 'Set' of keys and a function which for each+-- key computes its value in an 'Applicative' context.+--+-- The @Applicative@ actions are sequenced in order of increasing key.+--+-- > let f k = if k == 0 then Nothing else Just (6 `div` k)+-- > fromSetA f (Data.Set.fromList [1,2,3,4]) == Just (fromList [(1,6),(2,3),(3,2),(4,1)])+-- > fromSetA f (Data.Set.fromList [0,1,2]) == Nothing+--+-- @since 0.8.1+fromSetA :: Applicative f => (k -> f a) -> Set k -> f (Map k a)+fromSetA _ Set.Tip = pure Tip+fromSetA f (Set.Bin sz x l r) =+  liftA3 (flip (Bin sz x)) (fromSetA f l) (f x) (fromSetA f r)+{-# INLINABLE fromSetA #-}++-- | \(O(n)\). Build a map from a 'Set' of keys and a function which for each+-- key optionally computes its value.+--+-- > let f k = if even k then Just (replicate k 'a') else Nothing+-- > fromSetMaybe f (Data.Set.fromList [1,2,3,4]) == fromList [(2,"aa"), (4,"aaaa")]+--+-- @since 0.8.1+fromSetMaybe :: (k -> Maybe a) -> Set k -> Map k a+#ifdef __GLASGOW_HASKELL__+fromSetMaybe =+  (coerce :: ((k -> Identity (Maybe a)) -> Set k -> Identity (Map k a))+          -> (k -> Maybe a) -> Set k -> Map k a)+     fromSetMaybeA+#else+fromSetMaybe f s = runIdentity (fromSetMaybeA (Identity . f) s)+#endif++-- | \(O(n)\). Build a map from a 'Set' of keys and a function which for each+-- key optionally computes its values in an 'Applicative' context.+--+-- The @Applicative@ actions are sequenced in order of increasing key.+--+-- @since 0.8.1+fromSetMaybeA :: Applicative f => (k -> f (Maybe a)) -> Set k -> f (Map k a)+fromSetMaybeA f = go+  where+    go Set.Tip = pure Tip+    go (Set.Bin _ k l r) =+      liftA3 (\l' mx r' -> maybe link2 (link k) mx l' r') (go l) (f k) (go r)+{-# INLINABLE fromSetMaybeA #-}++-- | \(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.+-- 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.+--+-- 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@.+--+-- See also: 'fromListUpsert'+--+-- === 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.+--+-- 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'.+--+-- See also: 'fromListUpsert'++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 \log n)\). Build a map from a list of key\/value pairs with a+-- combining function.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- The result is equivalent to performing an @upsert@ for every key\/value in+-- the list.+--+-- @+-- fromListUpsert f = foldl' (\\m (k, x) -> 'upsert' (f x) k m) 'empty'+-- @+--+-- > let f x = maybe [x] (x:)+-- > fromListUpsert f [(5,'a'), (5,'b'), (3,'c'), (3,'d'), (5,'e')] == fromList [(3,"dc"), (5,"eba")]+--+-- @since 0.8.1+fromListUpsert :: Ord k => (a -> Maybe b -> b) -> [(k, a)] -> Map k b+fromListUpsert f xs =+  finishB (Foldable.foldl' (\b (kx, x) -> upsertB (f x) kx b) emptyB xs)+{-# INLINE fromListUpsert #-}  -- 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+--+-- See also: 'fromAscListUpsert'++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'.+--+-- See also: 'fromDescListUpsert'+--+-- @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,"c")] == fromList [(3, "b"), (5, "5:c5:ba")]+-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"c")]) == True+-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"c")]) == False+--+-- Also see the performance note on 'fromListWith'.+--+-- See also: 'fromAscListUpsert'++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'.+--+-- See also: 'fromDescListUpsert'++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 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 'fromListUpsert'+-- if the precondition may not hold.+--+-- > let f x = maybe [x] (x:)+-- > fromAscListUpsert f [(3,'a'), (3,'b'), (5,'c'), (5,'d'), (5,'e')] == fromList [(3,"ba"), (5,"edc")]+--+-- @since 0.8.1+fromAscListUpsert :: Eq k => (a -> Maybe b -> b) -> [(k, a)] -> Map k b+fromAscListUpsert 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 y (Just x)) l stk'+        | Tip <- l -> ascLinkTop stk' 1 (singleton kx x) ky (f y Nothing)+        | otherwise -> Push ky (f y Nothing) Tip stk+      Nada -> Push ky (f y Nothing) Tip stk+{-# INLINE fromAscListUpsert #-}  -- 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 'fromListUpsert'+-- if the precondition may not hold.+--+-- > let f x = maybe [x] (x:)+-- > fromDescListUpsert f [(5,'a'), (5,'b'), (5,'c'), (3,'d'), (3,'e')] == fromList [(3,"ed"), (5,"cba")]+--+-- @since 0.8.1+fromDescListUpsert :: Eq k => (a -> Maybe b -> b) -> [(k, a)] -> Map k b+fromDescListUpsert 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 y (Just x)) r stk'+        | Tip <- r -> descLinkTop ky (f y Nothing) 1 (singleton kx x) stk'+        | otherwise -> Push ky (f y Nothing) Tip stk+      Nada -> Push ky (f y Nothing) Tip stk+{-# INLINE fromDescListUpsert #-}  -- 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 -> linkL 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 -> linkR 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 :*: linkR kx x gt r+          GT -> let (lt :*: gt) = go k r in linkL kx x l lt :*: gt+          EQ -> (l :*: r)+{-# INLINABLE split #-}++-- | \(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+     TripleS 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            -> TripleS Tip Nothing Tip+        Bin _ kx x l r -> case compare k kx of+          LT -> let TripleS lt z gt = go k l+                    !gt' = linkR kx x gt r+                in TripleS lt z gt'+          GT -> let TripleS lt z gt = go k r+                    !lt' = linkL kx x l lt+                in TripleS lt' z gt+          EQ -> TripleS l (Just x) r+{-# INLINABLE splitLookup #-}++-- | \(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+     TripleS 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            -> TripleS Tip False Tip+        Bin _ kx x l r -> case compare k kx of+          LT -> let TripleS lt z gt = go k l+                    !gt' = linkR kx x gt r+                in TripleS lt z gt'+          GT -> let TripleS lt z gt = go k r+                    !lt' = linkL kx x l lt+                in TripleS lt' z gt+          EQ -> TripleS l True r+{-# INLINABLE splitMember #-}++{--------------------------------------------------------------------+  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 #-}++-- Upsert a key-value. The given function is used to generate the value based+-- on the existing value for the key.+upsertB :: Ord k => (Maybe a -> a) -> k -> MapBuilder k a -> MapBuilder k a+upsertB f !ky b = case b of+  BAsc stk -> case stk of+    Push kx x l stk' -> case compare ky kx of+      LT -> BMap (upsert f ky (ascLinkAll stk))+      EQ -> BAsc (Push ky (f (Just x)) l stk')+      GT -> case l of+        Tip -> BAsc (ascLinkTop stk' 1 (singleton kx x) ky (f Nothing))+        Bin{} -> BAsc (Push ky (f Nothing) Tip stk)+    Nada -> BAsc (Push ky (f Nothing) Tip Nada)+  BMap m -> BMap (upsert f ky m)+{-# INLINE upsertB #-}++-- 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 lsz lkx lx ll lr) r@(Bin rsz rkx rx rl rr)+  | delta*lsz < rsz = balanceL rkx rx (linkR_ kx x lsz l rl) rr+  | delta*rsz < lsz = balanceR lkx lx ll (linkL_ kx x lr rsz r)+  | otherwise       = Bin (1+lsz+rsz) kx x l r++-- Variant of link. Restores balance when the left tree may be too large for the+-- right tree, but not the other way around.+linkL :: k -> a -> Map k a -> Map k a -> Map k a+linkL kx x l r = case r of+  Tip -> insertMax kx x l+  Bin rsz _ _ _ _ -> linkL_ kx x l rsz r++linkL_ :: k -> a -> Map k a -> Int -> Map k a -> Map k a+linkL_ kx x l !rsz r = case l of+  Bin lsz lkx lx ll lr+    | delta*rsz < lsz -> balanceR lkx lx ll (linkL_ kx x lr rsz r)+    | otherwise -> Bin (1+lsz+rsz) kx x l r+  Tip -> Bin (1+rsz) kx x Tip r++-- Variant of link. Restores balance when the right tree may be too large for+-- the left tree, but not the other way around.+linkR :: k -> a -> Map k a -> Map k a -> Map k a+linkR kx x l r = case l of+  Tip -> insertMin kx x r+  Bin lsz _ _ _ _ -> linkR_ kx x lsz l r++linkR_ :: k -> a -> Int -> Map k a -> Map k a -> Map k a+linkR_ kx x !lsz l r = case r of+  Bin rsz rkx rx rl rr+    | delta*lsz < rsz -> balanceL rkx rx (linkR_ kx x lsz l rl) rr+    | otherwise -> Bin (1+lsz+rsz) kx x l r+  Tip -> Bin (1+lsz) kx x l Tip++-- 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 lsz lkx lx ll lr) r@(Bin rsz rkx rx rl rr)+  | delta*lsz < rsz = balanceL rkx rx (link2R_ lsz l rl) rr+  | delta*rsz < lsz = balanceR lkx lx ll (link2L_ lr rsz r)+  | otherwise = glue l r++link2L_ :: Map k a -> Int -> Map k a -> Map k a+link2L_ l !rsz r = case l of+  Bin lsz lkx lx ll lr+    | delta*rsz < lsz -> balanceR lkx lx ll (link2L_ lr rsz r)+    | otherwise -> glue l r+  Tip -> r++link2R_ :: Int -> Map k a -> Map k a -> Map k a+link2R_ !lsz l r = case r of+  Bin rsz rkx rx rl rr+    | delta*lsz < rsz -> balanceL rkx rx (link2R_ lsz l rl) rr+    | otherwise -> glue l r+  Tip -> l++{--------------------------------------------------------------------+  [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.+--+-- Calls 'error' if the map is empty.+--+-- __Note__: This function is partial. Prefer 'minViewWithKey'.+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.+--+-- Calls 'error' if the map is empty.+--+-- __Note__: This function is partial. Prefer 'maxViewWithKey'.+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 specialized 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
src/Data/Map/Internal/Debug.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE CPP #-}-#include "containers.h"- module Data.Map.Internal.Debug where  import Data.Map.Internal (Map (..), size, delta)
− src/Data/Map/Internal/DeprecatedShowTree.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts, DataKinds, MonoLocalBinds #-}--#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
@@ -3,8 +3,6 @@ {-# LANGUAGE Safe #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Map.Lazy@@ -18,7 +16,8 @@ -- = Finite Maps (lazy interface) -- -- 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+-- from keys of type @k@ to values of type @v@. Most operations require that @k@+-- have an instance of the 'Ord' class. A 'Map' is strict in its keys but lazy -- in its values. -- -- The functions in "Data.Map.Strict" are careful to force values before@@ -30,7 +29,8 @@ -- * 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+-- * If you don't care about ordering and don't handle untrusted keys, consider+-- using @Data.HashMap.Lazy@ from the -- <https://hackage.haskell.org/package/unordered-containers unordered-containers> -- package instead. --@@ -38,22 +38,16 @@ -- <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--- two maps as arguments and combine them, such as `union` and `intersection`,--- 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.+-- The @'Ord' k@ instance is expected to be lawful and define a total order.+-- Unless otherwise specified, operations expect equality on keys to be+-- extensional: if keys @k1@ and @k2@ satisfy @k1 == k2@, they are considered+-- identical. For instance, if only one key must be retained by an operation, it+-- is free to select either. -- -- -- == Warning@@ -68,20 +62,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 (@@ -91,26 +107,34 @@     -- * Construction     , empty     , singleton-    , fromSet-    , fromArgSet      -- ** From Unordered Lists     , fromList     , fromListWith     , fromListWithKey+    , fromListUpsert      -- ** From Ascending Lists     , fromAscList     , fromAscListWith     , fromAscListWithKey+    , fromAscListUpsert     , fromDistinctAscList      -- ** From Descending Lists     , fromDescList     , fromDescListWith     , fromDescListWithKey+    , fromDescListUpsert     , fromDistinctDescList +    -- ** From @Set@+    , fromSet+    , fromSetA+    , fromSetMaybe+    , fromSetMaybeA+    , fromArgSet+     -- * Insertion     , insert     , insertWith@@ -119,10 +143,12 @@      -- * Deletion\/Update     , delete+    , pop     , adjust     , adjustWithKey     , update     , updateWithKey+    , upsert     , updateLookupWithKey     , alter     , alterF@@ -164,6 +190,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -189,6 +218,7 @@     , mapKeys     , mapKeysWith     , mapKeysMonotonic+    , mapAssocsMonotonic      -- * Folds     , foldr@@ -219,6 +249,7 @@      -- * Filter     , filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -254,12 +285,8 @@     -- * Min\/Max     , lookupMin     , lookupMax-    , findMin-    , findMax     , deleteMin     , deleteMax-    , deleteFindMin-    , deleteFindMax     , updateMin     , updateMax     , updateMinWithKey@@ -268,16 +295,15 @@     , maxView     , minViewWithKey     , maxViewWithKey+    , findMin+    , findMax+    , deleteFindMin+    , deleteFindMax      -- * 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
@@ -3,8 +3,6 @@ {-# LANGUAGE Safe #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Map.Merge.Lazy@@ -42,6 +40,7 @@     , merge      -- *** @WhenMatched@ tactics+    , dropMatched     , zipWithMaybeMatched     , zipWithMatched @@ -73,6 +72,7 @@     , traverseMaybeMissing     , traverseMissing     , filterAMissing+    , whenMissing      -- *** Covariant maps for tactics     , mapWhenMissing
+ src/Data/Map/Merge/Set/Internal.hs view
@@ -0,0 +1,293 @@+{-# OPTIONS_HADDOCK not-home #-}++-- |+-- = 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.Map.Merge.Set.Lazy"+-- and "Data.Map.Merge.Set.Strict".+--+-- @since 0.8.1+--+module Data.Map.Merge.Set.Internal+  ( WhenMatched(..)+  , SimpleWhenMatched+  , dropMatched+  , filterMatched+  , filterAMatched++  , WhenMissingSet(..)+  , SimpleWhenMissingSet+  , dropMissingSet++  , merge+  , mergeA++  , runWhenMatched+  , runWhenMissingSet+  ) where++import Control.Applicative (liftA3)+import Data.Functor.Identity (Identity(..))+import Data.Set (Set)+import qualified Data.Set.Internal as S+import Data.Map (Map)+import qualified Data.Map.Internal as M++-- | A tactic for dealing with keys present in both the set and the map in+-- 'merge' or 'mergeA'.+--+-- A tactic of type @WhenMatched f k a b@ is an abstract representation of+-- a function of type @k -> a -> f (Maybe b)@.+--+-- @since 0.8.1+newtype WhenMatched f k a b = WhenMatched+  { matchedKey :: k -> a -> f (Maybe b)+  }++-- | Run @WhenMatched@.+--+-- @since 0.8.1+runWhenMatched :: WhenMatched f k a b -> k -> a -> f (Maybe b)+runWhenMatched = matchedKey++-- | A tactic for dealing with keys present in both the set and the map in+-- 'merge'.+--+-- A tactic of type @SimpleWhenMatched k a b@ is an abstract representation of+-- a function of type @k -> a -> Maybe b@.+--+-- @since 0.8.1+type SimpleWhenMatched = WhenMatched Identity++-- | When a key is found in both the map and the set, drop the key and value.+--+-- @since 0.8.1+dropMatched :: Applicative f => WhenMatched f k a b+dropMatched = WhenMatched (\_ _ -> pure Nothing)+{-# INLINE dropMatched #-}++-- | When a key is found in both the map and the set, apply a function to the+-- key and the value in the map and keep the value in the merged map if the+-- result is @True@.+--+-- @since 0.8.1+filterMatched :: Applicative f => (k -> a -> Bool) -> WhenMatched f k a a+filterMatched f =+  WhenMatched (\k x -> if f k x then pure (Just x) else pure Nothing)+{-# INLINE filterMatched #-}++-- | When a key is found in both the map and the set, apply a function to the+-- key and the value in the map and keep the value in the merged map if the+-- result of the action is @True@.+--+-- @since 0.8.1+filterAMatched :: Functor f => (k -> a -> f Bool) -> WhenMatched f k a a+filterAMatched f =+  WhenMatched (\k x -> (\b -> if b then Just x else Nothing) <$> f k x)+{-# INLINE filterAMatched #-}++-- | A tactic for dealing with keys present in the set but not in the map in+-- 'merge' or 'mergeA'.+--+-- A tactic of type @WhenMissingSet f k a@ is an abstract representation of+-- a function of type @k -> f (Maybe a)@.+--+-- @since 0.8.1+data WhenMissingSet f k a = WhenMissingSet+  { missingSubtree :: Set k -> f (Map k a)+  , missingKey :: k -> f (Maybe a)+  }++-- | Run @WhenMissingSet@.+--+-- @since 0.8.1+runWhenMissingSet :: WhenMissingSet f k a -> k -> f (Maybe a)+runWhenMissingSet = missingKey++-- | A tactic for dealing with keys present in the set but not in the map in+-- 'merge'.+--+-- A tactic of type @SimpleWhenMissingSet k a@ is an abstract representation of+-- a function of type @k -> Maybe a@.+--+-- @since 0.8.1+type SimpleWhenMissingSet = WhenMissingSet Identity++-- | Drop keys that are present in the set but missing from the map.+--+-- @since 0.8.1+dropMissingSet :: Applicative f => WhenMissingSet f k a+dropMissingSet = WhenMissingSet+  { missingSubtree = \_ -> pure M.empty+  , missingKey = \_ -> pure Nothing+  }+{-# INLINE dropMissingSet #-}++-- | Merge a map and a set into a map.+--+-- 'merge' takes a 'M.SimpleWhenMissing' tactic, a 'SimpleWhenMissingSet'+-- tactic, a 'SimpleWhenMatched' tactic, a map and a set. It uses the tactics to+-- merge the map and the set into a map.+--+-- Its behavior is best understood via the tactics @mapMaybeMissing@,+-- @generateMaybeMissingSet@, and @mapMaybeMatched@. Consider+--+-- @+-- merge (mapMaybeMissing g1) (generateMaybeMissingSet g2) (mapMaybeMatched f) m1 s2+-- @+--+-- @+-- g1 k x = if k == 2 then Just ("1" ++ x) else Nothing+-- g2 k = if k == 3 then Just "2" else Nothing+-- f k x = if k == 6 then Just ("3" ++ x) else Nothing+-- m1 = fromList [(2,"a"), (4,"b"), (6,"c"), (8,"d"), (10,"e"), (12,"f")]+-- s2 = fromList [3, 6, 9, 12]+-- @+--+-- 'merge' will pass the keys and values to @g1@, @g2@, or @f@ as appropriate,+-- producing a @Maybe@ for each element.+--+-- @+-- m1:      [ (2, "a"),           (4, "b"),  (6, "c"), (8, "d"),          (10, "e"), (12, "f")]+-- s2:      [                  3,                   6,                 9,                   12]+-- result:  [ g1 2 "a",     g2 3, g1 4 "b",   f 6 "c", g1 8 "d",    g2 9, g1 10 "e",  f 12 "f"]+--        = [Just "1a", Just "2",  Nothing, Just "3c",  Nothing, Nothing,   Nothing,   Nothing]+-- @+--+-- The result map contains the @Just@ values.+--+-- >>> merge (mapMaybeMissing g1) (generateMaybeMissingSet g2) (mapMaybeMatched f) m1 s2+-- fromList [(2,"1a"), (3,"2g"), (6,"3c")]+--+-- 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.+--+-- @since 0.8.1+merge+  :: Ord k+  => M.SimpleWhenMissing k a b -- ^ What to do with keys in @m1@ but not @s2@+  -> SimpleWhenMissingSet k b -- ^ What to do with keys in @s2@ but not @m1@+  -> SimpleWhenMatched k a b -- ^ What to do with keys in both @m1@ and @s2@+  -> Map k a -- ^ Map @m1@+  -> Set k -- ^ Set @s2@+  -> Map k b+merge miss1 miss2 match = \t1 t2 -> runIdentity (mergeA miss1 miss2 match t1 t2)+{-# INLINE merge #-}++-- | Merge a map and a set into a map. Applicative version of 'merge'.+--+-- 'mergeA' takes a 'M.WhenMissing' tactic, a 'WhenMissingSet' tactic, a+-- 'WhenMatched' tactic, a map and a set. It uses the tactics to merge the map+-- and the set into a map.+--+-- Behaves just like 'merge' while allowing @Applicative@ effects. Effects are+-- performed in increasing order of keys.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+--        (generateMaybeAMissingSet g2)+--        (traverseMaybeMatched f)+--        m1+--        s2+-- @+--+-- @+-- g1 k x = let z = if k == 2 then Just ("1" ++ x) else Nothing+--          in z <$ putStrLn ("g1 " ++ show (k, x))+-- g2 k = let z = if k == 3 then Just "2" else Nothing+--        in z <$ putStrLn ("g2 " ++ show k)+-- f k x = let z = if k == 6 then Just ("3" ++ x) else Nothing+--         in z <$ putStrLn ("f " ++ show (k, x))+-- m1 = fromList [(2,"a"), (4,"b"), (6,"c"), (8,"d"), (10,"e"), (12,"f")]+-- m2 = fromList [3, 6, 9, 12]+-- @+--+-- As with 'merge', the result map is @[(2,"1a"), (3,"2"), (6,"3c")]@.+-- Additionally, @g1@, @g2@, and @f@ perform @IO@ effects, printing in+-- increasing order of key.+--+-- >>> mergeA (traverseMaybeMissing g1) (generateMaybeAMissingSet g2) (traverseMaybeMatched f) m1 s2+-- g1 (2,"a")+-- g2 3+-- g1 (4,"b")+-- f (6,"c")+-- g1 (8,"d")+-- g2 9+-- g1 (10,"e")+-- f (12,"f")+-- fromList [(2,"1a"),(3,"2"),(6,"3c")]+--+-- 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.+--+-- === __Examples__+--+-- @+-- data Pair a = Pair !a !a deriving Functor+--+-- instance Applicative Pair where+--    pure x = Pair x x+--    liftA2 f (Pair x1 y1) (Pair x2 y2) = Pair (f x1 x2) (f y1 y2)+--+-- -- | Partition the map according to whether the keys appear in the set.+-- partitionKeys :: Ord k => Map k a -> Set k -> (Map k a, Map k a)+-- partitionKeys m s =+--   case mergeA dropAndPreserveMissing dropMissingSet preserveAndDropMatched m s of+--     Pair m1 m2 -> (m1, m2)+--   where+--     dropAndPreserveMissing = whenMissing (\\_k x -> Pair Nothing (Just x)) (\\m -> Pair empty m)+--     preserveAndDropMatched = traverseMaybeMatched (\\_k x -> Pair (Just x) Nothing)+-- @+--+-- @+-- import Data.Functor.Const (Const(..))+-- import Data.Monoid (All(..))+--+-- -- | Whether the keys of the map are a subset of the keys of the set.+-- keysAreSubsetOf :: Ord k => Map k a -> Set k -> Bool+-- keysAreSubsetOf m s =+--   getAll (getConst (mergeA isEmpty dropMissing 'dropMatched' m1 m2))+--   where+--     isEmpty = whenMissing (\\_k _x -> Const (All False)) (\\m -> Const (All (null m)))+-- @+--+-- @since 0.8.1+mergeA+  :: (Applicative f, Ord k)+  => M.WhenMissing f k a b -- ^ What to do with keys in @m1@ but not @s2@+  -> WhenMissingSet f k b -- ^ What to do with keys in @s2@ but not @m1@+  -> WhenMatched f k a b -- ^ What to do with keys in both @m1@ and @s2@+  -> Map k a -- ^ Map @m1@+  -> Set k -- ^ Set @s2@+  -> f (Map k b)+mergeA+  M.WhenMissing{M.missingSubtree = g1t, M.missingKey = g1k}+  WhenMissingSet{missingSubtree = g2t}+  WhenMatched{matchedKey = f} = go+  where+    go t1 S.Tip = g1t t1+    go M.Tip t2 = g2t t2+    go (M.Bin _ k1 x1 l1 r1) t2 = case S.splitMember k1 t2 of+      (l2, found, r2) ->+        liftA3+          (\l' mx' r' -> maybe M.link2 (M.link k1) mx' l' r')+          (go l1 l2)+          (if found then f k1 x1 else g1k k1 x1)+          (go r1 r2)+{-# INLINE mergeA #-}
+ src/Data/Map/Merge/Set/Lazy.hs view
@@ -0,0 +1,155 @@+-- |+-- This module defines an API for writing functions that merge a map and a+-- set into a map. The key functions are 'Data.Map.Merge.Set.Lazy.merge' and+-- 'Data.Map.Merge.Set.Lazy.mergeA'. Each of these can be used with several+-- different \"merge tactics\".+--+-- The @merge@ and @mergeA@ functions are shared by the lazy and strict+-- modules. Only the choice of merge tactics determines strictness. If you+-- use 'Data.Map.Merge.Set.Strict.mapMissing' from "Data.Map.Merge.Set.Strict"+-- then the results will be forced before they are inserted. If you use+-- 'Data.Map.Merge.Set.Lazy.mapMissing' from this module then they will not.+--+-- @since 0.8.1+--+module Data.Map.Merge.Set.Lazy+  (+  -- ** Simple merge tactic types+    M.SimpleWhenMissing+  , Internal.SimpleWhenMissingSet+  , Internal.SimpleWhenMatched++  -- ** General combining function+  , Internal.merge++  -- *** @WhenMatched@ tactics+  , Internal.dropMatched+  , Internal.filterMatched+  , mapMatched+  , mapMaybeMatched++  -- *** @WhenMissing@ tactics+  , M.dropMissing+  , M.preserveMissing+  , M.mapMissing+  , M.filterMissing+  , M.mapMaybeMissing++  -- *** @WhenMissingSet@ tactics+  , Internal.dropMissingSet+  , generateMissingSet+  , generateMaybeMissingSet++  -- ** Applicative merge tactic types+  , M.WhenMissing+  , Internal.WhenMissingSet+  , Internal.WhenMatched++  -- ** General combining function+  , Internal.mergeA++  -- *** @WhenMatched@ tactics+  , Internal.filterAMatched+  , traverseMatched+  , traverseMaybeMatched++  -- *** @WhenMissing@ tactics+  , M.filterAMissing+  , M.traverseMissing+  , M.traverseMaybeMissing+  , M.whenMissing++  -- *** @WhenMissingSet@ tactics+  , generateAMissingSet+  , generateMaybeAMissingSet++  -- ** Miscellaneous+  , Internal.runWhenMatched+  , Internal.runWhenMissingSet+  ) where++import qualified Data.Map.Internal as M+import qualified Data.Map.Merge.Set.Internal as Internal+import Data.Map.Merge.Set.Internal (WhenMatched(..), WhenMissingSet(..))++-- | When a key is found in both the map and the set, apply a function to the+-- key and the value in the map and use the result as the value for the merged+-- map.+--+-- @since 0.8.1+mapMatched :: Applicative f => (k -> a -> b) -> WhenMatched f k a b+mapMatched f = WhenMatched (\k x -> pure (Just (f k x)))+{-# INLINE mapMatched #-}++-- | When a key is found in both the map and the set, apply a function to the+-- key and the value in the map and maybe use the result as the value for the+-- merged map.+--+-- @since 0.8.1+mapMaybeMatched :: Applicative f => (k -> a -> Maybe b) -> WhenMatched f k a b+mapMaybeMatched f = WhenMatched (\k x -> pure (f k x))+{-# INLINE mapMaybeMatched #-}++-- | When a key is found in both the map and the set, apply a function to the+-- key and the value in the map, and use the result of the action as the value+-- for the merged map.+--+-- @since 0.8.1+traverseMatched :: Functor f => (k -> a -> f b) -> WhenMatched f k a b+traverseMatched f = WhenMatched (\k x -> Just <$> f k x)+{-# INLINE traverseMatched #-}++-- | When a key is found in both the map and the set, apply a function to the+-- key and the value in the map, and maybe use the result of the action as the+-- value for the merged map.+--+-- @since 0.8.1+traverseMaybeMatched :: (k -> a -> f (Maybe b)) -> WhenMatched f k a b+traverseMaybeMatched = WhenMatched++-- | For keys that are present in the set but missing from the map, apply a+-- function and use the result as the value for the merged map.+--+-- @since 0.8.1+generateMissingSet :: Applicative f => (k -> a) -> WhenMissingSet f k a+generateMissingSet f = WhenMissingSet+  { missingSubtree = \s -> pure (M.fromSet f s)+  , missingKey = \k -> pure (Just (f k))+  }+{-# INLINE generateMissingSet #-}++-- | For keys that are present in the set but missing from the map, apply a+-- function, and use the result of the action as the value for the merged map.+--+-- @since 0.8.1+generateAMissingSet :: Applicative f => (k -> f a) -> WhenMissingSet f k a+generateAMissingSet f = WhenMissingSet+  { missingSubtree = M.fromSetA f+  , missingKey = \k -> Just <$> f k+  }+{-# INLINE generateAMissingSet #-}++-- | For keys that are present in the set but missing from the map, apply a+-- function and maybe use the result as the value for the merged map.+--+-- @since 0.8.1+generateMaybeMissingSet+  :: Applicative f => (k -> Maybe a) -> WhenMissingSet f k a+generateMaybeMissingSet f = WhenMissingSet+  { missingSubtree = \s -> pure (M.fromSetMaybe f s)+  , missingKey = \k -> pure (f k)+  }+{-# INLINE generateMaybeMissingSet #-}++-- | For keys that are present in the set but missing from the map, apply a+-- function, and maybe use the result of the action as the value for the merged+-- map.+--+-- @since 0.8.1+generateMaybeAMissingSet+  :: Applicative f => (k -> f (Maybe a)) -> WhenMissingSet f k a+generateMaybeAMissingSet f = WhenMissingSet+  { missingSubtree = M.fromSetMaybeA f+  , missingKey = f+  }+{-# INLINE generateMaybeAMissingSet #-}
+ src/Data/Map/Merge/Set/Strict.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE BangPatterns #-}++-- |+-- This module defines an API for writing functions that merge a map and a+-- set into a map. The key functions are 'Data.Map.Merge.Set.Strict.merge' and+-- 'Data.Map.Merge.Set.Strict.mergeA'. Each of these can be used with several+-- different \"merge tactics\".+--+-- The @merge@ and @mergeA@ functions are shared by the lazy and strict+-- modules. Only the choice of merge tactics determines strictness.+-- If you use 'Data.Map.Merge.Set.Strict.mapMissing' from this module+-- then the results will be forced before they are inserted. If you use+-- 'Data.Map.Merge.Set.Lazy.mapMissing' from "Data.Map.Merge.Set.Lazy" then they+-- will not.+--+-- @since 0.8.1+--+module Data.Map.Merge.Set.Strict+  (+  -- ** Simple merge tactic types+    MS.SimpleWhenMissing+  , Internal.SimpleWhenMissingSet+  , Internal.SimpleWhenMatched++  -- ** General combining function+  , Internal.merge++  -- *** @WhenMatched@ tactics+  , Internal.dropMatched+  , Internal.filterMatched+  , mapMatched+  , mapMaybeMatched++  -- *** @WhenMissing@ tactics+  , MS.dropMissing+  , MS.preserveMissing+  , MS.mapMissing+  , MS.filterMissing+  , MS.mapMaybeMissing++  -- *** @WhenMissingSet@ tactics+  , Internal.dropMissingSet+  , generateMissingSet+  , generateMaybeMissingSet++  -- ** Applicative merge tactic types+  , MS.WhenMissing+  , Internal.WhenMissingSet+  , Internal.WhenMatched++  -- ** General combining function+  , Internal.mergeA++  -- *** @WhenMatched@ tactics+  , Internal.filterAMatched+  , traverseMatched+  , traverseMaybeMatched++  -- *** @WhenMissing@ tactics+  , MS.filterAMissing+  , MS.traverseMissing+  , MS.traverseMaybeMissing+  , M.whenMissing++  -- *** @WhenMissingSet@ tactics+  , generateAMissingSet+  , generateMaybeAMissingSet++  -- ** Miscellaneous+  , Internal.runWhenMatched+  , Internal.runWhenMissingSet+  ) where++import qualified Data.Map.Strict.Internal as MS+import qualified Data.Map.Internal as M+import qualified Data.Map.Merge.Set.Internal as Internal+import Data.Map.Merge.Set.Internal (WhenMatched(..), WhenMissingSet(..))++-- | When the key is found in both the map and the set, apply a function to the+-- key and the value in the map and use the result as the value for the result+-- map.+--+-- @since 0.8.1+mapMatched :: Applicative f => (k -> a -> b) -> WhenMatched f k a b+mapMatched f = WhenMatched (\k x -> pure (Just $! f k x))+{-# INLINE mapMatched #-}++-- | When a key is found in both the map and the set, apply a function to the+-- key and the value in the map and maybe use the result as the value for the+-- merged map.+--+-- @since 0.8.1+mapMaybeMatched :: Applicative f => (k -> a -> Maybe b) -> WhenMatched f k a b+mapMaybeMatched f = WhenMatched (\k x -> pure (forceMaybe (f k x)))+{-# INLINE mapMaybeMatched #-}++-- | When a key is found in both the map and the set, apply a function to the+-- key and the value in the map, and use the result of the action as the value+-- for the merged map.+--+-- @since 0.8.1+traverseMatched :: Functor f => (k -> a -> f b) -> WhenMatched f k a b+traverseMatched f = WhenMatched (\k x -> (Just $!) <$> f k x)+{-# INLINE traverseMatched #-}++-- | When a key is found in both the map and the set, apply a function to the+-- key and the value in the map, and maybe use the result of the action as the+-- value for the merged map.+--+-- @since 0.8.1+traverseMaybeMatched+  :: Functor f => (k -> a -> f (Maybe b)) -> WhenMatched f k a b+traverseMaybeMatched f = WhenMatched (\k x -> forceMaybe <$> f k x)+{-# INLINE traverseMaybeMatched #-}++-- | For keys that are present in the set but missing from the map, apply a+-- function and use the result as the value for the merge map.+--+-- @since 0.8.1+generateMissingSet :: Applicative f => (k -> a) -> WhenMissingSet f k a+generateMissingSet f = WhenMissingSet+  { missingSubtree = \s -> pure (MS.fromSet f s)+  , missingKey = \k -> pure (Just $! f k)+  }+{-# INLINE generateMissingSet #-}++-- | For keys that are present in the set but missing from the map, apply a+-- function, and use the result of the action as the value for the merged map.+--+-- @since 0.8.1+generateAMissingSet :: Applicative f => (k -> f a) -> WhenMissingSet f k a+generateAMissingSet f = WhenMissingSet+  { missingSubtree = MS.fromSetA f+  , missingKey = \k -> (Just $!) <$> f k+  }+{-# INLINE generateAMissingSet #-}++-- | For keys that are present in the set but missing from the map, apply a+-- function and maybe use the result as the value for the merged map.+--+-- @since 0.8.1+generateMaybeMissingSet+  :: Applicative f => (k -> Maybe a) -> WhenMissingSet f k a+generateMaybeMissingSet f = WhenMissingSet+  { missingSubtree = \s -> pure (MS.fromSetMaybe f s)+  , missingKey = \k -> pure (f k)+  }+{-# INLINE generateMaybeMissingSet #-}++-- | For keys that are present in the set but missing from the map, apply a+-- function, and maybe use the result of the action as the value for the merged+-- map.+--+-- @since 0.8.1+generateMaybeAMissingSet+  :: Applicative f => (k -> f (Maybe a)) -> WhenMissingSet f k a+generateMaybeAMissingSet f = WhenMissingSet+  { missingSubtree = MS.fromSetMaybeA f+  , missingKey = \k -> forceMaybe <$> f k+  }+{-# INLINE generateMaybeAMissingSet #-}++forceMaybe :: Maybe a -> Maybe a+forceMaybe Nothing = Nothing+forceMaybe m@(Just !_) = m
src/Data/Map/Merge/Strict.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Map.Merge.Strict@@ -47,6 +45,7 @@     , merge      -- *** @WhenMatched@ tactics+    , dropMatched     , zipWithMaybeMatched     , zipWithMatched @@ -79,6 +78,7 @@     , traverseMaybeMissing     , traverseMissing     , filterAMissing+    , Internal.whenMissing      -- ** Covariant maps for tactics     , mapWhenMissing@@ -90,4 +90,5 @@     , runWhenMissing     ) where +import qualified Data.Map.Internal as Internal import Data.Map.Strict.Internal
src/Data/Map/Strict.hs view
@@ -1,11 +1,8 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-} #if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Map.Strict@@ -19,7 +16,8 @@ -- = Finite Maps (strict interface) -- -- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)--- from keys of type @k@ to values of type @v@.+-- from keys of type @k@ to values of type @v@. Most operations require that @k@+-- have an instance of the 'Ord' class. -- -- Each function in this module is careful to force values before installing -- them in a 'Map'. This is usually more efficient when laziness is not@@ -36,7 +34,8 @@ -- * If you are using 'Prelude.Int' keys, you will get much better performance for -- most operations using "Data.IntMap.Strict". ----- * If you don't care about ordering, consider use @Data.HashMap.Strict@ from the+-- * If you don't care about ordering and don't handle untrusted keys, consider+-- using @Data.HashMap.Strict@ from the -- <https://hackage.haskell.org/package/unordered-containers unordered-containers> -- package instead. --@@ -44,22 +43,16 @@ -- <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--- two maps as arguments and combine them, such as `union` and `intersection`,--- 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.+-- The @'Ord' k@ instance is expected to be lawful and define a total order.+-- Unless otherwise specified, operations expect equality on keys to be+-- extensional: if keys @k1@ and @k2@ satisfy @k1 == k2@, they are considered+-- identical. For instance, if only one key must be retained by an operation, it+-- is free to select either. -- -- -- == Warning@@ -80,21 +73,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.@@ -107,26 +121,34 @@     -- * Construction     , empty     , singleton-    , fromSet-    , fromArgSet      -- ** From Unordered Lists     , fromList     , fromListWith     , fromListWithKey+    , fromListUpsert      -- ** From Ascending Lists     , fromAscList     , fromAscListWith     , fromAscListWithKey+    , fromAscListUpsert     , fromDistinctAscList      -- ** From Descending Lists     , fromDescList     , fromDescListWith     , fromDescListWithKey+    , fromDescListUpsert     , fromDistinctDescList +    -- ** From @Set@+    , fromSet+    , fromSetA+    , fromSetMaybe+    , fromSetMaybeA+    , fromArgSet+     -- * Insertion     , insert     , insertWith@@ -135,10 +157,12 @@      -- * Deletion\/Update     , delete+    , pop     , adjust     , adjustWithKey     , update     , updateWithKey+    , upsert     , updateLookupWithKey     , alter     , alterF@@ -180,6 +204,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -205,6 +232,7 @@     , mapKeys     , mapKeysWith     , mapKeysMonotonic+    , mapAssocsMonotonic      -- * Folds     , foldr@@ -235,6 +263,7 @@      -- * Filter     , filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -271,12 +300,8 @@     -- * Min\/Max     , lookupMin     , lookupMax-    , findMin-    , findMax     , deleteMin     , deleteMax-    , deleteFindMin-    , deleteFindMax     , updateMin     , updateMax     , updateMinWithKey@@ -285,12 +310,12 @@     , maxView     , minViewWithKey     , maxViewWithKey+    , findMin+    , findMax+    , deleteFindMin+    , deleteFindMax      -- * Debugging-#ifdef __GLASGOW_HASKELL__-    , showTree-    , showTreeWith-#endif     , valid     ) where
src/Data/Map/Strict/Internal.hs view
@@ -5,8 +5,6 @@ #endif {-# OPTIONS_HADDOCK not-home #-} -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Map.Strict.Internal@@ -28,62 +26,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@@ -115,10 +95,12 @@      -- ** Delete\/Update     , delete+    , pop     , adjust     , adjustWithKey     , update     , updateWithKey+    , upsert     , updateLookupWithKey     , alter     , alterF@@ -142,6 +124,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -156,6 +141,7 @@     , runWhenMissing      -- *** @WhenMatched@ tactics+    , dropMatched     , zipWithMaybeMatched     , zipWithMatched @@ -207,6 +193,7 @@     , mapKeys     , mapKeysWith     , mapKeysMonotonic+    , mapAssocsMonotonic      -- * Folds     , foldr@@ -228,6 +215,9 @@     , keysSet     , argSet     , fromSet+    , fromSetA+    , fromSetMaybe+    , fromSetMaybeA     , fromArgSet      -- ** Lists@@ -235,6 +225,7 @@     , fromList     , fromListWith     , fromListWithKey+    , fromListUpsert      -- ** Ordered lists     , toAscList@@ -242,14 +233,17 @@     , fromAscList     , fromAscListWith     , fromAscListWithKey+    , fromAscListUpsert     , fromDistinctAscList     , fromDescList     , fromDescListWith     , fromDescListWithKey+    , fromDescListUpsert     , fromDistinctDescList      -- * Filter     , filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -301,10 +295,6 @@     , maxViewWithKey      -- * Debugging-#ifdef __GLASGOW_HASKELL__-    , showTree-    , showTreeWith-#endif     , valid     ) where @@ -326,21 +316,24 @@   , dropMissing   , filterMissing   , filterAMissing+  , dropMatched   , merge   , mergeA-  , fromDistinctAscList_linkTop-  , fromDistinctAscList_linkAll-  , fromDistinctDescList_linkTop-  , fromDistinctDescList_linkAll-  , FromDistinctMonoState (..)+  , ascLinkTop+  , ascLinkAll+  , descLinkTop+  , descLinkAll   , Stack (..)+  , MapBuilder(..)+  , emptyB+  , insertB+  , finishB   , (!)   , (!?)   , (\\)   , argSet   , assocs   , atKeyImpl-  , atKeyPlain   , balance   , balanceL   , balanceR@@ -349,6 +342,7 @@   , elems   , empty   , delete+  , pop   , deleteAt   , deleteFindMax   , deleteFindMin@@ -359,6 +353,7 @@   , drop   , dropWhileAntitone   , filter+  , filterKeys   , filterWithKey   , findIndex   , findMax@@ -373,7 +368,6 @@   , foldrWithKey   , foldrWithKey'   , glue-  , insertMax   , intersection   , isProperSubmapOf   , isProperSubmapOfBy@@ -383,6 +377,7 @@   , keysSet   , link   , lookup+  , findWithDefault   , lookupGE   , lookupGT   , lookupIndex@@ -409,6 +404,7 @@   , splitAt   , splitLookup   , splitRoot+  , symmetricDifference   , take   , takeWhileAntitone   , toList@@ -418,46 +414,23 @@   , 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) import Data.Semigroup (Arg (..))+import Data.Set.Internal (Set) import qualified Data.Set.Internal as Set import qualified Data.Map.Internal as L-import Utils.Containers.Internal.StrictPair+import Utils.Containers.Internal.Strict (StrictPair(..), toPair) -import Data.Bits (shiftL, shiftR) #ifdef __GLASGOW_HASKELL__ import Data.Coerce #endif -#ifdef __GLASGOW_HASKELL__ import Data.Functor.Identity (Identity (..))-#endif  import qualified Data.Foldable as Foldable --- $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@@ -470,32 +443,6 @@ -- 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 --------------------------------------------------------------------} @@ -531,11 +478,7 @@             LT -> balanceL ky y (go kx x l) r             GT -> balanceR ky y l (go kx x r)             EQ -> Bin sz kx x l r-#if __GLASGOW_HASKELL__ {-# INLINABLE insert #-}-#else-{-# INLINE insert #-}-#endif  -- | \(O(\log n)\). Insert with a function, combining new value and old value. -- @'insertWith' f key value mp@@@ -559,11 +502,7 @@             LT -> balanceL ky y (go f kx x l) r             GT -> balanceR ky y l (go f kx x r)             EQ -> let !y' = f x y in Bin sy kx y' l r-#if __GLASGOW_HASKELL__ {-# INLINABLE insertWith #-}-#else-{-# INLINE insertWith #-}-#endif  insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a insertWithR = go@@ -575,11 +514,7 @@             LT -> balanceL ky y (go f kx x l) r             GT -> balanceR ky y l (go f kx x r)             EQ -> let !y' = f y x in Bin sy ky y' 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@@@ -609,11 +544,7 @@             GT -> balanceR ky y l (go f kx x r)             EQ -> let !x' = f kx x y                   in Bin sy kx x' l r-#if __GLASGOW_HASKELL__ {-# INLINABLE insertWithKey #-}-#else-{-# INLINE insertWithKey #-}-#endif  insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a insertWithKeyR = go@@ -628,11 +559,7 @@             GT -> balanceR ky y l (go f kx x r)             EQ -> let !y' = f ky y x                   in Bin sy ky y' 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@)@@ -667,11 +594,7 @@                   in found :*: balanceR ky y l r'             EQ -> let x' = f kx x y                   in x' `seq` (Just y :*: Bin sy kx x' l r)-#if __GLASGOW_HASKELL__ {-# INLINABLE insertLookupWithKey #-}-#else-{-# INLINE insertLookupWithKey #-}-#endif  {--------------------------------------------------------------------   Deletion@@ -687,11 +610,7 @@  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.@@ -712,11 +631,7 @@            GT -> Bin sx kx x l (go f k r)            EQ -> Bin sx kx x' l r              where !x' = f kx x-#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@@ -729,11 +644,7 @@  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',@@ -758,14 +669,29 @@            EQ -> case f kx x of                    Just x' -> x' `seq` 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.+-- | \(O(\log n)\). Update the value at a key or insert a value if the key is+-- not in the map.+--+-- @+-- let inc = maybe 1 (+1)+-- upsert inc \'a\' (fromList [(\'a\',1),(\'c\',2)]) == fromList [(\'a\',2),(\'c\',2)]+-- upsert inc \'b\' (fromList [(\'a\',1),(\'c\',2)]) == fromList [(\'a\',1),(\'b\',1),(\'c\',2)]+-- @+--+-- @since 0.8.1+upsert :: Ord k => (Maybe a -> a) -> k -> Map k a -> Map k a+upsert f !k (Bin sz kx x l r) =+  case compare k kx of+    LT -> balanceL kx x (upsert f k l) r+    EQ -> let !x' = f (Just x) in Bin sz kx x' l r+    GT -> balanceR kx x l (upsert f k r)+upsert f !k Tip = singleton k (f Nothing)+{-# INLINABLE upsert #-}++-- | \(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@@ -788,11 +714,7 @@                EQ -> case f kx x of                        Just x' -> x' `seq` (Just x' :*: Bin sx kx x' l r)                        Nothing -> (Just x :*: glue l r)-#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'.@@ -823,31 +745,12 @@                EQ -> case f (Just x) of                        Just x' -> x' `seq` Bin sx kx x' l r                        Nothing -> glue l r-#if __GLASGOW_HASKELL__ {-# INLINABLE alter #-}-#else-{-# INLINE alter #-}-#endif  -- | \(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@@ -868,15 +771,27 @@ -- Note: 'alterF' is a flipped version of the @at@ combinator from -- @Control.Lens.At@. --+-- === Examples+--+-- @+-- -- Lookup the value at the key, and also remove the existing value or set a new value.+-- lookupAndSet :: Ord k => k -> Maybe a -> Map k a -> (Maybe a, Map k a)+-- lookupAndSet k new = alterF (\\old -> (old, new)) k+-- @+--+-- @+-- -- Delete the value at the key. If it is absent the result is Nothing.+-- mustDelete :: Ord k => k -> Map k a -> Maybe (Map k a)+-- mustDelete = alterF (Nothing <$)+-- @+-- -- @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 Strict k f m -#ifndef __GLASGOW_HASKELL__-{-# INLINE alterF #-}-#else-{-# INLINABLE [2] alterF #-}+#ifdef __GLASGOW_HASKELL__+{-# INLINE [2] alterF #-}  -- We can save a little time by recognizing the special case of -- `Control.Applicative.Const` and just doing a lookup.@@ -886,7 +801,7 @@  #-}  atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)-atKeyIdentity k f t = Identity $ atKeyPlain Strict k (coerce f) t+atKeyIdentity k f t = Identity (alter (coerce f) k t) {-# INLINABLE atKeyIdentity #-} #endif @@ -897,6 +812,8 @@ -- | \(O(\log n)\). Update the element at /index/. Calls 'error' when an -- invalid index is used. --+-- __Note__: This function is partial.+-- -- > 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@@ -979,9 +896,7 @@ 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  {--------------------------------------------------------------------   Union with a combining function@@ -1000,9 +915,7 @@ unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of   (l2, mb, r2) -> link k1 x1' (unionWith f l1 l2) (unionWith f r1 r2)     where !x1' = maybe x1 (f x1) mb-#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.@@ -1020,9 +933,7 @@ unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of   (l2, mb, r2) -> link k1 x1' (unionWithKey f l1 l2) (unionWithKey f r1 r2)     where !x1' = maybe x1 (f k1 x1) mb-#if __GLASGOW_HASKELL__ {-# INLINABLE unionWithKey #-}-#endif  {--------------------------------------------------------------------   Difference@@ -1040,9 +951,7 @@  differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a differenceWith f = merge preserveMissing dropMissing (zipWithMaybeMatched $ \_ x1 x2 -> f x1 x2)-#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.@@ -1055,9 +964,7 @@  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   {--------------------------------------------------------------------@@ -1078,9 +985,7 @@     !(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. --@@ -1097,9 +1002,7 @@     !(l2, mb, r2) = splitLookup k t2     !l1l2 = intersectionWithKey f l1 l2     !r1r2 = intersectionWithKey f r1 r2-#if __GLASGOW_HASKELL__ {-# INLINABLE intersectionWithKey #-}-#endif  -- | Map covariantly over a @'WhenMissing' f k x@. mapWhenMissing :: Functor f => (a -> b) -> WhenMissing f k x a -> WhenMissing f k x b@@ -1222,7 +1125,7 @@  -- | \(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'.@@ -1261,6 +1164,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 =@@ -1271,7 +1175,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@@ -1316,6 +1220,7 @@         combine !l' mx !r' = case mx of           Nothing -> link2 l' r'           Just !x' -> link kx x' l' r'+{-# INLINABLE traverseMaybeWithKey #-}  -- | \(O(n)\). Map values and separate the 'Left' and 'Right' results. --@@ -1461,6 +1366,8 @@ -- | \(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@@ -1472,25 +1379,94 @@ -- 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) []-#if __GLASGOW_HASKELL__+mapKeysWith c f m =+  finishB (foldlWithKey' (\b kx x -> insertWithB c (f kx) x b) emptyB m) {-# INLINABLE mapKeysWith #-}-#endif +-- | \(O(n)\). Map over keys and values with a function @f@ that is+-- monotonically strictly increasing in the keys. That is, for keys @kx@ and+-- @ky@ and values @x@ and @y@, if @kx@ < @ky@ then+-- @fst (f kx x)@ < @fst (f ky y)@.+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing in the key. This precondition is not checked.+--+-- @since 0.8.1+mapAssocsMonotonic :: (k1 -> a1 -> (k2, a2)) -> Map k1 a1 -> Map k2 a2+mapAssocsMonotonic f = go+  where+    go Tip = Tip+    go (Bin sz k1 x1 l r) = case f k1 x1 of+      (k2, !x2) -> Bin sz k2 x2 (go l) (go r)+-- See Note [INLINABLE to expose unfoldings] in Data.IntMap.Internal+{-# INLINABLE mapAssocsMonotonic #-}+ {--------------------------------------------------------------------   Conversions --------------------------------------------------------------------} --- | \(O(n)\). Build a map from a set of keys and a function which for each key--- computes its value.+-- | \(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) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r)+fromSet :: (k -> a) -> Set k -> Map k a+#ifdef __GLASGOW_HASKELL__+fromSet =+  (coerce :: ((k -> Identity a) -> Set k -> Identity (Map k a))+          -> (k -> a) -> Set k -> Map k a)+    fromSetA+#else+fromSet f = runIdentity . fromSetA (pure . f)+#endif +-- | \(O(n)\). Build a map from a 'Set' of keys and a function which for each+-- key computes its value in an 'Applicative' context.+--+-- The @Applicative@ actions are sequenced in order of increasing key.+--+-- > let f k = if k == 0 then Nothing else Just (6 `div` k)+-- > fromSetA f (Data.Set.fromList [1,2,3,4]) == Just (fromList [(1,6),(2,3),(3,2),(4,1)])+-- > fromSetA f (Data.Set.fromList [0,1,2]) == Nothing+--+-- @since 0.8.1+fromSetA :: Applicative f => (k -> f a) -> Set k -> f (Map k a)+fromSetA _ Set.Tip = pure Tip+fromSetA f (Set.Bin sz x l r) = +  liftA3 (flip (Bin sz x $!)) (fromSetA f l) (f x) (fromSetA f r)+{-# INLINABLE fromSetA #-}++-- | \(O(n)\). Build a map from a 'Set' of keys and a function which for each+-- key optionally computes its value.+--+-- > let f k = if even k then Just (replicate k 'a') else Nothing+-- > fromSetMaybe f (Data.Set.fromList [1,2,3,4]) == fromList [(2,"aa"), (4,"aaaa")]+--+-- @since 0.8.1+fromSetMaybe :: (k -> Maybe a) -> Set k -> Map k a+#ifdef __GLASGOW_HASKELL__+fromSetMaybe =+  (coerce :: ((k -> Identity (Maybe a)) -> Set k -> Identity (Map k a))+          -> (k -> Maybe a) -> Set k -> Map k a)+     fromSetMaybeA+#else+fromSetMaybe f s = runIdentity (fromSetMaybeA (Identity . f) s)+#endif++-- | \(O(n)\). Build a map from a 'Set' of keys and a function which for each+-- key optionally computes its values in an 'Applicative' context.+--+-- The @Applicative@ actions are sequenced in order of increasing key.+--+-- @since 0.8.1+fromSetMaybeA :: Applicative f => (k -> f (Maybe a)) -> Set k -> f (Map k a)+fromSetMaybeA f = go+  where+    go Set.Tip = pure Tip+    go (Set.Bin _ k l r) =+      liftA3 (\l' mx r' -> maybe link2 (link k $!) mx l' r') (go l) (f k) (go r)+{-# INLINABLE fromSetMaybeA #-}+ -- | \(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")]@@ -1503,59 +1479,25 @@ {--------------------------------------------------------------------   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. -- 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, a linear-time implementation is used.+-- 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. --+-- 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 --@@ -1563,6 +1505,8 @@ -- -- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@. --+-- See also: 'fromListUpsert'+-- -- === Performance -- -- You should ensure that the given @f@ is fast with this order of arguments.@@ -1591,29 +1535,48 @@ -- > 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. --+-- 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'.+--+-- See also: 'fromListUpsert'  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 +-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a+-- combining function.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- The result is equivalent to performing an @upsert@ for every key\/value in+-- the list.+--+-- @+-- fromListUpsert f = foldl' (\\m (k, x) -> 'upsert' (f x) k m) 'empty'+-- @+--+-- > let f x = maybe [x] (x:)+-- > fromListUpsert f [(5,'a'), (5,'b'), (3,'c'), (3,'d'), (5,'e')] == fromList [(3,"dc"), (5,"eba")]+--+-- @since 0.8.1+fromListUpsert :: Ord k => (a -> Maybe b -> b) -> [(k, a)] -> Map k b+fromListUpsert f xs =+  finishB (Foldable.foldl' (\b (kx, x) -> upsertB (f x) kx b) emptyB xs)+{-# INLINE fromListUpsert #-}  -- INLINE for fusion+ {--------------------------------------------------------------------   Building trees from ascending/descending lists can be done in linear time. @@ -1627,8 +1590,11 @@ --------------------------------------------------------------------}  -- | \(O(n)\). Build a map from an ascending list in linear time.--- /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 '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@@ -1636,13 +1602,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./ --+-- __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@@ -1650,136 +1617,224 @@ 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./ --+-- __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'.+--+-- See also: 'fromAscListUpsert'  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./ --+-- __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'.+--+-- See also: 'fromDescListUpsert'  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 -- 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+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"c")] == fromList [(3, "b"), (5, "5:c5:ba")]+-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"c")]) == True+-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"c")]) == False -- -- Also see the performance note on 'fromListWith'.+--+-- See also: 'fromAscListUpsert'  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 -- 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'.+--+-- See also: 'fromDescListUpsert'  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+    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 -  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+-- | \(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 'fromListUpsert'+-- if the precondition may not hold.+--+-- > let f x = maybe [x] (x:)+-- > fromAscListUpsert f [(3,'a'), (3,'b'), (5,'c'), (5,'d'), (5,'e')] == fromList [(3,"ba"), (5,"edc")]+--+-- @since 0.8.1+fromAscListUpsert :: Eq k => (a -> Maybe b -> b) -> [(k, a)] -> Map k b+fromAscListUpsert 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 y (Just x)) l stk'+        | Tip <- l -> let !y' = f y Nothing+                      in ascLinkTop stk' 1 (singleton kx x) ky y'+        | otherwise -> push' ky (f y Nothing) Tip stk+      Nada -> push' ky (f y Nothing) Tip stk+    push' kx !x = Push kx x+{-# INLINE fromAscListUpsert #-}  -- 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 'fromListUpsert'+-- if the precondition may not hold.+--+-- > let f x = maybe [x] (x:)+-- > fromDescListUpsert f [(5,'a'), (5,'b'), (5,'c'), (3,'d'), (3,'e')] == fromList [(3,"ed"), (5,"cba")]+--+-- @since 0.8.1+fromDescListUpsert :: Eq k => (a -> Maybe b -> b) -> [(k, a)] -> Map k b+fromDescListUpsert 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 y (Just x)) r stk'+        | Tip <- r -> let !y' = f y Nothing+                      in descLinkTop ky y' 1 (singleton kx x) stk'+        | otherwise -> push' ky (f y Nothing) Tip stk+      Nada -> push' ky (f y Nothing) Tip stk+    push' kx !x = Push kx x+{-# INLINE fromDescListUpsert #-}  -- INLINE for fusion+ -- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time.--- /The precondition 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")] -- > 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 = fromDistinctAscList_linkAll . Foldable.foldl' next (State0 Nada)+fromDistinctAscList xs = ascLinkAll (Foldable.foldl' next Nada xs)   where-    next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a-    next (State0 stk) (!kx, !x) = fromDistinctAscList_linkTop (Bin 1 kx x Tip Tip) stk-    next (State1 l stk) (kx, x) = State0 (Push kx x l stk)+    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./ --+-- __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 = fromDistinctDescList_linkAll . Foldable.foldl' next (State0 Nada)+fromDistinctDescList xs = descLinkAll (Foldable.foldl' next Nada xs)   where-    next :: FromDistinctMonoState k a -> (k,a) -> FromDistinctMonoState k a-    next (State0 stk) (!kx, !x) = fromDistinctDescList_linkTop (Bin 1 kx x Tip Tip) stk-    next (State1 r stk) (kx, x) = State0 (Push kx x r stk)+    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++{--------------------------------------------------------------------+  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 #-}++-- Upsert a key-value. The given function is used to generate the value based+-- on the existing value for the key. Strict in the inserted value.+upsertB :: Ord k => (Maybe b -> b) -> k -> MapBuilder k b -> MapBuilder k b+upsertB f !ky b = case b of+  BAsc stk -> case stk of+    Push kx x l stk' -> case compare ky kx of+      LT -> BMap (upsert f ky (ascLinkAll stk))+      EQ -> BAsc (push' ky (f (Just x)) l stk')+      GT -> case l of+        Tip -> let !y = f Nothing+               in BAsc (ascLinkTop stk' 1 (singleton kx x) ky y)+        Bin{} -> BAsc (push' ky (f Nothing) Tip stk)+    Nada -> BAsc (push' ky (f Nothing) Tip Nada)+  BMap m -> BMap (upsert f ky m)+  where+    push' kx !x = Push kx x+{-# INLINE upsertB #-}
src/Data/Sequence.hs view
@@ -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>. -- ----------------------------------------------------------------------------- @@ -172,6 +172,8 @@     viewl,          -- :: Seq a -> ViewL a     ViewR(..),     viewr,          -- :: Seq a -> ViewR a+    -- ** List+    toList,     -- * Scans     scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a     scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a@@ -192,6 +194,7 @@     breakr,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)     partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)     filter,         -- :: (a -> Bool) -> Seq a -> Seq a+    mapMaybe,       -- :: (a -> Maybe b) -> Seq a -> Seq b     -- * Sorting     sort,           -- :: Ord a => Seq a -> Seq a     sortBy,         -- :: (a -> a -> Ordering) -> Seq a -> Seq a@@ -207,10 +210,13 @@     adjust',        -- :: (a -> a) -> Int -> Seq a -> Seq a     update,         -- :: Int -> a -> Seq a -> Seq a     take,           -- :: Int -> Seq a -> Seq a+    takeR,          -- :: Int -> Seq a -> Seq a     drop,           -- :: Int -> Seq a -> Seq a+    dropR,          -- :: Int -> Seq a -> Seq a     insertAt,       -- :: Int -> a -> Seq a -> Seq a     deleteAt,       -- :: Int -> Seq a -> Seq a     splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)+    splitAtR,       -- :: Int -> Seq a -> (Seq a, Seq a)     -- ** Indexing with predicates     -- | These functions perform sequential searches from the left     -- or right ends of the sequence, returning indices of matching
src/Data/Sequence/Internal.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Trustworthy #-}@@ -17,10 +17,8 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} #endif-{-# LANGUAGE PatternGuards #-}  {-# OPTIONS_HADDOCK not-home #-}-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}  ----------------------------------------------------------------------------- -- |@@ -46,35 +44,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 -----------------------------------------------------------------------------@@ -86,8 +70,6 @@ #else     Seq (..), #endif-    State(..),-    execState,     foldDigit,     foldNode,     foldWithIndexDigit,@@ -123,6 +105,8 @@     viewl,          -- :: Seq a -> ViewL a     ViewR(..),     viewr,          -- :: Seq a -> ViewR a+    -- ** List+    toList,     -- * Scans     scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a     scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a@@ -143,6 +127,7 @@     breakr,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)     partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)     filter,         -- :: (a -> Bool) -> Seq a -> Seq a+    mapMaybe,       -- :: (a -> Maybe b) -> Seq a -> Seq b     -- * Indexing     lookup,         -- :: Int -> Seq a -> Maybe a     (!?),           -- :: Seq a -> Int -> Maybe a@@ -151,10 +136,13 @@     adjust',        -- :: (a -> a) -> Int -> Seq a -> Seq a     update,         -- :: Int -> a -> Seq a -> Seq a     take,           -- :: Int -> Seq a -> Seq a+    takeR,          -- :: Int -> Seq a -> Seq a     drop,           -- :: Int -> Seq a -> Seq a+    dropR,          -- :: Int -> Seq a -> Seq a     insertAt,       -- :: Int -> a -> Seq a -> Seq a     deleteAt,       -- :: Int -> Seq a -> Seq a     splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)+    splitAtR,       -- :: Int -> Seq a -> (Seq a, Seq a)     -- ** Indexing with predicates     -- | These functions perform sequential searches from the left     -- or right ends of the sequence, returning indices of matching@@ -207,12 +195,12 @@ 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 (foldr', toList)+import Data.Foldable (foldr') import qualified Data.Foldable as F  import qualified Data.Semigroup as Semigroup@@ -220,32 +208,37 @@ import Data.Traversable  -- 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(..))+#  if __GLASGOW_HASKELL__ >= 914+import qualified Language.Haskell.TH.Lift as TH+#  else import qualified Language.Haskell.TH.Syntax as TH -- See Note [ Template Haskell Dependencies ] import Language.Haskell.TH ()+#  endif 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 ((.#), (.^#)) import Data.Coerce import qualified GHC.Exts+#else+import qualified Data.List+#endif +import Data.Array (Ix, Array)+import qualified Data.Array+ import Data.Functor.Identity (Identity(..)) -import Utils.Containers.Internal.StrictPair (StrictPair (..), toPair)+import Utils.Containers.Internal.Strict (StrictPair (..), toPair) import Control.Monad.Zip (MonadZip (..)) import Control.Monad.Fix (MonadFix (..), fix) @@ -344,7 +337,8 @@ #ifdef __GLASGOW_HASKELL__ -- | @since 0.6.6 instance TH.Lift a => TH.Lift (Seq a) where-#  if MIN_VERSION_template_haskell(2,16,0)+-- template-haskell >= 2.16+#  if __GLASGOW_HASKELL__ >= 810   liftTyped t = [|| coerceFT z ||] #  else   lift t = [| coerceFT z |]@@ -392,33 +386,45 @@  #-} #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      length = length     {-# INLINE length #-}@@ -426,9 +432,7 @@     {-# INLINE null #-}  instance Traversable Seq where-#if __GLASGOW_HASKELL__     {-# INLINABLE traverse #-}-#endif     traverse _ (Seq EmptyT) = pure (Seq EmptyT)     traverse f' (Seq (Single (Elem x'))) =         (\x'' -> Seq (Single (Elem x''))) <$> f' x'@@ -504,8 +508,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     (>>) = (*>)@@ -908,10 +915,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@@ -929,14 +938,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)+  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@@ -957,11 +1004,16 @@     (xs,t) <- readLst s     pure (fromList xs, t) +-- | @mempty@ = 'empty' instance Monoid (Seq a) where     mempty = empty+#if !MIN_VERSION_base(4,11,0)     mappend = (Semigroup.<>)+#endif --- | @since 0.5.7+-- | @(<>)@ = '(><)'+--+-- @since 0.5.7 instance Semigroup.Semigroup (Seq a) where     (<>)    = (><)     stimes = cycleNTimes . fromIntegral@@ -1048,9 +1100,7 @@          foldMapNodeN :: Monoid m => (Node a -> m) -> Node (Node a) -> m         foldMapNodeN f t = foldNode (<>) f t-#if __GLASGOW_HASKELL__     {-# INLINABLE foldMap #-}-#endif      foldr _ z' EmptyT = z'     foldr f' z' (Single x') = x' `f'` z'@@ -1101,16 +1151,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 +1172,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 +1220,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@@ -1230,16 +1286,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@@ -1272,6 +1328,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@@ -1328,12 +1391,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@@ -1350,6 +1413,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@@ -1410,6 +1478,10 @@ 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 -------------------------------------------------------@@ -1692,6 +1764,10 @@ singleton x     =  Seq (Single (Elem x))  -- | \( O(\log n) \). @replicate n x@ is a sequence consisting of @n@ copies of @x@.+--+-- Calls 'error' if @n < 0@.+--+-- __Note__: This function is partial. replicate       :: Int -> a -> Seq a replicate n x   | n >= 0      = runIdentity (replicateA n (Identity x))@@ -1700,6 +1776,10 @@ -- | 'replicateA' is an 'Applicative' version of 'replicate', and makes -- \( O(\log n) \) calls to 'liftA2' and 'pure'. --+-- Calls 'error' if @n < 0@.+--+-- __Note__: This function is partial.+-- -- > replicateA n x = sequenceA (replicate n x) replicateA :: Applicative f => Int -> f a -> f (Seq a) replicateA n x@@ -1707,13 +1787,9 @@   | otherwise   = error "replicateA takes a nonnegative integer argument" {-# SPECIALIZE replicateA :: Int -> State a b -> State a (Seq b) #-} --- | 'replicateM' is the @Seq@ counterpart of--- @Control.Monad.'Control.Monad.replicateM'@.------ > replicateM n x = sequence (replicate n x)+-- | Synonym for 'replicateA'. ----- For @base >= 4.8.0@ and @containers >= 0.5.11@, 'replicateM'--- is a synonym for 'replicateA'.+-- This definition exists for backwards compatibility. replicateM :: Applicative m => Int -> m a -> m (Seq a) replicateM = replicateA @@ -1722,11 +1798,15 @@ -- @k@ is 0. -- -- prop> cycleTaking k = fromList . take k . cycle . toList-+-- -- If you wish to concatenate a possibly empty sequence @xs@ with--- itself precisely @k@ times, use @'stimes' k xs@ instead of this--- function.+-- itself precisely @k@ times, use @'Data.Semigroup.stimes' k xs@ instead of+-- this function. --+-- Calls 'error' if @k > 0@ and @null xs@.+--+-- __Note__: This function is partial.+-- -- @since 0.5.8 cycleTaking :: Int -> Seq a -> Seq a cycleTaking n !_xs | n <= 0 = empty@@ -2139,7 +2219,9 @@ -- | \( O(n) \).  Constructs a sequence by repeated application of a function -- to a seed value. ----- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))+-- Calls 'error' if @n < 0@.+--+-- __Note__: This function is partial. iterateN :: Int -> (a -> a) -> a -> Seq a iterateN n f x   | n >= 0      = replicateA n (State (\ y -> (f y, y))) `execState` x@@ -2296,6 +2378,12 @@ viewRTree (Deep s pr m (Four w x y z)) =     SnocRTree (Deep (s - size z) pr m (Three w x y)) z +-- | \(O(n)\). Convert to a list of elements.+--+-- @since 0.8.1+toList :: Seq a -> [a]+toList = F.toList+ ------------------------------------------------------------------------ -- Scans --@@ -2318,6 +2406,10 @@  -- | 'scanl1' is a variant of 'scanl' that has no starting value argument: --+-- Calls 'error' if the sequence is empty.+--+-- __Note__: This function is partial.+-- -- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...] scanl1 :: (a -> a -> a) -> Seq a -> Seq a scanl1 f xs = case viewl xs of@@ -2329,6 +2421,10 @@ scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0  -- | 'scanr1' is a variant of 'scanr' that has no starting value argument.+--+-- Calls 'error' if the sequence is empty.+--+-- __Note__: This function is partial. scanr1 :: (a -> a -> a) -> Seq a -> Seq a scanr1 f xs = case viewr xs of     EmptyR          -> error "scanr1 takes a nonempty sequence as an argument"@@ -2343,7 +2439,9 @@ -- -- prop> xs `index` i = toList xs !! i ----- Caution: 'index' necessarily delays retrieving the requested+-- __Note__: This function is partial. Prefer 'lookup'.+--+-- __Note__: 'index' necessarily delays retrieving the requested -- element until the result is forced. It can therefore lead to a space -- leak if the result is stored, unforced, in another structure. To retrieve -- an element immediately without forcing it, use 'lookup' or '(!?)'.@@ -3194,9 +3292,7 @@   foldMapWithIndexNodeN :: Monoid m => (Int -> Node a -> m) -> Int -> Node (Node a) -> m   foldMapWithIndexNodeN f i t = foldWithIndexNode (<>) f i t -#if __GLASGOW_HASKELL__ {-# INLINABLE foldMapWithIndex #-}-#endif  -- | 'traverseWithIndex' is a version of 'traverse' that also offers -- access to the index of each element.@@ -3277,11 +3373,7 @@  #ifdef __GLASGOW_HASKELL__ {-# INLINABLE [1] traverseWithIndex #-}-#else-{-# INLINE [1] traverseWithIndex #-}-#endif -#ifdef __GLASGOW_HASKELL__ {-# RULES "travWithIndex/mapWithIndex" forall f g xs . traverseWithIndex f (mapWithIndex g xs) =   traverseWithIndex (\k a -> f k (g k a)) xs@@ -3314,6 +3406,10 @@ -- | \( O(n) \). Convert a given sequence length and a function representing that -- sequence into a sequence. --+-- Calls 'error' if @n < 0@.+--+-- __Note__: This function is partial.+-- -- @since 0.5.6.2 fromFunction :: Int -> (Int -> a) -> Seq a fromFunction len f | len < 0 = error "Data.Sequence.fromFunction called with negative len"@@ -3385,6 +3481,15 @@   | i <= 0 = empty   | otherwise = xs +-- | \( O(\log(\min(i,n-i))) \). The last @i@ elements of a sequence.+-- If @i@ is negative, @'takeR' i s@ yields the empty sequence.+-- If the sequence contains fewer than @i@ elements, the whole sequence+-- is returned.+--+-- @since 0.8.1+takeR :: Int -> Seq a -> Seq a+takeR i xs = drop (length xs - i) xs+ takeTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a) takeTreeE !_i EmptyT = EmptyT takeTreeE i t@(Single _)@@ -3547,6 +3652,15 @@   | i <= 0 = xs   | otherwise = empty +-- | \( O(\log(\min(i,n-i))) \). Elements of a sequence before the last @i@.+-- If @i@ is negative, @'dropR' i s@ yields the whole sequence.+-- If the sequence contains fewer than @i@ elements, the empty sequence+-- is returned.+--+-- @since 0.8.1+dropR :: Int -> Seq a -> Seq a+dropR i xs = take (length xs - i) xs+ -- We implement `drop` using a "take from the rear" strategy.  There's no -- particular technical reason for this; it just lets us reuse the arithmetic -- from `take` (which itself reuses the arithmetic from `splitAt`) instead of@@ -3716,6 +3830,14 @@   | i <= 0 = (empty, xs)   | otherwise = (xs, empty) +-- | \( O(\log(\min(i,n-i))) \). Split a sequence at a given position,+-- with the position being counted from the last (rightmost) element.+-- @'splitAtR' i s = ('dropR' i s, 'takeR' i s)@.+--+-- @since 0.8.1+splitAtR :: Int -> Seq a -> (Seq a, Seq a)+splitAtR i xs = splitAt (length xs - i) xs+ -- | \( O(\log(\min(i,n-i))) \) A version of 'splitAt' that does not attempt to -- enhance sharing when the split point is less than or equal to 0, and that -- gives completely wrong answers when the split point is at least the length@@ -3892,6 +4014,10 @@ -- \( c = n \)) to \( O(n) \) (for \( c = 1 \)). The true bound is more like -- \( O \Bigl( \bigl(\frac{n}{c} - 1\bigr) (\log (c + 1)) + 1 \Bigr) \) --+-- Calls 'error' if @n <= 0@ and @not (null xs)@.+--+-- __Note__: This function is partial.+-- -- @since 0.5.8 chunksOf :: Int -> Seq a -> Seq (Seq a) chunksOf n xs | n <= 0 =@@ -3995,8 +4121,10 @@         (tailsTree f' m)         (fmap (f . digitToTree) (tailsDigit sf))   where-    f' ms = let ConsLTree node m' = viewLTree ms in+    f' ms = case viewLTree ms of+      ConsLTree node m' ->         fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)+      EmptyLTree -> error "EmptyLTree"  {-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-} {-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}@@ -4010,8 +4138,10 @@         (initsTree f' m)         (fmap (f . deep pr m) (initsDigit sf))   where-    f' ms =  let SnocRTree m' node = viewRTree ms in+    f' ms = case viewRTree ms of+      SnocRTree m' node ->              fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)+      EmptyRTree -> error "EmptyRTree"  {-# INLINE foldlWithIndex #-} -- | 'foldlWithIndex' is a version of 'foldl' that also provides access@@ -4103,6 +4233,15 @@ filter :: (a -> Bool) -> Seq a -> Seq a filter p = foldl' (\ xs x -> if p x then xs `snoc'` x else xs) empty +-- | \( O(n) \). Map elements and collect the 'Just' results.+--+-- @since 0.8.1+mapMaybe :: (a -> Maybe b) -> Seq a -> Seq b+mapMaybe f = foldl' go empty+  where go xs x = case f x of+          Nothing -> xs+          Just x' -> xs `snoc'` x'+ -- Indexing sequences  -- | 'elemIndexL' finds the leftmost index of the specified element,@@ -4212,15 +4351,17 @@ -- eventually find a less mind-bending way to accomplish this.  -- | \( O(n) \). Create a sequence from a finite list of elements.--- There is a function 'toList' in the opposite direction for all--- instances of the 'Foldable' class, including 'Seq'.+--+-- @'fromList' . 'toList' = id@+--+-- For any finite list @xs@, @'toList' ('fromList' xs) = xs@. fromList        :: [a] -> Seq a -- Note: we can avoid map_elem if we wish by scattering -- Elem applications throughout mkTreeE and getNodesE, but -- 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)@@ -4268,7 +4409,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 =@@ -4295,7 +4436,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)@@ -4337,7 +4478,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 =
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:@@ -406,8 +407,8 @@                          -> Maybe b foldToMaybeWithIndexTree = foldToMaybeWithIndexTree'   where-    {-# SPECIALISE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> Maybe b #-}-    {-# SPECIALISE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> Maybe b #-}+    {-# SPECIALIZE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> Maybe b #-}+    {-# SPECIALIZE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> Maybe b #-}     foldToMaybeWithIndexTree'         :: Sized a         => (b -> b -> b) -> (Int -> a -> b) -> Int -> FingerTree a -> Maybe b@@ -421,14 +422,14 @@         m' = foldToMaybeWithIndexTree' (<+>) (node (<+>) f) sPspr m         !sPspr = s + size pr         !sPsprm = sPspr + size m-    {-# SPECIALISE digit :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> b #-}-    {-# SPECIALISE digit :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Digit (Node y) -> b #-}+    {-# SPECIALIZE digit :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> b #-}+    {-# SPECIALIZE digit :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Digit (Node y) -> b #-}     digit         :: Sized a         => (b -> b -> b) -> (Int -> a -> b) -> Int -> Digit a -> b     digit = foldWithIndexDigit-    {-# SPECIALISE node :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Node (Elem y) -> b #-}-    {-# SPECIALISE node :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Node (Node y) -> b #-}+    {-# SPECIALIZE node :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Node (Elem y) -> b #-}+    {-# SPECIALIZE node :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Node (Node y) -> b #-}     node         :: Sized a         => (b -> b -> b) -> (Int -> a -> b) -> Int -> Node a -> b
src/Data/Set.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Set@@ -17,25 +15,35 @@ -- = Finite Sets -- -- 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.+-- require that @e@ have an instance of the 'Ord' class. A 'Set' is strict in+-- its elements. --+-- When deciding if this is the correct data structure to use, consider:+--+-- * If you are using 'Int' keys, you will get much better performance for most+-- operations using "Data.IntSet".+--+-- * If you don't care about ordering and don't handle untrusted elements,+-- consider using @Data.HashSet@ 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/set.html sets introduction>. ----- 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.+-- 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 --+-- The @'Ord' e@ instance is expected to be lawful and define a total order.+-- Unless otherwise specified, operations expect equality to be extensional: if+-- elements @x1@ and @x2@ satisfy @x1 == x2@, they are considered identical. For+-- instance, if only one element must be retained by an operation, it is free to+-- select either. --+-- -- == Warning -- -- The size of the set must not exceed @maxBound::Int@. Violation of@@ -48,29 +56,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-#else-              Set(..)-#endif              -- * Construction             , empty@@ -87,6 +110,7 @@              -- * Deletion             , delete+            , pop              -- * Generalized insertion/deletion @@ -111,14 +135,19 @@             , difference             , (\\)             , intersection+            , intersections+            , symmetricDifference             , cartesianProduct             , disjointUnion+            , Intersection(..)              -- * Filter             , S.filter+            , filterA             , takeWhileAntitone             , dropWhileAntitone             , spanAntitone+            , mapMaybe             , partition             , split             , splitMember@@ -149,14 +178,14 @@             -- * Min\/Max             , lookupMin             , lookupMax-            , findMin-            , findMax             , deleteMin             , deleteMax-            , deleteFindMin-            , deleteFindMax             , maxView             , minView+            , findMin+            , findMax+            , deleteFindMin+            , deleteFindMax              -- * Conversion @@ -170,14 +199,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,2124 +1,2759 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-#endif--{-# OPTIONS_HADDOCK not-home #-}--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.Set.Internal--- Copyright   :  (c) Daan Leijen 2002--- 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 sets.------ 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------ 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/\",---      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'.  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---------------------------------------------------------------------------------- [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 IntSet, 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 Set 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.Set.Internal (-            -- * Set type-              Set(..)       -- instance Eq,Ord,Show,Read,Data-            , Size--            -- * Operators-            , (\\)--            -- * Query-            , null-            , size-            , member-            , notMember-            , lookupLT-            , lookupGT-            , lookupLE-            , lookupGE-            , isSubsetOf-            , isProperSubsetOf-            , disjoint--            -- * Construction-            , empty-            , singleton-            , insert-            , delete-            , alterF-            , powerSet--            -- * Combine-            , union-            , unions-            , difference-            , intersection-            , intersections-            , cartesianProduct-            , disjointUnion-            , Intersection(..)---            -- * Filter-            , filter-            , takeWhileAntitone-            , dropWhileAntitone-            , spanAntitone-            , partition-            , split-            , splitMember-            , splitRoot--            -- * Indexed-            , lookupIndex-            , findIndex-            , elemAt-            , deleteAt-            , take-            , drop-            , splitAt--            -- * Map-            , map-            , mapMonotonic--            -- * Folds-            , foldr-            , foldl-            -- ** 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-            , fromDescList-            , fromDistinctDescList--            -- * Debugging-            , showTree-            , showTreeWith-            , valid--            -- Internals (for testing)-            , bin-            , balanced-            , link-            , merge-            ) where--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)-import Data.Semigroup (Semigroup(stimes))-import Data.List.NonEmpty (NonEmpty(..))-#if !(MIN_VERSION_base(4,11,0))-import Data.Semigroup (Semigroup((<>)))-#endif-import Data.Semigroup (stimesIdempotentMonoid, stimesIdempotent)-import Data.Functor.Classes-import Data.Functor.Identity (Identity)-import qualified Data.Foldable as Foldable-import Control.DeepSeq (NFData(rnf))--import Utils.Containers.Internal.StrictPair-import Utils.Containers.Internal.PtrEquality--#if __GLASGOW_HASKELL__-import GHC.Exts ( build, lazy )-import qualified GHC.Exts as GHCExts-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 ()-#endif---{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}-infixl 9 \\ ------ | \(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__-{-# INLINABLE (\\) #-}-#endif--{---------------------------------------------------------------------  Sets are size balanced trees---------------------------------------------------------------------}--- | A set of values @a@.---- See Note: Order of constructors-data Set a    = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)-              | Tip--type Size     = Int--#ifdef __GLASGOW_HASKELL__-type role Set nominal-#endif---- | @since 0.6.6-deriving instance Lift a => Lift (Set a)--instance Ord a => Monoid (Set a) where-    mempty  = empty-    mconcat = unions-    mappend = (<>)---- | @since 0.5.7-instance Ord a => Semigroup (Set a) where-    (<>)    = union-    stimes  = stimesIdempotentMonoid---- | Folds in order of increasing key.-instance Foldable.Foldable Set where-    fold = go-      where go Tip = mempty-            go (Bin 1 k _ _) = k-            go (Bin _ k l r) = go l `mappend` (k `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 k _ _) = f k-            go (Bin _ k l r) = go l `mappend` (f k `mappend` go r)-    {-# INLINE foldMap #-}-    foldl' = foldl'-    {-# INLINE foldl' #-}-    foldr' = foldr'-    {-# INLINE foldr' #-}-    length = size-    {-# INLINE length #-}-    null   = null-    {-# INLINE null #-}-    toList = toList-    {-# INLINE toList #-}-    elem = go-      where go !_ Tip = False-            go x (Bin _ y l r) = x == y || go x l || go x r-    {-# INLINABLE elem #-}-    minimum = findMin-    {-# INLINE minimum #-}-    maximum = findMax-    {-# INLINE maximum #-}-    sum = foldl' (+) 0-    {-# INLINABLE sum #-}-    product = foldl' (*) 1-    {-# INLINABLE product #-}--#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, Ord a) => Data (Set a) where-  gfoldl f z set = z fromList `f` (toList set)-  toConstr _     = fromListConstr-  gunfold k z c  = case constrIndex c of-    1 -> k (z fromList)-    _ -> error "gunfold"-  dataTypeOf _   = setDataType-  dataCast1 f    = gcast1 f--fromListConstr :: Constr-fromListConstr = mkConstr setDataType "fromList" [] Prefix--setDataType :: DataType-setDataType = mkDataType "Data.Set.Internal.Set" [fromListConstr]--#endif--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | \(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.-size :: Set a -> Int-size Tip = 0-size (Bin sz _ _ _) = sz-{-# INLINE size #-}---- | \(O(\log n)\). Is the element in the set?-member :: Ord a => a -> Set a -> Bool-member = go-  where-    go !_ Tip = False-    go x (Bin _ y l r) = case compare x y of-      LT -> go x l-      GT -> go x r-      EQ -> True-#if __GLASGOW_HASKELL__-{-# INLINABLE member #-}-#else-{-# INLINE member #-}-#endif---- | \(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__-{-# INLINABLE notMember #-}-#else-{-# INLINE notMember #-}-#endif---- | \(O(\log n)\). Find largest element smaller than the given one.------ > lookupLT 3 (fromList [3, 5]) == Nothing--- > lookupLT 5 (fromList [3, 5]) == Just 3-lookupLT :: Ord a => a -> Set a -> Maybe a-lookupLT = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing x (Bin _ y l r) | x <= y = goNothing x l-                              | otherwise = goJust x y r--    goJust !_ best Tip = Just best-    goJust x best (Bin _ y l r) | x <= y = goJust x best l-                                | otherwise = goJust x y r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupLT #-}-#else-{-# INLINE lookupLT #-}-#endif---- | \(O(\log n)\). Find smallest element greater than the given one.------ > lookupGT 4 (fromList [3, 5]) == Just 5--- > lookupGT 5 (fromList [3, 5]) == Nothing-lookupGT :: Ord a => a -> Set a -> Maybe a-lookupGT = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing x (Bin _ y l r) | x < y = goJust x y l-                              | otherwise = goNothing x r--    goJust !_ best Tip = Just best-    goJust x best (Bin _ y l r) | x < y = goJust x y l-                                | otherwise = goJust x best r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupGT #-}-#else-{-# INLINE lookupGT #-}-#endif---- | \(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-lookupLE :: Ord a => a -> Set a -> Maybe a-lookupLE = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing x (Bin _ y l r) = case compare x y of LT -> goNothing x l-                                                    EQ -> Just y-                                                    GT -> goJust x y r--    goJust !_ best Tip = Just best-    goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x best l-                                                      EQ -> Just y-                                                      GT -> goJust x y r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupLE #-}-#else-{-# INLINE lookupLE #-}-#endif---- | \(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-lookupGE :: Ord a => a -> Set a -> Maybe a-lookupGE = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing x (Bin _ y l r) = case compare x y of LT -> goJust x y l-                                                    EQ -> Just y-                                                    GT -> goNothing x r--    goJust !_ best Tip = Just best-    goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x y l-                                                      EQ -> Just y-                                                      GT -> goJust x best r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupGE #-}-#else-{-# INLINE lookupGE #-}-#endif--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | \(O(1)\). The empty set.-empty  :: Set a-empty = Tip-{-# INLINE empty #-}---- | \(O(1)\). Create a singleton set.-singleton :: a -> Set a-singleton x = Bin 1 x Tip Tip-{-# INLINE singleton #-}--{---------------------------------------------------------------------  Insertion, Deletion---------------------------------------------------------------------}--- | \(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.---- See Note: Type of local 'go' function--- See Note: Avoiding worker/wrapper (in Data.Map.Internal)-insert :: Ord a => a -> Set a -> Set a-insert x0 = go x0 x0-  where-    go :: Ord a => a -> a -> Set a -> Set a-    go orig !_ Tip = singleton (lazy orig)-    go orig !x t@(Bin sz y l r) = case compare x y of-        LT | l' `ptrEq` l -> t-           | otherwise -> balanceL y l' r-           where !l' = go orig x l-        GT | r' `ptrEq` r -> t-           | otherwise -> balanceR y l r'-           where !r' = go orig x r-        EQ | lazy orig `seq` (orig `ptrEq` y) -> t-           | otherwise -> Bin sz (lazy orig) l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insert #-}-#else-{-# INLINE insert #-}-#endif--#ifndef __GLASGOW_HASKELL__-lazy :: a -> a-lazy a = a-#endif---- Insert an element to the set only if it is not in the set.--- Used by `union`.---- See Note: Type of local 'go' function--- See Note: Avoiding worker/wrapper (in Data.Map.Internal)-insertR :: Ord a => a -> Set a -> Set a-insertR x0 = go x0 x0-  where-    go :: Ord a => a -> a -> Set a -> Set a-    go orig !_ Tip = singleton (lazy orig)-    go orig !x t@(Bin _ y l r) = case compare x y of-        LT | l' `ptrEq` l -> t-           | otherwise -> balanceL y l' r-           where !l' = go orig x l-        GT | r' `ptrEq` r -> t-           | otherwise -> balanceR y l r'-           where !r' = go orig x r-        EQ -> t-#if __GLASGOW_HASKELL__-{-# INLINABLE insertR #-}-#else-{-# INLINE insertR #-}-#endif---- | \(O(\log n)\). Delete an element from a set.---- See Note: Type of local 'go' function-delete :: Ord a => a -> Set a -> Set a-delete = go-  where-    go :: Ord a => a -> Set a -> Set a-    go !_ Tip = Tip-    go x t@(Bin _ y l r) = case compare x y of-        LT | l' `ptrEq` l -> t-           | otherwise -> balanceR y l' r-           where !l' = go x l-        GT | r' `ptrEq` r -> t-           | otherwise -> balanceL y l r'-           where !r' = go x r-        EQ -> glue l r-#if __GLASGOW_HASKELL__-{-# INLINABLE delete #-}-#else-{-# INLINE delete #-}-#endif---- | \(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:------ @--- 'member' x \<$\> 'alterF' f x s = f ('member' x s)--- @------ Note that unlike 'insert', 'alterF' will /not/ replace an element equal to--- the given value.------ Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".------ @since 0.6.3.1-alterF :: (Ord a, Functor f) => (Bool -> f Bool) -> a -> Set a -> f (Set a)-alterF f k s = fmap choose (f member_)-  where-    (member_, inserted, deleted) = case alteredSet k s of-        Deleted d           -> (True , s, d)-        Inserted i          -> (False, i, 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 :: Ord a => (Bool -> Identity Bool) -> a -> Set a -> Identity (Set a) #-}--data AlteredSet a-      -- | The needle is present in the original set.-      -- We return the set where the needle is deleted.-    = Deleted !(Set a)--      -- | The needle is not present in the original set.-      -- We return the set with the needle inserted.-    | Inserted !(Set a)--alteredSet :: Ord a => a -> Set a -> AlteredSet a-alteredSet x0 s0 = go x0 s0-  where-    go :: Ord a => a -> Set a -> AlteredSet a-    go x Tip           = Inserted (singleton x)-    go x (Bin _ y l r) = case compare x y of-        LT -> case go x l of-            Deleted d           -> Deleted (balanceR y d r)-            Inserted i          -> Inserted (balanceL y i r)-        GT -> case go x r of-            Deleted d           -> Deleted (balanceL y l d)-            Inserted i          -> Inserted (balanceR y l i)-        EQ -> Deleted (glue l r)-#if __GLASGOW_HASKELL__-{-# INLINABLE alteredSet #-}-#else-{-# INLINE alteredSet #-}-#endif--{---------------------------------------------------------------------  Subset---------------------------------------------------------------------}--- | \(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@.------ @--- s1 \`isProperSubsetOf\` s2 = s1 ``isSubsetOf`` s2 && s1 /= s2--- @-isProperSubsetOf :: Ord a => Set a -> Set a -> Bool-isProperSubsetOf s1 s2-    = size s1 < size s2 && isSubsetOfX s1 s2-#if __GLASGOW_HASKELL__-{-# INLINABLE isProperSubsetOf #-}-#endif----- | \(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@.------ @--- s1 \`isSubsetOf\` s2 = all (``member`` s2) s1--- s1 \`isSubsetOf\` s2 = null (s1 ``difference`` s2)--- s1 \`isSubsetOf\` s2 = s1 ``union`` s2 == s2--- s1 \`isSubsetOf\` s2 = s1 ``intersection`` s2 == s1--- @-isSubsetOf :: Ord a => Set a -> Set a -> Bool-isSubsetOf t1 t2-  = size t1 <= size t2 && isSubsetOfX t1 t2-#if __GLASGOW_HASKELL__-{-# INLINABLE isSubsetOf #-}-#endif---- Test whether a set is a subset of another without the *initial*--- size test.------ This function is structured very much like `difference`, `union`,--- and `intersection`. Whereas the bounds proofs for those in Blelloch--- 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-isSubsetOfX Tip _ = True-isSubsetOfX _ Tip = False--- Skip the final split when we hit a singleton.-isSubsetOfX (Bin 1 x _ _) t = member x t-isSubsetOfX (Bin _ x l r) t-  = found &&-    -- Cheap size checks can sometimes save expensive recursive calls when the-    -- result will be False. Suppose we check whether [1..10] (with root 4) is-    -- a subset of [0..9]. After the first split, we have to check if [1..3] is-    -- a subset of [0..3] and if [5..10] is a subset of [5..9]. But we can bail-    -- immediately because size [5..10] > size [5..9].-    ---    -- Why not just call `isSubsetOf` on each side to do the size checks?-    -- Because that could make a recursive call on the left even though the-    -- size check would fail on the right. In principle, we could take this to-    -- extremes by maintaining a queue of pairs of sets to be checked, working-    -- through the tree level-wise. But that would impose higher administrative-    -- costs without obvious benefits. It might be worth considering if we find-    -- a way to use it to tighten the bounds in some useful/comprehensible way.-    size l <= size lt && size r <= size gt &&-    isSubsetOfX l lt && isSubsetOfX r gt-  where-    (lt,found,gt) = splitMember x t-#if __GLASGOW_HASKELL__-{-# INLINABLE isSubsetOfX #-}-#endif--{---------------------------------------------------------------------  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--- > 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------ @--- xs ``disjoint`` ys = null (xs ``intersection`` ys)--- @------ @since 0.5.11--disjoint :: Ord a => Set a -> Set a -> Bool-disjoint Tip _ = True-disjoint _ Tip = True--- Avoid a split for the singleton case.-disjoint (Bin 1 x _ _) t = x `notMember` t-disjoint (Bin _ x l r) t-  -- Analogous implementation to `subsetOfX`-  = not found && disjoint l lt && disjoint r gt-  where-    (lt,found,gt) = splitMember x t--{---------------------------------------------------------------------  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.--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.------ @since 0.5.9--lookupMin :: Set a -> Maybe a-lookupMin Tip = Nothing-lookupMin (Bin _ x l _) = Just $! lookupMinSure x l---- | \(O(\log n)\). The minimal element of a set.-findMin :: Set a -> a-findMin t-  | Just r <- lookupMin t = r-  | otherwise = error "Set.findMin: empty set has no minimal element"--lookupMaxSure :: a -> Set a -> a-lookupMaxSure x Tip = x-lookupMaxSure _ (Bin _ x _ r) = lookupMaxSure x r---- | \(O(\log n)\). The maximal element of a set.------ @since 0.5.9--lookupMax :: Set a -> Maybe a-lookupMax Tip = Nothing-lookupMax (Bin _ x _ r) = Just $! lookupMaxSure x r---- | \(O(\log n)\). The maximal element of a set.-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.-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.-deleteMax :: Set a -> Set a-deleteMax (Bin _ _ l Tip) = l-deleteMax (Bin _ x l r)   = balanceL x l (deleteMax r)-deleteMax Tip             = Tip--{---------------------------------------------------------------------  Union.---------------------------------------------------------------------}--- | The union of the sets in a Foldable structure : (@'unions' == 'foldl' 'union' 'empty'@).-unions :: (Foldable f, Ord a) => f (Set a) -> Set a-unions = Foldable.foldl' union empty-#if __GLASGOW_HASKELL__-{-# INLINABLE unions #-}-#endif---- | \(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-union t1 (Bin 1 x _ _) = insertR x t1-union (Bin 1 x _ _) t2 = insert x t2-union Tip t2  = t2-union t1@(Bin _ x l1 r1) t2 = case splitS x t2 of-  (l2 :*: r2)-    | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1-    | otherwise -> link x l1l2 r1r2-    where !l1l2 = union l1 l2-          !r1r2 = union r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE union #-}-#endif--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | \(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.------ > difference (fromList [5, 3]) (fromList [5, 7]) == singleton 3-difference :: Ord a => Set a -> Set a -> Set a-difference Tip _   = Tip-difference t1 Tip  = t1-difference t1 (Bin _ x l2 r2) = case split x t1 of-   (l1, r1)-     | size l1l2 + size r1r2 == size t1 -> t1-     | otherwise -> merge l1l2 r1r2-     where !l1l2 = difference l1 l2-           !r1r2 = difference r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE difference #-}-#endif--{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | \(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--- > data AB = A | B deriving Show--- > instance Ord AB where compare _ _ = EQ--- > instance Eq AB where _ == _ = True--- > main = print (S.singleton A `S.intersection` S.singleton B,--- >               S.singleton B `S.intersection` S.singleton A)------ prints @(fromList [A],fromList [B])@.-intersection :: Ord a => Set a -> Set a -> Set a-intersection Tip _ = Tip-intersection _ Tip = Tip-intersection t1@(Bin _ x l1 r1) t2-  | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1-        then t1-        else link x l1l2 r1r2-  | otherwise = merge l1l2 r1r2-  where-    !(l2, b, r2) = splitMember x t2-    !l1l2 = intersection l1 l2-    !r1r2 = intersection r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE intersection #-}-#endif---- | The intersection of a series of sets. Intersections are performed left-to-right.-intersections :: Ord a => NonEmpty (Set a) -> Set a-intersections (s0 :| ss) = List.foldr go id ss s0-    where-      go s r acc-          | null acc = empty-          | otherwise = r (intersection acc s)---- | Sets form a 'Semigroup' under 'intersection'.-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-    stimes = stimesIdempotent--{---------------------------------------------------------------------  Filter and partition---------------------------------------------------------------------}--- | \(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)-    | p x = if l `ptrEq` l' && r `ptrEq` r'-            then t-            else link x l' r'-    | otherwise = merge l' r'-    where-      !l' = filter p l-      !r' = filter p r---- | \(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)-partition p0 t0 = toPair $ go p0 t0-  where-    go _ Tip = (Tip :*: Tip)-    go p t@(Bin _ x l r) = case (go p l, go p r) of-      ((l1 :*: l2), (r1 :*: r2))-        | p x       -> (if l1 `ptrEq` l && r1 `ptrEq` r-                        then t-                        else link x l1 r1) :*: merge l2 r2-        | otherwise -> merge l1 r1 :*:-                       (if l2 `ptrEq` l && r2 `ptrEq` r-                        then t-                        else link x l2 r2)--{-----------------------------------------------------------------------  Map-----------------------------------------------------------------------}---- | \(O(n \log n)\).--- @'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 :: Ord b => (a->b) -> Set a -> Set b-map f = fromList . List.map f . toList-#if __GLASGOW_HASKELL__-{-# INLINABLE map #-}-#endif---- | \(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--mapMonotonic :: (a->b) -> Set a -> Set b-mapMonotonic _ Tip = Tip-mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)--{---------------------------------------------------------------------  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 :: (a -> b -> b) -> b -> Set a -> 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 :: (a -> b -> b) -> b -> Set 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 -> Set 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 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 -> b -> a) -> a -> Set 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 -> Set 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' #-}--{---------------------------------------------------------------------  List variations---------------------------------------------------------------------}--- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order.--- Subject to list fusion.-elems :: Set a -> [a]-elems = toAscList--{---------------------------------------------------------------------  Lists---------------------------------------------------------------------}--#ifdef __GLASGOW_HASKELL__--- | @since 0.5.6.2-instance (Ord a) => GHCExts.IsList (Set a) where-  type Item (Set a) = a-  fromList = fromList-  toList   = toList-#endif---- | \(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.-toAscList :: Set a -> [a]-toAscList = foldr (:) []---- | \(O(n)\). Convert the set to a descending list of elements. Subject to list--- fusion.-toDescList :: Set a -> [a]-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 :: (a -> b -> b) -> b -> Set a -> b-foldrFB = foldr-{-# INLINE[0] foldrFB #-}-foldlFB :: (a -> b -> a) -> a -> Set b -> 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 "Set.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-}-{-# RULES "Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-}-{-# RULES "Set.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}-{-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}-#endif---- | \(O(n \log n)\). Create a set from a list of elements.------ If the elements are ordered, a linear-time implementation is used.---- For some reason, when 'singleton' is used in fromList or in--- create, it is not inlined, so we inline it manually.-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--{---------------------------------------------------------------------  Building trees from ascending/descending lists can be done in linear time.--  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./-fromAscList :: Eq a => [a] -> Set a-fromAscList xs = fromDistinctAscList (combineEq xs)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscList #-}-#endif---- | \(O(n)\). Build a set from a descending list in linear time.--- /The precondition (input list is descending) is not checked./------ @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-  where-    combineEq' z [] = [z]-    combineEq' z (y:ys)-      | z == y = combineEq' z ys-      | otherwise = z : combineEq' y ys---- | \(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./---- 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 = fromDistinctAscList_linkAll . Foldable.foldl' next (State0 Nada)-  where-    next :: FromDistinctMonoState a -> a -> FromDistinctMonoState a-    next (State0 stk) !x = fromDistinctAscList_linkTop (Bin 1 x Tip Tip) stk-    next (State1 l stk) x = State0 (Push x l stk)-{-# INLINE fromDistinctAscList #-}  -- INLINE for fusion--fromDistinctAscList_linkTop :: Set a -> Stack a -> FromDistinctMonoState a-fromDistinctAscList_linkTop r@(Bin rsz _ _ _) (Push x l@(Bin lsz _ _ _) stk)-  | rsz == lsz = fromDistinctAscList_linkTop (bin x l r) stk-fromDistinctAscList_linkTop l stk = State1 l stk-{-# INLINABLE fromDistinctAscList_linkTop #-}--fromDistinctAscList_linkAll :: FromDistinctMonoState a -> Set a-fromDistinctAscList_linkAll (State0 stk)    = foldl'Stack (\r x l -> link x l r) Tip stk-fromDistinctAscList_linkAll (State1 r0 stk) = foldl'Stack (\r x l -> link x l r) r0 stk-{-# INLINABLE fromDistinctAscList_linkAll #-}---- | \(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./------ @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.---- See Note [fromDistinctAscList implementation]-fromDistinctDescList :: [a] -> Set a-fromDistinctDescList = fromDistinctDescList_linkAll . Foldable.foldl' next (State0 Nada)-  where-    next :: FromDistinctMonoState a -> a -> FromDistinctMonoState a-    next (State0 stk) !x = fromDistinctDescList_linkTop (Bin 1 x Tip Tip) stk-    next (State1 r stk) x = State0 (Push x r stk)-{-# INLINE fromDistinctDescList #-}  -- INLINE for fusion--fromDistinctDescList_linkTop :: Set a -> Stack a -> FromDistinctMonoState a-fromDistinctDescList_linkTop l@(Bin lsz _ _ _) (Push x r@(Bin rsz _ _ _) stk)-  | lsz == rsz = fromDistinctDescList_linkTop (bin x l r) stk-fromDistinctDescList_linkTop r stk = State1 r stk-{-# INLINABLE fromDistinctDescList_linkTop #-}--fromDistinctDescList_linkAll :: FromDistinctMonoState a -> Set a-fromDistinctDescList_linkAll (State0 stk)    = foldl'Stack (\l x r -> link x l r) Tip stk-fromDistinctDescList_linkAll (State1 l0 stk) = foldl'Stack (\l x r -> link x l r) l0 stk-{-# INLINABLE fromDistinctDescList_linkAll #-}--data FromDistinctMonoState a-  = State0 !(Stack a)-  | State1 !(Set a) !(Stack a)--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 :-)---------------------------------------------------------------------}-instance Eq a => Eq (Set a) where-  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)--{---------------------------------------------------------------------  Ord---------------------------------------------------------------------}--instance Ord a => Ord (Set a) where-    compare s1 s2 = compare (toAscList s1) (toAscList s2)--{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance Show a => Show (Set a) where-  showsPrec p xs = showParen (p > 10) $-    showString "fromList " . shows (toList xs)---- | @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)--{---------------------------------------------------------------------  Read---------------------------------------------------------------------}-instance (Read a, Ord a) => Read (Set a) 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---------------------------------------------------------------------}--instance NFData a => NFData (Set a) where-    rnf Tip           = ()-    rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r--{---------------------------------------------------------------------  Split---------------------------------------------------------------------}--- | \(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)-split x t = toPair $ splitS x t-{-# INLINABLE split #-}--splitS :: Ord a => a -> Set a -> StrictPair (Set a) (Set a)-splitS _ Tip = (Tip :*: Tip)-splitS x (Bin _ y l r)-      = case compare x y of-          LT -> let (lt :*: gt) = splitS x l in (lt :*: link y gt r)-          GT -> let (lt :*: gt) = splitS x r in (link y l lt :*: gt)-          EQ -> (l :*: r)-{-# INLINABLE splitS #-}---- | \(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)-splitMember x (Bin _ y l r)-   = case compare x y of-       LT -> let (lt, found, gt) = splitMember x l-                 !gt' = link y gt r-             in (lt, found, gt')-       GT -> let (lt, found, gt) = splitMember x r-                 !lt' = link y l lt-             in (lt', found, gt)-       EQ -> (l, True, r)-#if __GLASGOW_HASKELL__-{-# INLINABLE splitMember #-}-#endif--{---------------------------------------------------------------------  Indexing---------------------------------------------------------------------}---- | \(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.------ > findIndex 2 (fromList [5,3])    Error: element is not in the set--- > findIndex 3 (fromList [5,3]) == 0--- > findIndex 5 (fromList [5,3]) == 1--- > findIndex 6 (fromList [5,3])    Error: element is not in the set------ @since 0.5.4---- See Note: Type of local 'go' function-findIndex :: Ord a => a -> Set a -> Int-findIndex = go 0-  where-    go :: Ord a => Int -> a -> Set a -> Int-    go !_ !_ Tip  = error "Set.findIndex: element is not in the set"-    go idx x (Bin _ kx l r) = case compare x kx of-      LT -> go idx x l-      GT -> go (idx + size l + 1) x r-      EQ -> idx + size l-#if __GLASGOW_HASKELL__-{-# INLINABLE findIndex #-}-#endif---- | \(O(\log n)\). Lookup 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.------ > isJust   (lookupIndex 2 (fromList [5,3])) == False--- > fromJust (lookupIndex 3 (fromList [5,3])) == 0--- > fromJust (lookupIndex 5 (fromList [5,3])) == 1--- > isJust   (lookupIndex 6 (fromList [5,3])) == False------ @since 0.5.4---- See Note: Type of local 'go' function-lookupIndex :: Ord a => a -> Set a -> Maybe Int-lookupIndex = go 0-  where-    go :: Ord a => Int -> a -> Set a -> Maybe Int-    go !_ !_ Tip  = Nothing-    go idx x (Bin _ kx l r) = case compare x kx of-      LT -> go idx x l-      GT -> go (idx + size l + 1) x 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 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.------ > elemAt 0 (fromList [5,3]) == 3--- > elemAt 1 (fromList [5,3]) == 5--- > elemAt 2 (fromList [5,3])    Error: index out of range------ @since 0.5.4--elemAt :: Int -> Set a -> a-elemAt !_ Tip = error "Set.elemAt: index out of range"-elemAt i (Bin _ x l r)-  = case compare i sizeL of-      LT -> elemAt i l-      GT -> elemAt (i-sizeL-1) r-      EQ -> x-  where-    sizeL = size l---- | \(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.------ > deleteAt 0    (fromList [5,3]) == singleton 5--- > deleteAt 1    (fromList [5,3]) == singleton 3--- > deleteAt 2    (fromList [5,3])    Error: index out of range--- > deleteAt (-1) (fromList [5,3])    Error: index out of range------ @since 0.5.4--deleteAt :: Int -> Set a -> Set a-deleteAt !i t =-  case t of-    Tip -> error "Set.deleteAt: index out of range"-    Bin _ x l r -> case compare i sizeL of-      LT -> balanceR x (deleteAt i l) r-      GT -> balanceL x l (deleteAt (i-sizeL-1) r)-      EQ -> glue l r-      where-        sizeL = size l---- | \(O(\log n)\). Take a given number of elements in order, beginning--- with the smallest ones.------ @--- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'--- @------ @since 0.5.8-take :: Int -> Set a -> Set 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 _ x l r) =-      case compare i sizeL of-        LT -> go i l-        GT -> link x l (go (i - sizeL - 1) r)-        EQ -> l-      where sizeL = size l---- | \(O(\log n)\). Drop a given number of elements in order, beginning--- with the smallest ones.------ @--- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'--- @------ @since 0.5.8-drop :: Int -> Set a -> Set 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 _ x l r) =-      case compare i sizeL of-        LT -> link x (go i l) r-        GT -> go (i - sizeL - 1) r-        EQ -> insertMin x r-      where sizeL = size l---- | \(O(\log n)\). Split a set at a particular index.------ @--- splitAt !n !xs = ('take' n xs, 'drop' n xs)--- @-splitAt :: Int -> Set a -> (Set a, Set 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 _ x l r)-      = case compare i sizeL of-          LT -> case go i l of-                  ll :*: lr -> ll :*: link x lr r-          GT -> case go (i - sizeL - 1) r of-                  rl :*: rr -> link x l rl :*: rr-          EQ -> l :*: insertMin x r-      where sizeL = size l---- | \(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'.------ @--- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'--- takeWhileAntitone p = 'filter' p--- @------ @since 0.5.8--takeWhileAntitone :: (a -> Bool) -> Set a -> Set a-takeWhileAntitone _ Tip = Tip-takeWhileAntitone p (Bin _ x l r)-  | p x = link x l (takeWhileAntitone p r)-  | otherwise = takeWhileAntitone p l---- | \(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'.------ @--- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'--- dropWhileAntitone p = 'filter' (not . p)--- @------ @since 0.5.8--dropWhileAntitone :: (a -> Bool) -> Set a -> Set a-dropWhileAntitone _ Tip = Tip-dropWhileAntitone p (Bin _ x l r)-  | 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.--- The user is responsible for ensuring that for all elements @j@ and @k@ in the set,--- @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 where the predicate switches from holding to not--- holding (where the predicate is seen to hold before the first element and to fail--- after the last element).------ @since 0.5.8--spanAntitone :: (a -> Bool) -> Set a -> (Set a, Set a)-spanAntitone p0 m = toPair (go p0 m)-  where-    go _ Tip = Tip :*: Tip-    go p (Bin _ x l r)-      | 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---{---------------------------------------------------------------------  Utility functions that maintain the balance properties of the tree.-  All constructors assume that all values in [l] < [x] and all values-  in [r] > [x], and that [l] and [r] are valid trees.--  In order of sophistication:-    [Bin sz x l r]    The type constructor.-    [bin x l r]       Maintains the correct size, assumes that both [l]-                      and [r] are balanced with respect to each other.-    [balance 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 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.-    [merge l r]       Merges two trees and restores balance.---------------------------------------------------------------------}--{---------------------------------------------------------------------  Link---------------------------------------------------------------------}-link :: a -> Set a -> Set a -> Set a-link x Tip r  = insertMin x r-link x l Tip  = insertMax x l-link x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)-  | delta*sizeL < sizeR  = balanceL z (link x l lz) rz-  | delta*sizeR < sizeL  = balanceR y ly (link x ry r)-  | otherwise            = bin x l r----- insertMin and insertMax don't perform potentially expensive comparisons.-insertMax,insertMin :: a -> Set a -> Set a-insertMax x t-  = case t of-      Tip -> singleton x-      Bin _ y l r-          -> balanceR y l (insertMax x r)--insertMin x t-  = case t of-      Tip -> singleton x-      Bin _ y l r-          -> balanceL y (insertMin x l) r--{---------------------------------------------------------------------  [merge l r]: merges two trees.---------------------------------------------------------------------}-merge :: Set a -> Set a -> Set a-merge Tip r   = r-merge l Tip   = l-merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)-  | delta*sizeL < sizeR = balanceL y (merge l ly) ry-  | delta*sizeR < sizeL = balanceR x lx (merge 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 :: Set a -> Set a -> Set a-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'---- | \(O(\log n)\). Delete and find the minimal element.------ > deleteFindMin set = (findMin set, deleteMin set)--deleteFindMin :: Set a -> (a,Set a)-deleteFindMin t-  | 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.------ > deleteFindMax set = (findMax set, deleteMax set)-deleteFindMax :: Set a -> (a,Set a)-deleteFindMax t-  | Just r <- maxView t = r-  | otherwise = (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)--minViewSure :: a -> Set a -> Set a -> StrictPair a (Set a)-minViewSure = go-  where-    go x Tip r = x :*: r-    go x (Bin _ xl ll lr) r =-      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--- stripped of that element, or 'Nothing' if passed an empty set.-minView :: Set a -> Maybe (a, Set a)-minView Tip = Nothing-minView (Bin _ x l r) = Just $! toPair $ minViewSure x l r--maxViewSure :: a -> Set a -> Set a -> StrictPair a (Set a)-maxViewSure = go-  where-    go x l Tip = x :*: l-    go x l (Bin _ xr rl rr) =-      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--- stripped of that element, or 'Nothing' if passed an empty set.-maxView :: Set a -> Maybe (a, Set a)-maxView Tip = Nothing-maxView (Bin _ x l r) = Just $! toPair $ maxViewSure x l r--{---------------------------------------------------------------------  [balance x l 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 :: a -> Set a -> Set a -> Set a---   balance x l r---     | sizeL + sizeR <= 1   = Bin sizeX x l r---     | sizeR > delta*sizeL  = rotateL x l r---     | sizeL > delta*sizeR  = rotateR x l r---     | otherwise            = Bin sizeX x l r---     where---       sizeL = size l---       sizeR = size r---       sizeX = sizeL + sizeR + 1------   rotateL :: a -> Set a -> Set a -> Set a---   rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r---                                 | otherwise               = doubleL x l r---   rotateR :: a -> Set a -> Set a -> Set a---   rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r---                                 | otherwise               = doubleR x l r------   singleL, singleR :: a -> Set a -> Set a -> Set a---   singleL x1 t1 (Bin _ x2 t2 t3)  = bin x2 (bin x1 t1 t2) t3---   singleR x1 (Bin _ x2 t1 t2) t3  = bin x2 t1 (bin x1 t2 t3)------   doubleL, doubleR :: a -> Set a -> Set a -> Set a---   doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)---   doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)------ It is only written in such a way that every node is pattern-matched only once.------ Only balanceL and balanceR are needed at the moment, so balance is not here anymore.--- In case it is needed, it can be found in Data.Map.---- 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 :: 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-           (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)-           (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)-           (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))-             | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)-             | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)--  (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 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.Set.balanceL"-              | otherwise -> Bin (1+ls+rs) 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 :: 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-           (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr-           (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)-           (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))-             | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr-             | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)--  (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 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.Set.balanceR"-              | otherwise -> Bin (1+ls+rs) x l r-{-# NOINLINE balanceR #-}--{---------------------------------------------------------------------  The bin constructor maintains the size of the tree---------------------------------------------------------------------}-bin :: a -> Set a -> Set a -> Set a-bin x l r-  = Bin (size l + size r + 1) x l r-{-# INLINE bin #-}---{---------------------------------------------------------------------  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 subset less than all--- elements in the second, and so on).------ Examples:------ > splitRoot (fromList [1..6]) ==--- >   [fromList [1,2,3],fromList [4],fromList [5,6]]------ > splitRoot empty == []------  Note that the current implementation does not return more than three subsets,---  but you should not depend on this behaviour because it can change in the---  future without notice.------ @since 0.5.4-splitRoot :: Set a -> [Set a]-splitRoot orig =-  case orig of-    Tip           -> []-    Bin _ v l r -> [l, singleton v, r]-{-# INLINE splitRoot #-}----- | \(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--- @------ Example:------ @--- powerSet (fromList [1,2,3]) =---   fromList $ map fromList [[],[1],[1,2],[1,2,3],[1,3],[2],[2,3],[3]]--- @------ @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(nm)\). Calculate the Cartesian product of two sets.------ @--- cartesianProduct xs ys = fromList $ liftA2 (,) (toList xs) (toList ys)--- @------ Example:------ @--- cartesianProduct (fromList [1,2]) (fromList [\'a\',\'b\']) =---   fromList [(1,\'a\'), (1,\'b\'), (2,\'a\'), (2,\'b\')]--- @------ @since 0.5.11-cartesianProduct :: Set a -> Set b -> Set (a, b)--- The obvious big-O optimal (O(nm)) implementation would be------   cartesianProduct _as Tip = Tip---   cartesianProduct as bs = fromDistinctAscList---     [(a,b) | a <- toList as, b <- toList bs]------ 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 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.-cartesianProduct !_as Tip = Tip-cartesianProduct as (Bin 1 b _ _) = mapMonotonic (flip (,) b) as-cartesianProduct as bs =-  getMergeSet $ foldMap (\a -> MergeSet $ mapMonotonic ((,) a) bs) as---- A version of Set with peculiar Semigroup and Monoid instances.--- The result of xs <> ys will only be a valid set if the greatest--- element of xs is strictly less than the least element of ys.--- This is used to define cartesianProduct.-newtype MergeSet a = MergeSet { getMergeSet :: Set a }--instance Semigroup (MergeSet a) where-  MergeSet xs <> MergeSet ys = MergeSet (merge xs ys)--instance Monoid (MergeSet a) where-  mempty = MergeSet empty--  mappend = (<>)---- | \(O(n+m)\). Calculate the disjoint union of two sets.------ @ disjointUnion xs ys = map Left xs ``union`` map Right ys @------ Example:------ @--- disjointUnion (fromList [1,2]) (fromList ["hi", "bye"]) =---   fromList [Left 1, Left 2, Right "hi", Right "bye"]--- @------ @since 0.5.11-disjointUnion :: Set a -> Set b -> Set (Either a b)-disjointUnion as bs = merge (mapMonotonic Left as) (mapMonotonic Right bs)--{---------------------------------------------------------------------  Debugging---------------------------------------------------------------------}--- | \(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 \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.--> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]-> 4-> +--2-> |  +--1-> |  +--3-> +--5->-> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]-> 4-> |-> +--2-> |  |-> |  +--1-> |  |-> |  +--3-> |-> +--5->-> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]-> +--5-> |-> 4-> |-> |  +--3-> |  |-> +--2->    |->    +--1---}-showTreeWith :: Show a => Bool -> Bool -> Set a -> String-showTreeWith hang wide t-  | hang      = (showsTreeHang wide [] t) ""-  | otherwise = (showsTree wide [] [] t) ""--showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS-showsTree wide lbars rbars t-  = case t of-      Tip -> showsBars lbars . showString "|\n"-      Bin _ x Tip Tip-          -> showsBars lbars . shows x . showString "\n"-      Bin _ x l r-          -> showsTree wide (withBar rbars) (withEmpty rbars) r .-             showWide wide rbars .-             showsBars lbars . shows x . showString "\n" .-             showWide wide lbars .-             showsTree wide (withEmpty lbars) (withBar lbars) l--showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS-showsTreeHang wide bars t-  = case t of-      Tip -> showsBars bars . showString "|\n"-      Bin _ x Tip Tip-          -> showsBars bars . shows x . showString "\n"-      Bin _ x l r-          -> showsBars bars . shows x . showString "\n" .-             showWide wide bars .-             showsTreeHang wide (withBar bars) l .-             showWide wide bars .-             showsTreeHang wide (withEmpty bars) r--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--{---------------------------------------------------------------------  Assertions---------------------------------------------------------------------}--- | \(O(n)\). Test if the internal set structure is valid.-valid :: Ord a => Set a -> Bool-valid t-  = balanced t && ordered t && validsize t--ordered :: Ord a => Set a -> Bool-ordered t-  = bounded (const True) (const True) t-  where-    bounded lo hi t'-      = case t' of-          Tip         -> True-          Bin _ x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r--balanced :: Set a -> Bool-balanced t-  = case t of-      Tip         -> True-      Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&-                     balanced l && balanced r--validsize :: Set a -> Bool-validsize t-  = (realsize t == Just (size t))-  where-    realsize t'-      = case t' of-          Tip          -> Just 0-          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.------ When we get an element from the list, we attempt to link it as the right--- branch with the top (root, perfect left branch) of the stack to create a new--- perfect tree. We can only do this if the left branch has size 1. If we link--- it, we get a perfect tree of size 3. We repeat this process, merging with the--- top of the stack as long as the sizes match. When we can't link any more, the--- perfect tree we built so far is a potential left branch. The next element--- we find becomes the root, and we push this new (root, left branch) on the--- stack.------ 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)+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Set.Internal+-- Copyright   :  (c) Daan Leijen 2002+-- 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 Sets (internals)+--+-- 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.+--+--+-- == 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/\",+--      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]+-- ~~~~~~~~~~~~~~~~~~~~+-- We mark some functions INLINE where it is more beneficial than INLINABLE.+-- There is a price to pay -- code growth. The code INLINED is therefore usually+-- only the tree navigation, other work such as rebalancing is not INLINED.+--+-- 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 IntSet, 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 Set 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.Set.Internal (+            -- * Set type+              Set(..)       -- instance Eq,Ord,Show,Read,Data+            , Size++            -- * Operators+            , (\\)++            -- * Query+            , null+            , size+            , member+            , notMember+            , lookupLT+            , lookupGT+            , lookupLE+            , lookupGE+            , isSubsetOf+            , isProperSubsetOf+            , disjoint++            -- * Construction+            , empty+            , singleton+            , insert+            , delete+            , pop+            , alterF+            , powerSet++            -- * Combine+            , union+            , unions+            , difference+            , intersection+            , intersections+            , symmetricDifference+            , cartesianProduct+            , disjointUnion+            , Intersection(..)+++            -- * Filter+            , filter+            , filterA+            , takeWhileAntitone+            , dropWhileAntitone+            , spanAntitone+            , mapMaybe+            , partition+            , split+            , splitMember+            , splitRoot++            -- * Indexed+            , lookupIndex+            , findIndex+            , elemAt+            , deleteAt+            , take+            , drop+            , splitAt++            -- * Map+            , map+            , mapMonotonic++            -- * Folds+            , foldr+            , foldl+            -- ** 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+            , fromDescList+            , fromDistinctDescList++            -- * Debugging+            , showTree+            , showTreeWith+            , valid++            -- * General merge functions+            , WhenMissing(..)+            , SimpleWhenMissing+            , dropMissing+            , preserveMissing+            , filterMissing+            , filterAMissing+            , whenMissing+            , runWhenMissing+            , WhenMatched(..)+            , SimpleWhenMatched+            , dropMatched+            , preserveMatched+            , filterMatched+            , filterAMatched+            , runWhenMatched+            , merge+            , mergeA++            -- Internals (for testing)+            , bin+            , balanced+            , link+            , link2+            , balanceL+            , balanceR+            , glue+            , insertMin+            , insertMax+            ) where++import Utils.Containers.Internal.Prelude hiding+  (filter,foldl,foldl',foldr,null,map,take,drop,splitAt)+import Prelude ()+import Control.Applicative (Const(..), liftA3)+import qualified Data.List as List+import Data.Semigroup (Semigroup(..), stimesIdempotentMonoid, stimesIdempotent)+import Data.Functor.Classes+import Data.Functor.Identity (Identity(..))+import qualified Data.Foldable as Foldable+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf))+import Data.List.NonEmpty (NonEmpty(..))++import Utils.Containers.Internal.Strict+  (StrictPair(..), StrictTriple(..), toPair)+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 )+import qualified GHC.Exts as GHCExts+import Data.Data+#  if __GLASGOW_HASKELL__ >= 914+import Language.Haskell.TH.Lift (Lift)+#  else+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#  endif+import Data.Coerce (coerce)+#endif+++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 \\ --++-- | \(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+{-# INLINABLE (\\) #-}++{--------------------------------------------------------------------+  Sets are size balanced trees+--------------------------------------------------------------------}+-- | A set of values @a@.++-- See Note: Order of constructors+data Set a    = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)+              | Tip++type Size     = Int++#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,11,0)+    mappend = (<>)+#endif++-- | @(<>)@ = 'union'+--+-- @since 0.5.7+instance Ord a => Semigroup (Set a) where+    (<>)    = union+    stimes  = stimesIdempotentMonoid++-- | Folds in order of increasing key.+instance Foldable.Foldable Set where+    fold = go+      where go Tip = mempty+            go (Bin 1 k _ _) = k+            go (Bin _ k l r) = go l `mappend` (k `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 k _ _) = f k+            go (Bin _ k l r) = go l `mappend` (f k `mappend` go r)+    {-# INLINE foldMap #-}+    foldl' = foldl'+    {-# INLINE foldl' #-}+    foldr' = foldr'+    {-# INLINE foldr' #-}+    length = size+    {-# INLINE length #-}+    null   = null+    {-# INLINE null #-}+    toList = toList+    {-# INLINE toList #-}+    elem = go+      where go !_ Tip = False+            go x (Bin _ y l r) = x == y || go x l || go x r+    {-# INLINABLE elem #-}+    minimum = findMin+    {-# INLINE minimum #-}+    maximum = findMax+    {-# INLINE maximum #-}+    sum = foldl' (+) 0+    {-# INLINABLE sum #-}+    product = foldl' (*) 1+    {-# INLINABLE product #-}++#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, Ord a) => Data (Set a) where+  gfoldl f z set = z fromList `f` (toList set)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = setDataType+  dataCast1 f    = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr setDataType "fromList" [] Prefix++setDataType :: DataType+setDataType = mkDataType "Data.Set.Internal.Set" [fromListConstr]++#endif++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(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.+size :: Set a -> Int+size Tip = 0+size (Bin sz _ _ _) = sz+{-# INLINE size #-}++-- | \(O(\log n)\). Is the element in the set?+member :: Ord a => a -> Set a -> Bool+member = go+  where+    go !_ Tip = False+    go x (Bin _ y l r) = case compare x y of+      LT -> go x l+      GT -> go x r+      EQ -> True+{-# INLINABLE member #-}++-- | \(O(\log n)\). Is the element not in the set?+notMember :: Ord a => a -> Set a -> Bool+notMember a t = not $ member a t+{-# INLINABLE notMember #-}++-- | \(O(\log n)\). Find largest element smaller than the given one.+--+-- > lookupLT 3 (fromList [3, 5]) == Nothing+-- > lookupLT 5 (fromList [3, 5]) == Just 3+lookupLT :: Ord a => a -> Set a -> Maybe a+lookupLT = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing x (Bin _ y l r) | x <= y = goNothing x l+                              | otherwise = goJust x y r++    goJust !_ best Tip = Just best+    goJust x best (Bin _ y l r) | x <= y = goJust x best l+                                | otherwise = goJust x y r+{-# INLINABLE lookupLT #-}++-- | \(O(\log n)\). Find smallest element greater than the given one.+--+-- > lookupGT 4 (fromList [3, 5]) == Just 5+-- > lookupGT 5 (fromList [3, 5]) == Nothing+lookupGT :: Ord a => a -> Set a -> Maybe a+lookupGT = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing x (Bin _ y l r) | x < y = goJust x y l+                              | otherwise = goNothing x r++    goJust !_ best Tip = Just best+    goJust x best (Bin _ y l r) | x < y = goJust x y l+                                | otherwise = goJust x best r+{-# INLINABLE lookupGT #-}++-- | \(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+lookupLE :: Ord a => a -> Set a -> Maybe a+lookupLE = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing x (Bin _ y l r) = case compare x y of LT -> goNothing x l+                                                    EQ -> Just y+                                                    GT -> goJust x y r++    goJust !_ best Tip = Just best+    goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x best l+                                                      EQ -> Just y+                                                      GT -> goJust x y r+{-# INLINABLE lookupLE #-}++-- | \(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+lookupGE :: Ord a => a -> Set a -> Maybe a+lookupGE = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing x (Bin _ y l r) = case compare x y of LT -> goJust x y l+                                                    EQ -> Just y+                                                    GT -> goNothing x r++    goJust !_ best Tip = Just best+    goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x y l+                                                      EQ -> Just y+                                                      GT -> goJust x best r+{-# INLINABLE lookupGE #-}++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty set.+empty  :: Set a+empty = Tip+{-# INLINE empty #-}++-- | \(O(1)\). Create a singleton set.+singleton :: a -> Set a+singleton x = Bin 1 x Tip Tip+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insertion, Deletion+--------------------------------------------------------------------}+-- | \(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.++-- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper (in Data.Map.Internal)+insert :: Ord a => a -> Set a -> Set a+insert x0 = go x0 x0+  where+    go :: Ord a => a -> a -> Set a -> Set a+    go orig !_ Tip = singleton (lazy orig)+    go orig !x t@(Bin sz y l r) = case compare x y of+        LT | l' `ptrEq` l -> t+           | otherwise -> balanceL y l' r+           where !l' = go orig x l+        GT | r' `ptrEq` r -> t+           | otherwise -> balanceR y l r'+           where !r' = go orig x r+        EQ | lazy orig `seq` (orig `ptrEq` y) -> t+           | otherwise -> Bin sz (lazy orig) l r+{-# INLINABLE insert #-}++#ifndef __GLASGOW_HASKELL__+lazy :: a -> a+lazy a = a+#endif++-- Insert an element to the set only if it is not in the set.+-- Used by `union`.++-- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper (in Data.Map.Internal)+insertR :: Ord a => a -> Set a -> Set a+insertR x0 = go x0 x0+  where+    go :: Ord a => a -> a -> Set a -> Set a+    go orig !_ Tip = singleton (lazy orig)+    go orig !x t@(Bin _ y l r) = case compare x y of+        LT | l' `ptrEq` l -> t+           | otherwise -> balanceL y l' r+           where !l' = go orig x l+        GT | r' `ptrEq` r -> t+           | otherwise -> balanceR y l r'+           where !r' = go orig x r+        EQ -> t+{-# INLINABLE insertR #-}++-- | \(O(\log n)\). Delete an element from a set.++-- See Note: Type of local 'go' function+delete :: Ord a => a -> Set a -> Set a+delete = go+  where+    go :: Ord a => a -> Set a -> Set a+    go !_ Tip = Tip+    go x t@(Bin _ y l r) = case compare x y of+        LT | l' `ptrEq` l -> t+           | otherwise -> balanceR y l' r+           where !l' = go x l+        GT | r' `ptrEq` r -> t+           | otherwise -> balanceL y l r'+           where !r' = go x r+        EQ -> glue l r+{-# INLINABLE delete #-}++-- | \(O(\log n)\). Pop an element from the set.+--+-- Returns @Nothing@ if the element is not a member of the set. Otherwise+-- returns @Just@ the set with the element removed.+--+-- @+-- pop 1 (fromList [0,2,4]) == Nothing+-- pop 2 (fromList [0,2,4]) == Just (fromList [0,4])+-- @+--+-- @since 0.8.1+pop :: Ord a => a -> Set a -> Maybe (Set a)+pop x0 t0 = case go x0 t0 of+  True :*: t -> Just t+  _ -> Nothing+  where+    -- We use `StrictPair Bool (Set a)` instead of a sum to avoid allocations.+    -- See Note [Popped impl] in Data.Map.Internal+    go !x (Bin _ y l r) = case compare x y of+      LT -> case go x l of+        True :*: l' -> True :*: balanceR y l' r+        q -> q+      EQ -> True :*: glue l r+      GT -> case go x r of+        True :*: r' -> True :*: balanceL y l r'+        q -> q+    go !_ Tip = False :*: Tip+{-# INLINABLE pop #-}++-- | \(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:+--+-- @+-- 'member' x \<$\> 'alterF' f x s = f ('member' x s)+-- @+--+-- Note that unlike 'insert', 'alterF' will /not/ replace an element equal to+-- the given value.+--+-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".+--+-- === Examples+--+-- @+-- -- Get whether the element is a member, and also insert or remove it.+-- getAndSet :: Ord a => a -> Bool -> Set a -> (Bool, Set a)+-- getAndSet x new = alterF (\\old -> (old, new)) x+-- @+--+-- @+-- -- Delete the element. If it is absent the result is Nothing.+-- mustDelete :: Ord a => a -> Set a -> Maybe (Set a)+-- mustDelete = alterF (\\b -> if b then Just False else Nothing)+-- @+--+-- @since 0.6.3.1++-- See Note [alterF implementation]+alterF :: (Ord a, Functor f) => (Bool -> f Bool) -> a -> Set a -> f (Set a)+alterF f k s = fmap choose (f member_)+  where+    MemberIndex member_ i = memberIndex k s+    inserted = if member_ then s else insertAt i k s+    deleted = if member_ then deleteAt i s else s+    choose True  = inserted+    choose False = deleted+#ifdef __GLASGOW_HASKELL__+{-# INLINE [2] alterF #-}++{-# RULES+"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s+ #-}+#endif++data MemberIndex = MemberIndex !Bool {-# UNPACK #-} !Int++-- Whether the element is a member of the set along with its index.+-- If it is not a member, the index is the index it would have if inserted.+memberIndex :: Ord a => a -> Set a -> MemberIndex+memberIndex = go 0+  where+    go !i !_ Tip = MemberIndex False i+    go !i !x (Bin _ y l r) = case compare x y of+      LT -> go i x l+      EQ -> MemberIndex True (i + size l)+      GT -> go (i + size l + 1) x r+{-# INLINABLE memberIndex #-}++-- Insert the element at the given index. The caller must ensure that the index+-- is correct and will not violate Set invariants.+insertAt :: Int -> a -> Set a -> Set a+insertAt !_ !x Tip = singleton x+insertAt !i !x (Bin _ y l r)+  | i <= sizeL = balanceL y (insertAt i x l) r+  | otherwise = balanceR y l (insertAt (i - sizeL - 1) x r)+  where+    !sizeL = size l++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | \(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@.+--+-- @+-- s1 \`isProperSubsetOf\` s2 = s1 ``isSubsetOf`` s2 && s1 /= s2+-- @+isProperSubsetOf :: Ord a => Set a -> Set a -> Bool+isProperSubsetOf s1 s2+    = size s1 < size s2 && isSubsetOfX s1 s2+{-# INLINABLE isProperSubsetOf #-}+++-- | \(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@.+--+-- @+-- s1 \`isSubsetOf\` s2 = all (``member`` s2) s1+-- s1 \`isSubsetOf\` s2 = null (s1 ``difference`` s2)+-- s1 \`isSubsetOf\` s2 = s1 ``union`` s2 == s2+-- s1 \`isSubsetOf\` s2 = s1 ``intersection`` s2 == s1+-- @+isSubsetOf :: Ord a => Set a -> Set a -> Bool+isSubsetOf t1 t2+  = size t1 <= size t2 && isSubsetOfX t1 t2+{-# INLINABLE isSubsetOf #-}++-- Test whether a set is a subset of another without the *initial*+-- size test.+--+-- This function is structured very much like `difference`, `union`,+-- and `intersection`. Whereas the bounds proofs for those in Blelloch+-- 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+isSubsetOfX Tip _ = True+isSubsetOfX _ Tip = False+-- Skip the final split when we hit a singleton.+isSubsetOfX (Bin 1 x _ _) t = member x t+isSubsetOfX (Bin _ x l r) t+  = found &&+    -- Cheap size checks can sometimes save expensive recursive calls when the+    -- result will be False. Suppose we check whether [1..10] (with root 4) is+    -- a subset of [0..9]. After the first split, we have to check if [1..3] is+    -- a subset of [0..3] and if [5..10] is a subset of [5..9]. But we can bail+    -- immediately because size [5..10] > size [5..9].+    --+    -- Why not just call `isSubsetOf` on each side to do the size checks?+    -- Because that could make a recursive call on the left even though the+    -- size check would fail on the right. In principle, we could take this to+    -- extremes by maintaining a queue of pairs of sets to be checked, working+    -- through the tree level-wise. But that would impose higher administrative+    -- costs without obvious benefits. It might be worth considering if we find+    -- a way to use it to tighten the bounds in some useful/comprehensible way.+    size l <= size lt && size r <= size gt &&+    isSubsetOfX l lt && isSubsetOfX r gt+  where+    (lt,found,gt) = splitMember x t+{-# INLINABLE isSubsetOfX #-}++{--------------------------------------------------------------------+  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+-- > 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+--+-- @+-- xs ``disjoint`` ys = null (xs ``intersection`` ys)+-- @+--+-- @since 0.5.11++disjoint :: Ord a => Set a -> Set a -> Bool+disjoint Tip _ = True+disjoint _ Tip = True+-- Avoid a split for the singleton case.+disjoint (Bin 1 x _ _) t = x `notMember` t+disjoint (Bin _ x l r) t+  -- Analogous implementation to `subsetOfX`+  = not found && disjoint l lt && disjoint r gt+  where+    (lt,found,gt) = splitMember x t++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}++-- 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 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 the set. Calls 'error' if the set is+-- empty.+--+-- __Note__: This function is partial. Prefer 'lookupMin'.+findMin :: Set a -> a+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "Set.findMin: empty set has no minimal element"++lookupMaxSure :: a -> Set a -> a+lookupMaxSure x Tip = x+lookupMaxSure _ (Bin _ x _ r) = lookupMaxSure x r++-- | \(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 the set. Calls 'error' if the set is+-- empty.+--+-- __Note__: This function is partial. Prefer 'lookupMax'.+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.+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.+deleteMax :: Set a -> Set a+deleteMax (Bin _ _ l Tip) = l+deleteMax (Bin _ x l r)   = balanceL x l (deleteMax r)+deleteMax Tip             = Tip++{--------------------------------------------------------------------+  Union.+--------------------------------------------------------------------}+-- | The union of the sets in a Foldable structure : (@'unions' == 'foldl' 'union' 'empty'@).+unions :: (Foldable f, Ord a) => f (Set a) -> Set a+unions = Foldable.foldl' union empty+{-# INLINE unions #-} -- Inline for list fusion++-- | \(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+union t1 (Bin 1 x _ _) = insertR x t1+union (Bin 1 x _ _) t2 = insert x t2+union Tip t2  = t2+union t1@(Bin _ x l1 r1) t2 = case splitS x t2 of+  (l2 :*: r2)+    | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1+    | otherwise -> link x l1l2 r1r2+    where !l1l2 = union l1 l2+          !r1r2 = union r1 r2+{-# INLINABLE union #-}++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | \(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.+--+-- > difference (fromList [5, 3]) (fromList [5, 7]) == singleton 3+difference :: Ord a => Set a -> Set a -> Set a+difference Tip _   = Tip+difference t1 Tip  = t1+difference t1 (Bin _ x l2 r2) = case split x t1 of+   (l1, r1)+     | size l1l2 + size r1r2 == size t1 -> t1+     | otherwise -> link2 l1l2 r1r2+     where !l1l2 = difference l1 l2+           !r1r2 = difference r1 r2+{-# INLINABLE difference #-}++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(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+-- > data AB = A | B deriving Show+-- > instance Ord AB where compare _ _ = EQ+-- > instance Eq AB where _ == _ = True+-- > main = print (S.singleton A `S.intersection` S.singleton B,+-- >               S.singleton B `S.intersection` S.singleton A)+--+-- prints @(fromList [A],fromList [B])@.+intersection :: Ord a => Set a -> Set a -> Set a+intersection Tip _ = Tip+intersection _ Tip = Tip+intersection t1@(Bin _ x l1 r1) t2+  | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1+        then t1+        else link x l1l2 r1r2+  | otherwise = link2 l1l2 r1r2+  where+    !(l2, b, r2) = splitMember x t2+    !l1l2 = intersection l1 l2+    !r1r2 = intersection r1 r2+{-# INLINABLE intersection #-}++-- | 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 = link2 l1l2 r1r2+  | otherwise = link x l1l2 r1r2+  where+    !(l2, found, r2) = splitMember x t2+    !l1l2 = symmetricDifference l1 l2+    !r1r2 = symmetricDifference r1 r2+{-# INLINABLE symmetricDifference #-}++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | \(O(n)\). Keep all elements that satisfy the predicate.+filter :: (a -> Bool) -> Set a -> Set a+filter _ Tip = Tip+filter p t@(Bin _ x l r)+    | p x = if l `ptrEq` l' && r `ptrEq` r'+            then t+            else link x l' r'+    | otherwise = link2 l' r'+    where+      !l' = filter p l+      !r' = filter p r++-- | \(O(n)\). Keep all elements that satisfy the Applicative predicate.+--+-- @since 0.8.1+filterA :: Applicative f => (a -> f Bool) -> Set a -> f (Set a)+filterA p = go+  where+    -- Handle the singleton case separately as it is possible for fmap to be+    -- cheaper than liftA3.+    go t@(Bin 1 x _ _) = finish <$> p x+      where+        finish False = Tip+        finish True = t+    go t@(Bin _ x l r) = liftA3 doLink (go l) (p x) (go r)+      where+        doLink !l' keepx !r'+          | keepx = if l `ptrEq` l' && r `ptrEq` r'+                    then t+                    else link x l' r'+          | otherwise = link2 l' r'+    go Tip = pure Tip+{-# INLINABLE filterA #-}++-- | \(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)+partition p0 t0 = toPair $ go p0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go p t@(Bin _ x l r) = case (go p l, go p r) of+      ((l1 :*: l2), (r1 :*: r2))+        | p x       -> (if l1 `ptrEq` l && r1 `ptrEq` r+                        then t+                        else link x l1 r1) :*: link2 l2 r2+        | otherwise -> link2 l1 r1 :*:+                       (if l2 `ptrEq` l && r2 `ptrEq` r+                        then t+                        else link x l2 r2)++{--------------------------------------------------------------------+  Maybes+--------------------------------------------------------------------}++-- | \(O(n \log n)\). Map elements and collect the 'Just' results.+--+-- If the function is monotonically non-decreasing, this function takes \(O(n)\)+-- time.+--+-- @since 0.8.1+mapMaybe :: Ord b => (a -> Maybe b) -> Set a -> Set b+mapMaybe f t = finishB (foldl' go emptyB t)+  where go b x = case f x of+          Nothing -> b+          Just x' -> insertB x' b+{-# INLINABLE mapMaybe #-}++{----------------------------------------------------------------------+  Map+----------------------------------------------------------------------}++-- | \(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 t = finishB (foldl' (\b x -> insertB (f x) b) emptyB t)+{-# INLINABLE map #-}++-- | \(O(n)\).+-- @'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.++mapMonotonic :: (a->b) -> Set a -> Set b+mapMonotonic _ Tip = Tip+mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator.+--+{-# 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+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.+--+-- For example,+--+-- > toAscList set = foldr (:) [] set+foldr :: (a -> b -> b) -> b -> Set 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 -> Set 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 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 -> b -> a) -> a -> Set 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 -> Set 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' #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order.+-- Subject to list fusion.+elems :: Set a -> [a]+elems = toAscList++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.6.2+instance (Ord a) => GHCExts.IsList (Set a) where+  type Item (Set a) = a+  fromList = fromList+  toList   = toList+#endif++-- | \(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.+toAscList :: Set a -> [a]+toAscList = foldr (:) []++-- | \(O(n)\). Convert the set to a descending list of elements. Subject to list+-- fusion.+toDescList :: Set a -> [a]+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 :: (a -> b -> b) -> b -> Set a -> b+foldrFB = foldr+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> b -> a) -> a -> Set b -> 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 "Set.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-}+{-# RULES "Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-}+{-# RULES "Set.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}+{-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}+#endif++-- | \(O(n \log n)\). Create a set from a list of elements.+--+-- If the elements are in non-decreasing order, this function takes \(O(n)\)+-- time.+fromList :: Ord a => [a] -> Set a+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.++  Note that if [xs] is ascending that:+    fromAscList xs == fromList xs+--------------------------------------------------------------------}+-- | \(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 = 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.+--+-- __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 = descLinkAll (Foldable.foldl' next Nada xs)+  where+    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.+--+-- __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.++-- See Note [fromDistinctAscList implementation]+fromDistinctAscList :: [a] -> Set a+fromDistinctAscList xs = ascLinkAll (Foldable.foldl' next Nada xs)+  where+    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++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++ascLinkAll :: Stack a -> Set a+ascLinkAll stk = foldl'Stack (\r x l -> linkL x l r) Tip stk+{-# INLINABLE ascLinkAll #-}++-- | \(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 xs = descLinkAll (Foldable.foldl' next Nada xs)+  where+    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++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 -> linkR 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 #-}++{--------------------------------------------------------------------+  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+  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 = 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+--------------------------------------------------------------------}+instance Show a => Show (Set a) where+  showsPrec p xs = showParen (p > 10) $+    showString "fromList " . shows (toList xs)++-- | @since 0.5.9+instance Show1 Set where+    liftShowsPrec sp sl d m =+        showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance (Read a, Ord a) => Read (Set a) 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++{--------------------------------------------------------------------+  NFData+--------------------------------------------------------------------}++instance NFData a => NFData (Set a) where+    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)@+-- 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)+split x t = toPair $ splitS x t+{-# INLINABLE split #-}++splitS :: Ord a => a -> Set a -> StrictPair (Set a) (Set a)+splitS _ Tip = (Tip :*: Tip)+splitS x (Bin _ y l r)+      = case compare x y of+          LT -> let (lt :*: gt) = splitS x l in (lt :*: linkR y gt r)+          GT -> let (lt :*: gt) = splitS x r in (linkL y l lt :*: gt)+          EQ -> (l :*: r)+{-# INLINABLE splitS #-}++-- | \(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 x0 t = case go x0 t of+  TripleS lt found gt -> (lt, found, gt)+  where+    go _ Tip = TripleS Tip False Tip+    go x (Bin _ y l r) =+      case compare x y of+        LT -> case go x l of+          TripleS lt found gt -> TripleS lt found (linkR y gt r)+        GT -> case go x r of+          TripleS lt found gt -> TripleS (linkL y l lt) found gt+        EQ -> TripleS l True r+{-# INLINABLE splitMember #-}++{--------------------------------------------------------------------+  Indexing+--------------------------------------------------------------------}++-- | \(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.+--+-- __Note__: This function is partial. Prefer 'lookupIndex'.+--+-- > findIndex 2 (fromList [5,3])    Error: element is not in the set+-- > findIndex 3 (fromList [5,3]) == 0+-- > findIndex 5 (fromList [5,3]) == 1+-- > findIndex 6 (fromList [5,3])    Error: element is not in the set+--+-- @since 0.5.4++-- See Note: Type of local 'go' function+findIndex :: Ord a => a -> Set a -> Int+findIndex = go 0+  where+    go :: Ord a => Int -> a -> Set a -> Int+    go !_ !_ Tip  = error "Set.findIndex: element is not in the set"+    go idx x (Bin _ kx l r) = case compare x kx of+      LT -> go idx x l+      GT -> go (idx + size l + 1) x r+      EQ -> idx + size l+{-# INLINABLE findIndex #-}++-- | \(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.+--+-- > isJust   (lookupIndex 2 (fromList [5,3])) == False+-- > fromJust (lookupIndex 3 (fromList [5,3])) == 0+-- > fromJust (lookupIndex 5 (fromList [5,3])) == 1+-- > isJust   (lookupIndex 6 (fromList [5,3])) == False+--+-- @since 0.5.4++-- See Note: Type of local 'go' function+lookupIndex :: Ord a => a -> Set a -> Maybe Int+lookupIndex = go 0+  where+    go :: Ord a => Int -> a -> Set a -> Maybe Int+    go !_ !_ Tip  = Nothing+    go idx x (Bin _ kx l r) = case compare x kx of+      LT -> go idx x l+      GT -> go (idx + size l + 1) x r+      EQ -> Just $! idx + size l+{-# INLINABLE lookupIndex #-}++-- | \(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.+--+-- __Note__: This function is partial.+--+-- > elemAt 0 (fromList [5,3]) == 3+-- > elemAt 1 (fromList [5,3]) == 5+-- > elemAt 2 (fromList [5,3])    Error: index out of range+--+-- @since 0.5.4++elemAt :: Int -> Set a -> a+elemAt !_ Tip = error "Set.elemAt: index out of range"+elemAt i (Bin _ x l r)+  = case compare i sizeL of+      LT -> elemAt i l+      GT -> elemAt (i-sizeL-1) r+      EQ -> x+  where+    sizeL = size l++-- | \(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.+--+-- __Note__: This function is partial.+--+-- > deleteAt 0    (fromList [5,3]) == singleton 5+-- > deleteAt 1    (fromList [5,3]) == singleton 3+-- > deleteAt 2    (fromList [5,3])    Error: index out of range+-- > deleteAt (-1) (fromList [5,3])    Error: index out of range+--+-- @since 0.5.4++deleteAt :: Int -> Set a -> Set a+deleteAt !i t =+  case t of+    Tip -> error "Set.deleteAt: index out of range"+    Bin _ x l r -> case compare i sizeL of+      LT -> balanceR x (deleteAt i l) r+      GT -> balanceL x l (deleteAt (i-sizeL-1) r)+      EQ -> glue l r+      where+        sizeL = size l++-- | \(O(\log n)\). Take a given number of elements in order, beginning+-- with the smallest ones.+--+-- @+-- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'+-- @+--+-- @since 0.5.8+take :: Int -> Set a -> Set 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 _ x l r) =+      case compare i sizeL of+        LT -> go i l+        GT -> linkL x l (go (i - sizeL - 1) r)+        EQ -> l+      where sizeL = size l++-- | \(O(\log n)\). Drop a given number of elements in order, beginning+-- with the smallest ones.+--+-- @+-- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'+-- @+--+-- @since 0.5.8+drop :: Int -> Set a -> Set 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 _ x l r) =+      case compare i sizeL of+        LT -> linkR x (go i l) r+        GT -> go (i - sizeL - 1) r+        EQ -> insertMin x r+      where sizeL = size l++-- | \(O(\log n)\). Split a set at a particular index.+--+-- @+-- splitAt !n !xs = ('take' n xs, 'drop' n xs)+-- @+splitAt :: Int -> Set a -> (Set a, Set 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 _ x l r)+      = case compare i sizeL of+          LT -> case go i l of+                  ll :*: lr -> ll :*: linkR x lr r+          GT -> case go (i - sizeL - 1) r of+                  rl :*: rr -> linkL x l rl :*: rr+          EQ -> l :*: insertMin x r+      where sizeL = size l++-- | \(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'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'+-- takeWhileAntitone p = 'filter' p+-- @+--+-- @since 0.5.8++takeWhileAntitone :: (a -> Bool) -> Set a -> Set a+takeWhileAntitone _ Tip = Tip+takeWhileAntitone p (Bin _ x l r)+  | p x = linkL x l (takeWhileAntitone p r)+  | otherwise = takeWhileAntitone p l++-- | \(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'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'+-- dropWhileAntitone p = 'filter' (not . p)+-- @+--+-- @since 0.5.8++dropWhileAntitone :: (a -> Bool) -> Set a -> Set a+dropWhileAntitone _ Tip = Tip+dropWhileAntitone p (Bin _ x l r)+  | p x = dropWhileAntitone p r+  | otherwise = linkR x (dropWhileAntitone p l) r++-- | \(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@.+--+-- @+-- 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 where the predicate switches from holding to not+-- holding (where the predicate is seen to hold before the first element and to fail+-- after the last element).+--+-- @since 0.5.8++spanAntitone :: (a -> Bool) -> Set a -> (Set a, Set a)+spanAntitone p0 m = toPair (go p0 m)+  where+    go _ Tip = Tip :*: Tip+    go p (Bin _ x l r)+      | p x = let u :*: v = go p r in linkL x l u :*: v+      | otherwise = let u :*: v = go p l in u :*: linkR 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+  in [r] > [x], and that [l] and [r] are valid trees.++  In order of sophistication:+    [Bin sz x l r]    The type constructor.+    [bin x l r]       Maintains the correct size, assumes that both [l]+                      and [r] are balanced with respect to each other.+    [balance 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 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 :: a -> Set a -> Set a -> Set a+link x Tip r  = insertMin x r+link x l Tip  = insertMax x l+link x l@(Bin lsz lx ll lr) r@(Bin rsz rx rl rr)+  | delta*lsz < rsz = balanceL rx (linkR_ x lsz l rl) rr+  | delta*rsz < lsz = balanceR lx ll (linkL_ x lr rsz r)+  | otherwise = Bin (1+lsz+rsz) x l r++-- Variant of link. Restores balance when the left tree may be too large for the+-- right tree, but not the other way around.+linkL :: a -> Set a -> Set a -> Set a+linkL x l r = case r of+  Tip -> insertMax x l+  Bin rsz _ _ _ -> linkL_ x l rsz r++linkL_ :: a -> Set a -> Int -> Set a -> Set a+linkL_ x l !rsz r = case l of+  Bin lsz lx ll lr+    | delta*rsz < lsz -> balanceR lx ll (linkL_ x lr rsz r)+    | otherwise -> Bin (1+lsz+rsz) x l r+  Tip -> Bin (1+rsz) x Tip r++-- Variant of link. Restores balance when the right tree may be too large for+-- the left tree, but not the other way around.+linkR :: a -> Set a -> Set a -> Set a+linkR x l r = case l of+  Tip -> insertMin x r+  Bin lsz _ _ _ -> linkR_ x lsz l r++linkR_ :: a -> Int -> Set a -> Set a -> Set a+linkR_ x !lsz l r = case r of+  Bin rsz rx rl rr+    | delta*lsz < rsz -> balanceL rx (linkR_ x lsz l rl) rr+    | otherwise -> Bin (1+lsz+rsz) x l r+  Tip -> Bin (1+lsz) x l Tip++-- insertMin and insertMax don't perform potentially expensive comparisons.+-- @since 0.8.1+insertMax :: a -> Set a -> Set a+insertMax x t+  = case t of+      Tip -> singleton x+      Bin _ y l r+          -> balanceR y l (insertMax x r)++-- @since 0.8.1+insertMin :: a -> Set a -> Set a+insertMin x t+  = case t of+      Tip -> singleton x+      Bin _ y l r+          -> balanceL y (insertMin x l) r++{--------------------------------------------------------------------+  [link2 l r]: merges two trees.+--------------------------------------------------------------------}+-- @since 0.8.1+link2 :: Set a -> Set a -> Set a+link2 Tip r   = r+link2 l Tip   = l+link2 l@(Bin lsz lx ll lr) r@(Bin rsz rx rl rr)+  | delta*lsz < rsz = balanceL rx (link2R_ lsz l rl) rr+  | delta*rsz < lsz = balanceR lx ll (link2L_ lr rsz r)+  | otherwise = glue l r++link2L_ :: Set a -> Int -> Set a -> Set a+link2L_ l !rsz r = case l of+  Bin lsz lx ll lr+    | delta*rsz < lsz -> balanceR lx ll (link2L_ lr rsz r)+    | otherwise -> glue l r+  Tip -> r++link2R_ :: Int -> Set a -> Set a -> Set a+link2R_ !lsz l r = case r of+  Bin rsz rx rl rr+    | delta*lsz < rsz -> balanceL rx (link2R_ lsz l rl) rr+    | otherwise -> glue l r+  Tip -> l++{--------------------------------------------------------------------+  [glue l r]: glues two trees together.+  Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+-- @since 0.8.1+glue :: Set a -> Set a -> Set a+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 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.+--+-- Calls 'error' if the set is empty.+--+-- __Note__: This function is partial. Prefer 'minView'.+deleteFindMin :: Set a -> (a,Set a)+deleteFindMin t+  | 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.+--+-- Calls 'error' if the set is empty.+--+-- __Note__: This function is partial. Prefer 'maxView'.+deleteFindMax :: Set a -> (a,Set a)+deleteFindMax t+  | Just r <- maxView t = r+  | otherwise = (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)++minViewSure :: a -> Set a -> Set a -> StrictPair a (Set a)+minViewSure = go+  where+    go x Tip r = x :*: r+    go x (Bin _ xl ll lr) r =+      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+-- stripped of that element, or 'Nothing' if passed an empty set.+minView :: Set a -> Maybe (a, Set a)+minView Tip = Nothing+minView (Bin _ x l r) = Just $! toPair $ minViewSure x l r++maxViewSure :: a -> Set a -> Set a -> StrictPair a (Set a)+maxViewSure = go+  where+    go x l Tip = x :*: l+    go x l (Bin _ xr rl rr) =+      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+-- stripped of that element, or 'Nothing' if passed an empty set.+maxView :: Set a -> Maybe (a, Set a)+maxView Tip = Nothing+maxView (Bin _ x l r) = Just $! toPair $ maxViewSure x l r++{--------------------------------------------------------------------+  [balance x l 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 :: a -> Set a -> Set a -> Set a+--   balance x l r+--     | sizeL + sizeR <= 1   = Bin sizeX x l r+--     | sizeR > delta*sizeL  = rotateL x l r+--     | sizeL > delta*sizeR  = rotateR x l r+--     | otherwise            = Bin sizeX x l r+--     where+--       sizeL = size l+--       sizeR = size r+--       sizeX = sizeL + sizeR + 1+--+--   rotateL :: a -> Set a -> Set a -> Set a+--   rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r+--                                 | otherwise               = doubleL x l r+--   rotateR :: a -> Set a -> Set a -> Set a+--   rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r+--                                 | otherwise               = doubleR x l r+--+--   singleL, singleR :: a -> Set a -> Set a -> Set a+--   singleL x1 t1 (Bin _ x2 t2 t3)  = bin x2 (bin x1 t1 t2) t3+--   singleR x1 (Bin _ x2 t1 t2) t3  = bin x2 t1 (bin x1 t2 t3)+--+--   doubleL, doubleR :: a -> Set a -> Set a -> Set a+--   doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)+--   doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)+--+-- It is only written in such a way that every node is pattern-matched only once.+--+-- Only balanceL and balanceR are needed at the moment, so balance is not here anymore.+-- In case it is needed, it can be found in Data.Map.++-- Functions balanceL and balanceR are specialized versions of balance.+-- 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.+-- @since 0.8.1+balanceL :: a -> Set a -> Set a -> Set a+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+           (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)+           (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)+           (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))+             | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)+             | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)++  (Bin rs _ _ _) -> case l of+           Tip -> Bin (1+rs) x Tip r++           (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.Set.balanceL_"+{-# NOINLINE balanceL_ #-}++-- balanceR is called when right subtree might have been inserted to or when+-- left subtree might have been deleted from.+-- @since 0.8.1+balanceR :: a -> Set a -> Set a -> Set a+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+           (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr+           (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)+           (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))+             | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr+             | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)++  (Bin ls _ _ _) -> case r of+           Tip -> Bin (1+ls) x l Tip++           (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.Set.balanceR_"+{-# NOINLINE balanceR_ #-}++{--------------------------------------------------------------------+  The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: a -> Set a -> Set a -> Set a+bin x l r+  = Bin (size l + size r + 1) x l r+{-# INLINE bin #-}+++{--------------------------------------------------------------------+  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 subset less than all+-- elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList [1..6]) ==+-- >   [fromList [1,2,3],fromList [4],fromList [5,6]]+--+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than three subsets,+--  but you should not depend on this behaviour because it can change in the+--  future without notice.+--+-- @since 0.5.4+splitRoot :: Set a -> [Set a]+splitRoot orig =+  case orig of+    Tip           -> []+    Bin _ v l r -> [l, singleton v, r]+{-# INLINE splitRoot #-}+++-- | \(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+-- @+--+-- Example:+--+-- @+-- powerSet (fromList [1,2,3]) =+--   fromList $ map fromList [[],[1],[1,2],[1,2,3],[1,3],[2],[2,3],[3]]+-- @+--+-- @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(nm)\). Calculate the Cartesian product of two sets.+--+-- @+-- cartesianProduct xs ys = fromList $ liftA2 (,) (toList xs) (toList ys)+-- @+--+-- Example:+--+-- @+-- cartesianProduct (fromList [1,2]) (fromList [\'a\',\'b\']) =+--   fromList [(1,\'a\'), (1,\'b\'), (2,\'a\'), (2,\'b\')]+-- @+--+-- @since 0.5.11+cartesianProduct :: Set a -> Set b -> Set (a, b)+-- The obvious big-O optimal (O(nm)) implementation would be+--+--   cartesianProduct _as Tip = Tip+--   cartesianProduct as bs = fromDistinctAscList+--     [(a,b) | a <- toList as, b <- toList bs]+--+-- 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 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.+cartesianProduct !_as Tip = Tip+cartesianProduct as (Bin 1 b _ _) = mapMonotonic (flip (,) b) as+cartesianProduct as bs =+  getMergeSet $ foldMap (\a -> MergeSet $ mapMonotonic ((,) a) bs) as++-- A version of Set with peculiar Semigroup and Monoid instances.+-- The result of xs <> ys will only be a valid set if the greatest+-- element of xs is strictly less than the least element of ys.+-- This is used to define cartesianProduct.+newtype MergeSet a = MergeSet { getMergeSet :: Set a }++instance Semigroup (MergeSet a) where+  MergeSet xs <> MergeSet ys = MergeSet (link2 xs ys)++instance Monoid (MergeSet a) where+  mempty = MergeSet empty+#if !MIN_VERSION_base(4,11,0)+  mappend = (<>)+#endif++-- | \(O(n+m)\). Calculate the disjoint union of two sets.+--+-- @ disjointUnion xs ys = map Left xs ``union`` map Right ys @+--+-- Example:+--+-- @+-- disjointUnion (fromList [1,2]) (fromList ["hi", "bye"]) =+--   fromList [Left 1, Left 2, Right "hi", Right "bye"]+-- @+--+-- @since 0.5.11+disjointUnion :: Set a -> Set b -> Set (Either a b)+disjointUnion as bs = link2 (mapMonotonic Left as) (mapMonotonic Right bs)++{--------------------------------------------------------------------+  Merging Sets+--------------------------------------------------------------------}++-- | A tactic for dealing with elements present in one set but not the other in+-- 'merge' or 'mergeA'.+--+-- A tactic of type @WhenMissing f a@ is an abstract representation of a+-- function of type @a -> f Bool@.+--+-- @since 0.8.1+data WhenMissing f a = WhenMissing+  { missingSubtree :: Set a -> f (Set a)+  , missingElem :: a -> f Bool+  }++-- | A tactic for dealing with elements present in one set but not the other in+-- 'merge'.+--+-- A tactic of type @SimpleWhenMissing a@ is an abstract representation+-- of a function of type @a -> Bool@.+--+-- @since 0.8.1+type SimpleWhenMissing = WhenMissing Identity++-- | Along with 'filterAMissing', witnesses the isomorphism between+-- @WhenMissing f a@ and @a -> f Bool@.+--+-- @since 0.8.1+runWhenMissing :: WhenMissing f a -> a -> f Bool+runWhenMissing = missingElem++-- | A tactic for dealing with elements present in both sets in 'merge' or+-- 'mergeA'.+--+-- A tactic of type @WhenMatched f a@ is an abstract representation of a+-- function of type @a -> f Bool@.+--+-- @since 0.8.1+newtype WhenMatched f a = WhenMatched { matchedElem :: a -> f Bool }++-- | A tactic for dealing with elements present in both sets in 'merge'.+--+-- A tactic of type @SimpleWhenMatched a@ is an abstract representation of a+-- function of type @a -> Bool@.+--+-- @since 0.8.1+type SimpleWhenMatched = WhenMatched Identity++-- | Along with 'filterAMatched', witnesses the isomorphism between+-- @WhenMatched f a@ and @a -> f Bool@.+--+-- @since 0.8.1+runWhenMatched :: WhenMatched f a -> a -> f Bool+runWhenMatched = matchedElem++-- | When an element is found in both sets, drop the element.+--+-- @since 0.8.1+dropMatched :: Applicative f => WhenMatched f a+dropMatched = WhenMatched (\_ -> pure False)+{-# INLINE dropMatched #-}++-- | When an element is found in both sets, keep the element.+--+-- @since 0.8.1+preserveMatched :: Applicative f => WhenMatched f a+preserveMatched = WhenMatched (\_ -> pure True)+{-# INLINE preserveMatched #-}++-- | When an element is found in both sets, choose whether to keep the element+-- in the merged set.+--+-- @since 0.8.1+filterMatched :: Applicative f => (a -> Bool) -> WhenMatched f a+filterMatched f = WhenMatched (pure . f)+{-# INLINE filterMatched #-}++-- | When an element is found in both sets, choose whether to keep the element+-- in the merged set.+--+-- @since 0.8.1+filterAMatched :: (a -> f Bool) -> WhenMatched f a+filterAMatched = WhenMatched++-- | Create a @WhenMissing@ from two functions.+--+-- @whenMissing@ must be called with two functions @f@ and @g@ such that+-- @g = 'filterA' f@. @g@ may be a more efficient way of applying @f@ to all+-- elements in a @Set@.+--+-- __Warning__: It is the caller's responsibility to ensure the above property.+--+-- === __Examples__+--+-- @+-- preserveMissing :: Applicative f => WhenMissing f a+-- preserveMissing = whenMissing f g+--   where+--     f _x = pure True+--     g s = pure s+--     -- Note that this satisfies g = filterA f+-- @+--+-- @+-- import Data.Functor.Const (Const(..))+-- import Data.Monoid (All(..))+--+-- -- For a usage of this, see examples on mergeA+-- isEmpty :: WhenMissing (Const All) a+-- isEmpty = whenMissing f g+--   where+--     f _x = Const (All False)+--     g s = Const (All (null s))+--     -- Note that this satisfies g = filterA f+-- @+--+-- @since 0.8.1+whenMissing :: (a -> f Bool) -> (Set a -> f (Set a)) -> WhenMissing f a+whenMissing = flip WhenMissing++-- | Drop all the elements that are missing from the other set.+--+-- @+-- dropMissing :: 'SimpleWhenMissing' a+-- @+--+-- > dropMissing = filterMissing (\_ -> False)+--+-- but @dropMissing@ is more efficient.+--+-- @since 0.8.1+dropMissing :: Applicative f => WhenMissing f a+dropMissing = WhenMissing+  { missingSubtree = \_ -> pure Tip+  , missingElem = \_ -> pure False+  }+{-# INLINE dropMissing #-}++-- | Preserve the elements that are missing from the other set.+--+-- @+-- preserveMissing :: 'SimpleWhenMissing' a+-- @+--+-- > preserveMissing = filterMissing (\_ -> True)+--+-- but @preserveMissing@ is more efficient.+--+-- @since 0.8.1+preserveMissing :: Applicative f => WhenMissing f a+preserveMissing = WhenMissing+  { missingSubtree = pure+  , missingElem = \_ -> pure True+  }+{-# INLINE preserveMissing #-}++-- | Filter the elements that are missing from the other set.+--+-- @+-- filterMissing :: (a -> Bool) -> 'SimpleWhenMissing' a+-- @+--+-- @since 0.8.1+filterMissing :: Applicative f => (a -> Bool) -> WhenMissing f a+filterMissing f = WhenMissing+  { missingSubtree = pure . filter f+  , missingElem = pure . f+  }+{-# INLINE filterMissing #-}++-- | Filter the elements that are missing from the other set using some+-- 'Applicative' action.+--+-- @since 0.8.1+filterAMissing :: Applicative f => (a -> f Bool) -> WhenMissing f a+filterAMissing f = WhenMissing+  { missingSubtree = filterA f+  , missingElem = f+  }+{-# INLINE filterAMissing #-}++-- | Merge two sets.+--+-- 'merge' takes two 'SimpleWhenMissing' tactics, a 'SimpleWhenMatched' tactic,+-- and two sets. It uses the tactics to merge the sets.+--+-- Consider+--+-- @+-- merge (filterMissing g1) (filterMissing g2) (filterMatched f) s1 s2+-- @+--+-- @+-- g1 = (==2)+-- g2 = (==3)+-- f  = (==6)+-- s1 = [2, 4, 6, 8, 10, 12]+-- s2 = [3, 6, 9, 12]+-- @+--+-- 'merge' will pass the elements to @g1@, @g2@, or @f@ as appropriate,+-- producing a @Bool@ for each element.+--+-- @+-- m1:      [   2,            4,     6,     8,           10     12]+-- m2:      [          3,            6,            9,           12]+-- result:  [g1 2,  g2 3,  g1 4,   f 6,  g1 8,  g2 9, g1 10,  f 12]+--        = [True,  True, False,  True, False, False, False, False]+-- @+--+-- The result set contains the element for which we have @True@.+--+-- >>> merge (filterMissing g1) (filterMissing g2) (filterMatched f) s1 s2+-- fromList [2,3,6]+--+-- The other tactics below are optimizations or simplifications of+-- 'filterMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all elements.+-- * 'preserveMissing' leaves all elements 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.+--+-- @since 0.8.1+merge+  :: Ord a+  => SimpleWhenMissing a -- ^ What to do with elements in @s1@ but not @s2@+  -> SimpleWhenMissing a -- ^ What to do with elements in @s2@ but not @s1@+  -> SimpleWhenMatched a -- ^ What to do with elements in both @s1@ and @s2@+  -> Set a -- ^ Set @s1@+  -> Set a -- ^ Set @s2@+  -> Set a+merge g1 g2 f = \s1 s2 -> runIdentity (mergeA g1 g2 f s1 s2)+{-# INLINE merge #-}++-- | An applicative version of 'merge'.+--+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic, and two+-- sets. It uses the tactics to merge the sets.+--+-- Behaves just like 'merge' while allowing @Applicative@ effects. Effects are+-- performed in increasing order of elements.+--+-- Consider,+--+-- @+-- mergeA (filterAMissing g1) (filterAMissing g2) (filterAMatched f) s1 s2+-- @+--+-- @+-- g1 x = (x == 2) <$ putStrLn ("g1 " ++ show x)+-- g2 x = (x == 3) <$ putStrLn ("g2 " ++ show x)+-- f x = (x == 6) <$ putStrLn ("f " ++ show x)+-- s1 = [2, 4, 6, 8, 10, 12]+-- s2 = [3, 6, 9, 12]+-- @+--+-- As with 'merge', the result set is @[2,3,6]@. Additionally, @g1@, @g2@, and+-- @f@ perform @IO@ effects, printing the elements in increasing order.+--+-- >>> mergeA (filterAMissing g1) (filterAMissing g2) (filterAMatched f) s1 s2+-- g1 2+-- g2 3+-- g1 4+-- f 6+-- g1 8+-- g2 9+-- g1 10+-- f 12+-- fromList [2,3,6]+--+-- 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.+--+-- === __Examples__+--+-- @+-- data Pair a = Pair !a !a deriving Functor+--+-- instance Applicative Pair where+--    pure x = Pair x x+--    liftA2 f (Pair x1 y1) (Pair x2 y2) = Pair (f x1 x2) (f y1 y2)+--+-- -- | Calculate the union and intersection of two sets.+-- unionIntersection :: Ord a => Set a -> Set a -> (Set a, Set a)+-- unionIntersection m1 m2 =+--   case mergeA preserveAndDropMissing preserveAndDropMissing 'preserveMatched' m1 m2 of+--     Pair mu mi -> (mu, mi)+--   where+--     -- use Pair to build the union and intersection together+--     preserveAndDropMissing = 'whenMissing' (\\_x -> Pair True False) (\\s -> Pair s empty)+-- @+--+-- @+-- import Data.Functor.Const (Const(..))+-- import Data.Monoid (All(..))+--+-- -- | Whether the first set is a subset of the second set.+-- isSubsetOf :: Ord a => Set a -> Set a -> Bool+-- isSubsetOf m1 m2 =+--   getAll (getConst (mergeA isEmpty 'dropMissing' 'dropMatched' m1 m2))+--   where+--     isEmpty = 'whenMissing' (\\_x -> Const (All False)) (\\s -> Const (All (null s)))+-- @+--+-- @since 0.8.1+mergeA+  :: (Applicative f, Ord a)+  => WhenMissing f a -- ^ What to do with elements in @s1@ but not @s2@+  -> WhenMissing f a -- ^ What to do with elements in @s2@ but not @s1@+  -> WhenMatched f a -- ^ What to do with elements in both @s1@ and @s2@+  -> Set a -- ^ Set @s1@+  -> Set a -- ^ Set @s2@+  -> f (Set a)+mergeA+    WhenMissing{missingSubtree = g1t, missingElem = g1k}+    WhenMissing{missingSubtree = g2t}+    WhenMatched{matchedElem = f} = go+  where+    go t1 Tip = g1t t1+    go Tip t2 = g2t t2+    go (Bin _ x1 l1 r1) t2 = case splitMember x1 t2 of+      (l2, found, r2)+        | found -> liftA3 doLink l1l2 (f x1) r1r2+        | otherwise -> liftA3 doLink l1l2 (g1k x1) r1r2+        where+          doLink l' True r' = link x1 l' r'+          doLink l' False r' = link2 l' r'+          l1l2 = go l1 l2+          r1r2 = go r1 r2+{-# INLINE mergeA #-}++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | \(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 \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.++> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]+> 4+> +--2+> |  +--1+> |  +--3+> +--5+>+> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]+> 4+> |+> +--2+> |  |+> |  +--1+> |  |+> |  +--3+> |+> +--5+>+> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]+> +--5+> |+> 4+> |+> |  +--3+> |  |+> +--2+>    |+>    +--1++-}+showTreeWith :: Show a => Bool -> Bool -> Set a -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS+showsTree wide lbars rbars t+  = case t of+      Tip -> showsBars lbars . showString "|\n"+      Bin _ x Tip Tip+          -> showsBars lbars . shows x . showString "\n"+      Bin _ x l r+          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . shows x . showString "\n" .+             showWide wide lbars .+             showsTree wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS+showsTreeHang wide bars t+  = case t of+      Tip -> showsBars bars . showString "|\n"+      Bin _ x Tip Tip+          -> showsBars bars . shows x . showString "\n"+      Bin _ x l r+          -> showsBars bars . shows x . showString "\n" .+             showWide wide bars .+             showsTreeHang wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang wide (withEmpty bars) r++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++{--------------------------------------------------------------------+  Assertions+--------------------------------------------------------------------}+-- | \(O(n)\). Test if the internal set structure is valid.+valid :: Ord a => Set a -> Bool+valid t+  = balanced t && ordered t && validsize t++ordered :: Ord a => Set a -> Bool+ordered t+  = bounded (const True) (const True) t+  where+    bounded lo hi t'+      = case t' of+          Tip         -> True+          Bin _ x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r++balanced :: Set a -> Bool+balanced t+  = case t of+      Tip         -> True+      Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+                     balanced l && balanced r++validsize :: Set a -> Bool+validsize t+  = (realsize t == Just (size t))+  where+    realsize t'+      = case t' of+          Tip          -> Just 0+          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 implementation 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)++-- Note [alterF implementation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- When implementing alterF, there are various costs to consider:+--+-- 1. The number of times we travel down the tree to the target+-- 2. The number of times we travel back up the tree+-- 3. The number of element comparisons we perform+-- 4. The number of times we apply fmap+-- 5. The amount of allocations we perform+--+-- The weights of these further depend on the Ord instance of the element type,+-- the Functor used, and GHC optimizations. Unfortunately, there is no clear+-- winning implementation which performs best in all situations. The current+-- implementation is chosen for its good characteristics:+--+-- 1. It travels down the tree once if the membership is demanded, and once more+--    if the changed Set is demanded.+-- 2. It travels up the tree once if the changed Set is demanded.+-- 3. It compares the given element against stored elements on the path to the+--    target at most once.+-- 4. It applies fmap exactly once.+-- 5. It allocates the changed Set if it is demanded. It does not allocate any+--    intermediate structure.+--+-- Note that 2,3,4,5 are all optimal. As for 1, implementations that travel down+-- the tree at most once are possible, but they are worse in at least one of the+-- other categories.+-- See https://github.com/haskell/containers/issues/1209#issuecomment-4530740850+-- for some other implementations and benchmarks.
+ src/Data/Set/Merge.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Safe #-}+#endif++-- | This module defines an API for writing functions that merge two sets. The key+-- functions are 'merge' and 'mergeA'. Each of these can be used with several+-- different \"merge tactics\".+--+-- @since 0.8.1+module Data.Set.Merge+  (+    -- ** Simple merge tactic types+    SimpleWhenMissing+  , SimpleWhenMatched++    -- ** General combining function+  , merge++    -- *** @WhenMissing@ tactics+  , dropMissing+  , preserveMissing+  , filterMissing++    -- *** @WhenMatched@ tactics+  , dropMatched+  , preserveMatched+  , filterMatched++    -- ** Applicative merge tactic types+  , WhenMissing+  , WhenMatched++    -- ** Applicative general combining function+  , mergeA++    -- *** @WhenMissing@ tactics+    -- | The tactics described for 'merge' work for 'mergeA' as well.+    -- Furthermore, the following are available.+  , filterAMissing+  , whenMissing++    -- *** @WhenMatched@ tactics+    -- | The tactics described for 'merge' work for 'mergeA' as well.+    -- Furthermore, the following are available.+  , filterAMatched++    -- ** Miscellaneous tactic functions+  , runWhenMissing+  , runWhenMatched+  ) where++import Data.Set.Internal
src/Data/Tree.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable #-}@@ -8,8 +7,6 @@ {-# LANGUAGE Trustworthy #-} #endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Data.Tree@@ -33,6 +30,7 @@     -- * Trees and Forests       Tree(..)     , Forest+    , PostOrder(..)      -- * Construction     , unfoldTree@@ -46,6 +44,10 @@     , foldTree     , flatten     , levels+    , leaves+    , edges+    , pathsToRoot+    , pathsFromRoot      -- * Ascii Drawings     , drawTree@@ -55,26 +57,35 @@  import Utils.Containers.Internal.Prelude as Prelude import Prelude ()-import Data.Foldable (fold, toList)+import Data.Bits ((.&.))+import Data.Foldable (toList)+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 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+#  if __GLASGOW_HASKELL__ >= 914+import Language.Haskell.TH.Lift (Lift)+#  else import Language.Haskell.TH.Syntax (Lift) -- See Note [ Template Haskell Dependencies ] import Language.Haskell.TH ()+#  endif #endif  import Control.Monad.Zip (MonadZip (..)) -import Data.Coerce-+#ifdef __GLASGOW_HASKELL__+import Data.Coerce (coerce)+#endif import Data.Functor.Classes  #if !MIN_VERSION_base(4,11,0)@@ -83,7 +94,6 @@  #if MIN_VERSION_base(4,18,0) import qualified Data.Foldable1 as Foldable1-import Data.List.NonEmpty (NonEmpty(..)) #endif  -- | Non-empty, possibly infinite, multi-way trees; also known as /rose trees/.@@ -170,7 +180,6 @@         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) @@ -184,12 +193,13 @@   = Node a (zipWith (\i _ -> mfixTree ((!! i) . subForest . f))                     [0..] children) +-- | Traverses in pre-order. instance Traversable Tree where   traverse f = go     where go (Node x ts) = liftA2 Node (f x) (traverse go ts)   {-# INLINE traverse #-} --- | Folds in preorder+-- | Folds in pre-order.  -- See Note [Implemented Foldable Tree functions] instance Foldable Tree where@@ -201,10 +211,7 @@      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)+        go (Node x ts) z' = f x (foldrTreeList go z' ts)     {-# INLINE foldr #-}      foldl' f = go@@ -233,8 +240,19 @@     product = foldlMap1' id (*)     {-# INLINABLE product #-} +-- This is the same as List's foldr, but unlike GHC's implementation the z is+-- passed along in go instead of go closing over it.+-- When folding over a Tree this avoids a closure per Node, which results in+-- significant reductions in time and allocations according to benchmarks.+foldrTreeList :: (Tree a -> b -> b) -> b -> [Tree a] -> b+foldrTreeList f = go+  where+    go z [] = z+    go z (t:ts) = f t (go z ts)+{-# INLINE foldrTreeList #-}+ #if MIN_VERSION_base(4,18,0)--- | Folds in preorder+-- | Folds in pre-order. -- -- @since 0.6.7 @@ -251,17 +269,17 @@       go (Node x []) = f x       go (Node x (t : ts)) =         f x <> Foldable1.foldrMap1 go (\t' z -> go t' <> z) (t :| ts)-  {-# INLINABLE foldMap1 #-}+  {-# INLINE foldMap1 #-}    foldMap1' f = foldlMap1' f (\z x -> z <> f x)-  {-# INLINABLE foldMap1' #-}+  {-# INLINE foldMap1' #-}    toNonEmpty (Node x ts) = x :| concatMap toList ts -  maximum = maximum+  maximum = Foldable.maximum   {-# INLINABLE maximum #-} -  minimum = minimum+  minimum = Foldable.minimum   {-# INLINABLE minimum #-}    foldrMap1 = foldrMap1@@ -300,6 +318,12 @@ 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)@@ -359,6 +383,8 @@  -- | Returns the elements of a tree in pre-order. --+-- @flatten == Data.Foldable.'toList'@+-- -- @ -- --   a@@ -391,7 +417,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@.@@ -426,13 +452,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__ --@@ -463,12 +490,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)@@ -479,10 +506,12 @@     (a, bs) <- f b     ts <- unfoldForestM f bs     return (Node a ts)+{-# INLINABLE unfoldTreeM #-} --- | 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)+{-# INLINABLE unfoldForestM #-}  -- | Monadic tree builder, in breadth-first order. --@@ -497,8 +526,9 @@     getElement xs = case viewl xs of         x :< _ -> x         EmptyL -> error "unfoldTreeM_BF"+{-# INLINABLE unfoldTreeM_BF #-} --- | Monadic forest builder, in breadth-first order+-- | Monadic forest builder, in breadth-first order. -- -- See 'unfoldForest' for more info. --@@ -507,6 +537,7 @@ -- 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+{-# INLINABLE unfoldForestM_BF #-}  -- Takes a sequence (queue) of seeds and produces a sequence (reversed queue) of -- trees of the same length.@@ -524,7 +555,323 @@     splitOnto as (_:bs) q = case viewr q of         q' :> a -> splitOnto (a:as) bs q'         EmptyR -> error "unfoldForestQ"+{-# INLINABLE 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 = foldrTreeList 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 _ [] z = z+      go p (Node x ts : ts') z = cons (p, x) (go x ts (go p ts' z))+  in go x0 ts0 nil+{-# 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.+--+-- ==== __@Foldable@ examples__+--+-- >>> import Data.Foldable (toList)+-- >>> toList $ PostOrder $ Node 1 [Node 2 [Node 3 [], Node 4 []], Node 5 []]+-- [3,4,2,5,1]+--+-- @foldr@ produces elements incrementally, inspecting the structure of the+-- @Tree@ just as much as necessary.+--+-- >>> take 3 $ foldr (:) [] $ PostOrder $ Node 1 ([Node 2 [Node 3 [], Node 4 []]] ++ undefined)+-- [3,4,2]+--+-- @foldl@ also produces elements incrementally.+--+-- >>> foldl (flip (:)) [] $ PostOrder $ Node 1 [Node 2 [Node 3 [], Node 4 []], Node 5 []]+-- [1,5,2,4,3]+-- >>> take 4 $ foldl (flip (:)) [] $ PostOrder $ Node 1 [Node 2 [undefined, Node 4 []], Node 5 []]+-- [1,5,2,4]+--+-- @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 = foldrTreeList 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' #-}++    foldl f z0 = -- Inline with two arguments+      \(PostOrder t) -> go z0 t+      where+        go z (Node x ts) = f (Foldable.foldl go z ts) x+    {-# INLINE foldl #-}++    foldr' f z0 = -- Inline with two arguments+      \(PostOrder t) -> go t z0+      where+        go (Node x ts) !z =+          let !z' = f x z+          in foldrTreeList go z' ts+    {-# INLINE foldr' #-}++    foldr1 = foldrMap1PostOrder id+    {-# INLINE foldr1 #-}++    foldl1 = foldlMap1PostOrder id+    {-# INLINE foldl1 #-}++    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 (foldrTreeList (\t' z' -> foldr (:) z' (PostOrder t')) (x:z) ts)++  maximum = Foldable.maximum+  {-# INLINABLE maximum #-}++  minimum = Foldable.minimum+  {-# INLINABLE minimum #-}++  foldrMap1 = foldrMap1PostOrder+  {-# INLINE foldrMap1 #-}++  foldlMap1' = foldlMap1'PostOrder+  {-# INLINE foldlMap1' #-}++  foldlMap1 = foldlMap1PostOrder+  {-# INLINE foldlMap1 #-}++  foldrMap1' f g = -- Inline with two arguments+    \(PostOrder (Node x ts)) ->+      foldr (\t !z -> Foldable.foldr' g z (PostOrder t)) (f x) ts+  {-# INLINE foldrMap1' #-}+#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]@@ -560,3 +907,38 @@ -- -- 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
@@ -1,7 +1,4 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}--#include "containers.h"  ----------------------------------------------------------------------------- -- |
src/Utils/Containers/Internal/BitUtil.hs view
@@ -1,13 +1,8 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-} #endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif -#include "containers.h"- ----------------------------------------------------------------------------- -- | -- Module      :  Utils.Containers.Internal.BitUtil@@ -31,44 +26,20 @@ -- closely.  module Utils.Containers.Internal.BitUtil-    ( bitcount-    , highestBitMask-    , shiftLL+    ( shiftLL     , shiftRL     , wordSize+    , iShiftRL     ) where -import Data.Bits (popCount, unsafeShiftL, unsafeShiftR-    , countLeadingZeros, finiteBitSize-    )---{-----------------------------------------------------------------------  [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-highestBitMask w = shiftLL 1 (wordSize - 1 - countLeadingZeros w)-{-# INLINE highestBitMask #-}+import Data.Bits (unsafeShiftL, unsafeShiftR, finiteBitSize)+#ifdef __GLASGOW_HASKELL__+import GHC.Exts (Int(..), uncheckedIShiftRL#)+#endif  -- Right and left logical shifts.+--+-- Precondition for defined behavior: 0 <= shift amount < wordSize shiftRL, shiftLL :: Word -> Int -> Word shiftRL = unsafeShiftR shiftLL = unsafeShiftL@@ -76,3 +47,13 @@ {-# INLINE wordSize #-} wordSize :: Int 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+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--#ifdef __GLASGOW_HASKELL__-import Data.Coerce-#endif--infixl 8 .#-#ifdef __GLASGOW_HASKELL__-(.#) :: 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--- @-#ifdef __GLASGOW_HASKELL__-(.^#) :: 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.Strict (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
@@ -1,12 +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,12 +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 )-import GHC.Exts ( Int#, isTrue# )+import GHC.Exts ( isTrue#, reallyUnsafePtrEquality# ) #endif  -- | Checks if two pointers are equal. Yes means yes;@@ -19,24 +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__ ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)-hetPtrEq x y = isTrue# (unsafeCoerce (reallyUnsafePtrEquality# :: x -> x -> Int#) x y)- #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
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}-#include "containers.h" {-# OPTIONS_HADDOCK hide #-}  -- | A clone of Control.Monad.State.Strict.@@ -16,9 +14,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'
+ src/Utils/Containers/Internal/Strict.hs view
@@ -0,0 +1,22 @@+-- | Simple strict types for internal use.+module Utils.Containers.Internal.Strict+  ( StrictPair(..)+  , toPair+  , StrictTriple(..)+  ) where++-- | The same as a regular Haskell pair, but+--+-- @+-- (x :*: _|_) = (_|_ :*: y) = _|_+-- @+data StrictPair a b = !a :*: !b++infixr 1 :*:++-- | Convert a strict pair to a standard pair.+toPair :: StrictPair a b -> (a, b)+toPair (x :*: y) = (x, y)+{-# INLINE toPair #-}++data StrictTriple a b c = TripleS !a !b !c
− src/Utils/Containers/Internal/StrictMaybe.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE CPP #-}--#include "containers.h"--{-# OPTIONS_HADDOCK hide #-}--- | Strict 'Maybe'--module Utils.Containers.Internal.StrictMaybe (MaybeS (..), maybeS, toMaybe, toMaybeS) where--data MaybeS a = NothingS | JustS !a--instance Foldable MaybeS where-  foldMap _ NothingS = mempty-  foldMap f (JustS a) = f a--maybeS :: r -> (a -> r) -> MaybeS a -> r-maybeS n _ NothingS = n-maybeS _ j (JustS a) = j a--toMaybe :: MaybeS a -> Maybe a-toMaybe NothingS = Nothing-toMaybe (JustS a) = Just a--toMaybeS :: Maybe a -> MaybeS a-toMaybeS Nothing = NothingS-toMaybeS (Just a) = JustS a
− src/Utils/Containers/Internal/StrictPair.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif--#include "containers.h"---- | A strict pair--module Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where---- | The same as a regular Haskell pair, but------ @--- (x :*: _|_) = (_|_ :*: y) = _|_--- @-data StrictPair a b = !a :*: !b--infixr 1 :*:---- | Convert a strict pair to a standard pair.-toPair :: StrictPair a b -> (a, b)-toPair (x :*: y) = (x, y)-{-# INLINE toPair #-}
− src/Utils/Containers/Internal/TypeError.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleInstances, FlexibleContexts, UndecidableInstances,-     KindSignatures, TypeFamilies, CPP #-}--#if !defined(TESTING)-{-# LANGUAGE Safe #-}-#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@.  Trying--- to use a function with a @Whoops s@ constraint will lead to a pretty type--- error explaining how to fix the problem.------ ==== Example------ @--- oldFunction :: Whoops "oldFunction is gone now. Use newFunction."---             => Int -> IntMap a -> IntMap a--- @-class Whoops (a :: Symbol)--instance TypeError ('Text a) => Whoops a---- 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.