packages feed

containers 0.6.8 → 0.8

raw patch · 37 files changed

Files

changelog.md view
@@ -1,5 +1,223 @@ # Changelog for [`containers` package](http://github.com/haskell/containers) +## 0.8  *March 2025*++### Breaking changes++* `Data.IntMap.Lazy.split`, `Data.IntMap.Strict.split`,+  `Data.IntMap.Lazy.splitLookup`, `Data.IntMap.Strict.splitLookup` and+  `Data.IntSet.splitMember` are now strict in the key. Previously, the key was+  ignored for an empty map or set. (Soumik Sarkar)+  ([#982](https://github.com/haskell/containers/pull/982),+  [#983](https://github.com/haskell/containers/pull/983))++* These functions have been updated to match the strictness of their+  `fromList` counterparts:++  * `Data.Map.Strict`: `fromAscList`, `fromAscListWith`, `fromAscListWithKey`+    `fromDescList`, `fromDescListWith`, `fromDescListWithKey`+  * `Data.IntMap.Strict`: `fromAscList`, `fromAscListWith`, `fromAscListWithKey`++  Previously they were lazier and did not force the first value in runs of at+  least 2 entries with equal keys. (Soumik Sarkar)+  ([#1023](https://github.com/haskell/containers/pull/1023))++* `Data.Set.fold` and `Data.IntSet.fold` are deprecated. One should instead use+  `Data.Set.foldr` and `Data.IntSet.foldr`. (Soumik Sarkar)+  ([#1049](https://github.com/haskell/containers/pull/1049))++* For `Data.IntMap.{Lazy,Strict}`, `updateMin`, `updateMax`, `updateMinWithKey`,+  `updateMaxWithKey` now return an empty map for an input empty map instead of+  calling `error`. This matches the behavior of `Data.Map`. (Kushagra Gupta)+  ([#1065](https://github.com/haskell/containers/pull/1065))++* `foldl'` and `foldr'` for `Seq` are now strict in the initial value. This+  matches the behavior of the default implementations and of other structures in+  the library. (Soumik Sarkar)+  ([#1077](https://github.com/haskell/containers/pull/1077))++* Some long deprecated functions, whose definitions currently cause type errors,+  have been removed. (Soumik Sarkar)+  ([#1046](https://github.com/haskell/containers/pull/1046))++### Bug fixes++* Make the package compile with [MicroHs](https://github.com/augustss/MicroHs).+  (Lennart Augustsson)+  ([#1043](https://github.com/haskell/containers/pull/1043),+  [#1081](https://github.com/haskell/containers/pull/1081))++* Fix a strictness bug in `Data.Map.Strict.fromDistinctAscList` and+  `Data.Map.Strict.fromDistinctDescList` where all values were not forced to+  WHNF. This bug affects versions 0.6.8 and 0.7. (Neil Mayhew)+  ([#996](https://github.com/haskell/containers/pull/996))++* Fix a bug in `Data.IntMap`'s `isProperSubmapOfBy` where it could incorrectly+  return `False`. (Soumik Sarkar)+  ([#1008](https://github.com/haskell/containers/pull/1008))++* Make `Data.Map.Merge.{Lazy,Strict}.filterAMissing` sequence effects in the+  correct order. (j6carey)+  ([#1005](https://github.com/haskell/containers/pull/1005))++* `Data.Map.Strict.mergeWithKey` now forces the result of the combining function+  to WHNF. (Soumik Sarkar)+  ([#1024](https://github.com/haskell/containers/pull/1024))++* Fix an issue where `Data.Map.mergeWithKey`, `Data.Map.Strict.mergeWithKey`,+  `Data.IntMap.mergeWithKey`, `Data.IntMap.Strict.mergeWithKey` could call the+  provided `only2` function with empty maps, contrary to documentation.+  (Soumik Sarkar) ([#1025](https://github.com/haskell/containers/pull/1025))++### Additions++* Add `Data.Graph.flattenSCC1`. (Andreas Abel)+  ([#987](https://github.com/haskell/containers/pull/987))++* Add `symmetricDifference` for `Set`, `Map`, `IntSet`, `IntMap`.+  (Soumik Sarkar) ([#1009](https://github.com/haskell/containers/pull/1009))++* Add `lookupMin` and `lookupMax` for `Data.IntSet`. (Soumik Sarkar)+  ([#976](https://github.com/haskell/containers/pull/976))++* Add `Intersection` and `intersections` for `Data.Set` and `Data.IntSet`.+  (Reed Mullanix, Soumik Sarkar)+  ([#756](https://github.com/haskell/containers/pull/756),+  [#1040](https://github.com/haskell/containers/pull/1040),+  [#1052](https://github.com/haskell/containers/pull/1052),+  [#1080](https://github.com/haskell/containers/pull/1080))++* Add `foldMap` for `Data.IntSet`. (Soumik Sarkar)+  ([#1048](https://github.com/haskell/containers/pull/1048))++* Add `filterKeys` for `Data.Map` and `Data.IntMap`. (flip111)+  ([#972](https://github.com/haskell/containers/pull/972))++* `NFData1`, `NFData2` instances for `SCC`, `IntMap`, `Map`, `Sequence`, `Set`,+  `Tree` and relevant internal dependencies (David Beacham)+  ([#992](https://github.com/haskell/containers/pull/992))++* Add `leaves`, `edges`, `pathsToRoot`, `pathsFromRoot`, `PostOrder` to+  `Data.Tree`. (Soumik Sarkar)+  ([#1109](https://github.com/haskell/containers/pull/1109))++### Performance improvements++* The internal representations of `IntMap` and `IntSet` have been changed+  to be a little more memory efficient. Consequently, many functions on+  `IntMap`s and `IntSet`s are a little faster now. (Soumik Sarkar)+  ([#995](https://github.com/haskell/containers/pull/995),+  [#998](https://github.com/haskell/containers/pull/998))++* Improved performance for `Data.Map`'s `minView`, `maxView`, `difference`.+  (Soumik Sarkar) ([#1001](https://github.com/haskell/containers/pull/1001))++* For `Data.Graph.SCC`, `Foldable.toList` and `Foldable1.toNonEmpty` now+  do not perform an unnecessary copy. (Soumik Sarkar)+  ([#1057](https://github.com/haskell/containers/pull/1057))++* Improved performance for `Data.Intset`'s `foldr`, `foldl'`, `foldl`, `foldr'`.+  (Soumik Sarkar) ([#1079](https://github.com/haskell/containers/pull/1079))++* Improved performance for `Data.Set` and `Data.Map`'s `fromAscList*` and+  `fromDescList*` functions. (Soumik Sarkar)+  ([#1083](https://github.com/haskell/containers/pull/1083))++* Improved performance for `Data.Set`'s `fromList`, `map` and `Data.Map`'s+  `fromList`, `fromListWith`, `fromListWithKey`, `mapKeys`, `mapKeysWith`.+  (Soumik Sarkar) ([#1042](https://github.com/haskell/containers/pull/1042))++* Improved performance for many `Set` and `Map` modification operations,+  including `insert` and `delete`, by inlining part of the balancing+  routine. (Soumik Sarkar)+  ([#1056](https://github.com/haskell/containers/pull/1056))++* Improved performance for `Eq` and `Ord` instances of `Set`, `Map`, `IntSet`,+  `IntMap`, `Seq`. (Soumik Sarkar)+  ([#1028](https://github.com/haskell/containers/pull/1028),+  [#1017](https://github.com/haskell/containers/pull/1017),+  [#1035](https://github.com/haskell/containers/pull/1035),+  [#1086](https://github.com/haskell/containers/pull/1086),+  [#1112](https://github.com/haskell/containers/pull/1112))++### Documentation++* Add and improve documentation (Bodigrim, konsumlamm, Toni Dietze, alexfmpe,+  Soumik Sarkar, Jonathan Knowles, Xavier Góngora, Xia Li-yao, eyelash)+  ([#957](https://github.com/haskell/containers/pull/957),+  [#1006](https://github.com/haskell/containers/pull/1006),+  [#877](https://github.com/haskell/containers/pull/877),+  [#960](https://github.com/haskell/containers/pull/960),+  [#1033](https://github.com/haskell/containers/pull/1033),+  [#1041](https://github.com/haskell/containers/pull/1041),+  [#1039](https://github.com/haskell/containers/pull/1039),+  [#1050](https://github.com/haskell/containers/pull/1050),+  [#1088](https://github.com/haskell/containers/pull/1088),+  [#1087](https://github.com/haskell/containers/pull/1087),+  [#1098](https://github.com/haskell/containers/pull/1098),+  [#1106](https://github.com/haskell/containers/pull/1106),+  [#1104](https://github.com/haskell/containers/pull/1104),+  [#1105](https://github.com/haskell/containers/pull/1105),+  [#1111](https://github.com/haskell/containers/pull/1111),+  [#1110](https://github.com/haskell/containers/pull/1110),+  [#1114](https://github.com/haskell/containers/pull/1114),+  [#1115](https://github.com/haskell/containers/pull/1115))++### Miscellaneous/internal++* Internal modules `Utils.Containers.Internal.BitUtil`,+  `Utils.Containers.Internal.BitQueue`, `Utils.Containers.Internal.StrictPair`+  are no longer exposed. (Soumik Sarkar)+  ([#1101](https://github.com/haskell/containers/pull/1101))++* Test and CI maintenance. (Andreas Abel, Soumik Sarkar)+  ([#986](https://github.com/haskell/containers/pull/986),+  [#1015](https://github.com/haskell/containers/pull/1015),+  [#1030](https://github.com/haskell/containers/pull/1030),+  [#1055](https://github.com/haskell/containers/pull/1055),+  [#1067](https://github.com/haskell/containers/pull/1067))++* Internal cleanups and improvements. (Soumik Sarkar, alexfmpe)+  ([#1000](https://github.com/haskell/containers/pull/1000),+  [#959](https://github.com/haskell/containers/pull/959),+  [#1020](https://github.com/haskell/containers/pull/1020),+  [#1029](https://github.com/haskell/containers/pull/1029),+  [#1031](https://github.com/haskell/containers/pull/1031),+  [#1037](https://github.com/haskell/containers/pull/1037),+  [#1058](https://github.com/haskell/containers/pull/1058),+  [#1076](https://github.com/haskell/containers/pull/1076),+  [#1084](https://github.com/haskell/containers/pull/1084),+  [#1085](https://github.com/haskell/containers/pull/1085),+  [#1093](https://github.com/haskell/containers/pull/1093),+  [#1094](https://github.com/haskell/containers/pull/1094),+  [#1095](https://github.com/haskell/containers/pull/1095),+  [#1097](https://github.com/haskell/containers/pull/1097),+  [#1103](https://github.com/haskell/containers/pull/1103),+  [#1117](https://github.com/haskell/containers/pull/1117))++* Add new tests and benchmarks (Soumik Sarkar)+  ([#962](https://github.com/haskell/containers/pull/962),+  [#1021](https://github.com/haskell/containers/pull/1021),+  [#1063](https://github.com/haskell/containers/pull/1063),+  [#1068](https://github.com/haskell/containers/pull/1068),+  [#1071](https://github.com/haskell/containers/pull/1071),+  [#1075](https://github.com/haskell/containers/pull/1075),+  [#1082](https://github.com/haskell/containers/pull/1082))++* Fix the Read the Docs tutorial (Soumik Sarkar)+  ([#1091](https://github.com/haskell/containers/pull/1091),+  [#1099](https://github.com/haskell/containers/pull/1099))++## 0.7++### Breaking changes++* Breaking changes to `Data.Graph.SCC v` (bodʲɪˈɡrʲim):+  * `CyclicSCC [v]` is now not a constructor,+    but a bundled pattern synonym for backward compatibility.+  * `NECyclicSCC (NonEmpty v)` is a new constructor, maintaining an invariant+    that a set of mutually reachable vertices is non-empty.+ ## 0.6.8  ### Additions@@ -76,17 +294,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 +552,13 @@  * Rewrite the `IsString` instance head for sequences, improving compatibility   with the list instance and also improving type inference. We used to have-  +   ```haskell   instance IsString (Seq Char)   ```-  +   Now we commit more eagerly with-  +   ```haskell   instance a ~ Char => IsString (Seq a)   ```@@ -390,7 +632,7 @@ * Fix completely incorrect implementations of `Data.IntMap.restrictKeys` and   `Data.IntMap.withoutKeys`. Make the tests for these actually run. (Thanks   to Tom Smalley for reporting this.)-  + * Fix a minor bug in the `Show1` instance of `Data.Tree`. This produced valid   output, but with fewer parentheses than `Show`. (Thanks, Ryan Scott.) @@ -445,7 +687,7 @@     before 7.0.    * Integrate benchmarks with Cabal. (Thanks, Gabriel Gonzalez!)-  +   * Make Cabal report required extensions properly, and stop using     default extensions. Note that we do *not* report extensions conditionally enabled     based on GHC version, as doing so would lead to a maintenance nightmare@@ -495,7 +737,7 @@     it returned a lazy pair.    * Fix completely erroneous definition of `length` for `Data.Sequence.ViewR`.-  +   * Make `Data.Map.Strict.traverseWithKey` force result values before     installing them in the new map.
containers.cabal view
@@ -1,8 +1,10 @@+cabal-version: 2.2 name: containers-version: 0.6.8-license: BSD3+version: 0.8+license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org+homepage: https://github.com/haskell/containers bug-reports: https://github.com/haskell/containers/issues synopsis: Assorted concrete container types category: Data Structures@@ -20,25 +22,27 @@     remains valid even if structures are shared.  build-type: Simple-cabal-version:  >=1.10+extra-doc-files:+    changelog.md extra-source-files:     include/containers.h-    changelog.md     mkappend.hs  tested-with:   GHC ==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.6 || ==9.8.4 || ==9.10.1 || ==9.12.1  source-repository head     type:     git-    location: http://github.com/haskell/containers.git+    location: https://github.com/haskell/containers  Library     default-language: Haskell2010-    build-depends: base >= 4.10 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.6, template-haskell+    build-depends: base >= 4.10 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.6+    if impl(ghc)+       build-depends: template-haskell     hs-source-dirs: src-    ghc-options: -O2 -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+    ghc-options: -O2 -Wall      other-extensions: CPP, BangPatterns @@ -53,6 +57,7 @@         Data.IntMap.Merge.Lazy         Data.IntMap.Merge.Strict         Data.IntSet.Internal+        Data.IntSet.Internal.IntTreeCommons         Data.IntSet         Data.Map         Data.Map.Lazy@@ -69,20 +74,15 @@         Data.Sequence.Internal         Data.Sequence.Internal.Sorting         Data.Tree-        Utils.Containers.Internal.BitUtil-        Utils.Containers.Internal.BitQueue-        Utils.Containers.Internal.StrictPair      other-modules:         Utils.Containers.Internal.Prelude         Utils.Containers.Internal.State         Utils.Containers.Internal.StrictMaybe         Utils.Containers.Internal.PtrEquality-        Utils.Containers.Internal.Coercions-    if impl(ghc)-      other-modules:-        Utils.Containers.Internal.TypeError-        Data.Map.Internal.DeprecatedShowTree-        Data.IntMap.Internal.DeprecatedDebug+        Utils.Containers.Internal.EqOrdUtil+        Utils.Containers.Internal.BitUtil+        Utils.Containers.Internal.BitQueue+        Utils.Containers.Internal.StrictPair      include-dirs: include
include/containers.h view
@@ -6,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/Graph.hs view
@@ -1,15 +1,21 @@ {-# LANGUAGE CPP #-}+#include "containers.h" {-# LANGUAGE BangPatterns #-} #if __GLASGOW_HASKELL__-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Safe #-}+{-# LANGUAGE TemplateHaskellQuotes #-} #endif--#include "containers.h"+#ifdef DEFINE_PATTERN_SYNONYMS+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+#endif+#ifdef USE_ST_MONAD+{-# LANGUAGE RankNTypes #-}+#endif  ----------------------------------------------------------------------------- -- |@@ -33,8 +39,11 @@ -- -- The implementation is based on -----   * /Structuring Depth-First Search Algorithms in Haskell/,---     by David King and John Launchbury, <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.52.6526>+--   * David King and John Launchbury,+--     \"/Structuring Depth-First Search Algorithms in Haskell/\",+--     Proceedings of the 22nd ACM SIGPLAN-SIGACT Symposium on Principles of+--     Programming Languages, 344-354, 1995,+--     <https://doi.org/10.1145/199448.199530>. -- ----------------------------------------------------------------------------- @@ -74,7 +83,11 @@       -- * Strongly Connected Components-    , SCC(..)+    , SCC(..+#ifdef DEFINE_PATTERN_SYNONYMS+      , CyclicSCC+#endif+      )      -- ** Construction     , stronglyConnComp@@ -82,6 +95,7 @@      -- ** Conversion     , flattenSCC+    , flattenSCC1     , flattenSCCs      -- * Trees@@ -107,7 +121,10 @@  -- std interfaces import Data.Foldable as F-import Control.DeepSeq (NFData(rnf))+#if MIN_VERSION_base(4,18,0)+import qualified Data.Foldable1 as F1+#endif+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf)) import Data.Maybe import Data.Array #if USE_UNBOXED_ARRAYS@@ -117,6 +134,8 @@ import qualified Data.Array as UA #endif import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE import Data.Functor.Classes #if !MIN_VERSION_base(4,11,0) import Data.Semigroup (Semigroup (..))@@ -124,7 +143,7 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Generics (Generic, Generic1) import Data.Data (Data)-import Language.Haskell.TH.Syntax (Lift)+import Language.Haskell.TH.Syntax (Lift(..)) -- See Note [ Template Haskell Dependencies ] import Language.Haskell.TH () #endif@@ -139,15 +158,28 @@ -------------------------------------------------------------------------  -- | Strongly connected component.-data SCC vertex = AcyclicSCC vertex     -- ^ A single vertex that is not-                                        -- in any cycle.-                | CyclicSCC  [vertex]   -- ^ A maximal set of mutually-                                        -- reachable vertices.+data SCC vertex+  = AcyclicSCC vertex+  -- ^ A single vertex that is not in any cycle.+  | NECyclicSCC {-# UNPACK #-} !(NonEmpty vertex)+  -- ^ A maximal set of mutually reachable vertices.+  --+  -- @since 0.7   deriving ( Eq   -- ^ @since 0.5.9            , Show -- ^ @since 0.5.9            , Read -- ^ @since 0.5.9            ) +#ifdef DEFINE_PATTERN_SYNONYMS+-- | Partial pattern synonym for backward compatibility with @containers < 0.7@.+pattern CyclicSCC :: [vertex] -> SCC vertex+pattern CyclicSCC xs <- NECyclicSCC (NE.toList -> xs) where+  CyclicSCC [] = error "CyclicSCC: an argument cannot be an empty list"+  CyclicSCC (x : xs) = NECyclicSCC (x :| xs)++{-# COMPLETE AcyclicSCC, CyclicSCC #-}+#endif+ #ifdef __GLASGOW_HASKELL__ -- | @since 0.5.9 deriving instance Data vertex => Data (SCC vertex)@@ -158,57 +190,100 @@ -- | @since 0.5.9 deriving instance Generic (SCC vertex) +-- There is no instance Lift (NonEmpty v) before template-haskell-2.15.+#if MIN_VERSION_template_haskell(2,15,0) -- | @since 0.6.6 deriving instance Lift vertex => Lift (SCC vertex)+#else+instance Lift vertex => Lift (SCC vertex) where+  lift (AcyclicSCC v) = [| AcyclicSCC v |]+  lift (NECyclicSCC (v :| vs)) = [| NECyclicSCC (v :| vs) |] #endif +#endif+ -- | @since 0.5.9 instance Eq1 SCC where   liftEq eq (AcyclicSCC v1) (AcyclicSCC v2) = eq v1 v2-  liftEq eq (CyclicSCC vs1) (CyclicSCC vs2) = liftEq eq vs1 vs2+  liftEq eq (NECyclicSCC vs1) (NECyclicSCC vs2) = liftEq eq vs1 vs2   liftEq _ _ _ = False -- | @since 0.5.9 instance Show1 SCC where   liftShowsPrec sp _sl d (AcyclicSCC v) = showsUnaryWith sp "AcyclicSCC" d v-  liftShowsPrec _sp sl d (CyclicSCC vs) = showsUnaryWith (const sl) "CyclicSCC" d vs+  liftShowsPrec sp sl d (NECyclicSCC vs) = showsUnaryWith (liftShowsPrec sp sl) "NECyclicSCC" d vs -- | @since 0.5.9 instance Read1 SCC where   liftReadsPrec rp rl = readsData $     readsUnaryWith rp "AcyclicSCC" AcyclicSCC <>-    readsUnaryWith (const rl) "CyclicSCC" CyclicSCC+    readsUnaryWith (liftReadsPrec rp rl) "NECyclicSCC" NECyclicSCC+#ifdef __GLASGOW_HASKELL__+    <> readsUnaryWith (const rl) "CyclicSCC" CyclicSCC+#endif  -- | @since 0.5.9 instance F.Foldable SCC where   foldr c n (AcyclicSCC v) = c v n-  foldr c n (CyclicSCC vs) = foldr c n vs+  foldr c n (NECyclicSCC vs) = foldr c n vs +  toList = flattenSCC++#if MIN_VERSION_base(4,18,0)+-- | @since 0.7+instance F1.Foldable1 SCC where+  foldMap1 f (AcyclicSCC v) = f v+  foldMap1 f (NECyclicSCC vs) = F1.foldMap1 f vs++  toNonEmpty = flattenSCC1++  -- TODO define more methods+#endif+ -- | @since 0.5.9 instance Traversable SCC where-  -- We treat the non-empty cyclic case specially to cut one-  -- fmap application.   traverse f (AcyclicSCC vertex) = AcyclicSCC <$> f vertex-  traverse _f (CyclicSCC []) = pure (CyclicSCC [])-  traverse f (CyclicSCC (x : xs)) =-    liftA2 (\x' xs' -> CyclicSCC (x' : xs')) (f x) (traverse f xs)+  -- Avoid traverse from instance Traversable NonEmpty,+  -- it is redundantly lazy.+  traverse f (NECyclicSCC (x :| xs)) =+    liftA2 (\x' xs' -> NECyclicSCC (x' :| xs')) (f x) (traverse f xs)  instance NFData a => NFData (SCC a) where     rnf (AcyclicSCC v) = rnf v-    rnf (CyclicSCC vs) = rnf vs+    rnf (NECyclicSCC vs) = rnf vs +-- | @since 0.8+instance NFData1 SCC where+    liftRnf rnfx (AcyclicSCC v)   = rnfx v+    liftRnf rnfx (NECyclicSCC vs) = liftRnf rnfx vs+ -- | @since 0.5.4 instance Functor SCC where     fmap f (AcyclicSCC v) = AcyclicSCC (f v)-    fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)+    -- Avoid fmap from instance Functor NonEmpty,+    -- it is redundantly lazy.+    fmap f (NECyclicSCC (x :| xs)) = NECyclicSCC (f x :| map f xs)  -- | The vertices of a list of strongly connected components. flattenSCCs :: [SCC a] -> [a] flattenSCCs = concatMap flattenSCC  -- | The vertices of a strongly connected component.+--+-- @flattenSCC = 'Data.List.NonEmpty.toList' . 'flattenSCC1'@.+--+-- This function is retained for backward compatibility,+-- 'flattenSCC1' has the more precise type. flattenSCC :: SCC vertex -> [vertex] flattenSCC (AcyclicSCC v) = [v]-flattenSCC (CyclicSCC vs) = vs+flattenSCC (NECyclicSCC (v :| vs)) = v : vs+-- Note: Best to avoid NE.toList, it is too lazy. +-- | The 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. --@@ -229,7 +304,8 @@   = map get_node (stronglyConnCompR edges0)   where     get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n-    get_node (CyclicSCC triples)     = CyclicSCC [n | (n,_,_) <- triples]+    get_node (NECyclicSCC ((n0, _, _) :| triples)) =+      NECyclicSCC (n0 :| [n | (n, _, _) <- triples]) {-# INLINABLE stronglyConnComp #-}  -- | \(O((V+E) \log V)\). The strongly connected components of a directed graph,@@ -258,11 +334,12 @@   where     (graph, vertex_fn,_) = graphFromEdges edges0     forest             = scc graph-    decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]++    decode (Node v []) | mentions_itself v = NECyclicSCC (vertex_fn v :| [])                        | otherwise         = AcyclicSCC (vertex_fn v)-    decode other = CyclicSCC (dec other [])-                 where-                   dec (Node v ts) vs = vertex_fn v : foldr dec vs ts+    decode (Node v ts) = NECyclicSCC (vertex_fn v :| foldr dec [] ts)++    dec (Node v ts) vs = vertex_fn v : foldr dec vs ts     mentions_itself v = v `elem` (graph ! v) {-# INLINABLE stronglyConnCompR #-} @@ -486,9 +563,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@@ -499,74 +575,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 */
src/Data/IntMap.hs view
@@ -1,11 +1,6 @@ {-# 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"@@ -19,81 +14,88 @@ -- Maintainer  :  libraries@haskell.org -- Portability :  portable ----- An efficient implementation of maps from integer keys to values--- (dictionaries). ----- This module re-exports the value lazy "Data.IntMap.Lazy" API, plus--- several deprecated value strict functions. Please note that these functions--- have different strictness properties than those in "Data.IntMap.Strict":--- they only evaluate the result of the combining function. For example, the--- default value to 'insertWith'' is only evaluated if the combining function--- is called and uses it.+-- = Finite Int Maps (lazy interface) ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.+-- This module re-exports the value lazy "Data.IntMap.Lazy" API. ----- >  import Data.IntMap (IntMap)--- >  import qualified Data.IntMap as IntMap+-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @Int@ to values of type @v@. --+-- The functions in "Data.IntMap.Strict" are careful to force values before+-- installing them in an 'IntMap'. This is usually more efficient in cases where+-- laziness is not essential. The functions in this module do not do so.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- > import Data.IntMap.Lazy (IntMap)+-- > import qualified Data.IntMap.Lazy as IntMap+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Implementation+-- -- The implementation is based on /big-endian patricia trees/.  This data -- structure performs especially well on binary operations like 'union'--- and 'intersection'.  However, my benchmarks show that it is also+-- and 'intersection'. Additionally, benchmarks show that it is also -- (much) faster on insertions and deletions when compared to a generic -- size-balanced map implementation (see "Data.Map"). -----    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\", --      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>. -----    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>. --+--+-- == Performance information+-- -- Operation comments contain the operation time complexity in--- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.--- Many operations have a worst-case complexity of \(O(\min(n,W))\).--- This means that the operation can become linear in the number of--- elements with a maximum of \(W\) -- the number of bits in an 'Int'--- (32 or 64).+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'lookup', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+--   the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+--   shared by all subelements, so there could not be more+--   than \(W\) levels.+--+-- If all \(n\) keys in the tree are between 0 and \(N\) (or, say, between \(-N\) and \(N\)),+-- the estimate can be refined to \(O(\min(n, \log N))\). If the set of keys+-- is sufficiently "dense", this becomes \(O(\min(n, \log n))\) or simply+-- the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntMap' are keys from a contiguous subset,+-- in which case the complexity is proportional to \(\log n\), capped by \(W\).+-- The worst scenario are exponentially growing keys \(1,2,4,\ldots,2^n\),+-- for which complexity grows as fast as \(n\) but again is capped by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+-- -----------------------------------------------------------------------------  module Data.IntMap     ( module Data.IntMap.Lazy-#ifdef __GLASGOW_HASKELL__--- For GHC, we disable these, pending removal. For anything else,--- we just don't define them at all.-    , insertWith'-    , insertWithKey'-    , fold-    , foldWithKey-#endif     ) where  import Data.IntMap.Lazy--#ifdef __GLASGOW_HASKELL__-import Utils.Containers.Internal.TypeError---- | This function is being removed and is no longer usable.--- Use 'Data.IntMap.Strict.insertWith'-insertWith' :: Whoops "Data.IntMap.insertWith' is gone. Use Data.IntMap.Strict.insertWith."-            => (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWith' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.IntMap.Strict.insertWithKey'.-insertWithKey' :: Whoops "Data.IntMap.insertWithKey' is gone. Use Data.IntMap.Strict.insertWithKey."-               => (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWithKey' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.IntMap.Lazy.foldr'.-fold :: Whoops "Data.IntMap.fold' is gone. Use Data.IntMap.foldr or Prelude.foldr."-     => (a -> b -> b) -> b -> IntMap a -> b-fold _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'foldrWithKey'.-foldWithKey :: Whoops "Data.IntMap.foldWithKey is gone. Use foldrWithKey."-            => (Key -> a -> b -> b) -> b -> IntMap a -> b-foldWithKey _ _ _ = undefined-#endif
src/Data/IntMap/Internal.hs view
@@ -7,3663 +7,3880 @@ {-# 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+{-# LANGUAGE Trustworthy #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IntMap.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+--                (c) wren romano 2016+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Int Maps (lazy interface internals)+--+-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @Int@ to values of type @v@.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. Additionally, benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced map implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of IntMap matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.+--++module Data.IntMap.Internal (+    -- * Map type+      IntMap(..)          -- instance Eq,Show+    , Key++    -- * Operators+    , (!), (!?), (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookup+    , findWithDefault+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , disjoint++    -- * Construction+    , empty+    , singleton++    -- ** Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- ** Delete\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Symmetric difference+    , symmetricDifference++    -- ** Compose+    , compose++    -- ** General combining function+    , SimpleWhenMissing+    , SimpleWhenMatched+    , runWhenMatched+    , runWhenMissing+    , merge+    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched+    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , mapMissing+    , filterMissing++    -- ** Applicative general combining function+    , WhenMissing (..)+    , WhenMatched (..)+    , mergeA+    -- *** @WhenMatched@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , zipWithMaybeAMatched+    , zipWithAMatched+    -- *** @WhenMissing@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , traverseMaybeMissing+    , traverseMissing+    , filterAMissing++    -- ** Deprecated general combining function+    , mergeWithKey+    , mergeWithKey'++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , fromSet++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * Filter+    , filter+    , filterKeys+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- * Debugging+    , showTree+    , showTreeWith++    -- * Utility+    , link+    , linkKey+    , linkWithMask+    , bin+    , binCheckLeft+    , binCheckRight++    -- * Used by "IntMap.Merge.Lazy" and "IntMap.Merge.Strict"+    , mapWhenMissing+    , mapWhenMatched+    , lmapWhenMissing+    , contramapFirstWhenMatched+    , contramapSecondWhenMatched+    , mapGentlyWhenMissing+    , mapGentlyWhenMatched+    ) where++import Data.Functor.Identity (Identity (..))+import Data.Semigroup (Semigroup(stimes))+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+import Data.Semigroup (stimesIdempotentMonoid)+import Data.Functor.Classes++import Control.DeepSeq (NFData(rnf),NFData1(liftRnf))+import Data.Bits+import qualified Data.Foldable as Foldable+import Data.Maybe (fromMaybe)+import Utils.Containers.Internal.Prelude hiding+  (lookup, map, filter, foldr, foldl, foldl', null)+import Prelude ()++import qualified Data.IntSet.Internal as IntSet+import Data.IntSet.Internal.IntTreeCommons+  ( Key+  , Prefix(..)+  , nomatch+  , left+  , signBranch+  , mask+  , branchMask+  , TreeTreeBranch(..)+  , treeTreeBranch+  , i2w+  , Order(..)+  )+import Utils.Containers.Internal.BitUtil (shiftLL, shiftRL, iShiftRL)+import Utils.Containers.Internal.StrictPair++#ifdef __GLASGOW_HASKELL__+import Data.Coerce+import Data.Data (Data(..), Constr, mkConstr, constrIndex,+                  DataType, mkDataType, gcast1)+import qualified Data.Data as Data+import GHC.Exts (build)+import qualified GHC.Exts as GHCExts+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+import Text.Read+#endif+import qualified Control.Category as Category+++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}+++-- | A map of integers to values @a@.++-- See Note: Order of constructors+data IntMap a = Bin {-# UNPACK #-} !Prefix+                    !(IntMap a)+                    !(IntMap a)+              | Tip {-# UNPACK #-} !Key a+              | Nil++--+-- Note [IntMap structure and invariants]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- * Nil is never found as a child of Bin.+--+-- * The Prefix of a Bin indicates the common high-order bits that all keys in+--   the Bin share.+--+-- * The least significant set bit of the Int value of a Prefix is called the+--   mask bit.+--+-- * All the bits to the left of the mask bit are called the shared prefix. All+--   keys stored in the Bin begin with the shared prefix.+--+-- * All keys in the left child of the Bin have the mask bit unset, and all keys+--   in the right child have the mask bit set. It follows that+--+--   1. The Int value of the Prefix of a Bin is the smallest key that can be+--      present in the right child of the Bin.+--+--   2. All keys in the right child of a Bin are greater than keys in the+--      left child, with one exceptional situation. If the Bin separates+--      negative and non-negative keys, the mask bit is the sign bit and the+--      left child stores the non-negative keys while the right child stores the+--      negative keys.+--+-- * All bits to the right of the mask bit are set to 0 in a Prefix.+--++-- See Note [Okasaki-Gill] for how the implementation here relates to the one in+-- Okasaki and Gill's paper.++-- Some stuff from "Data.IntSet.Internal", for 'restrictKeys' and+-- 'withoutKeys' to use.+type IntSetPrefix = Int+type IntSetBitMap = Word++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+deriving instance Lift a => Lift (IntMap a)+#endif++bitmapOf :: Int -> IntSetBitMap+bitmapOf x = shiftLL 1 (x .&. IntSet.suffixBitMask)+{-# INLINE bitmapOf #-}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: IntMap a -> Key -> a+(!) m k = find k m++-- | \(O(\min(n,W))\). Find the value at a key.+-- Returns 'Nothing' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing+-- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a'+--+-- @since 0.5.11++(!?) :: IntMap a -> Key -> Maybe a+(!?) m k = lookup k m++-- | Same as 'difference'.+(\\) :: IntMap a -> IntMap b -> IntMap a+m1 \\ m2 = difference m1 m2++infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}++-- | @mempty@ = 'empty'+instance Monoid (IntMap a) where+    mempty  = empty+    mconcat = unions+    mappend = (<>)++-- | @(<>)@ = 'union'+--+-- @since 0.5.7+instance Semigroup (IntMap a) where+    (<>)    = union+    stimes  = stimesIdempotentMonoid++-- | Folds in order of increasing key.+instance Foldable.Foldable IntMap where+  fold = go+    where go Nil = mempty+          go (Tip _ v) = v+          go (Bin p l r)+            | signBranch p = go r `mappend` go l+            | otherwise = go l `mappend` go r+  {-# INLINABLE fold #-}+  foldr = foldr+  {-# INLINE foldr #-}+  foldl = foldl+  {-# INLINE foldl #-}+  foldMap f t = go t+    where go Nil = mempty+          go (Tip _ v) = f v+          go (Bin p l r)+            | signBranch p = go r `mappend` go l+            | otherwise = go l `mappend` go r+  {-# INLINE foldMap #-}+  foldl' = foldl'+  {-# INLINE foldl' #-}+  foldr' = foldr'+  {-# INLINE foldr' #-}+  length = size+  {-# INLINE length #-}+  null   = null+  {-# INLINE null #-}+  toList = elems -- NB: Foldable.toList /= IntMap.toList+  {-# INLINE toList #-}+  elem = go+    where go !_ Nil = False+          go x (Tip _ y) = x == y+          go x (Bin _ l r) = go x l || go x r+  {-# INLINABLE elem #-}+  maximum = start+    where start Nil = error "Data.Foldable.maximum (for Data.IntMap): empty map"+          start (Tip _ y) = y+          start (Bin p l r)+            | signBranch p = go (start r) l+            | otherwise = go (start l) r++          go !m Nil = m+          go m (Tip _ y) = max m y+          go m (Bin _ l r) = go (go m l) r+  {-# INLINABLE maximum #-}+  minimum = start+    where start Nil = error "Data.Foldable.minimum (for Data.IntMap): empty map"+          start (Tip _ y) = y+          start (Bin p l r)+            | signBranch p = go (start r) l+            | otherwise = go (start l) r++          go !m Nil = m+          go m (Tip _ y) = min m y+          go m (Bin _ l r) = go (go m l) r+  {-# INLINABLE minimum #-}+  sum = foldl' (+) 0+  {-# INLINABLE sum #-}+  product = foldl' (*) 1+  {-# INLINABLE product #-}++-- | Traverses in order of increasing key.+instance Traversable IntMap where+    traverse f = traverseWithKey (\_ -> f)+    {-# INLINE traverse #-}++instance NFData a => NFData (IntMap a) where+    rnf Nil = ()+    rnf (Tip _ v) = rnf v+    rnf (Bin _ l r) = rnf l `seq` rnf r++-- | @since 0.8+instance NFData1 IntMap where+    liftRnf rnfx = go+      where+      go Nil         = ()+      go (Tip _ v)   = rnfx v+      go (Bin _ l r) = go l `seq` go r++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data a => Data (IntMap a) where+  gfoldl f z im = z fromList `f` (toList im)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = intMapDataType+  dataCast1 f    = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr intMapDataType "fromList" [] Data.Prefix++intMapDataType :: DataType+intMapDataType = mkDataType "Data.IntMap.Internal.IntMap" [fromListConstr]++#endif++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the map empty?+--+-- > Data.IntMap.null (empty)           == True+-- > Data.IntMap.null (singleton 1 'a') == False++null :: IntMap a -> Bool+null Nil = True+null _   = False+{-# INLINE null #-}++-- | \(O(n)\). Number of elements in the map.+--+-- > size empty                                   == 0+-- > size (singleton 1 'a')                       == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3+size :: IntMap a -> Int+size = go 0+  where+    go !acc (Bin _ l r) = go (go acc l) r+    go acc (Tip _ _) = 1 + acc+    go acc Nil = acc++-- | \(O(\min(n,W))\). Is the key a member of the map?+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False++-- See Note: Local 'go' functions and capturing]+member :: Key -> IntMap a -> Bool+member !k = go+  where+    go (Bin p l r)+      | nomatch k p = False+      | left k p    = go l+      | otherwise   = go r+    go (Tip kx _) = k == kx+    go Nil = False++-- | \(O(\min(n,W))\). Is the key not a member of the map?+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Key -> IntMap a -> Bool+notMember k m = not $ member k m++-- | \(O(\min(n,W))\). Look up the value at a key in the map. See also 'Data.Map.lookup'.++-- See Note: Local 'go' functions and capturing+lookup :: Key -> IntMap a -> Maybe a+lookup !k = go+  where+    go (Bin p l r) | left k p  = go l+                   | otherwise = go r+    go (Tip kx x) | k == kx   = Just x+                  | otherwise = Nothing+    go Nil = Nothing++-- See Note: Local 'go' functions and capturing]+find :: Key -> IntMap a -> a+find !k = go+  where+    go (Bin p l r) | left k p  = go l+                   | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = not_found+    go Nil = not_found++    not_found = error ("IntMap.!: key " ++ show k ++ " is not an element of the map")++-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See Note: Local 'go' functions and capturing]+findWithDefault :: a -> Key -> IntMap a -> a+findWithDefault def !k = go+  where+    go (Bin p l r) | nomatch k p = def+                   | left k p    = go l+                   | otherwise   = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = def+    go Nil = def++-- | \(O(\min(n,W))\). Find largest key smaller than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> IntMap a -> Maybe (Key, a)+lookupLT !k t = case t of+    Bin p l r | signBranch p -> if k >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p l r)+      | nomatch k p = if k < unPrefix p then unsafeFindMax def else unsafeFindMax r+      | left k p  = go def l+      | otherwise = go l r+    go def (Tip ky y)+      | k <= ky   = unsafeFindMax def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMax def++-- | \(O(\min(n,W))\). Find smallest key greater than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> IntMap a -> Maybe (Key, a)+lookupGT !k t = case t of+    Bin p l r | signBranch p -> if k >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p l r)+      | nomatch k p = if k < unPrefix p then unsafeFindMin l else unsafeFindMin def+      | left k p  = go r l+      | otherwise = go def r+    go def (Tip ky y)+      | k >= ky   = unsafeFindMin def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMin def++-- | \(O(\min(n,W))\). Find largest key smaller or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> IntMap a -> Maybe (Key, a)+lookupLE !k t = case t of+    Bin p l r | signBranch p -> if k >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p l r)+      | nomatch k p = if k < unPrefix p then unsafeFindMax def else unsafeFindMax r+      | left k p  = go def l+      | otherwise = go l r+    go def (Tip ky y)+      | k < ky    = unsafeFindMax def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMax def++-- | \(O(\min(n,W))\). Find smallest key greater or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> IntMap a -> Maybe (Key, a)+lookupGE !k t = case t of+    Bin p l r | signBranch p -> if k >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p l r)+      | nomatch k p = if k < unPrefix p then unsafeFindMin l else unsafeFindMin def+      | left k p  = go r l+      | otherwise = go def r+    go def (Tip ky y)+      | k > ky    = unsafeFindMin def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMin def+++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: IntMap a -> Maybe (Key, a)+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip ky y) = Just (ky, y)+unsafeFindMin (Bin _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: IntMap a -> Maybe (Key, a)+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip ky y) = Just (ky, y)+unsafeFindMax (Bin _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Check whether the key sets of two maps are disjoint+-- (i.e. their 'intersection' is empty).+--+-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())])   == True+-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False+-- > disjoint (fromList [])        (fromList [])                 == True+--+-- > disjoint a b == null (intersection a b)+--+-- @since 0.6.2.1+disjoint :: IntMap a -> IntMap b -> Bool+disjoint Nil _ = True+disjoint _ Nil = True+disjoint (Tip kx _) ys = notMember kx ys+disjoint xs (Tip ky _) = notMember ky xs+disjoint t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> disjoint l1 t2+  ABR -> disjoint r1 t2+  BAL -> disjoint t1 l2+  BAR -> disjoint t1 r2+  EQL -> disjoint l1 l2 && disjoint r1 r2+  NOM -> True++{--------------------------------------------------------------------+  Compose+--------------------------------------------------------------------}+-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument+--+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- __Note:__ Prior to v0.6.4, "Data.IntMap.Strict" exposed a version of+-- 'compose' that forced the values of the output 'IntMap'. This version does+-- not force these values.+--+-- @since 0.6.3.1+compose :: IntMap c -> IntMap Int -> IntMap c+compose bc !ab+  | null bc = empty+  | otherwise = mapMaybe (bc !?) ab++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty map.+--+-- > empty      == fromList []+-- > size empty == 0++empty :: IntMap a+empty+  = Nil+{-# INLINE empty #-}++-- | \(O(1)\). A map of one element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: Key -> a -> IntMap a+singleton k x+  = Tip k x+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty                         == singleton 5 'x'++insert :: Key -> a -> IntMap a -> IntMap a+insert !k x t@(Bin p l r)+  | nomatch k p = linkKey k (Tip k x) p t+  | left k p    = Bin p (insert k x l) r+  | otherwise   = Bin p l (insert k x r)+insert k x t@(Tip ky _)+  | k==ky         = Tip k x+  | otherwise     = link k (Tip k x) ky t+insert k x Nil = Tip k x++-- right-biased insertion, used by 'union'+-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWith f k x t+  = insertWithKey (\_ x' y' -> f x' y') k x t++-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithKey f !k x t@(Bin p l r)+  | nomatch k p = linkKey k (Tip k x) p t+  | left k p    = Bin p (insertWithKey f k x l) r+  | otherwise   = Bin p l (insertWithKey f k x r)+insertWithKey f k x t@(Tip ky y)+  | k == ky       = Tip k (f k x y)+  | otherwise     = link k (Tip k x) ky t+insertWithKey _ k x Nil = Tip k x++-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])+--+-- Also see the performance note on 'fromListWith'.++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)+insertLookupWithKey f !k x t@(Bin p l r)+  | nomatch k p = (Nothing,linkKey k (Tip k x) p t)+  | left k p    = let (found,l') = insertLookupWithKey f k x l+                  in (found,Bin p l' r)+  | otherwise   = let (found,r') = insertLookupWithKey f k x r+                  in (found,Bin p l r')+insertLookupWithKey f k x t@(Tip ky y)+  | k == ky       = (Just y,Tip k (f k x y))+  | otherwise     = (Nothing,link k (Tip k x) ky t)+insertLookupWithKey _ k x Nil = (Nothing,Tip k x)+++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > delete 5 empty                         == empty++delete :: Key -> IntMap a -> IntMap a+delete !k t@(Bin p l r)+  | nomatch k p = t+  | left k p    = binCheckLeft p (delete k l) r+  | otherwise   = binCheckRight p l (delete k r)+delete k t@(Tip ky _)+  | k == ky       = Nil+  | otherwise     = t+delete _k Nil = Nil++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty                         == empty++adjust ::  (a -> a) -> Key -> IntMap a -> IntMap a+adjust f k m+  = adjustWithKey (\_ x -> f x) k m++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty                         == empty++adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a+adjustWithKey f !k (Bin p l r)+  | left k p      = Bin p (adjustWithKey f k l) r+  | otherwise     = Bin p l (adjustWithKey f k r)+adjustWithKey f k t@(Tip ky y)+  | k == ky       = Tip ky (f k y)+  | otherwise     = t+adjustWithKey _ _ Nil = Nil+++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update ::  (a -> Maybe a) -> Key -> IntMap a -> IntMap a+update f+  = updateWithKey (\_ x -> f x)++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a+updateWithKey f !k (Bin p l r)+  | left k p      = binCheckLeft p (updateWithKey f k l) r+  | otherwise     = binCheckRight p l (updateWithKey f k r)+updateWithKey f k t@(Tip ky y)+  | k == ky       = case (f k y) of+                      Just y' -> Tip ky y'+                      Nothing -> Nil+  | otherwise     = t+updateWithKey _ _ Nil = Nil++-- | \(O(\min(n,W))\). Look up and update.+-- This function returns the original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)+updateLookupWithKey f !k (Bin p l r)+  | left k p      = let !(found,l') = updateLookupWithKey f k l+                    in (found,binCheckLeft p l' r)+  | otherwise     = let !(found,r') = updateLookupWithKey f k r+                    in (found,binCheckRight p l r')+updateLookupWithKey f k t@(Tip ky y)+  | k==ky         = case (f k y) of+                      Just y' -> (Just y,Tip ky y')+                      Nothing -> (Just y,Nil)+  | otherwise     = (Nothing,t)+updateLookupWithKey _ _ Nil = (Nothing,Nil)++++-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a+alter f !k t@(Bin p l r)+  | nomatch k p = case f Nothing of+                    Nothing -> t+                    Just x -> linkKey k (Tip k x) p t+  | left k p    = binCheckLeft p (alter f k l) r+  | otherwise   = binCheckRight p l (alter f k r)+alter f k t@(Tip ky y)+  | k==ky         = case f (Just y) of+                      Just x -> Tip ky x+                      Nothing -> Nil+  | otherwise     = case f Nothing of+                      Just x -> link k (Tip k x) ky t+                      Nothing -> Tip ky y+alter f k Nil     = case f Nothing of+                      Just x -> Tip k x+                      Nothing -> Nil++-- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,+-- or update a value in an 'IntMap'.  In short : @'lookup' k \<$\> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)+-- interactiveAlter k m = alterF f k m where+--   f Nothing = do+--      putStrLn $ show k +++--          " was not found in the map. Would you like to add it?"+--      getUserResponse1 :: IO (Maybe String)+--   f (Just old) = do+--      putStrLn $ "The key is currently bound to " ++ show old +++--          ". Would you like to change or delete it?"+--      getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map.+--+-- Note: 'alterF' is a flipped version of the @at@ combinator from+-- @Control.Lens.At@.+--+-- @since 0.5.8++alterF :: Functor f+       => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)+-- This implementation was stolen from 'Control.Lens.At'.+alterF f k m = (<$> f mv) $ \fres ->+  case fres of+    Nothing -> maybe m (const (delete k m)) mv+    Just v' -> insert k v' m+  where mv = lookup k m++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+--+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "b"), (5, "a"), (7, "C")]+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]+-- >     == fromList [(3, "B3"), (5, "A3"), (7, "C")]++unions :: Foldable f => f (IntMap a) -> IntMap a+unions xs+  = Foldable.foldl' union empty xs++-- | The union of a list of maps, with a combining operation.+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The (left-biased) union of two maps.+-- It prefers the first map when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: IntMap a -> IntMap a -> IntMap a+union m1 m2+  = mergeWithKey' Bin const id id m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWith f m1 m2+  = unionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWithKey f m1 m2+  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference between two maps (based on keys).+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: IntMap a -> IntMap b -> IntMap a+difference m1 m2+  = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWith f m1 m2+  = differenceWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWithKey f m1 m2+  = mergeWithKey f id (const Nil) m1 m2+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Remove all the keys in a given set from a map.+--+-- @+-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``IntSet.notMember`` s) m+-- @+--+-- @since 0.5.8+withoutKeys :: IntMap a -> IntSet.IntSet -> IntMap a+withoutKeys t1@(Bin p1 l1 r1) t2@(IntSet.Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> binCheckLeft p1 (withoutKeys l1 t2) r1+  ABR -> binCheckRight p1 l1 (withoutKeys r1 t2)+  BAL -> withoutKeys t1 l2+  BAR -> withoutKeys t1 r2+  EQL -> bin p1 (withoutKeys l1 l2) (withoutKeys r1 r2)+  NOM -> t1+  where+withoutKeys t1@(Bin p1 _ _) (IntSet.Tip p2 bm2) =+    let px1 = unPrefix p1+        minbit = bitmapOf (px1 .&. (px1-1))+        lt_minbit = minbit - 1+        maxbit = bitmapOf (px1 .|. (px1-1))+        gt_maxbit = (-maxbit) `xor` maxbit+    -- TODO(wrengr): should we manually inline/unroll 'updatePrefix'+    -- and 'withoutBM' here, in order to avoid redundant case analyses?+    in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)+withoutKeys t1@(Bin _ _ _) IntSet.Nil = t1+withoutKeys t1@(Tip k1 _) t2+    | k1 `IntSet.member` t2 = Nil+    | otherwise = t1+withoutKeys Nil _ = Nil+++updatePrefix+    :: IntSetPrefix -> IntMap a -> (IntMap a -> IntMap a) -> IntMap a+updatePrefix !kp t@(Bin p l r) f+    | unPrefix p .&. IntSet.suffixBitMask /= 0 =+        if unPrefix p .&. IntSet.prefixBitMask == kp then f t else t+    | nomatch kp p = t+    | left kp p    = binCheckLeft p (updatePrefix kp l f) r+    | otherwise    = binCheckRight p l (updatePrefix kp r f)+updatePrefix kp t@(Tip kx _) f+    | kx .&. IntSet.prefixBitMask == kp = f t+    | otherwise = t+updatePrefix _ Nil _ = Nil+++withoutBM :: IntSetBitMap -> IntMap a -> IntMap a+withoutBM 0 t = t+withoutBM bm (Bin p l r) =+    let leftBits = bitmapOf (unPrefix p) - 1+        bmL = bm .&. leftBits+        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+    in  bin p (withoutBM bmL l) (withoutBM bmR r)+withoutBM bm t@(Tip k _)+    -- TODO(wrengr): need we manually inline 'IntSet.Member' here?+    | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = Nil+    | otherwise = t+withoutBM _ Nil = Nil+++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The (left-biased) intersection of two maps (based on keys).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: IntMap a -> IntMap b -> IntMap a+intersection m1 m2+  = mergeWithKey' bin const (const Nil) (const Nil) m1 m2+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The restriction of a map to the keys in a set.+--+-- @+-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``IntSet.member`` s) m+-- @+--+-- @since 0.5.8+restrictKeys :: IntMap a -> IntSet.IntSet -> IntMap a+restrictKeys t1@(Bin p1 l1 r1) t2@(IntSet.Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> restrictKeys l1 t2+  ABR -> restrictKeys r1 t2+  BAL -> restrictKeys t1 l2+  BAR -> restrictKeys t1 r2+  EQL -> bin p1 (restrictKeys l1 l2) (restrictKeys r1 r2)+  NOM -> Nil+restrictKeys t1@(Bin p1 _ _) (IntSet.Tip p2 bm2) =+    let px1 = unPrefix p1+        minbit = bitmapOf (px1 .&. (px1-1))+        ge_minbit = complement (minbit - 1)+        maxbit = bitmapOf (px1 .|. (px1-1))+        le_maxbit = maxbit .|. (maxbit - 1)+    -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'+    -- and 'restrictBM' here, in order to avoid redundant case analyses?+    in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)+restrictKeys (Bin _ _ _) IntSet.Nil = Nil+restrictKeys t1@(Tip k1 _) t2+    | k1 `IntSet.member` t2 = t1+    | otherwise = Nil+restrictKeys Nil _ = Nil+++-- | \(O(\min(n,W))\). Restrict to the sub-map with all keys matching+-- a key prefix.+lookupPrefix :: IntSetPrefix -> IntMap a -> IntMap a+lookupPrefix !kp t@(Bin p l r)+    | unPrefix p .&. IntSet.suffixBitMask /= 0 =+        if unPrefix p .&. IntSet.prefixBitMask == kp then t else Nil+    | nomatch kp p = Nil+    | left kp p    = lookupPrefix kp l+    | otherwise    = lookupPrefix kp r+lookupPrefix kp t@(Tip kx _)+    | (kx .&. IntSet.prefixBitMask) == kp = t+    | otherwise = Nil+lookupPrefix _ Nil = Nil+++restrictBM :: IntSetBitMap -> IntMap a -> IntMap a+restrictBM 0 _ = Nil+restrictBM bm (Bin p l r) =+    let leftBits = bitmapOf (unPrefix p) - 1+        bmL = bm .&. leftBits+        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+    in  bin p (restrictBM bmL l) (restrictBM bmR r)+restrictBM bm t@(Tip k _)+    -- TODO(wrengr): need we manually inline 'IntSet.Member' here?+    | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = t+    | otherwise = Nil+restrictBM _ Nil = Nil+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWith f m1 m2+  = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWithKey f m1 m2+  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2++{--------------------------------------------------------------------+  Symmetric difference+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The symmetric difference of two maps.+--+-- The result contains entries whose keys appear in exactly one of the two maps.+--+-- @+-- symmetricDifference+--   (fromList [(0,\'q\'),(2,\'b\'),(4,\'w\'),(6,\'o\')])+--   (fromList [(0,\'e\'),(3,\'r\'),(6,\'t\'),(9,\'s\')])+-- ==+-- fromList [(2,\'b\'),(3,\'r\'),(4,\'w\'),(9,\'s\')]+-- @+--+-- @since 0.8+symmetricDifference :: IntMap a -> IntMap a -> IntMap a+symmetricDifference t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) =+  case treeTreeBranch p1 p2 of+    ABL -> bin p1 (symmetricDifference l1 t2) r1+    ABR -> bin p1 l1 (symmetricDifference r1 t2)+    BAL -> bin p2 (symmetricDifference t1 l2) r2+    BAR -> bin p2 l2 (symmetricDifference t1 r2)+    EQL -> bin p1 (symmetricDifference l1 l2) (symmetricDifference r1 r2)+    NOM -> link (unPrefix p1) t1 (unPrefix p2) t2+symmetricDifference t1@(Bin _ _ _) t2@(Tip k2 _) = symDiffTip t2 k2 t1+symmetricDifference t1@(Bin _ _ _) Nil = t1+symmetricDifference t1@(Tip k1 _) t2 = symDiffTip t1 k1 t2+symmetricDifference Nil t2 = t2++symDiffTip :: IntMap a -> Int -> IntMap a -> IntMap a+symDiffTip !t1 !k1 = go+  where+    go t2@(Bin p2 l2 r2)+      | nomatch k1 p2 = linkKey k1 t1 p2 t2+      | left k1 p2 = bin p2 (go l2) r2+      | otherwise = bin p2 l2 (go r2)+    go t2@(Tip k2 _)+      | k1 == k2 = Nil+      | otherwise = link k1 t1 k2 t2+    go Nil = t1++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- A high-performance universal combining function. Using+-- 'mergeWithKey', all combining functions can be defined without any loss of+-- efficiency (with exception of 'union', 'difference' and 'intersection',+-- where sharing of some nodes is lost with 'mergeWithKey').+--+-- __Warning__: Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'IntMap's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++-- See Note [IntMap merge complexity]+mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)+             -> IntMap a -> IntMap b -> IntMap c+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2+  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.+        combine = \(Tip k1 x1) (Tip _k2 x2) ->+          case f k1 x1 x2 of+            Nothing -> Nil+            Just x -> Tip k1 x+        {-# INLINE combine #-}+{-# INLINE mergeWithKey #-}++-- Slightly more general version of mergeWithKey. It differs in the following:+--+-- * the combining function operates on maps instead of keys and values. The+--   reason is to enable sharing in union, difference and intersection.+--+-- * mergeWithKey' is given an equivalent of bin. The reason is that in union*,+--   Bin constructor can be used, because we know both subtrees are nonempty.++mergeWithKey' :: (Prefix -> IntMap c -> IntMap c -> IntMap c)+              -> (IntMap a -> IntMap b -> IntMap c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)+              -> IntMap a -> IntMap b -> IntMap c+mergeWithKey' bin' f g1 g2 = go+  where+    go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+      ABL -> bin' p1 (go l1 t2) (g1 r1)+      ABR -> bin' p1 (g1 l1) (go r1 t2)+      BAL -> bin' p2 (go t1 l2) (g2 r2)+      BAR -> bin' p2 (g2 l2) (go t1 r2)+      EQL -> bin' p1 (go l1 l2) (go r1 r2)+      NOM -> maybe_link (unPrefix p1) (g1 t1) (unPrefix p2) (g2 t2)++    go t1'@(Bin _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1'+      where+        merge0 t2 k2 t1@(Bin p1 l1 r1)+          | nomatch k2 p1 = maybe_link (unPrefix p1) (g1 t1) k2 (g2 t2)+          | left k2 p1    = bin' p1 (merge0 t2 k2 l1) (g1 r1)+          | otherwise     = bin' p1 (g1 l1) (merge0 t2 k2 r1)+        merge0 t2 k2 t1@(Tip k1 _)+          | k1 == k2 = f t1 t2+          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+        merge0 t2 _  Nil = g2 t2++    go t1@(Bin _ _ _) Nil = g1 t1++    go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'+      where+        merge0 t1 k1 t2@(Bin p2 l2 r2)+          | nomatch k1 p2 = maybe_link k1 (g1 t1) (unPrefix p2) (g2 t2)+          | left k1 p2    = bin' p2 (merge0 t1 k1 l2) (g2 r2)+          | otherwise     = bin' p2 (g2 l2) (merge0 t1 k1 r2)+        merge0 t1 k1 t2@(Tip k2 _)+          | k1 == k2 = f t1 t2+          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+        merge0 t1 _  Nil = g1 t1++    go Nil Nil = Nil++    go Nil t2 = g2 t2++    maybe_link _ Nil _ t2 = t2+    maybe_link _ t1 _ Nil = t1+    maybe_link k1 t1 k2 t2 = link k1 t1 k2 t2+    {-# INLINE maybe_link #-}+{-# INLINE mergeWithKey' #-}+++{--------------------------------------------------------------------+  mergeA+--------------------------------------------------------------------}++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge' or 'mergeA'.+--+-- A tactic of type @WhenMissing f k x z@ is an abstract representation+-- of a function of type @Key -> x -> f (Maybe z)@.+--+-- @since 0.5.9++data WhenMissing f x y = WhenMissing+  { missingSubtree :: IntMap x -> f (IntMap y)+  , missingKey :: Key -> x -> f (Maybe y)}++-- | @since 0.5.9+instance (Applicative f, Monad f) => Functor (WhenMissing f x) where+  fmap = mapWhenMissing+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Applicative f, Monad f) => Category.Category (WhenMissing f)+  where+    id = preserveMissing+    f . g =+      traverseMaybeMissing $ \ k x -> do+        y <- missingKey g k x+        case y of+          Nothing -> pure Nothing+          Just q  -> missingKey f k q+    {-# INLINE id #-}+    {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where+  pure x = mapMissing (\ _ _ -> x)+  f <*> g =+    traverseMaybeMissing $ \k x -> do+      res1 <- missingKey f k x+      case res1 of+        Nothing -> pure Nothing+        Just r  -> (pure $!) . fmap r =<< missingKey g k x+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Monad (WhenMissing f x) where+  m >>= f =+    traverseMaybeMissing $ \k x -> do+      res1 <- missingKey m k x+      case res1 of+        Nothing -> pure Nothing+        Just r  -> missingKey (f r) k x+  {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMissing' f x@.+--+-- @since 0.5.9+mapWhenMissing+  :: (Applicative f, Monad f)+  => (a -> b)+  -> WhenMissing f x a+  -> WhenMissing f x b+mapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'+  , missingKey     = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }+{-# INLINE mapWhenMissing #-}+++-- | Map covariantly over a @'WhenMissing' f x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMissing+  :: Functor f+  => (a -> b)+  -> WhenMissing f x a+  -> WhenMissing f x b+mapGentlyWhenMissing f t = WhenMissing+  { missingSubtree = \m -> fmap f <$> missingSubtree t m+  , missingKey     = \k x -> fmap f <$> missingKey t k x }+{-# INLINE mapGentlyWhenMissing #-}+++-- | Map covariantly over a @'WhenMatched' f k x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMatched+  :: Functor f+  => (a -> b)+  -> WhenMatched f x y a+  -> WhenMatched f x y b+mapGentlyWhenMatched f t =+  zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y+{-# INLINE mapGentlyWhenMatched #-}+++-- | Map contravariantly over a @'WhenMissing' f _ x@.+--+-- @since 0.5.9+lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x+lmapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t (fmap f m)+  , missingKey     = \k x -> missingKey t k (f x) }+{-# INLINE lmapWhenMissing #-}+++-- | Map contravariantly over a @'WhenMatched' f _ y z@.+--+-- @since 0.5.9+contramapFirstWhenMatched+  :: (b -> a)+  -> WhenMatched f a y z+  -> WhenMatched f b y z+contramapFirstWhenMatched f t =+  WhenMatched $ \k x y -> runWhenMatched t k (f x) y+{-# INLINE contramapFirstWhenMatched #-}+++-- | Map contravariantly over a @'WhenMatched' f x _ z@.+--+-- @since 0.5.9+contramapSecondWhenMatched+  :: (b -> a)+  -> WhenMatched f x a z+  -> WhenMatched f x b z+contramapSecondWhenMatched f t =+  WhenMatched $ \k x y -> runWhenMatched t k x (f y)+{-# INLINE contramapSecondWhenMatched #-}+++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge'.+--+-- A tactic of type @SimpleWhenMissing x z@ is an abstract+-- representation of a function of type @Key -> x -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMissing = WhenMissing Identity+++-- | A tactic for dealing with keys present in both maps in 'merge'+-- or 'mergeA'.+--+-- A tactic of type @WhenMatched f x y z@ is an abstract representation+-- of a function of type @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+newtype WhenMatched f x y z = WhenMatched+  { matchedKey :: Key -> x -> y -> f (Maybe z) }+++-- | Along with zipWithMaybeAMatched, witnesses the isomorphism+-- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z)+runWhenMatched = matchedKey+{-# INLINE runWhenMatched #-}+++-- | Along with traverseMaybeMissing, witnesses the isomorphism+-- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@.+--+-- @since 0.5.9+runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y)+runWhenMissing = missingKey+{-# INLINE runWhenMissing #-}+++-- | @since 0.5.9+instance Functor f => Functor (WhenMatched f x y) where+  fmap = mapWhenMatched+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Monad f, Applicative f) => Category.Category (WhenMatched f x)+  where+    id = zipWithMatched (\_ _ y -> y)+    f . g =+      zipWithMaybeAMatched $ \k x y -> do+        res <- runWhenMatched g k x y+        case res of+          Nothing -> pure Nothing+          Just r  -> runWhenMatched f k x r+    {-# INLINE id #-}+    {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where+  pure x = zipWithMatched (\_ _ _ -> x)+  fs <*> xs =+    zipWithMaybeAMatched $ \k x y -> do+      res <- runWhenMatched fs k x y+      case res of+        Nothing -> pure Nothing+        Just r  -> (pure $!) . fmap r =<< runWhenMatched xs k x y+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where+  m >>= f =+    zipWithMaybeAMatched $ \k x y -> do+      res <- runWhenMatched m k x y+      case res of+        Nothing -> pure Nothing+        Just r  -> runWhenMatched (f r) k x y+  {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMatched' f x y@.+--+-- @since 0.5.9+mapWhenMatched+  :: Functor f+  => (a -> b)+  -> WhenMatched f x y a+  -> WhenMatched f x y b+mapWhenMatched f (WhenMatched g) =+  WhenMatched $ \k x y -> fmap (fmap f) (g k x y)+{-# INLINE mapWhenMatched #-}+++-- | A tactic for dealing with keys present in both maps in 'merge'.+--+-- A tactic of type @SimpleWhenMatched x y z@ is an abstract+-- representation of a function of type @Key -> x -> y -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMatched = WhenMatched Identity+++-- | When a key is found in both maps, apply a function to the key+-- and values and use the result in the merged map.+--+-- > zipWithMatched+-- >   :: (Key -> x -> y -> z)+-- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMatched+  :: Applicative f+  => (Key -> x -> y -> z)+  -> WhenMatched f x y z+zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y+{-# INLINE zipWithMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values to produce an action and use its result in the merged+-- map.+--+-- @since 0.5.9+zipWithAMatched+  :: Applicative f+  => (Key -> x -> y -> f z)+  -> WhenMatched f x y z+zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y+{-# INLINE zipWithAMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values and maybe use the result in the merged map.+--+-- > zipWithMaybeMatched+-- >   :: (Key -> x -> y -> Maybe z)+-- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMaybeMatched+  :: Applicative f+  => (Key -> x -> y -> Maybe z)+  -> WhenMatched f x y z+zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y+{-# INLINE zipWithMaybeMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values, perform the resulting action, and maybe use the+-- result in the merged map.+--+-- This is the fundamental 'WhenMatched' tactic.+--+-- @since 0.5.9+zipWithMaybeAMatched+  :: (Key -> x -> y -> f (Maybe z))+  -> WhenMatched f x y z+zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y+{-# INLINE zipWithMaybeAMatched #-}+++-- | Drop all the entries whose keys are missing from the other+-- map.+--+-- > dropMissing :: SimpleWhenMissing x y+--+-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)+--+-- but @dropMissing@ is much faster.+--+-- @since 0.5.9+dropMissing :: Applicative f => WhenMissing f x y+dropMissing = WhenMissing+  { missingSubtree = const (pure Nil)+  , missingKey     = \_ _ -> pure Nothing }+{-# INLINE dropMissing #-}+++-- | Preserve, unchanged, the entries whose keys are missing from+-- the other map.+--+-- > preserveMissing :: SimpleWhenMissing x x+--+-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)+--+-- but @preserveMissing@ is much faster.+--+-- @since 0.5.9+preserveMissing :: Applicative f => WhenMissing f x x+preserveMissing = WhenMissing+  { missingSubtree = pure+  , missingKey     = \_ v -> pure (Just v) }+{-# INLINE preserveMissing #-}+++-- | Map over the entries whose keys are missing from the other map.+--+-- > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+--+-- @since 0.5.9+mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y+mapMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapWithKey f m+  , missingKey     = \k x -> pure $ Just (f k x) }+{-# INLINE mapMissing #-}+++-- | Map over the entries whose keys are missing from the other+-- map, optionally removing some. This is the most powerful+-- 'SimpleWhenMissing' tactic, but others are usually more efficient.+--+-- > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y+--+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))+--+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative'+-- operations.+--+-- @since 0.5.9+mapMaybeMissing+  :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y+mapMaybeMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapMaybeWithKey f m+  , missingKey     = \k x -> pure $! f k x }+{-# INLINE mapMaybeMissing #-}+++-- | Filter the entries whose keys are missing from the other map.+--+-- > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x+--+-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterMissing+  :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x+filterMissing f = WhenMissing+  { missingSubtree = \m -> pure $! filterWithKey f m+  , missingKey     = \k x -> pure $! if f k x then Just x else Nothing }+{-# INLINE filterMissing #-}+++-- | Filter the entries whose keys are missing from the other map+-- using some 'Applicative' action.+--+-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $+-- >   \k x -> (\b -> guard b *> Just x) <$> f k x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterAMissing+  :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x+filterAMissing f = WhenMissing+  { missingSubtree = \m -> filterWithKeyA f m+  , missingKey     = \k x -> bool Nothing (Just x) <$> f k x }+{-# INLINE filterAMissing #-}+++-- | \(O(n)\). Filter keys and values using an 'Applicative' predicate.+filterWithKeyA+  :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a)+filterWithKeyA _ Nil           = pure Nil+filterWithKeyA f t@(Tip k x)   = (\b -> if b then t else Nil) <$> f k x+filterWithKeyA f (Bin p l r)+  | signBranch p = liftA2 (flip (bin p)) (filterWithKeyA f r) (filterWithKeyA f l)+  | otherwise = liftA2 (bin p) (filterWithKeyA f l) (filterWithKeyA f r)++-- | This wasn't in Data.Bool until 4.7.0, so we define it here+bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True  = t+++-- | Traverse over the entries whose keys are missing from the other+-- map.+--+-- @since 0.5.9+traverseMissing+  :: Applicative f => (Key -> x -> f y) -> WhenMissing f x y+traverseMissing f = WhenMissing+  { missingSubtree = traverseWithKey f+  , missingKey = \k x -> Just <$> f k x }+{-# INLINE traverseMissing #-}+++-- | Traverse over the entries whose keys are missing from the other+-- map, optionally producing values to put in the result. This is+-- the most powerful 'WhenMissing' tactic, but others are usually+-- more efficient.+--+-- @since 0.5.9+traverseMaybeMissing+  :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y+traverseMaybeMissing f = WhenMissing+  { missingSubtree = traverseMaybeWithKey f+  , missingKey = f }+{-# INLINE traverseMaybeMissing #-}+++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.6.4+traverseMaybeWithKey+  :: Applicative f => (Key -> a -> f (Maybe b)) -> IntMap a -> f (IntMap b)+traverseMaybeWithKey f = go+    where+    go Nil           = pure Nil+    go (Tip k x)     = maybe Nil (Tip k) <$> f k x+    go (Bin p l r)+      | signBranch p = liftA2 (flip (bin p)) (go r) (go l)+      | otherwise = liftA2 (bin p) (go l) (go r)+++-- | Merge two maps.+--+-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic+-- and two maps. It uses the tactics to merge the maps. Its behavior+-- is best understood via its fundamental tactics, 'mapMaybeMissing'+-- and 'zipWithMaybeMatched'.+--+-- Consider+--+-- @+-- merge (mapMaybeMissing g1)+--              (mapMaybeMissing g2)+--              (zipWithMaybeMatched f)+--              m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'merge' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]+-- m2 =           [(1, "one"), (2, "two"),           (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- This produces a 'Maybe' for each key:+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'mapMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+--+-- When 'merge' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should typically use+-- 'merge' to define your custom combining functions.+--+--+-- Examples:+--+-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)+-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)+-- prop> differenceWith f = merge diffPreserve diffDrop f+-- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)+-- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)+--+-- @since 0.5.9+merge+  :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@+  -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@+  -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> IntMap a -- ^ Map @m1@+  -> IntMap b -- ^ Map @m2@+  -> IntMap c+merge g1 g2 f m1 m2 =+  runIdentity $ mergeA g1 g2 f m1 m2+{-# INLINE merge #-}+++-- | An applicative version of 'merge'.+--+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'+-- tactic and two maps. It uses the tactics to merge the maps.+-- Its behavior is best understood via its fundamental tactics,+-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+--               (traverseMaybeMissing g2)+--               (zipWithMaybeAMatched f)+--               m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'mergeA' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]+-- m2 =           [(1, "one"), (2, "two"),           (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- Next, it will perform the actions in the @actions@ list in order from+-- left to right.+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'traverseMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+-- * 'mapMaybeMissing' does not use the 'Applicative' context.+--+-- When 'mergeA' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should generally only use+-- 'mergeA' to define custom combining functions.+--+-- @since 0.5.9+mergeA+  :: (Applicative f)+  => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@+  -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@+  -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> IntMap a -- ^ Map @m1@+  -> IntMap b -- ^ Map @m2@+  -> f (IntMap c)+mergeA+    WhenMissing{missingSubtree = g1t, missingKey = g1k}+    WhenMissing{missingSubtree = g2t, missingKey = g2k}+    WhenMatched{matchedKey = f}+    = go+  where+    go t1  Nil = g1t t1+    go Nil t2  = g2t t2++    -- This case is already covered below.+    -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2++    go (Tip k1 x1) t2' = merge2 t2'+      where+        merge2 t2@(Bin p2 l2 r2)+          | nomatch k1 p2 = linkA k1 (subsingletonBy g1k k1 x1) (unPrefix p2) (g2t t2)+          | left k1 p2    = binA p2 (merge2 l2) (g2t r2)+          | otherwise     = binA p2 (g2t l2) (merge2 r2)+        merge2 (Tip k2 x2)   = mergeTips k1 x1 k2 x2+        merge2 Nil           = subsingletonBy g1k k1 x1++    go t1' (Tip k2 x2) = merge1 t1'+      where+        merge1 t1@(Bin p1 l1 r1)+          | nomatch k2 p1 = linkA (unPrefix p1) (g1t t1) k2 (subsingletonBy g2k k2 x2)+          | left k2 p1    = binA p1 (merge1 l1) (g1t r1)+          | otherwise     = binA p1 (g1t l1) (merge1 r1)+        merge1 (Tip k1 x1)   = mergeTips k1 x1 k2 x2+        merge1 Nil           = subsingletonBy g2k k2 x2++    go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+      ABL -> binA p1 (go l1 t2) (g1t r1)+      ABR -> binA p1 (g1t l1) (go r1 t2)+      BAL -> binA p2 (go t1 l2) (g2t r2)+      BAR -> binA p2 (g2t l2) (go t1 r2)+      EQL -> binA p1 (go l1 l2) (go r1 r2)+      NOM -> linkA (unPrefix p1) (g1t t1) (unPrefix p2) (g2t t2)++    subsingletonBy :: Functor f => (Key -> a -> f (Maybe c)) -> Key -> a -> f (IntMap c)+    subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x+    {-# INLINE subsingletonBy #-}++    mergeTips k1 x1 k2 x2+      | k1 == k2  = maybe Nil (Tip k1) <$> f k1 x1 x2+      | k1 <  k2  = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2)+        {-+        = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2+        -}+      | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1)+    {-# INLINE mergeTips #-}++    subdoubleton _ _   Nothing Nothing     = Nil+    subdoubleton _ k2  Nothing (Just y2)   = Tip k2 y2+    subdoubleton k1 _  (Just y1) Nothing   = Tip k1 y1+    subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2)+    {-# INLINE subdoubleton #-}++    -- | A variant of 'link_' which makes sure to execute side-effects+    -- in the right order.+    linkA+        :: Applicative f+        => Int -> f (IntMap a)+        -> Int -> f (IntMap a)+        -> f (IntMap a)+    linkA k1 t1 k2 t2+      | i2w k1 < i2w k2 = binA p t1 t2+      | otherwise = binA p t2 t1+      where+        m = branchMask k1 k2+        p = Prefix (mask k1 m .|. m)+    {-# INLINE linkA #-}++    -- A variant of 'bin' that ensures that effects for negative keys are executed+    -- first.+    binA+        :: Applicative f+        => Prefix+        -> f (IntMap a)+        -> f (IntMap a)+        -> f (IntMap a)+    binA p a b+      | signBranch p = liftA2 (flip (bin p)) b a+      | otherwise = liftA2 (bin p) a b+    {-# INLINE binA #-}+{-# INLINE mergeA #-}+++{--------------------------------------------------------------------+  Min\/Max+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMinWithKey f t =+  case t of Bin p l r | signBranch p -> binCheckRight p l (go f r)+            _ -> go f t+  where+    go f' (Bin p l r) = binCheckLeft p (go f' l) r+    go f' (Tip k y) = case f' k y of+                        Just y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil =  Nil++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMaxWithKey f t =+  case t of Bin p l r | signBranch p -> binCheckLeft p (go f l) r+            _ -> go f t+  where+    go f' (Bin p l r) = binCheckRight p l (go f' r)+    go f' (Tip k y) = case f' k y of+                        Just y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = Nil+++data View a = View {-# UNPACK #-} !Key a !(IntMap a)++-- | \(O(\min(n,W))\). Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)+maxViewWithKey t = case t of+  Nil -> Nothing+  _ -> Just $ case maxViewWithKeySure t of+                View k v t' -> ((k, v), t')+{-# INLINE maxViewWithKey #-}++maxViewWithKeySure :: IntMap a -> View a+maxViewWithKeySure t =+  case t of+    Nil -> error "maxViewWithKeySure Nil"+    Bin p l r | signBranch p ->+      case go l of View k a l' -> View k a (binCheckLeft p l' r)+    _ -> go t+  where+    go (Bin p l r) =+        case go r of View k a r' -> View k a (binCheckRight p l r')+    go (Tip k y) = View k y Nil+    go Nil = error "maxViewWithKey_go Nil"+-- See note on NOINLINE at minViewWithKeySure+{-# NOINLINE maxViewWithKeySure #-}++-- | \(O(\min(n,W))\). Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)+minViewWithKey t =+  case t of+    Nil -> Nothing+    _ -> Just $ case minViewWithKeySure t of+                  View k v t' -> ((k, v), t')+-- We inline this to give GHC the best possible chance of+-- getting rid of the Maybe, pair, and Int constructors, as+-- well as a thunk under the Just. That is, we really want to+-- be certain this inlines!+{-# INLINE minViewWithKey #-}++minViewWithKeySure :: IntMap a -> View a+minViewWithKeySure t =+  case t of+    Nil -> error "minViewWithKeySure Nil"+    Bin p l r | signBranch p ->+      case go r of+        View k a r' -> View k a (binCheckRight p l r')+    _ -> go t+  where+    go (Bin p l r) =+        case go l of View k a l' -> View k a (binCheckLeft p l' r)+    go (Tip k y) = View k y Nil+    go Nil = error "minViewWithKey_go Nil"+-- There's never anything significant to be gained by inlining+-- this. Sufficiently recent GHC versions will inline the wrapper+-- anyway, which should be good enough.+{-# NOINLINE minViewWithKeySure #-}++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a+updateMax f = updateMaxWithKey (const f)++-- | \(O(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a+updateMin f = updateMinWithKey (const f)++-- | \(O(\min(n,W))\). Retrieves the maximal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+maxView :: IntMap a -> Maybe (a, IntMap a)+maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t)++-- | \(O(\min(n,W))\). Retrieves the minimal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+minView :: IntMap a -> Maybe (a, IntMap a)+minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t)++-- | \(O(\min(n,W))\). Delete and find the maximal element.+-- This function throws an error if the map is empty. Use 'maxViewWithKey'+-- if the map may be empty.+deleteFindMax :: IntMap a -> ((Key, a), IntMap a)+deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey++-- | \(O(\min(n,W))\). Delete and find the minimal element.+-- This function throws an error if the map is empty. Use 'minViewWithKey'+-- if the map may be empty.+deleteFindMin :: IntMap a -> ((Key, a), IntMap a)+deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey++-- The KeyValue type is used when returning a key-value pair and helps with+-- GHC optimizations.+--+-- For lookupMinSure, if the return type is (Int, a), GHC compiles it to a+-- worker $wlookupMinSure :: IntMap a -> (# Int, a #). If the return type is+-- KeyValue a instead, the worker does not box the int and returns+-- (# Int#, a #).+-- For a modern enough GHC (>=9.4), this measure turns out to be unnecessary in+-- this instance. We still use it for older GHCs and to make our intent clear.++data KeyValue a = KeyValue {-# UNPACK #-} !Key a++kvToTuple :: KeyValue a -> (Key, a)+kvToTuple (KeyValue k x) = (k, x)+{-# INLINE kvToTuple #-}++lookupMinSure :: IntMap a -> KeyValue a+lookupMinSure (Tip k v)   = KeyValue k v+lookupMinSure (Bin _ l _) = lookupMinSure l+lookupMinSure Nil         = error "lookupMinSure Nil"++-- | \(O(\min(n,W))\). The minimal key of the map. Returns 'Nothing' if the map is empty.+lookupMin :: IntMap a -> Maybe (Key, a)+lookupMin Nil         = Nothing+lookupMin (Tip k v)   = Just (k,v)+lookupMin (Bin p l r) =+  Just $! kvToTuple (lookupMinSure (if signBranch p then r else l))+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The minimal key of the map. Calls 'error' if the map is empty.+findMin :: IntMap a -> (Key, a)+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "findMin: empty map has no minimal element"++lookupMaxSure :: IntMap a -> KeyValue a+lookupMaxSure (Tip k v)   = KeyValue k v+lookupMaxSure (Bin _ _ r) = lookupMaxSure r+lookupMaxSure Nil         = error "lookupMaxSure Nil"++-- | \(O(\min(n,W))\). The maximal key of the map. Returns 'Nothing' if the map is empty.+lookupMax :: IntMap a -> Maybe (Key, a)+lookupMax Nil         = Nothing+lookupMax (Tip k v)   = Just (k,v)+lookupMax (Bin p l r) =+  Just $! kvToTuple (lookupMaxSure (if signBranch p then l else r))+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The maximal key of the map. Calls 'error' if the map is empty.+findMax :: IntMap a -> (Key, a)+findMax t+  | Just r <- lookupMax t = r+  | otherwise = error "findMax: empty map has no maximal element"++-- | \(O(\min(n,W))\). Delete the minimal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#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@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the value at the greatest of the+-- original keys is retained.+--+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])                        == fromList [(4, "b"), (6, "a")]+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"++mapKeys :: (Key->Key) -> IntMap a -> IntMap a+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | \(O(n \min(n,W))\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"+--+-- Also see the performance note on 'fromListWith'.++mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a+mapKeysWith c f+  = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | \(O(n)\).+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapKeysMonotonic f s == mapKeys f s+-- >     where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has slightly better performance than 'mapKeys'.+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'mapKeys' if the+-- precondition may not hold.+--+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]++mapKeysMonotonic :: (Key->Key) -> IntMap a -> IntMap a+mapKeysMonotonic f+  = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) []++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all values that satisfy some predicate.+--+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty++filter :: (a -> Bool) -> IntMap a -> IntMap a+filter p m+  = filterWithKey (\_ x -> p x) m++-- | \(O(n)\). Filter all keys that satisfy some predicate.+--+-- @+-- filterKeys p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- > filterKeys (> 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+--+-- @since 0.8++filterKeys :: (Key -> Bool) -> IntMap a -> IntMap a+filterKeys predicate = filterWithKey (\k _ -> predicate k)++-- | \(O(n)\). Filter all keys\/values that satisfy some predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a+filterWithKey predicate = go+    where+    go Nil         = Nil+    go t@(Tip k x) = if predicate k x then t else Nil+    go (Bin p l r) = bin p (go l) (go r)++-- | \(O(n)\). Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partition p m+  = partitionWithKey (\_ x -> p x) m++-- | \(O(n)\). Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partitionWithKey predicate0 t0 = toPair $ go predicate0 t0+  where+    go predicate t =+      case t of+        Bin p l r ->+          let (l1 :*: l2) = go predicate l+              (r1 :*: r2) = go predicate r+          in bin p l1 r1 :*: bin p l2 r2+        Tip k x+          | predicate k x -> (t :*: Nil)+          | otherwise     -> (Nil :*: t)+        Nil -> (Nil :*: Nil)++-- | \(O(\min(n,W))\). Take while a predicate on the keys holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'+-- takeWhileAntitone p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- @since 0.6.7+takeWhileAntitone :: (Key -> Bool) -> IntMap a -> IntMap a+takeWhileAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then bin p (go predicate l) r+        else go predicate r+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = bin p l (go predicate' r)+      | otherwise               = go predicate' l+    go predicate' t'@(Tip ky _)+      | predicate' ky = t'+      | otherwise     = Nil+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Drop while a predicate on the keys holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'+-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k))+-- @+--+-- @since 0.6.7+dropWhileAntitone :: (Key -> Bool) -> IntMap a -> IntMap a+dropWhileAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then go predicate l+        else bin p l (go predicate r)+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = go predicate' r+      | otherwise               = bin p (go predicate' l) r+    go predicate' t'@(Tip ky _)+      | predicate' ky = Nil+      | otherwise     = t'+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Divide a map at the point where a predicate on the keys stops holding.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = 'partitionWithKey' (\\k _ -> p k) xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map+-- at some /unspecified/ point.+--+-- @since 0.6.7+spanAntitone :: (Key -> Bool) -> IntMap a -> (IntMap a, IntMap a)+spanAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then+          case go predicate l of+            (lt :*: gt) ->+              let !lt' = bin p lt r+              in (lt', gt)+        else+          case go predicate r of+            (lt :*: gt) ->+              let !gt' = bin p l gt+              in (lt, gt')+    _ -> case go predicate t of+          (lt :*: gt) -> (lt, gt)+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p)+      = case go predicate' r of (lt :*: gt) -> bin p l lt :*: gt+      | otherwise+      = case go predicate' l of (lt :*: gt) -> lt :*: bin p gt r+    go predicate' t'@(Tip ky _)+      | predicate' ky = (t' :*: Nil)+      | otherwise     = (Nil :*: t')+    go _ Nil = (Nil :*: Nil)++-- | \(O(n)\). Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | \(O(n)\). Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b+mapMaybeWithKey f (Bin p l r)+  = bin p (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey _ Nil = Nil++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go f (Bin p l r) =+      bin p l1 r1 :*: bin p l2 r2+      where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r+    go f (Tip k x) = case f k x of+      Left y  -> (Tip k y :*: Nil)+      Right z -> (Nil :*: Tip k z)+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). The expression (@'split' k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)++split :: Key -> IntMap a -> (IntMap a, IntMap a)+split k t =+  case t of+    Bin p l r+      | signBranch p ->+        if k >= 0 -- handle negative numbers.+        then+          case go k l of+            (lt :*: gt) ->+              let !lt' = bin p lt r+              in (lt', gt)+        else+          case go k r of+            (lt :*: gt) ->+              let !gt' = bin p l gt+              in (lt, gt')+    _ -> case go k t of+          (lt :*: gt) -> (lt, gt)+  where+    go !k' t'@(Bin p l r)+      | nomatch k' p = if k' < unPrefix p then Nil :*: t' else t' :*: Nil+      | left k' p = case go k' l of (lt :*: gt) -> lt :*: bin p gt r+      | otherwise = case go k' r of (lt :*: gt) -> bin p l lt :*: gt+    go k' t'@(Tip ky _)+      | k' > ky   = (t' :*: Nil)+      | k' < ky   = (Nil :*: t')+      | otherwise = (Nil :*: Nil)+    go _ Nil = (Nil :*: Nil)+++data SplitLookup a = SplitLookup !(IntMap a) !(Maybe a) !(IntMap a)++mapLT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a+mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt+{-# INLINE mapLT #-}++mapGT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a+mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt)+{-# INLINE mapGT #-}++-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+--+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)++splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a)+splitLookup k t =+  case+    case t of+      Bin p l r+        | signBranch p ->+          if k >= 0 -- handle negative numbers.+          then mapLT (flip (bin p) r) (go k l)+          else mapGT (bin p l) (go k r)+      _ -> go k t+  of SplitLookup lt fnd gt -> (lt, fnd, gt)+  where+    go !k' t'@(Bin p l r)+      | nomatch k' p =+          if k' < unPrefix p+          then SplitLookup Nil Nothing t'+          else SplitLookup t' Nothing Nil+      | left k' p = mapGT (flip (bin p) r) (go k' l)+      | otherwise  = mapLT (bin p l) (go k' r)+    go k' t'@(Tip ky y)+      | k' > ky   = SplitLookup t'  Nothing  Nil+      | k' < ky   = SplitLookup Nil Nothing  t'+      | otherwise = SplitLookup Nil (Just y) Nil+    go _ Nil      = SplitLookup Nil Nothing  Nil++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr :: (a -> b -> b) -> b -> IntMap a -> b+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip _ x)   = f x z'+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> IntMap a -> b+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip _ x)   = f x z'+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+--+-- For example,+--+-- > elems = reverse . foldl (flip (:)) []+--+-- > let f len a = len + (length a)+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldl :: (a -> b -> a) -> a -> IntMap b -> a+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip _ x)   = f z' x+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> IntMap b -> a+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip _ x)   = f z' x+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip kx x)  = f kx x z'+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldrWithKey #-}++-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip kx x)  = f kx x z'+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldrWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+--+-- For example,+--+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []+--+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"+foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip kx x)  = f z' kx x+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldlWithKey #-}++-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip kx x)  = f z' kx x+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldlWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that+--+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@+--+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.+--+-- @since 0.5.4+foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m+foldMapWithKey f = go+  where+    go Nil           = mempty+    go (Tip kx x)    = f kx x+    go (Bin p l r)+      | signBranch p = go r `mappend` go l+      | otherwise = go l `mappend` go r+{-# INLINE foldMapWithKey #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\).+-- Return all elements of the map in the ascending order of their keys.+-- Subject to list fusion.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: IntMap a -> [a]+elems = foldr (:) []++-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list+-- fusion.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys  :: IntMap a -> [Key]+keys = foldrWithKey (\k _ ks -> k : ks) []++-- | \(O(n)\). An alias for 'toAscList'. Returns all key\/value pairs in the+-- map in ascending key order. Subject to list fusion.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: IntMap a -> [(Key,a)]+assocs = toAscList++-- | \(O(n)\). The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]+-- > keysSet empty == Data.IntSet.empty++keysSet :: IntMap a -> IntSet.IntSet+keysSet Nil = IntSet.Nil+keysSet (Tip kx _) = IntSet.singleton kx+keysSet (Bin p l r)+  | unPrefix p .&. IntSet.suffixBitMask == 0+  = IntSet.Bin p (keysSet l) (keysSet r)+  | otherwise+  = IntSet.Tip (unPrefix p .&. IntSet.prefixBitMask) (computeBm (computeBm 0 l) r)+  where computeBm !acc (Bin _ l' r') = computeBm (computeBm acc l') r'+        computeBm acc (Tip kx _) = acc .|. IntSet.bitmapOf kx+        computeBm _   Nil = error "Data.IntSet.keysSet: Nil"++-- | \(O(n)\). Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.IntSet.empty == empty++fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a+fromSet _ IntSet.Nil = Nil+fromSet f (IntSet.Bin p l r) = Bin p (fromSet f l) (fromSet f r)+fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)+  where+    -- This is slightly complicated, as we to convert the dense+    -- representation of IntSet into tree representation of IntMap.+    --+    -- We are given a nonzero bit mask 'bmask' of 'bits' bits with+    -- prefix 'prefix'. We split bmask into halves corresponding+    -- to left and right subtree. If they are both nonempty, we+    -- create a Bin node, otherwise exactly one of them is nonempty+    -- and we construct the IntMap from that half.+    buildTree g !prefix !bmask bits = case bits of+      0 -> Tip prefix (g prefix)+      _ -> case bits `iShiftRL` 1 of+        bits2+          | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->+              buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2+          | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->+              buildTree g prefix bmask bits2+          | otherwise ->+              Bin (Prefix (prefix .|. bits2))+                (buildTree g prefix bmask bits2)+                (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.6.2+instance GHCExts.IsList (IntMap a) where+  type Item (IntMap a) = (Key,a)+  fromList = fromList+  toList   = toList+#endif++-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list+-- fusion.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: IntMap a -> [(Key,a)]+toList = toAscList++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the+-- keys are in ascending order. Subject to list fusion.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: IntMap a -> [(Key,a)]+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys+-- are in descending order. Subject to list fusion.+--+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]++toDescList :: IntMap a -> [(Key,a)]+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.+-- They are important to convert unfused methods back, see mapFB in prelude.+foldrFB :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrFB = foldrWithKey+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlFB = foldlWithKey+{-# INLINE[0] foldlFB #-}++-- Inline assocs and toList, so that we need to fuse only toAscList.+{-# INLINE assocs #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to+-- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to+-- inline it before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] elems #-}+{-# NOINLINE[0] keys #-}+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "IntMap.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}+{-# RULES "IntMap.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}+{-# RULES "IntMap.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}+{-# RULES "IntMap.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}+{-# RULES "IntMap.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}+{-# RULES "IntMap.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}+{-# RULES "IntMap.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}+{-# RULES "IntMap.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}+#endif+++-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> IntMap a+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x)  = insert k x t++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")]+-- > fromListWith (++) [] == empty+--+-- Note the reverse ordering of @"cba"@ in the example.+--+-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@.+--+-- === Performance+--+-- You should ensure that the given @f@ is fast with this order of arguments.+--+-- Symmetric functions may be slow in one order, and fast in another.+-- For the common case of collecting values of matching keys in a list, as above:+--+-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument.+-- Thus:+--+-- > fromListWith       (++)  (replicate 1000000 (3, "x"))   -- O(n),  fast+-- > fromListWith (flip (++)) (replicate 1000000 (3, "x"))   -- O(n²), extremely slow+--+-- because they evaluate as, respectively:+--+-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))]   -- O(n)+-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")]   -- O(n²)+--+-- Thus, to get good performance with an operation like @(++)@ while also preserving+-- the same order as in the input list, reverse the input:+--+-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")]+--+-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in:+--+-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples++fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty+--+-- Also see the performance note on 'fromListWith'.++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> IntMap a+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+--+-- Also see the performance note on 'fromListWith'.++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)+{-# NOINLINE fromAscListWith #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")]+--+-- Also see the performance note on 'fromListWith'.++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWithKey f = fromMonoListWithKey Nondistinct f+{-# NOINLINE fromAscListWithKey #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+--+-- __Warning__: This function should be used only if the keys are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++fromDistinctAscList :: [(Key,a)] -> IntMap a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.+--+-- Also see the performance note on 'fromListWith'.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromMonoListWithKey distinct f = go+  where+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1++    -- `addAll'` collects all keys equal to `kx` into a single value,+    -- and then proceeds with `addAll`.+    addAll' !kx vx []+        = Tip kx vx+    addAll' !kx vx ((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let v = f kx vy vx in addAll' ky v zs+        -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty kx (Tip kx vx)) zs'++    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_kx !tx []+        = tx+    addAll !kx !tx ((ky,vy) : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty kx tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !kx vx []+        = Inserted (Tip kx vx) []+    addMany' !m !kx vx zs0@((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let v = f kx vy vx in addMany' m ky v zs+        -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)+        | mask kx m /= mask ky m+        = Inserted (Tip kx vx) zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty kx (Tip kx vx)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.+    addMany !_m !_kx tx []+        = Inserted tx []+    addMany !m !kx tx zs0@((ky,vy) : zs)+        | mask kx m /= mask ky m+        = Inserted tx zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty kx tx) zs'+{-# INLINE fromMonoListWithKey #-}++data Inserted a = Inserted !(IntMap a) ![(Key,a)]++data Distinct = Distinct | Nondistinct++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq a => Eq (IntMap a) where+  (==) = equal++equal :: Eq a => IntMap a -> IntMap a -> Bool+equal (Bin p1 l1 r1) (Bin p2 l2 r2)+  = (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx x) (Tip ky y)+  = (kx == ky) && (x==y)+equal Nil Nil = True+equal _   _   = False+{-# INLINABLE equal #-}++-- | @since 0.5.9+instance Eq1 IntMap where+  liftEq eq = go+    where+      go (Bin p1 l1 r1) (Bin p2 l2 r2) = p1 == p2 && go l1 l2 && go r1 r2+      go (Tip kx x) (Tip ky y) = kx == ky && eq x y+      go Nil Nil = True+      go _   _   = False+  {-# INLINE liftEq #-}++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord a => Ord (IntMap a) where+  compare m1 m2 = liftCmp compare m1 m2+  {-# INLINABLE compare #-}++-- | @since 0.5.9+instance Ord1 IntMap where+  liftCompare = liftCmp++liftCmp :: (a -> b -> Ordering) -> IntMap a -> IntMap b -> Ordering+liftCmp cmp m1 m2 = case (splitSign m1, splitSign m2) of+  ((l1, r1), (l2, r2)) -> case go l1 l2 of+    A_LT_B -> LT+    A_Prefix_B -> if null r1 then LT else GT+    A_EQ_B -> case go r1 r2 of+      A_LT_B -> LT+      A_Prefix_B -> LT+      A_EQ_B -> EQ+      B_Prefix_A -> GT+      A_GT_B -> GT+    B_Prefix_A -> if null r2 then GT else LT+    A_GT_B -> GT+  where+    go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+      ABL -> case go l1 t2 of+        A_Prefix_B -> A_GT_B+        A_EQ_B -> B_Prefix_A+        o -> o+      ABR -> A_LT_B+      BAL -> case go t1 l2 of+        A_EQ_B -> A_Prefix_B+        B_Prefix_A -> A_LT_B+        o -> o+      BAR -> A_GT_B+      EQL -> case go l1 l2 of+        A_Prefix_B -> A_GT_B+        A_EQ_B -> go r1 r2+        B_Prefix_A -> A_LT_B+        o -> o+      NOM -> if unPrefix p1 < unPrefix p2 then A_LT_B else A_GT_B+    go (Bin _ l1 _) (Tip k2 x2) = case lookupMinSure l1 of+      KeyValue k1 x1 -> case compare k1 k2 <> cmp x1 x2 of+        LT -> A_LT_B+        EQ -> B_Prefix_A+        GT -> A_GT_B+    go (Tip k1 x1) (Bin _ l2 _) = case lookupMinSure l2 of+      KeyValue k2 x2 -> case compare k1 k2 <> cmp x1 x2 of+        LT -> A_LT_B+        EQ -> A_Prefix_B+        GT -> A_GT_B+    go (Tip k1 x1) (Tip k2 x2) = case compare k1 k2 <> cmp x1 x2 of+      LT -> A_LT_B+      EQ -> A_EQ_B+      GT -> A_GT_B+    go Nil Nil = A_EQ_B+    go Nil _ = A_Prefix_B+    go _ Nil = B_Prefix_A+{-# INLINE liftCmp #-}++-- Split into negative and non-negative+splitSign :: IntMap a -> (IntMap a, IntMap a)+splitSign t@(Bin p l r)+  | signBranch p = (r, l)+  | unPrefix p < 0 = (t, Nil)+  | otherwise = (Nil, t)+splitSign t@(Tip k _)+  | k < 0 = (t, Nil)+  | otherwise = (Nil, t)+splitSign Nil = (Nil, Nil)+{-# INLINE splitSign #-}++{--------------------------------------------------------------------+  Functor+--------------------------------------------------------------------}++instance Functor IntMap where+    fmap = map++#ifdef __GLASGOW_HASKELL__+    a <$ Bin p l r = Bin p (a <$ l) (a <$ r)+    a <$ Tip k _   = Tip k a+    _ <$ Nil       = Nil+#endif++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}++instance Show a => Show (IntMap a) where+  showsPrec d m   = showParen (d > 10) $+    showString "fromList " . shows (toList m)++-- | @since 0.5.9+instance Show1 IntMap where+    liftShowsPrec sp sl d m =+        showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)+      where+        sp' = liftShowsPrec sp sl+        sl' = liftShowList sp sl++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance (Read e) => Read (IntMap e) where+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault+#else+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)+#endif++-- | @since 0.5.9+instance Read1 IntMap where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}++-- | Link two @IntMap@s. The maps must not be empty. The @Prefix@es of the two+-- maps must be different. @k1@ must share the prefix of @t1@. @p2@ must be the+-- prefix of @t2@.+linkKey :: Key -> IntMap a -> Prefix -> IntMap a -> IntMap a+linkKey k1 t1 p2 t2 = link k1 t1 (unPrefix p2) t2+{-# INLINE linkKey #-}++-- | Link two @IntMap@s. The maps must not be empty. The @Prefix@es of the two+-- maps must be different. @k1@ must share the prefix of @t1@ and @k2@ must+-- share the prefix of @t2@.+link :: Int -> IntMap a -> Int -> IntMap a -> IntMap a+link k1 t1 k2 t2 = linkWithMask (branchMask k1 k2) k1 t1 k2 t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Int -> Key -> IntMap a -> Key -> IntMap a -> IntMap a+linkWithMask m k1 t1 k2 t2+  | i2w k1 < i2w k2 = Bin p t1 t2+  | otherwise = Bin p t2 t1+  where+    p = Prefix (mask k1 m .|. m)+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}++bin :: Prefix -> IntMap a -> IntMap a -> IntMap a+bin _ l Nil = l+bin _ Nil r = r+bin p l r   = Bin p l r+{-# INLINE bin #-}++-- binCheckLeft only checks that the left subtree is non-empty+binCheckLeft :: Prefix -> IntMap a -> IntMap a -> IntMap a+binCheckLeft _ Nil r = r+binCheckLeft p l r   = Bin p l r+{-# INLINE binCheckLeft #-}++-- binCheckRight only checks that the right subtree is non-empty+binCheckRight :: Prefix -> IntMap a -> IntMap a -> IntMap a+binCheckRight _ l Nil = l+binCheckRight p l r   = Bin p l r+{-# INLINE binCheckRight #-}++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | \(O(1)\).  Decompose a map into pieces based on the structure+-- of the underlying tree. This function is useful for consuming a+-- map in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==+-- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]+--+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than two submaps,+--  but you should not depend on this behaviour because it can change in the+--  future without notice.+splitRoot :: IntMap a -> [IntMap a]+splitRoot orig =+  case orig of+    Nil -> []+    x@(Tip _ _) -> [x]+    Bin p l r+      | signBranch p -> [r, l]+      | otherwise -> [l, r]+{-# INLINE splitRoot #-}+++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}++-- | \(O(n \min(n,W))\). Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => IntMap a -> String+showTree s+  = showTreeWith True False s+++{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the map. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS+showsTree wide lbars rbars t = case t of+  Bin p l r ->+    showsTree wide (withBar rbars) (withEmpty rbars) r .+    showWide wide rbars .+    showsBars lbars . showString (showBin p) . showString "\n" .+    showWide wide lbars .+    showsTree wide (withEmpty lbars) (withBar lbars) l+  Tip k x ->+    showsBars lbars .+    showString " " . shows k . showString ":=" . shows x . showString "\n"+  Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS+showsTreeHang wide bars t = case t of+  Bin p l r ->+    showsBars bars . showString (showBin p) . showString "\n" .+    showWide wide bars .+    showsTreeHang wide (withBar bars) l .+    showWide wide bars .+    showsTreeHang wide (withEmpty bars) r+  Tip k x ->+    showsBars bars .+    showString " " . shows k . showString ":=" . shows x . showString "\n"+  Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> String+showBin _+  = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _ : tl -> showString (concat (reverse tl)) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars++{--------------------------------------------------------------------+  Notes+--------------------------------------------------------------------}++-- Note [Okasaki-Gill]+-- ~~~~~~~~~~~~~~~~~~~+--+-- The IntMap structure is based on the map described in the paper "Fast+-- Mergeable Integer Maps" by Chris Okasaki and Andy Gill, with some+-- differences.+--+-- The paper spends most of its time describing a little-endian tree, where the+-- branching is done first on low bits then high bits. It then briefly describes+-- a big-endian tree. The implementation here is big-endian.+--+-- The definition of Okasaki and Gill's map would be written in Haskell as+--+-- data Dict a+--   = Empty+--   | Lf !Int a+--   | Br !Int !Int !(Dict a) !(Dict a)+--+-- Empty is the same as IntMap's Nil, and Lf is the same as Tip.+--+-- In Br, the first Int is the shared prefix and the second is the mask bit by+-- itself. For the big-endian map, the paper suggests that the prefix be the+-- common prefix, followed by a 0-bit, followed by all 1-bits. This is so that+-- the prefix value can be used as a point of split for binary search.+--+-- IntMap's Bin corresponds to Br, but is different because it has only one+-- Int (newtyped as Prefix). This describes both prefix and mask, so it is not+-- necessary to store them separately. This value is, in fact, one plus the+-- value suggested for the prefix in the paper. This representation is chosen+-- because it saves one word per Bin without detriment to the efficiency of+-- operations.+--+-- The implementation of operations such as lookup, insert, union, follow+-- the described implementations on Dict and split into the same cases. For+-- instance, for insert, the three cases on a Br are whether the key belongs+-- outside the map, or it belongs in the left child, or it belongs in the+-- right child. We have the same three cases for a Bin. However, the bitwise+-- operations we use to determine the case is naturally different due to the+-- difference in representation.++-- Note [IntMap merge complexity]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The merge algorithm (used for union, intersection, etc.) is adopted from+-- Okasaki-Gill who give the complexity as O(m+n), where m and n are the sizes+-- of the two input maps. This is correct, since we visit all constructors in+-- both maps in the worst case, but we can try to find a tighter bound.+--+-- Consider that m<=n, i.e. m is the size of the smaller map and n is the size+-- of the larger. It does not matter which map is the first argument.+--+-- Now we have O(n) as one upper bound for our complexity, since O(n) is the+-- same as O(m+n) for m<=n.+--+-- Next, consider the smaller map. For this map, we will visit some+-- constructors, plus all the Bins of the larger map that lie in our way.+-- For the former, the worst case is that we visit all constructors, which is+-- O(m).+-- For the latter, the worst case is that we encounter Bins at every point+-- possible. This happens when for every key in the smaller map, the path to+-- that key's Tip in the larger map has a full length of W, with a Bin at every+-- bit position. To maximize the total number of Bins, the paths should be as+-- disjoint as possible. But even if the paths are spread out, at least O(m)+-- Bins are unavoidably shared, which extend up to a depth of lg(m) from the+-- root. Beyond this, the paths may be disjoint. This gives us a total of+-- O(m + m (W - lg m)) = O(m log (2^W / m)).+-- The number of Bins we encounter is also bounded by the total number of Bins,+-- which is n-1, but we already have O(n) as an upper bound.+--+-- Combining our bounds, we have the final complexity as+-- O(min(n, m log (2^W / m))).+--+-- Note that+-- * This is similar to the Map merge complexity, which is O(m log (n/m)).+-- * When m is a small constant the term simplifies to O(min(n, W)), which is+--   just the complexity we expect for single operations like insert and delete.
− src/Data/IntMap/Internal/DeprecatedDebug.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts, DataKinds, MonoLocalBinds #-}--module Data.IntMap.Internal.DeprecatedDebug where-import Data.IntMap.Internal (IntMap)--import Utils.Containers.Internal.TypeError----- | 'showTree' has moved to 'Data.IntMap.Internal.Debug.showTree'-showTree :: Whoops "Data.IntMap.showTree has moved to Data.IntMap.Internal.Debug.showTree"-         => IntMap a -> String-showTree _ = undefined---- | 'showTreeWith' has moved to 'Data.IntMap.Internal.Debug.showTreeWith'-showTreeWith :: Whoops "Data.IntMap.showTreeWith has moved to Data.IntMap.Internal.Debug.showTreeWith"-             => Bool -> Bool -> IntMap a -> String-showTreeWith _ _ _ = undefined
src/Data/IntMap/Lazy.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif @@ -28,7 +28,7 @@ -- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>. -- -- This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:+-- Prelude functions, e.g. -- -- > import Data.IntMap.Lazy (IntMap) -- > import qualified Data.IntMap.Lazy as IntMap@@ -38,16 +38,6 @@ -- prefer the values in the first argument to those in the second. -- ----- == Detailed performance information------ The amortized running time is given for each operation, with \(n\) referring to--- the number of entries in the map and \(W\) referring to the number of bits in--- an 'Int' (32 or 64).------ Benchmarks comparing "Data.IntMap.Lazy" with other dictionary--- implementations can be found at https://github.com/haskell-perf/dictionaries.------ -- == Implementation -- -- The implementation is based on /big-endian patricia trees/.  This data@@ -56,22 +46,58 @@ -- on insertions and deletions when compared to a generic size-balanced map -- implementation (see "Data.Map"). -----    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\", --      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>. -----    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>. --+--+-- == Performance information+--+-- Operation comments contain the operation time complexity in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'lookup', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+--   the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+--   shared by all subelements, so there could not be more+--   than \(W\) levels.+--+-- If all \(n\) keys in the tree are between 0 and \(N\) (or, say, between+-- \(-N\) and \(N\)), the estimate can be refined to \(O(\min(n, \log N))\). If+-- the set of keys is sufficiently "dense", this becomes \(O(\min(n, \log n))\)+-- or simply the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntMap' are keys from a contiguous subset,+-- in which case the complexity is proportional to \(\log n\), capped by \(W\).+-- The worst scenario are exponentially growing keys \(1,2,4,\ldots,2^n\),+-- for which complexity grows as fast as \(n\) but again is capped by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.IntMap.Lazy" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+-- -----------------------------------------------------------------------------  module Data.IntMap.Lazy (     -- * Map type-#if !defined(TESTING)     IntMap, Key          -- instance Eq,Show-#else-    IntMap(..), Key          -- instance Eq,Show-#endif      -- * Construction     , empty@@ -142,6 +168,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -192,6 +221,7 @@      -- * Filter     , IM.filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -232,15 +262,6 @@     , maxView     , minViewWithKey     , maxViewWithKey--#ifdef __GLASGOW_HASKELL__-    -- * Debugging-    , showTree-    , showTreeWith-#endif     ) where -import Data.IntMap.Internal as IM hiding (showTree, showTreeWith)-#ifdef __GLASGOW_HASKELL__-import Data.IntMap.Internal.DeprecatedDebug-#endif+import Data.IntMap.Internal as IM
src/Data/IntMap/Merge/Lazy.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif
src/Data/IntMap/Merge/Strict.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} #endif
src/Data/IntMap/Strict.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Trustworthy #-} #endif @@ -36,7 +35,7 @@ -- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>. -- -- This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:+-- Prelude functions, e.g. -- -- > import Data.IntMap.Strict (IntMap) -- > import qualified Data.IntMap.Strict as IntMap@@ -46,16 +45,6 @@ -- prefer the values in the first argument to those in the second. -- ----- == Detailed performance information------ The amortized running time is given for each operation, with \(n\) referring to--- the number of entries in the map and \(W\) referring to the number of bits in--- an 'Int' (32 or 64).------ Benchmarks comparing "Data.IntMap.Strict" with other dictionary--- implementations can be found at https://github.com/haskell-perf/dictionaries.------ -- == Warning -- -- The 'IntMap' type is shared between the lazy and strict modules, meaning that@@ -73,24 +62,60 @@ -- on insertions and deletions when compared to a generic size-balanced map -- implementation (see "Data.Map"). -----    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\", --      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>. -----    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>. --+--+-- == Performance information+--+-- Operation comments contain the operation time complexity in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'lookup', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+--   the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+--   shared by all subelements, so there could not be more+--   than \(W\) levels.+--+-- If all \(n\) keys in the tree are between 0 and \(N\) (or, say, between+-- \(-N\) and \(N\)), the estimate can be refined to \(O(\min(n, \log N))\). If+-- the set of keys is sufficiently "dense", this becomes \(O(\min(n, \log n))\)+-- or simply the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntMap' are keys from a contiguous subset,+-- in which case the complexity is proportional to \(\log n\), capped by \(W\).+-- The worst scenario are exponentially growing keys \(1,2,4,\ldots,2^n\),+-- for which complexity grows as fast as \(n\) but again is capped by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.IntMap.Strict" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+-- -----------------------------------------------------------------------------  -- See the notes at the beginning of Data.IntMap.Internal.  module Data.IntMap.Strict (     -- * Map type-#if !defined(TESTING)     IntMap, Key          -- instance Eq,Show-#else-    IntMap(..), Key          -- instance Eq,Show-#endif      -- * Construction     , empty@@ -161,6 +186,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -211,6 +239,7 @@      -- * Filter     , filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -251,12 +280,6 @@     , maxView     , minViewWithKey     , maxViewWithKey--#ifdef __GLASGOW_HASKELL__-    -- * Debugging-    , showTree-    , showTreeWith-#endif     ) where  import Data.IntMap.Strict.Internal
src/Data/IntMap/Strict/Internal.hs view
@@ -15,54 +15,23 @@ -- Maintainer  :  libraries@haskell.org -- Portability :  portable -------- = Finite Int Maps (strict interface)------ The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)--- from key of type @Int@ to values of type @v@.------ Each function in this module is careful to force values before installing--- them in an 'IntMap'. This is usually more efficient when laziness is not--- necessary. When laziness /is/ required, use the functions in--- "Data.IntMap.Lazy".------ In particular, the functions in this module obey the following law:------  - If all values stored in all maps in the arguments are in WHNF, then all---    values stored in all maps in the results will be in WHNF once those maps---    are evaluated.------ For a walkthrough of the most commonly used functions see the--- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.------ This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:------ > import Data.IntMap.Strict (IntMap)--- > import qualified Data.IntMap.Strict as IntMap------ Note that the implementation is generally /left-biased/. Functions that take--- two maps as arguments and combine them, such as `union` and `intersection`,--- prefer the values in the first argument to those in the second.+-- = WARNING --+-- This module is considered __internal__. ----- == Detailed performance information+-- The Package Versioning Policy __does not apply__. ----- The amortized running time is given for each operation, with \(n\) referring to--- the number of entries in the map and \(W\) referring to the number of bits in--- an 'Int' (32 or 64).+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package. ----- Benchmarks comparing "Data.IntMap.Strict" with other dictionary--- implementations can be found at https://github.com/haskell-perf/dictionaries.+-- Authors importing this module are expected to track development+-- closely. -- ----- == Warning+-- = Finite Int Maps (strict interface internals) ----- The 'IntMap' type is shared between the lazy and strict modules, meaning that--- the same 'IntMap' value can be passed to functions in both modules. This--- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are--- the same as for the "Data.IntMap.Lazy" module, so if they are used the--- resulting map may contain suspended values (thunks).+-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)+-- from key of type @Int@ to values of type @v@. -- -- -- == Implementation@@ -73,12 +42,15 @@ -- on insertions and deletions when compared to a generic size-balanced map -- implementation (see "Data.Map"). -----    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\", --      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>. -----    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>. -- ----------------------------------------------------------------------------- @@ -86,11 +58,7 @@  module Data.IntMap.Strict.Internal (     -- * Map type-#if !defined(TESTING)     IntMap, Key          -- instance Eq,Show-#else-    IntMap(..), Key          -- instance Eq,Show-#endif      -- * Construction     , empty@@ -161,6 +129,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -211,6 +182,7 @@      -- * Filter     , filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -251,12 +223,6 @@     , maxView     , minViewWithKey     , maxViewWithKey--#ifdef __GLASGOW_HASKELL__-    -- * Debugging-    , showTree-    , showTreeWith-#endif     ) where  import Utils.Containers.Internal.Prelude hiding@@ -265,19 +231,15 @@  import Data.Bits import qualified Data.IntMap.Internal as L+import Data.IntSet.Internal.IntTreeCommons+  (Key, Prefix(..), nomatch, left, signBranch, mask, branchMask) import Data.IntMap.Internal   ( IntMap (..)-  , Key-  , mask-  , branchMask-  , nomatch-  , zero-  , natFromInt-  , intFromNat   , bin   , binCheckLeft   , binCheckRight   , link+  , linkKey   , linkWithMask    , (\\)@@ -286,6 +248,7 @@   , empty   , assocs   , filter+  , filterKeys   , filterWithKey   , findMin   , findMax@@ -315,6 +278,7 @@   , isSubmapOf   , isSubmapOfBy   , lookup+  , findWithDefault   , lookupLE   , lookupGE   , lookupLT@@ -341,6 +305,7 @@   , split   , splitLookup   , splitRoot+  , symmetricDifference   , toAscList   , toDescList   , toList@@ -348,37 +313,12 @@   , unions   , withoutKeys   )-#ifdef __GLASGOW_HASKELL__-import Data.IntMap.Internal.DeprecatedDebug (showTree, showTreeWith)-#endif import qualified Data.IntSet.Internal as IntSet-import Utils.Containers.Internal.BitUtil+import Utils.Containers.Internal.BitUtil (iShiftRL, shiftLL, shiftRL) import Utils.Containers.Internal.StrictPair 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'---- See IntMap.Internal.Note: Local 'go' functions and capturing]-findWithDefault :: a -> Key -> IntMap a -> a-findWithDefault def !k = go-  where-    go (Bin p m l r) | nomatch k p m = def-                     | zero k m  = go l-                     | otherwise = go r-    go (Tip kx x) | k == kx   = x-                  | otherwise = def-    go Nil = def--{--------------------------------------------------------------------   Construction --------------------------------------------------------------------} -- | \(O(1)\). A map of one element.@@ -406,10 +346,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 +391,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 +422,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 +457,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 +491,10 @@ updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a updateWithKey f !k t =   case t of-    Bin p m l r-      | nomatch k p m -> t-      | zero k m      -> binCheckLeft p m (updateWithKey f k l) r-      | otherwise     -> binCheckRight p m l (updateWithKey f k r)+    Bin p l r+      | nomatch k p -> t+      | left k p    -> binCheckLeft p (updateWithKey f k l) r+      | otherwise   -> binCheckRight p l (updateWithKey f k r)     Tip ky y       | k==ky         -> case f k y of                            Just !y' -> Tip ky y'@@ -562,7 +502,7 @@       | otherwise     -> t     Nil -> Nil --- | \(O(\min(n,W))\). Lookup and update.+-- | \(O(\min(n,W))\). Look up and update. -- The function returns original value, if it is updated. -- This is different behavior than 'Data.Map.updateLookupWithKey'. -- Returns the original key value if the map entry is deleted.@@ -577,10 +517,10 @@   where     go f k t =       case t of-        Bin p m l r-          | nomatch k p m -> (Nothing :*: t)-          | zero k m      -> let (found :*: l') = go f k l in (found :*: binCheckLeft p m l' r)-          | otherwise     -> let (found :*: r') = go f k r in (found :*: binCheckRight p m l r')+        Bin p l r+          | nomatch k p -> (Nothing :*: t)+          | left k p    -> let (found :*: l') = go f k l in (found :*: binCheckLeft p l' r)+          | otherwise   -> let (found :*: r') = go f k r in (found :*: binCheckRight p l r')         Tip ky y           | k==ky         -> case f k y of                                Just !y' -> (Just y :*: Tip ky y')@@ -596,12 +536,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    -> binCheckLeft p (alter f k l) r+      | otherwise   -> binCheckRight p l (alter f k r)     Tip ky y       | k==ky         -> case f (Just y) of                            Just !x -> Tip ky x@@ -613,9 +553,9 @@                            Just !x -> Tip k x                            Nothing -> Nil --- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at+-- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at -- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,--- or update a value in an 'IntMap'.  In short : @'lookup' k <$> 'alterF' f k m = f+-- or update a value in an 'IntMap'.  In short : @'lookup' k \<$\> 'alterF' f k m = f -- ('lookup' k m)@. -- -- Example:@@ -663,7 +603,8 @@ unionsWith f ts   = Foldable.foldl' (unionWith f) empty ts --- | \(O(n+m)\). The union with a combining function.+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function. -- -- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")] --@@ -673,7 +614,8 @@ unionWith f m1 m2   = unionWithKey (\_ x y -> f x y) m1 m2 --- | \(O(n+m)\). The union with a combining function.+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function. -- -- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value -- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]@@ -688,7 +630,8 @@   Difference --------------------------------------------------------------------} --- | \(O(n+m)\). Difference with a combining function.+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function. -- -- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing -- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])@@ -698,7 +641,8 @@ differenceWith f m1 m2   = differenceWithKey (\_ x y -> f x y) m1 m2 --- | \(O(n+m)\). Difference with a combining function. When two equal keys are+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function. When two equal keys are -- encountered, the combining function is applied to the key and both values. -- If it returns 'Nothing', the element is discarded (proper set difference). -- If it returns (@'Just' y@), the element is updated with a new value @y@.@@ -715,7 +659,8 @@   Intersection --------------------------------------------------------------------} --- | \(O(n+m)\). The intersection with a combining function.+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA" @@ -723,7 +668,8 @@ intersectionWith f m1 m2   = intersectionWithKey (\_ x y -> f x y) m1 m2 --- | \(O(n+m)\). The intersection with a combining function.+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function. -- -- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar -- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"@@ -736,12 +682,13 @@   MergeWithKey --------------------------------------------------------------------} --- | \(O(n+m)\). A high-performance universal combining function. Using+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- A high-performance universal combining function. Using -- 'mergeWithKey', all combining functions can be defined without any loss of -- efficiency (with exception of 'union', 'difference' and 'intersection', -- where sharing of some nodes is lost with 'mergeWithKey'). ----- Please make sure you know what is going on when using 'mergeWithKey',+-- __Warning__: Please make sure you know what is going on when using 'mergeWithKey', -- otherwise you can be surprised by unexpected code growth or even -- corruption of the data structure. --@@ -785,39 +732,39 @@   Min\/Max --------------------------------------------------------------------} --- | \(O(\log n)\). Update the value at the minimal key.+-- | \(O(\min(n,W))\). Update the value at the minimal key. -- -- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")] -- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"  updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a updateMinWithKey f t =-  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)+  case t of Bin p l r | signBranch p -> binCheckRight p l (go f r)             _ -> go f t   where-    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r+    go f' (Bin p l r) = binCheckLeft p (go f' l) r     go f' (Tip k y) = case f' k y of                         Just !y' -> Tip k y'                         Nothing -> Nil-    go _ Nil = error "updateMinWithKey Nil"+    go _ Nil = Nil --- | \(O(\log n)\). Update the value at the maximal key.+-- | \(O(\min(n,W))\). Update the value at the maximal key. -- -- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")] -- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"  updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a updateMaxWithKey f t =-  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r+  case t of Bin p l r | signBranch p -> binCheckLeft p (go f l) r             _ -> go f t   where-    go f' (Bin p m l r) = binCheckRight p m l (go f' r)+    go f' (Bin p l r) = binCheckRight p l (go f' r)     go f' (Tip k y) = case f' k y of                         Just !y' -> Tip k y'                         Nothing -> Nil-    go _ Nil = error "updateMaxWithKey Nil"+    go _ Nil = Nil --- | \(O(\log n)\). Update the value at the maximal key.+-- | \(O(\min(n,W))\). Update the value at the maximal key. -- -- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")] -- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"@@ -825,7 +772,7 @@ updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a updateMax f = updateMaxWithKey (const f) --- | \(O(\log n)\). Update the value at the minimal key.+-- | \(O(\min(n,W))\). Update the value at the minimal key. -- -- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")] -- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"@@ -844,9 +791,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 +811,9 @@ mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b mapWithKey f t   = case t of-      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)-      Tip k x     -> Tip k $! f k x-      Nil         -> Nil+      Bin p l r -> Bin p (mapWithKey f l) (mapWithKey f r)+      Tip k x   -> Tip k $! f k x+      Nil       -> Nil  #ifdef __GLASGOW_HASKELL__ -- Pay close attention to strictness here. We need to force the@@ -880,7 +827,7 @@ -- lsmap :: (b -> c) -> (a -> b) -> IntMap a -> IntMap c -- lsmap _ _ Nil = Nil -- lsmap f g (Tip k x) = let !gx = g x in Tip k (f gx)--- lsmap f g (Bin p m l r) = Bin p m (lsmap f g l) (lsmap f g r)+-- lsmap f g (Bin p l r) = Bin p (lsmap f g l) (lsmap f g r) {-# NOINLINE [1] mapWithKey #-} {-# RULES "mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =@@ -910,9 +857,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 +871,9 @@     where     go Nil           = pure Nil     go (Tip k x)     = maybe Nil (Tip k $!) <$> f k x-    go (Bin p m l r)-      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)-      | otherwise = liftA2 (bin p m) (go l) (go r)+    go (Bin p l r)+      | signBranch p = liftA2 (flip (bin p)) (go r) (go l)+      | otherwise = liftA2 (bin p) (go l) (go r)  -- | \(O(n)\). The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys.@@ -956,15 +903,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,19 +922,19 @@   where     go f a t       = case t of-          Bin p m l r-            | m < 0 ->+          Bin p l r+            | signBranch p ->               let (a1 :*: l') = go f a l                   (a2 :*: r') = go f a1 r-              in (a2 :*: Bin p m l' r')+              in (a2 :*: Bin p l' r')             | otherwise ->               let (a1 :*: r') = go f a r                   (a2 :*: l') = go f a1 l-              in (a2 :*: Bin p m l' r')+              in (a2 :*: Bin p l' r')           Tip k x     -> let !(a',!x') = f a k x in (a' :*: Tip k x')           Nil         -> (a :*: Nil) --- | \(O(n \log n)\).+-- | \(O(n \min(n,W))\). -- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@. -- -- The size of the result may be smaller if @f@ maps two or more distinct@@ -1019,8 +966,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 +998,8 @@ mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c) mapEitherWithKey f0 t0 = toPair $ go f0 t0   where-    go f (Bin p m l r)-      = bin p m l1 r1 :*: bin p m l2 r2+    go f (Bin p l r)+      = bin p l1 r1 :*: bin p l2 r2       where         (l1 :*: l2) = go f l         (r1 :*: r2) = go f r@@ -1073,7 +1020,7 @@  fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a fromSet _ IntSet.Nil = Nil-fromSet f (IntSet.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)+fromSet f (IntSet.Bin p l r) = Bin p (fromSet f l) (fromSet f r) fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)   where -- This is slightly complicated, as we to convert the dense         -- representation of IntSet into tree representation of IntMap.@@ -1084,13 +1031,13 @@         -- one of them is nonempty and we construct the IntMap from that half.         buildTree g !prefix !bmask bits = case bits of           0 -> Tip prefix $! g prefix-          _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of+          _ -> case bits `iShiftRL` 1 of                  bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->                            buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2                        | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->                            buildTree g prefix bmask bits2                        | otherwise ->-                           Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)+                           Bin (Prefix (prefix .|. bits2)) (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)  {--------------------------------------------------------------------   Lists@@ -1164,6 +1111,10 @@ -- | \(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")] @@ -1173,8 +1124,11 @@  -- | \(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'.@@ -1185,8 +1139,11 @@  -- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./ --+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+-- -- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")] -- -- Also see the performance note on 'fromListWith'.@@ -1197,8 +1154,11 @@  -- | \(O(n)\). Build a map from a list of key\/value pairs where -- the keys are in ascending order and all distinct.--- /The precondition (input list is strictly ascending) is not checked./ --+-- __Warning__: This function should be used only if the keys are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+-- -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]  fromDistinctAscList :: [(Key,a)] -> IntMap a@@ -1222,15 +1182,18 @@      -- `addAll'` collects all keys equal to `kx` into a single value,     -- and then proceeds with `addAll`.-    addAll' !kx vx []-        = Tip kx $! vx-    addAll' !kx vx ((ky,vy) : zs)+    --+    -- We want to have the same strictness as fromListWithKey, which is achieved+    -- with the bang on vx.+    addAll' !kx !vx []+        = Tip kx vx+    addAll' !kx !vx ((ky,vy) : zs)         | Nondistinct <- distinct, kx == ky-        = let !v = f kx vy vx in addAll' ky v zs-        -- inlined: | otherwise = addAll kx (Tip kx $! vx) (ky : zs)+        = addAll' ky (f kx vy vx) zs+        -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)         | m <- branchMask kx ky         , Inserted ty zs' <- addMany' m ky vy zs-        = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx $! vx)) zs'+        = addAll kx (linkWithMask m ky ty kx (Tip kx vx)) zs'      -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`     -- `addAll` consumes the rest of the list, adding to the tree `tx`@@ -1239,20 +1202,23 @@     addAll !kx !tx ((ky,vy) : zs)         | m <- branchMask kx ky         , Inserted ty zs' <- addMany' m ky vy zs-        = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'+        = addAll kx (linkWithMask m ky ty kx tx) zs'      -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.-    addMany' !_m !kx vx []-        = Inserted (Tip kx $! vx) []-    addMany' !m !kx vx zs0@((ky,vy) : zs)+    --+    -- We want to have the same strictness as fromListWithKey, which is achieved+    -- with the bang on vx.+    addMany' !_m !kx !vx []+        = Inserted (Tip kx vx) []+    addMany' !m !kx !vx zs0@((ky,vy) : zs)         | Nondistinct <- distinct, kx == ky-        = let !v = f kx vy vx in addMany' m ky v zs-        -- inlined: | otherwise = addMany m kx (Tip kx $! vx) (ky : zs)+        = addMany' m ky (f kx vy vx) zs+        -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)         | mask kx m /= mask ky m-        = Inserted (Tip kx $! vx) zs0+        = Inserted (Tip kx vx) zs0         | mxy <- branchMask kx ky         , Inserted ty zs' <- addMany' mxy ky vy zs-        = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs'+        = addMany m kx (linkWithMask mxy ky ty kx (Tip kx vx)) zs'      -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.     addMany !_m !_kx tx []@@ -1262,7 +1228,7 @@         = Inserted tx zs0         | mxy <- branchMask kx ky         , Inserted ty zs' <- addMany' mxy ky vy zs-        = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'+        = addMany m kx (linkWithMask mxy ky ty kx tx) zs' {-# INLINE fromMonoListWithKey #-}  data Inserted a = Inserted !(IntMap a) ![(Key,a)]
src/Data/IntSet.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif @@ -17,7 +17,8 @@ -- -- = Finite Int Sets ----- The @'IntSet'@ type represents a set of elements of type @Int@.+-- The @'IntSet'@ type represents a set of elements of type @Int@. An @IntSet@+-- is strict in its elements. -- -- For a walkthrough of the most commonly used functions see their -- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>.@@ -29,28 +30,23 @@ -- >  import qualified Data.IntSet as IntSet -- ----- == Performance information------ Many operations have a worst-case complexity of \(O(\min(n,W))\).--- This means that the operation can become linear in the number of--- elements with a maximum of \(W\) -- the number of bits in an 'Int'--- (32 or 64).------ -- == Implementation -- -- The implementation is based on /big-endian patricia trees/.  This data -- structure performs especially well on binary operations like 'union'--- and 'intersection'.  However, my benchmarks show that it is also+-- and 'intersection'. Additionally, benchmarks show that it is also -- (much) faster on insertions and deletions when compared to a generic -- size-balanced set implementation (see "Data.Set"). -----    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\", --      Workshop on ML, September 1998, pages 77-86,---      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>. -----    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",---      Journal of the ACM, 15(4), October 1968, pages 514-534.+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>. -- -- Additionally, this implementation places bitmaps in the leaves of the tree. -- Their size is the natural size of a machine word (32 or 64 bits) and greatly@@ -58,18 +54,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@@ -108,6 +132,9 @@             , difference             , (\\)             , intersection+            , intersections+            , symmetricDifference+            , Intersection(..)              -- * Filter             , IS.filter@@ -128,6 +155,7 @@             -- * Folds             , IS.foldr             , IS.foldl+            , IS.foldMap             -- ** Strict folds             , IS.foldr'             , IS.foldl'@@ -135,6 +163,8 @@             , fold              -- * Min\/Max+            , lookupMin+            , lookupMax             , findMin             , findMax             , deleteMin@@ -155,21 +185,6 @@             -- * Debugging             , showTree             , showTreeWith--#if defined(TESTING)-            -- * Internals-            , match-#endif             ) where  import Data.IntSet.Internal as IS---- $strictness------ This module satisfies the following strictness property:------ * Key arguments are evaluated to WHNF------ Here are some examples that illustrate the property:------ > delete undefined s  ==  undefined
src/Data/IntSet/Internal.hs view
@@ -6,1820 +6,1997 @@ {-# 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]+{-# LANGUAGE Trustworthy #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IntSet.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Joachim Breitner 2011+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Int Sets (internals)+--+-- The @'IntSet'@ type represents a set of elements of type @Int@. An @IntSet@+-- is strict in its elements.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. Additionally, benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced set implementation (see "Data.Set").+--+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>.+--+-- Additionally, this implementation places bitmaps in the leaves of the tree.+-- Their size is the natural size of a machine word (32 or 64 bits) and greatly+-- reduces the memory footprint and execution times for dense sets, e.g. sets+-- where it is likely that many values lie close to each other. The asymptotics+-- are not affected by this optimization.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of IntSet matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.++module Data.IntSet.Internal (+    -- * Set type+      IntSet(..) -- instance Eq,Show+    , Key+    , BitMap++    -- * Operators+    , (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , isSubsetOf+    , isProperSubsetOf+    , disjoint++    -- * Construction+    , empty+    , singleton+    , fromRange+    , insert+    , delete+    , alterF++    -- * Combine+    , union+    , unions+    , difference+    , intersection+    , intersections+    , symmetricDifference+    , Intersection(..)++    -- * Filter+    , filter+    , partition++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , split+    , splitMember+    , splitRoot++    -- * Map+    , map+    , mapMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldMap+    -- ** Strict folds+    , foldr'+    , foldl'+    -- ** Legacy folds+    , fold++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , maxView+    , minView++    -- * Conversion++    -- ** List+    , elems+    , toList+    , fromList++    -- ** Ordered list+    , toAscList+    , toDescList+    , fromAscList+    , fromDistinctAscList++    -- * Debugging+    , showTree+    , showTreeWith++    -- * Internals+    , suffixBitMask+    , prefixBitMask+    , bitmapOf+    ) where++import Control.Applicative (Const(..))+import Control.DeepSeq (NFData(rnf))+import Data.Bits+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (fromMaybe)+import Data.Semigroup (Semigroup(..), stimesIdempotent, stimesIdempotentMonoid)+import Utils.Containers.Internal.Prelude hiding+  (filter, foldr, foldl, foldl', foldMap, null, map)+import Prelude ()++import Utils.Containers.Internal.BitUtil (iShiftRL, shiftLL, shiftRL)+import Utils.Containers.Internal.StrictPair+import Data.IntSet.Internal.IntTreeCommons+  ( Key+  , Prefix(..)+  , nomatch+  , left+  , signBranch+  , mask+  , branchMask+  , TreeTreeBranch(..)+  , treeTreeBranch+  , i2w+  , Order(..)+  )++#if __GLASGOW_HASKELL__+import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType)+import qualified Data.Data+import Text.Read+import Data.Coerce (coerce)+#endif++#if __GLASGOW_HASKELL__+import qualified GHC.Exts+#  if !(WORD_SIZE_IN_BITS==64)+import qualified GHC.Int+#  endif+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif++import qualified Data.Foldable as Foldable+import Data.Functor.Identity (Identity(..))++infixl 9 \\{-This comment teaches CPP correct behaviour -}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- See 'difference'.+(\\) :: IntSet -> IntSet -> IntSet+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}++-- | A set of integers.++-- See Note: Order of constructors+data IntSet = Bin {-# UNPACK #-} !Prefix+                  !IntSet+                  !IntSet+            | Tip {-# UNPACK #-} !Int+                  {-# UNPACK #-} !BitMap+            | Nil++type BitMap = Word++--+-- Note [IntSet structure and invariants]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- * Nil is never found as a child of Bin.+--+-- * The Prefix of a Bin indicates the common high-order bits that all keys in+--   the Bin share.+--+-- * The least significant set bit of the Int value of a Prefix is called the+--   mask bit.+--+-- * All the bits to the left of the mask bit are called the shared prefix. All+--   keys stored in the Bin begin with the shared prefix.+--+-- * All keys in the left child of the Bin have the mask bit unset, and all keys+--   in the right child have the mask bit set. It follows that+--+--   1. The Int value of the Prefix of a Bin is the smallest key that can be+--      present in the right child of the Bin.+--+--   2. All keys in the right child of a Bin are greater than keys in the+--      left child, with one exceptional situation. If the Bin separates+--      negative and non-negative keys, the mask bit is the sign bit and the+--      left child stores the non-negative keys while the right child stores the+--      negative keys.+--+-- * All bits to the right of the mask bit are set to 0 in a Prefix.+--+-- * The shared prefix of a Bin is never longer than+--   (WORD_SIZE - lg(WORD_SIZE) - 1) bits.+--+-- * In the context of a Tip, the highest (WORD_SIZE - lg(WORD_SIZE)) bits of+--   a key are called "prefix" and the lowest lg(WORD_SIZE) bits are called+--   "suffix". In Tip kx bm, kx is the shared prefix and bm is a bitmask of the+--   suffixes of the keys. In other words, the keys of Tip kx bm are (kx .|. i)+--   for every set bit i in bm.+--+-- * In Tip kx _, the lowest lg(WORD_SIZE) bits of kx are set to 0.+--+-- * In Tip _ bm, bm is never 0.+--++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+deriving instance Lift IntSet+#endif++-- | @mempty@ = 'empty'+instance Monoid IntSet where+    mempty  = empty+    mconcat = unions+    mappend = (<>)++-- | @(<>)@ = 'union'+--+-- @since 0.5.7+instance Semigroup IntSet where+    (<>)    = union+    stimes  = stimesIdempotentMonoid++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data IntSet where+  gfoldl f z is = z fromList `f` (toList is)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = intSetDataType++fromListConstr :: Constr+fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix++intSetDataType :: DataType+intSetDataType = mkDataType "Data.IntSet.Internal.IntSet" [fromListConstr]++#endif++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the set empty?+null :: IntSet -> Bool+null Nil = True+null _   = False+{-# INLINE null #-}++-- | \(O(n)\). Cardinality of the set.+size :: IntSet -> Int+size = go 0+  where+    go !acc (Bin _ l r) = go (go acc l) r+    go acc (Tip _ bm) = acc + popCount bm+    go acc Nil = acc++-- | \(O(\min(n,W))\). Is the value a member of the set?++-- See Note: Local 'go' functions and capturing.+member :: Key -> IntSet -> Bool+member !x = go+  where+    go (Bin p l r)+      | nomatch x p = False+      | left x p    = go l+      | otherwise   = go r+    go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0+    go Nil = False++-- | \(O(\min(n,W))\). Is the element not in the set?+notMember :: Key -> IntSet -> Bool+notMember k = not . member k++-- | \(O(\min(n,W))\). Find largest element smaller than the given one.+--+-- > lookupLT 3 (fromList [3, 5]) == Nothing+-- > lookupLT 5 (fromList [3, 5]) == Just 3++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> IntSet -> Maybe Key+lookupLT !x t = case t of+    Bin p l r | signBranch p -> if x >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMax def else unsafeFindMax r+                       | left x p  = go def l+                       | otherwise = go l r+    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm+                       | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT+                       | otherwise = unsafeFindMax def+                       where maskLT = (bitmapOf x - 1) .&. bm+    go def Nil = unsafeFindMax def+++-- | \(O(\min(n,W))\). Find smallest element greater than the given one.+--+-- > lookupGT 4 (fromList [3, 5]) == Just 5+-- > lookupGT 5 (fromList [3, 5]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> IntSet -> Maybe Key+lookupGT !x t = case t of+    Bin p l r | signBranch p -> if x >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMin l else unsafeFindMin def+                       | left x p  = go r l+                       | otherwise = go def r+    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm+                       | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT+                       | otherwise = unsafeFindMin def+                       where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm+    go def Nil = unsafeFindMin def+++-- | \(O(\min(n,W))\). Find largest element smaller or equal to the given one.+--+-- > lookupLE 2 (fromList [3, 5]) == Nothing+-- > lookupLE 4 (fromList [3, 5]) == Just 3+-- > lookupLE 5 (fromList [3, 5]) == Just 5++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> IntSet -> Maybe Key+lookupLE !x t = case t of+    Bin p l r | signBranch p -> if x >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMax def else unsafeFindMax r+                       | left x p  = go def l+                       | otherwise = go l r+    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm+                       | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE+                       | otherwise = unsafeFindMax def+                       where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm+    go def Nil = unsafeFindMax def+++-- | \(O(\min(n,W))\). Find smallest element greater or equal to the given one.+--+-- > lookupGE 3 (fromList [3, 5]) == Just 3+-- > lookupGE 4 (fromList [3, 5]) == Just 5+-- > lookupGE 6 (fromList [3, 5]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> IntSet -> Maybe Key+lookupGE !x t = case t of+    Bin p l r | signBranch p -> if x >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMin l else unsafeFindMin def+                       | left x p  = go r l+                       | otherwise = go def r+    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm+                       | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE+                       | otherwise = unsafeFindMin def+                       where maskGE = (- (bitmapOf x)) .&. bm+    go def Nil = unsafeFindMin def++++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: IntSet -> Maybe Key+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm+unsafeFindMin (Bin _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: IntSet -> Maybe Key+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm+unsafeFindMax (Bin _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty set.+empty :: IntSet+empty+  = Nil+{-# INLINE empty #-}++-- | \(O(1)\). A set of one element.+singleton :: Key -> IntSet+singleton x+  = Tip (prefixOf x) (bitmapOf x)+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Add a value to the set. There is no left- or right bias for+-- IntSets.+insert :: Key -> IntSet -> IntSet+insert !x = insertBM (prefixOf x) (bitmapOf x)++-- Helper function for insert and union.+insertBM :: Int -> BitMap -> IntSet -> IntSet+insertBM !kx !bm t@(Bin p l r)+  | nomatch kx p = linkKey kx (Tip kx bm) p t+  | left kx p    = Bin p (insertBM kx bm l) r+  | otherwise    = Bin p l (insertBM kx bm r)+insertBM kx bm t@(Tip kx' bm')+  | kx' == kx = Tip kx' (bm .|. bm')+  | otherwise = link kx (Tip kx bm) kx' t+insertBM kx bm Nil = Tip kx bm++-- | \(O(\min(n,W))\). Delete a value in the set. Returns the+-- original set when the value was not present.+delete :: Key -> IntSet -> IntSet+delete !x = deleteBM (prefixOf x) (bitmapOf x)++-- Deletes all values mentioned in the BitMap from the set.+-- Helper function for delete and difference.+deleteBM :: Int -> BitMap -> IntSet -> IntSet+deleteBM !kx !bm t@(Bin p l r)+  | nomatch kx p = t+  | left kx p    = bin p (deleteBM kx bm l) r+  | otherwise    = bin p l (deleteBM kx bm r)+deleteBM kx bm t@(Tip kx' bm')+  | kx' == kx = tip kx (bm' .&. complement bm)+  | otherwise = t+deleteBM _ _ Nil = Nil++-- | \(O(\min(n,W))\). @('alterF' f x s)@ can delete or insert @x@ in @s@ depending+-- on whether it is already present in @s@.+--+-- In short:+--+-- @+-- 'member' x \<$\> 'alterF' f x s = f ('member' x s)+-- @+--+-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".+--+-- @since 0.6.3.1+alterF :: Functor f => (Bool -> f Bool) -> Key -> IntSet -> f IntSet+alterF f k s = fmap choose (f member_)+  where+    member_ = member k s++    (inserted, deleted)+      | member_   = (s         , delete k s)+      | otherwise = (insert k s, s         )++    choose True  = inserted+    choose False = deleted+#ifndef __GLASGOW_HASKELL__+{-# INLINE alterF #-}+#else+{-# INLINABLE [2] alterF #-}++{-# RULES+"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s+ #-}+#endif++{-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> IntSet -> Identity IntSet #-}++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of sets.+unions :: Foldable f => f IntSet -> IntSet+unions xs+  = Foldable.foldl' union empty xs+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union of two sets.+union :: IntSet -> IntSet -> IntSet+union t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> Bin p1 (union l1 t2) r1+  ABR -> Bin p1 l1 (union r1 t2)+  BAL -> Bin p2 (union t1 l2) r2+  BAR -> Bin p2 l2 (union t1 r2)+  EQL -> Bin p1 (union l1 l2) (union r1 r2)+  NOM -> link (unPrefix p1) t1 (unPrefix p2) t2+union t@(Bin _ _ _) (Tip kx bm) = insertBM kx bm t+union t@(Bin _ _ _) Nil = t+union (Tip kx bm) t = insertBM kx bm t+union Nil t = t+++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference between two sets.+difference :: IntSet -> IntSet -> IntSet+difference t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> bin p1 (difference l1 t2) r1+  ABR -> bin p1 l1 (difference r1 t2)+  BAL -> difference t1 l2+  BAR -> difference t1 r2+  EQL -> bin p1 (difference l1 l2) (difference r1 r2)+  NOM -> t1++difference t@(Bin _ _ _) (Tip kx bm) = deleteBM kx bm t+difference t@(Bin _ _ _) Nil = t++difference t1@(Tip kx bm) t2 = differenceTip t2+  where differenceTip (Bin p2 l2 r2) | nomatch kx p2 = t1+                                     | left kx p2 = differenceTip l2+                                     | otherwise = differenceTip r2+        differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2)+                                    | otherwise = t1+        differenceTip Nil = t1++difference Nil _     = Nil++++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection of two sets.+intersection :: IntSet -> IntSet -> IntSet+intersection t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> intersection l1 t2+  ABR -> intersection r1 t2+  BAL -> intersection t1 l2+  BAR -> intersection t1 r2+  EQL -> bin p1 (intersection l1 l2) (intersection r1 r2)+  NOM -> Nil++intersection t1@(Bin _ _ _) (Tip kx2 bm2) = intersectBM t1+  where intersectBM (Bin p1 l1 r1) | nomatch kx2 p1 = Nil+                                   | left kx2 p1    = intersectBM l1+                                   | otherwise      = intersectBM r1+        intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+                                  | otherwise = Nil+        intersectBM Nil = Nil++intersection (Bin _ _ _) Nil = Nil++intersection (Tip kx1 bm1) t2 = intersectBM t2+  where intersectBM (Bin p2 l2 r2) | nomatch kx1 p2 = Nil+                                   | left kx1 p2    = intersectBM l2+                                   | otherwise      = intersectBM r2+        intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+                                  | otherwise = Nil+        intersectBM Nil = Nil++intersection Nil _ = Nil++-- | The intersection of a series of sets. Intersections are performed+-- left-to-right.+--+-- @since 0.8+intersections :: NonEmpty IntSet -> IntSet+intersections (s0 :| ss)+  | null s0 = empty+  | otherwise = List.foldr go id ss s0+  where+    go s r acc+      | null acc' = empty+      | otherwise = r acc'+      where+        acc' = intersection acc s+{-# INLINABLE intersections #-}++-- | @IntSet@s form a 'Semigroup' under 'intersection'.+--+-- A @Monoid@ instance is not defined because it would be impractical to+-- construct @mempty@, the @IntSet@ containing all @Int@s.+--+-- @since 0.8+newtype Intersection = Intersection { getIntersection :: IntSet }+  deriving (Show, Eq, Ord)++instance Semigroup Intersection where+  Intersection s1 <> Intersection s2 = Intersection (intersection s1 s2)++  stimes = stimesIdempotent+  {-# INLINABLE stimes #-}++  sconcat =+#ifdef __GLASGOW_HASKELL__+    coerce intersections+#else+    Intersection . intersections . fmap getIntersection+#endif++{--------------------------------------------------------------------+  Symmetric difference+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The symmetric difference of two sets.+--+-- The result contains elements that appear in exactly one of the two sets.+--+-- @+-- symmetricDifference (fromList [0,2,4,6]) (fromList [0,3,6,9]) == fromList [2,3,4,9]+-- @+--+-- @since 0.8+symmetricDifference :: IntSet -> IntSet -> IntSet+symmetricDifference t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) =+  case treeTreeBranch p1 p2 of+    ABL -> bin p1 (symmetricDifference l1 t2) r1+    ABR -> bin p1 l1 (symmetricDifference r1 t2)+    BAL -> bin p2 (symmetricDifference t1 l2) r2+    BAR -> bin p2 l2 (symmetricDifference t1 r2)+    EQL -> bin p1 (symmetricDifference l1 l2) (symmetricDifference r1 r2)+    NOM -> link (unPrefix p1) t1 (unPrefix p2) t2+symmetricDifference t1@(Bin _ _ _) t2@(Tip kx2 bm2) = symDiffTip t2 kx2 bm2 t1+symmetricDifference t1@(Bin _ _ _) Nil = t1+symmetricDifference t1@(Tip kx1 bm1) t2 = symDiffTip t1 kx1 bm1 t2+symmetricDifference Nil t2 = t2++symDiffTip :: IntSet -> Int -> BitMap -> IntSet -> IntSet+symDiffTip !t1 !kx1 !bm1 = go+  where+    go t2@(Bin p2 l2 r2)+      | nomatch kx1 p2 = linkKey kx1 t1 p2 t2+      | left kx1 p2 = bin p2 (go l2) r2+      | otherwise = bin p2 l2 (go r2)+    go t2@(Tip kx2 bm2)+      | kx1 == kx2 = tip kx1 (bm1 `xor` bm2)+      | otherwise = link kx1 t1 kx2 t2+    go Nil = t1++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Is this a proper subset? (ie. a subset but not equal).+isProperSubsetOf :: IntSet -> IntSet -> Bool+isProperSubsetOf t1 t2+  = case subsetCmp t1 t2 of+      LT -> True+      _  -> False++subsetCmp :: IntSet -> IntSet -> Ordering+subsetCmp t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> GT+  ABR -> GT+  BAL -> case subsetCmp t1 l2 of GT -> GT ; _ -> LT+  BAR -> case subsetCmp t1 r2 of GT -> GT ; _ -> LT+  EQL -> subsetCmpEq+  NOM -> GT  -- disjoint+  where+    subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of+                    (GT,_ ) -> GT+                    (_ ,GT) -> GT+                    (EQ,EQ) -> EQ+                    _       -> LT++subsetCmp (Bin _ _ _) _ = GT+subsetCmp (Tip kx1 bm1) (Tip kx2 bm2)+  | kx1 /= kx2                  = GT -- disjoint+  | bm1 == bm2                  = EQ+  | bm1 .&. complement bm2 == 0 = LT+  | otherwise                   = GT+subsetCmp t1@(Tip kx _) (Bin p l r)+  | nomatch kx p = GT+  | left kx p    = case subsetCmp t1 l of GT -> GT ; _ -> LT+  | otherwise    = case subsetCmp t1 r of GT -> GT ; _ -> LT+subsetCmp (Tip _ _) Nil = GT -- disjoint+subsetCmp Nil Nil = EQ+subsetCmp Nil _   = LT++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Is this a subset?+-- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.++isSubsetOf :: IntSet -> IntSet -> Bool+isSubsetOf t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> False+  ABR -> False+  BAL -> isSubsetOf t1 l2+  BAR -> isSubsetOf t1 r2+  EQL -> isSubsetOf l1 l2 && isSubsetOf r1 r2+  NOM -> False+isSubsetOf (Bin _ _ _) _ = False+isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0+isSubsetOf t1@(Tip kx _) (Bin p l r)+  | nomatch kx p = False+  | left kx p    = isSubsetOf t1 l+  | otherwise    = isSubsetOf t1 r+isSubsetOf (Tip _ _) Nil = False+isSubsetOf Nil _         = True+++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Check whether two sets are disjoint (i.e. their intersection+--   is empty).+--+-- > disjoint (fromList [2,4,6])   (fromList [1,3])     == True+-- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False+-- > disjoint (fromList [1,2])     (fromList [1,2,3,4]) == False+-- > disjoint (fromList [])        (fromList [])        == True+--+-- @since 0.5.11+disjoint :: IntSet -> IntSet -> Bool+disjoint t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> disjoint l1 t2+  ABR -> disjoint r1 t2+  BAL -> disjoint t1 l2+  BAR -> disjoint t1 r2+  EQL -> disjoint l1 l2 && disjoint r1 r2+  NOM -> True++disjoint t1@(Bin _ _ _) (Tip kx2 bm2) = disjointBM t1+  where disjointBM (Bin p1 l1 r1) | nomatch kx2 p1 = True+                                  | left kx2 p1    = disjointBM l1+                                  | otherwise      = disjointBM r1+        disjointBM (Tip kx1 bm1) | kx1 == kx2 = (bm1 .&. bm2) == 0+                                 | otherwise = True+        disjointBM Nil = True++disjoint (Bin _ _ _) Nil = True++disjoint (Tip kx1 bm1) t2 = disjointBM t2+  where disjointBM (Bin p2 l2 r2) | nomatch kx1 p2 = True+                                  | left kx1 p2    = disjointBM l2+                                  | otherwise      = disjointBM r2+        disjointBM (Tip kx2 bm2) | kx1 == kx2 = (bm1 .&. bm2) == 0+                                 | otherwise = True+        disjointBM Nil = True++disjoint Nil _ = True+++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all elements that satisfy some predicate.+filter :: (Key -> Bool) -> IntSet -> IntSet+filter predicate t+  = case t of+      Bin p l r+        -> bin p (filter predicate l) (filter predicate r)+      Tip kx bm+        -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm)+      Nil -> Nil+  where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+                         | otherwise           = bm+        {-# INLINE bitPred #-}++-- | \(O(n)\). partition the set according to some predicate.+partition :: (Key -> Bool) -> IntSet -> (IntSet,IntSet)+partition predicate0 t0 = toPair $ go predicate0 t0+  where+    go predicate t+      = case t of+          Bin p l r+            -> let (l1 :*: l2) = go predicate l+                   (r1 :*: r2) = go predicate r+               in bin p l1 r1 :*: bin p l2 r2+          Tip kx bm+            -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm+               in  tip kx bm1 :*: tip kx (bm `xor` bm1)+          Nil -> (Nil :*: Nil)+      where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+                             | otherwise           = bm+            {-# INLINE bitPred #-}++-- | \(O(\min(n,W))\). Take while a predicate on the elements holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'+-- takeWhileAntitone p = 'filter' p+-- @+--+-- @since 0.6.7+takeWhileAntitone :: (Key -> Bool) -> IntSet -> IntSet+takeWhileAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then bin p (go predicate l) r+        else go predicate r+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = bin p l (go predicate' r)+      | otherwise               = go predicate' l+    go predicate' (Tip kx bm) = tip kx (takeWhileAntitoneBits kx predicate' bm)+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Drop while a predicate on the elements holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'+-- dropWhileAntitone p = 'filter' (not . p)+-- @+--+-- @since 0.6.7+dropWhileAntitone :: (Key -> Bool) -> IntSet -> IntSet+dropWhileAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then go predicate l+        else bin p l (go predicate r)+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = go predicate' r+      | otherwise               = bin p (go predicate' l) r+    go predicate' (Tip kx bm) = tip kx (bm `xor` takeWhileAntitoneBits kx predicate' bm)+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Divide a set at the point where a predicate on the elements stops holding.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = 'partition' p xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set+-- at some /unspecified/ point.+--+-- @since 0.6.7+spanAntitone :: (Key -> Bool) -> IntSet -> (IntSet, IntSet)+spanAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then+          case go predicate l of+            (lt :*: gt) ->+              let !lt' = bin p lt r+              in (lt', gt)+        else+          case go predicate r of+            (lt :*: gt) ->+              let !gt' = bin p l gt+              in (lt, gt')+    _ -> case go predicate t of+          (lt :*: gt) -> (lt, gt)+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = case go predicate' r of (lt :*: gt) -> bin p l lt :*: gt+      | otherwise               = case go predicate' l of (lt :*: gt) -> lt :*: bin p gt r+    go predicate' (Tip kx bm) = let bm' = takeWhileAntitoneBits kx predicate' bm+                                in (tip kx bm' :*: tip kx (bm `xor` bm'))+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). The expression (@'split' x set@) is a pair @(set1,set2)@+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@+-- comprises the elements of @set@ greater than @x@.+--+-- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])+split :: Key -> IntSet -> (IntSet,IntSet)+split x t =+  case t of+    Bin p l r+      | signBranch p ->+        if x >= 0  -- handle negative numbers.+        then+          case go x l of+            (lt :*: gt) ->+              let !lt' = bin p lt r+              in (lt', gt)+        else+          case go x r of+            (lt :*: gt) ->+              let !gt' = bin p l gt+              in (lt, gt')+    _ -> case go x t of+          (lt :*: gt) -> (lt, gt)+  where+    go !x' t'@(Bin p l r)+        | nomatch x' p = if x' < unPrefix p then (Nil :*: t') else (t' :*: Nil)+        | left x' p    = case go x' l of (lt :*: gt) -> lt :*: bin p gt r+        | otherwise    = case go x' r of (lt :*: gt) -> bin p l lt :*: gt+    go x' t'@(Tip kx' bm)+        | kx' > x'          = (Nil :*: t')+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = (t' :*: Nil)+        | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)+            where lowerBitmap = bitmapOf x' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOf x')+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Key -> IntSet -> (IntSet,Bool,IntSet)+splitMember x t =+  case t of+    Bin p l r+      | signBranch p ->+        if x >= 0 -- handle negative numbers.+        then+          case go x l of+            (lt, fnd, gt) ->+              let !lt' = bin p lt r+              in (lt', fnd, gt)+        else+          case go x r of+            (lt, fnd, gt) ->+              let !gt' = bin p l gt+              in (lt, fnd, gt')+    _ -> go x t+  where+    go !x' t'@(Bin p l r)+        | nomatch x' p = if x' < unPrefix p then (Nil, False, t') else (t', False, Nil)+        | left x' p =+          case go x' l of+            (lt, fnd, gt) ->+              let !gt' = bin p gt r+              in (lt, fnd, gt')+        | otherwise =+          case go x' r of+            (lt, fnd, gt) ->+              let !lt' = bin p l lt+              in (lt', fnd, gt)+    go x' t'@(Tip kx' bm)+        | kx' > x'          = (Nil, False, t')+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = (t', False, Nil)+        | otherwise = let !lt = tip kx' (bm .&. lowerBitmap)+                          !found = (bm .&. bitmapOfx') /= 0+                          !gt = tip kx' (bm .&. higherBitmap)+                      in (lt, found, gt)+            where bitmapOfx' = bitmapOf x'+                  lowerBitmap = bitmapOfx' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOfx')+    go _ Nil = (Nil, False, Nil)++{----------------------------------------------------------------------+  Min/Max+----------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Retrieves the maximal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+maxView :: IntSet -> Maybe (Key, IntSet)+maxView t =+  case t of Nil -> Nothing+            Bin p l r | signBranch p -> case go l of (result, l') -> Just (result, bin p l' r)+            _ -> Just (go t)+  where+    go (Bin p l r) = case go r of (result, r') -> (result, bin p l r')+    go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))+    go Nil = error "maxView Nil"++-- | \(O(\min(n,W))\). Retrieves the minimal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+minView :: IntSet -> Maybe (Key, IntSet)+minView t =+  case t of Nil -> Nothing+            Bin p l r | signBranch p -> case go r of (result, r') -> Just (result, bin p l r')+            _ -> Just (go t)+  where+    go (Bin p l r) = case go l of (result, l') -> (result, bin p l' r)+    go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))+    go Nil = error "minView Nil"++-- | \(O(\min(n,W))\). Delete and find the minimal element.+--+-- > deleteFindMin set = (findMin set, deleteMin set)+deleteFindMin :: IntSet -> (Key, IntSet)+deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView++-- | \(O(\min(n,W))\). Delete and find the maximal element.+--+-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: IntSet -> (Key, IntSet)+deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView++lookupMinSure :: IntSet -> Key+lookupMinSure (Tip kx bm) = kx + lowestBitSet bm+lookupMinSure (Bin _ l _) = lookupMinSure l+lookupMinSure Nil         = error "lookupMin Nil"++-- | \(O(\min(n,W))\). The minimal element of the set. Returns 'Nothing' if the+-- set is empty.+--+-- @since 0.8+lookupMin :: IntSet -> Maybe Key+lookupMin Nil         = Nothing+lookupMin (Tip kx bm) = Just $! kx + lowestBitSet bm+lookupMin (Bin p l r) = Just $! lookupMinSure (if signBranch p then r else l)+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The minimal element of the set. Calls 'error' if the set+-- is empty.+findMin :: IntSet -> Key+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "findMin: empty set has no minimal element"++lookupMaxSure :: IntSet -> Key+lookupMaxSure (Tip kx bm) = kx + highestBitSet bm+lookupMaxSure (Bin _ _ r) = lookupMaxSure r+lookupMaxSure Nil         = error "lookupMax Nil"++-- | \(O(\min(n,W))\). The maximal element of the set. Returns 'Nothing' if the+-- set is empty.+--+-- @since 0.8+lookupMax :: IntSet -> Maybe Key+lookupMax Nil         = Nothing+lookupMax (Tip kx bm) = Just $! kx + highestBitSet bm+lookupMax (Bin p l r) = Just $! lookupMaxSure (if signBranch p then l else r)+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The maximal element of the set. Calls 'error' if the set+-- is empty.+findMax :: IntSet -> Key+findMax t+  | Just r <- lookupMax t = r+  | otherwise = error "findMax: empty set has no maximal element"++-- | \(O(\min(n,W))\). Delete the minimal element. Returns an empty set if the set is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#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.+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapMonotonic f s == map f s+-- >     where ls = toList s+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'map' if the+-- precondition may not hold.+--+-- @since 0.6.3.1++-- Note that for now the test is insufficient to support any fancier implementation.+mapMonotonic :: (Key -> Key) -> IntSet -> IntSet+mapMonotonic f = fromDistinctAscList . List.map f . toAscList+++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator.+--+{-# DEPRECATED fold "Use Data.IntSet.foldr instead" #-}+fold :: (Key -> b -> b) -> b -> IntSet -> b+fold = foldr+{-# INLINE fold #-}++-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.+--+-- For example,+--+-- > toAscList set = foldr (:) [] set+foldr :: (Key -> b -> b) -> b -> IntSet -> b+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin p l r | signBranch p -> go (go z l) r -- put negative numbers before+                      | otherwise -> go (go z r) l+            _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip kx bm) = foldrBits kx f z' bm+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (Key -> b -> b) -> b -> IntSet -> b+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin p l r | signBranch p -> go (go z l) r -- put negative numbers before+                      | otherwise -> go (go z r) l+            _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip kx bm) = foldr'Bits kx f z' bm+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the elements in the set using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.+--+-- For example,+--+-- > toDescList set = foldl (flip (:)) [] set+foldl :: (a -> Key -> a) -> a -> IntSet -> a+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin p l r | signBranch p -> go (go z r) l -- put negative numbers before+                      | otherwise -> go (go z l) r+            _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip kx bm) = foldlBits kx f z' bm+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> Key -> a) -> a -> IntSet -> a+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin p l r | signBranch p -> go (go z r) l -- put negative numbers before+                      | otherwise -> go (go z l) r+            _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip kx bm) = foldl'Bits kx f z' bm+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++-- | \(O(n)\). Map the elements in the set to a monoid and combine with @(<>)@.+--+-- @since 0.8+foldMap :: Monoid a => (Key -> a) -> IntSet -> a+foldMap f = \t ->  -- Use lambda t to be inlinable with one argument only.+  case t of+    Bin p l r+#if MIN_VERSION_base(4,11,0)+      | signBranch p -> go r <> go l  -- handle negative numbers+      | otherwise -> go l <> go r+#else+      | signBranch p -> go r `mappend` go l  -- handle negative numbers+      | otherwise -> go l `mappend` go r+#endif+    _ -> go t+  where+#if MIN_VERSION_base(4,11,0)+    go (Bin _ l r) = go l <> go r+#else+    go (Bin _ l r) = go l `mappend` go r+#endif+    go (Tip kx bm) = foldMapBits kx f bm+    go Nil = mempty+{-# INLINE foldMap #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order.+-- Subject to list fusion.+elems :: IntSet -> [Key]+elems+  = toAscList++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.6.2+instance GHC.Exts.IsList IntSet where+  type Item IntSet = Key+  fromList = fromList+  toList   = toList+#endif++-- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion.+toList :: IntSet -> [Key]+toList+  = toAscList++-- | \(O(n)\). Convert the set to an ascending list of elements. Subject to list+-- fusion.+toAscList :: IntSet -> [Key]+toAscList = foldr (:) []++-- | \(O(n)\). Convert the set to a descending list of elements. Subject to list+-- fusion.+toDescList :: IntSet -> [Key]+toDescList = foldl (flip (:)) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.+-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.+foldrFB :: (Key -> b -> b) -> b -> IntSet -> b+foldrFB = foldr+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> a) -> a -> IntSet -> a+foldlFB = foldl+{-# INLINE[0] foldlFB #-}++-- Inline elems and toList, so that we need to fuse only toAscList.+{-# INLINE elems #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded to{Asc,Desc}List calls back to+-- to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were used in+-- a list fusion, otherwise it would go away in phase 1), and let compiler do+-- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it+-- before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "IntSet.toAscList" [~1] forall s . toAscList s = GHC.Exts.build (\c n -> foldrFB c n s) #-}+{-# RULES "IntSet.toAscListBack" [1] foldrFB (:) [] = toAscList #-}+{-# RULES "IntSet.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}+{-# RULES "IntSet.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}+#endif+++-- | \(O(n \min(n,W))\). Create a set from a list of integers.+fromList :: [Key] -> IntSet+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t x  = insert x t++-- | \(O(n / W)\). Create a set from a range of integers.+--+-- > fromRange (low, high) == fromList [low..high]+--+-- @since 0.7+fromRange :: (Key, Key) -> IntSet+fromRange (lx,rx)+  | lx > rx  = empty+  | lp == rp = Tip lp (bitmapOf rx `shiftLL` 1 - bitmapOf lx)+  | otherwise =+      let m = branchMask lx rx+          p = Prefix (mask lx m .|. m)+      in if signBranch p  -- handle negative numbers+         then Bin p (goR 0) (goL 0)+         else Bin p (goL (unPrefix p)) (goR (unPrefix p))+  where+    lp = prefixOf lx+    rp = prefixOf rx+    -- goL p0 = fromList [lx .. p0-1]+    -- Expected: p0 is lx where one 0-bit is flipped to 1 and all bits lower than that are 0.+    --           p0 can be 0 (pretend that bit WORD_SIZE is flipped to 1).+    goL :: Int -> IntSet+    goL !p0 = go (Tip lp (- bitmapOf lx)) (lp + lbm prefixBitMask)+      where+        go !l p | p == p0 = l+        go l p =+          let m = lbm p+              l' = Bin (Prefix p) l (goFull p (shr1 m))+          in go l' (p + m)+    -- goR p0 = fromList [p0 .. rx]+    -- Expected: p0 is a prefix of rx+    goR :: Int -> IntSet+    goR !p0 = go (Tip rp (bitmapOf rx `shiftLL` 1 - 1)) rp+      where+        go !r p | p == p0 = r+        go r p =+          let m = lbm p+              p' = p `xor` m+              r' = Bin (Prefix p) (goFull p' (shr1 m)) r+          in go r' p'+    -- goFull p m = fromList [p .. p+2*m-1]+    -- Expected: popCount m == 1, p == mask p m+    goFull :: Int -> Int -> IntSet+    goFull p m+      | m < suffixBitMask = Tip p (complement 0)+      | otherwise         = Bin (Prefix (p .|. m)) (goFull p (shr1 m)) (goFull (p .|. m) (shr1 m))+    lbm :: Int -> Int+    lbm p = p .&. negate p -- lowest bit mask+    {-# INLINE lbm #-}+    shr1 :: Int -> Int+    shr1 m = m `iShiftRL` 1+    {-# INLINE shr1 #-}++-- | \(O(n)\). Build a set from an ascending list of elements.+--+-- __Warning__: This function should be used only if the elements are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+fromAscList :: [Key] -> IntSet+fromAscList = fromMonoList+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a set from an ascending list of distinct elements.+--+-- __Warning__: This function should be used only if the elements are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+fromDistinctAscList :: [Key] -> IntSet+fromDistinctAscList = fromAscList+{-# INLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a set from a monotonic list of elements.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.+fromMonoList :: [Key] -> IntSet+fromMonoList []         = Nil+fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1+  where+    -- `addAll'` collects all keys with the prefix `px` into a single+    -- bitmap, and then proceeds with `addAll`.+    addAll' !px !bm []+        = Tip px bm+    addAll' !px !bm (ky : zs)+        | px == prefixOf ky+        = addAll' px (bm .|. bitmapOf ky) zs+        -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs)+        | py <- prefixOf ky+        , m <- branchMask px py+        , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs+        = addAll px (linkWithMask m py ty px (Tip px bm)) zs'++    -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_px !tx []+        = tx+    addAll !px !tx (ky : zs)+        | py <- prefixOf ky+        , m <- branchMask px py+        , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs+        = addAll px (linkWithMask m py ty px tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !px !bm []+        = Inserted (Tip px bm) []+    addMany' !m !px !bm zs0@(ky : zs)+        | px == prefixOf ky+        = addMany' m px (bm .|. bitmapOf ky) zs+        -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs)+        | mask px m /= mask ky m+        = Inserted (Tip (prefixOf px) bm) zs0+        | py <- prefixOf ky+        , mxy <- branchMask px py+        , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs+        = addMany m px (linkWithMask mxy py ty px (Tip px bm)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`.+    addMany !_m !_px tx []+        = Inserted tx []+    addMany !m !px tx zs0@(ky : zs)+        | mask px m /= mask ky m+        = Inserted tx zs0+        | py <- prefixOf ky+        , mxy <- branchMask px py+        , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs+        = addMany m px (linkWithMask mxy py ty px tx) zs'+{-# INLINE fromMonoList #-}++data Inserted = Inserted !IntSet ![Key]++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq IntSet where+  (==) = equal++equal :: IntSet -> IntSet -> Bool+equal (Bin p1 l1 r1) (Bin p2 l2 r2)+  = (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx1 bm1) (Tip kx2 bm2)+  = kx1 == kx2 && bm1 == bm2+equal Nil Nil = True+equal _   _   = False++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord IntSet where+  compare = compareIntSets++compareIntSets :: IntSet -> IntSet -> Ordering+compareIntSets s1 s2 = case (splitSign s1, splitSign s2) of+  ((l1, r1), (l2, r2)) -> case go l1 l2 of+    A_LT_B -> LT+    A_Prefix_B -> if null r1 then LT else GT+    A_EQ_B -> case go r1 r2 of+      A_LT_B -> LT+      A_Prefix_B -> LT+      A_EQ_B -> EQ+      B_Prefix_A -> GT+      A_GT_B -> GT+    B_Prefix_A -> if null r2 then GT else LT+    A_GT_B -> GT+  where+    go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+      ABL -> case go l1 t2 of+        A_Prefix_B -> A_GT_B+        A_EQ_B -> B_Prefix_A+        o -> o+      ABR -> A_LT_B+      BAL -> case go t1 l2 of+        A_EQ_B -> A_Prefix_B+        B_Prefix_A -> A_LT_B+        o -> o+      BAR -> A_GT_B+      EQL -> case go l1 l2 of+        A_Prefix_B -> A_GT_B+        A_EQ_B -> go r1 r2+        B_Prefix_A -> A_LT_B+        o -> o+      NOM -> if unPrefix p1 < unPrefix p2 then A_LT_B else A_GT_B+    go (Bin _ l1 _) (Tip k2 bm2) = case leftmostTipSure l1 of+      Tip' k1 bm1 -> case orderTips k1 bm1 k2 bm2 of+        A_Prefix_B -> A_GT_B+        A_EQ_B -> B_Prefix_A+        o -> o+    go (Tip k1 bm1) (Bin _ l2 _) = case leftmostTipSure l2 of+      Tip' k2 bm2 -> case orderTips k1 bm1 k2 bm2 of+        A_EQ_B -> A_Prefix_B+        B_Prefix_A -> A_LT_B+        o -> o+    go (Tip k1 bm1) (Tip k2 bm2) = orderTips k1 bm1 k2 bm2+    go Nil Nil = A_EQ_B+    go Nil _ = A_Prefix_B+    go _ Nil = B_Prefix_A++-- This type allows GHC to return unboxed ints from leftmostTipSure, as+-- $wleftmostTipSure :: IntSet -> (# Int#, Word# #)+-- On a modern enough GHC (>=9.4) this is unnecessary, we could use StrictPair+-- instead and get the same Core.+data Tip' = Tip' {-# UNPACK #-} !Int {-# UNPACK #-} !BitMap++leftmostTipSure :: IntSet -> Tip'+leftmostTipSure (Bin _ l _) = leftmostTipSure l+leftmostTipSure (Tip k bm) = Tip' k bm+leftmostTipSure Nil = error "leftmostTipSure: Nil"++orderTips :: Int -> BitMap -> Int -> BitMap -> Order+orderTips k1 bm1 k2 bm2 = case compare k1 k2 of+  LT -> A_LT_B+  EQ | bm1 == bm2 -> A_EQ_B+     | otherwise ->+         -- To lexicographically compare the elements of two BitMaps,+         -- - Find the lowest bit where they differ.+         -- - For the BitMap with this bit 0, check if all higher bits are also+         --   0. If yes it is a prefix, otherwise it is greater.+         let diff = bm1 `xor` bm2+             lowestDiff = diff .&. negate diff+             highMask = negate lowestDiff+         in if bm1 .&. lowestDiff == 0+            then (if bm1 .&. highMask == 0 then A_Prefix_B else A_GT_B)+            else (if bm2 .&. highMask == 0 then B_Prefix_A else A_LT_B)+  GT -> A_GT_B+{-# INLINE orderTips #-}++-- Split into negative and non-negative+splitSign :: IntSet -> (IntSet, IntSet)+splitSign t@(Bin p l r)+  | signBranch p = (r, l)+  | unPrefix p < 0 = (t, Nil)+  | otherwise = (Nil, t)+splitSign t@(Tip k _)+  | k < 0 = (t, Nil)+  | otherwise = (Nil, t)+splitSign Nil = (Nil, Nil)+{-# INLINE splitSign #-}++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance Show IntSet where+  showsPrec p xs = showParen (p > 10) $+    showString "fromList " . shows (toList xs)++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance Read IntSet where+#ifdef __GLASGOW_HASKELL__+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault+#else+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)+#endif++{--------------------------------------------------------------------+  NFData+--------------------------------------------------------------------}++-- The IntSet constructors consist only of strict fields of Ints and+-- IntSets, thus the default NFData instance which evaluates to whnf+-- should suffice+instance NFData IntSet where rnf x = seq x ()++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | \(O(n \min(n,W))\). Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: IntSet -> String+showTree s+  = showTreeWith True False s+++{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the set. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Bool -> Bool -> IntSet -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS+showsTree wide lbars rbars t+  = case t of+      Bin p l r+          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . showString (showBin p) . showString "\n" .+             showWide wide lbars .+             showsTree wide (withEmpty lbars) (withBar lbars) l+      Tip kx bm+          -> showsBars lbars . showString " " . shows kx . showString " + " .+                                                showsBitMap bm . showString "\n"+      Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Bool -> [String] -> IntSet -> ShowS+showsTreeHang wide bars t+  = case t of+      Bin p l r+          -> showsBars bars . showString (showBin p) . showString "\n" .+             showWide wide bars .+             showsTreeHang wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang wide (withEmpty bars) r+      Tip kx bm+          -> showsBars bars . showString " " . shows kx . showString " + " .+                                               showsBitMap bm . showString "\n"+      Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> String+showBin _+  = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars [] = id+showsBars (_ : tl) = showString (concat (reverse tl)) . showString node++showsBitMap :: Word -> ShowS+showsBitMap = showString . showBitMap++showBitMap :: Word -> String+showBitMap w = show $ foldrBits 0 (:) [] w++node :: String+node           = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars+++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}++-- | Link two @IntSet@s. The sets must not be empty. The @Prefix@es of the two+-- sets must be different. @k1@ must share the prefix of @t1@. @p2@ must be the+-- prefix of @t2@.+linkKey :: Key -> IntSet -> Prefix -> IntSet -> IntSet+linkKey k1 t1 p2 t2 = link k1 t1 (unPrefix p2) t2+{-# INLINE linkKey #-}++-- | Link two @IntSets. The sets must not be empty. The @Prefix@es of the two+-- sets must be different. @k1@ must share the prefix of @t1@ and @k2@ must+-- share the prefix of @t2@.+link :: Int -> IntSet -> Int -> IntSet -> IntSet+link k1 t1 k2 t2 = linkWithMask (branchMask k1 k2) k1 t1 k2 t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Int -> Key -> IntSet -> Key -> IntSet -> IntSet+linkWithMask m k1 t1 k2 t2+  | i2w k1 < i2w k2 = Bin p t1 t2+  | otherwise = Bin p t2 t1+  where+    p = Prefix (mask k1 m .|. m)+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> IntSet -> IntSet -> IntSet+bin _ l Nil = l+bin _ Nil r = r+bin p l r   = Bin p l r+{-# INLINE bin #-}++{--------------------------------------------------------------------+  @tip@ assures that we never have empty bitmaps within a tree.+--------------------------------------------------------------------}+tip :: Int -> BitMap -> IntSet+tip _ 0 = Nil+tip kx bm = Tip kx bm+{-# INLINE tip #-}+++{----------------------------------------------------------------------+  Functions that generate Prefix and BitMap of a Key or a Suffix.+----------------------------------------------------------------------}++suffixBitMask :: Int+suffixBitMask = finiteBitSize (undefined::Word) - 1+{-# INLINE suffixBitMask #-}++prefixBitMask :: Int+prefixBitMask = complement suffixBitMask+{-# INLINE prefixBitMask #-}++prefixOf :: Int -> Int+prefixOf x = x .&. prefixBitMask+{-# INLINE prefixOf #-}++suffixOf :: Int -> Int+suffixOf x = x .&. suffixBitMask+{-# INLINE suffixOf #-}++bitmapOfSuffix :: Int -> BitMap+bitmapOfSuffix s = 1 `shiftLL` s+{-# INLINE bitmapOfSuffix #-}++bitmapOf :: Int -> BitMap+bitmapOf x = bitmapOfSuffix (suffixOf x)+{-# INLINE bitmapOf #-}+++{----------------------------------------------------------------------+  To get best performance, we provide fast implementations of+  lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.+  If the intel bsf and bsr instructions ever become GHC primops,+  this code should be reimplemented using these.++  Performance of this code is crucial for folds, toList, filter, partition.++  The signatures of methods in question are placed after this comment.+----------------------------------------------------------------------}++lowestBitSet :: Word -> Int+highestBitSet :: Word -> Int+foldlBits :: Int -> (a -> Int -> a) -> a -> Word -> a+foldl'Bits :: Int -> (a -> Int -> a) -> a -> Word -> a+foldrBits :: Int -> (Int -> a -> a) -> a -> Word -> a+foldr'Bits :: Int -> (Int -> a -> a) -> a -> Word -> a+#if MIN_VERSION_base(4,11,0)+foldMapBits :: Semigroup a => Int -> (Int -> a) -> Word -> a+#else+foldMapBits :: Monoid a => Int -> (Int -> a) -> Word -> a+#endif+takeWhileAntitoneBits :: Int -> (Int -> Bool) -> Word -> Word++{-# INLINE lowestBitSet #-}+{-# INLINE highestBitSet #-}+{-# INLINE foldlBits #-}+{-# INLINE foldl'Bits #-}+{-# INLINE foldrBits #-}+{-# INLINE foldr'Bits #-}+{-# INLINE foldMapBits #-}+{-# INLINE takeWhileAntitoneBits #-}++#if defined(__GLASGOW_HASKELL__)++lowestBitSet x = countTrailingZeros x++highestBitSet x = WORD_SIZE_IN_BITS - 1 - countLeadingZeros x++-- Reverse the order of bits in the Word.+revWord :: Word -> Word+#if WORD_SIZE_IN_BITS==32+revWord x1 = case ((x1 `shiftRL` 1) .&. 0x55555555) .|. ((x1 .&. 0x55555555) `shiftLL` 1) of+              x2 -> case ((x2 `shiftRL` 2) .&. 0x33333333) .|. ((x2 .&. 0x33333333) `shiftLL` 2) of+                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F) `shiftLL` 4) of+                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF) .|. ((x4 .&. 0x00FF00FF) `shiftLL` 8) of+                     x5 -> ( x5 `shiftRL` 16             ) .|. ( x5               `shiftLL` 16);+#else+revWord x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of+              x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of+                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of+                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of+                     x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of+                       x6 -> ( x6 `shiftRL` 32             ) .|. ( x6               `shiftLL` 32);+#endif++foldlBits prefix f z0 bitmap = go z0 $! revWord bitmap+  where+    -- Note: We pass the z as a static argument because it helps GHC with demand+    -- analysis. See GHC #25578 for details.+    go z !bm = f (if bm' == 0 then z else go z bm') x+      where+        bi = WORD_SIZE_IN_BITS - 1 - countTrailingZeros bm+        !x = prefix .|. bi+        bm' = bm .&. (bm-1)++foldl'Bits prefix f z0 bitmap = go z0 bitmap+  where+    go !z !bm = if bm' == 0 then z' else go z' bm'+      where+        bi = countTrailingZeros bm+        !x = prefix .|. bi+        !z' = f z x+        bm' = bm .&. (bm-1)++foldrBits prefix f z0 bitmap = go bitmap z0+  where+    -- Note: We pass the z as a static argument because it helps GHC with demand+    -- analysis. See GHC #25578 for details.+    go !bm z = f x (if bm' == 0 then z else go bm' z)+      where+        bi = countTrailingZeros bm+        !x = prefix .|. bi+        bm' = bm .&. (bm-1)++foldr'Bits prefix f z0 bitmap = (go $! revWord bitmap) z0+  where+    go !bm !z = if bm' == 0 then z' else go bm' z'+      where+        bi = WORD_SIZE_IN_BITS - 1 - countTrailingZeros bm+        !x = prefix .|. bi+        !z' = f x z+        bm' = bm .&. (bm-1)++foldMapBits prefix f bitmap = go bitmap+  where+    go !bm = if bm' == 0+             then f x+#if MIN_VERSION_base(4,11,0)+             else f x <> go bm'+#else+             else f x `mappend` go bm'+#endif+      where+        bi = countTrailingZeros bm+        !x = prefix .|. bi+        bm' = bm .&. (bm-1)++takeWhileAntitoneBits prefix predicate bitmap =+  -- Binary search for the first index where the predicate returns false, but skip a predicate+  -- call if the high half of the current range is empty. This ensures+  -- min (log2 WORD_SIZE_IN_BITS + 1) (popcount bitmap) predicate calls.+  let next d h (n',b') =+        if n' .&. h /= 0 && (predicate $! prefix+b'+d) then (n' `shiftRL` d, b'+d) else (n',b')+      {-# INLINE next #-}+      (_,b) = next 1  0x2 $+              next 2  0xC $+              next 4  0xF0 $+              next 8  0xFF00 $+              next 16 0xFFFF0000 $+#if WORD_SIZE_IN_BITS==64+              next 32 0xFFFFFFFF00000000 $+#endif+              (bitmap,0)+      m = if b /= 0 || (bitmap .&. 0x1 /= 0 && predicate prefix)+          then ((2 `shiftLL` b) - 1)+          else ((1 `shiftLL` b) - 1)+  in bitmap .&. m++#else+{----------------------------------------------------------------------+  In general case we use logarithmic implementation of+  lowestBitSet and highestBitSet, which works up to bit sizes of 64.++  Folds are linear scans.+----------------------------------------------------------------------}++lowestBitSet n0 =+    let (n1,b1) = if n0 .&. 0xFFFFFFFF /= 0 then (n0,0)  else (n0 `shiftRL` 32, 32)+        (n2,b2) = if n1 .&. 0xFFFF /= 0     then (n1,b1) else (n1 `shiftRL` 16, 16+b1)+        (n3,b3) = if n2 .&. 0xFF /= 0       then (n2,b2) else (n2 `shiftRL` 8,  8+b2)+        (n4,b4) = if n3 .&. 0xF /= 0        then (n3,b3) else (n3 `shiftRL` 4,  4+b3)+        (n5,b5) = if n4 .&. 0x3 /= 0        then (n4,b4) else (n4 `shiftRL` 2,  2+b4)+        b6      = if n5 .&. 0x1 /= 0        then     b5  else                   1+b5+    in b6++highestBitSet n0 =+    let (n1,b1) = if n0 .&. 0xFFFFFFFF00000000 /= 0 then (n0 `shiftRL` 32, 32)    else (n0,0)+        (n2,b2) = if n1 .&. 0xFFFF0000 /= 0         then (n1 `shiftRL` 16, 16+b1) else (n1,b1)+        (n3,b3) = if n2 .&. 0xFF00 /= 0             then (n2 `shiftRL` 8,  8+b2)  else (n2,b2)+        (n4,b4) = if n3 .&. 0xF0 /= 0               then (n3 `shiftRL` 4,  4+b3)  else (n3,b3)+        (n5,b5) = if n4 .&. 0xC /= 0                then (n4 `shiftRL` 2,  2+b4)  else (n4,b4)+        b6      = if n5 .&. 0x2 /= 0                then                   1+b5   else     b5+    in b6++foldlBits prefix f z bm = let lb = lowestBitSet bm+                          in  go (prefix+lb) z (bm `shiftRL` lb)+  where go !_ acc 0 = acc+        go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)+                    | otherwise     = go (bi + 1)    acc     (n `shiftRL` 1)++foldl'Bits prefix f z bm = let lb = lowestBitSet bm+                           in  go (prefix+lb) z (bm `shiftRL` lb)+  where go !_ !acc 0 = acc+        go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)+                    | otherwise     = go (bi + 1)    acc     (n `shiftRL` 1)++foldrBits prefix f z bm = let lb = lowestBitSet bm+                          in  go (prefix+lb) (bm `shiftRL` lb)+  where go !_ 0 = z+        go bi n | n `testBit` 0 = f bi (go (bi + 1) (n `shiftRL` 1))+                | otherwise     =       go (bi + 1) (n `shiftRL` 1)++foldr'Bits prefix f z bm = let lb = lowestBitSet bm+                           in  go (prefix+lb) (bm `shiftRL` lb)+  where+        go !_ 0 = z+        go bi n | n `testBit` 0 = f bi $! go (bi + 1) (n `shiftRL` 1)+                | otherwise     =         go (bi + 1) (n `shiftRL` 1)++foldMapBits prefix f bm = go x0 (x0 + 1) ((bm `shiftRL` lb) `shiftRL` 1)+  where+    lb = lowestBitSet bm+    x0 = prefix + lb+    go !x !_ 0 = f x+    go !x !bi n+#if MIN_VERSION_base(4,11,0)+      | n `testBit` 0 = f x <> go bi (bi + 1) (n `shiftRL` 1)+#else+      | n `testBit` 0 = f x `mappend` go bi (bi + 1) (n `shiftRL` 1)+#endif+      | otherwise = go x (bi + 1) (n `shiftRL` 1)++takeWhileAntitoneBits prefix predicate = foldl'Bits prefix f 0 -- Does not use antitone property+  where+    f acc bi | predicate bi = acc .|. bitmapOf bi+             | otherwise    = acc++#endif+++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | \(O(1)\).  Decompose a set into pieces based on the structure of the underlying+-- tree.  This function is useful for consuming a set in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than two subsets,+--  but you should not depend on this behaviour because it can change in the+--  future without notice. Also, the current version does not continue+--  splitting all the way to individual singleton sets -- it stops at some+--  point.+splitRoot :: IntSet -> [IntSet]+splitRoot Nil = []+-- NOTE: we don't currently split below Tip, but we could.+splitRoot x@(Tip _ _) = [x]+splitRoot (Bin p l r) | signBranch p = [r, l]+                      | otherwise = [l, r] {-# INLINE splitRoot #-}
+ src/Data/IntSet/Internal/IntTreeCommons.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif++-- |+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- This module defines common constructs used by both "Data.IntSet" and+-- "Data.IntMap".+--+-- @since 0.8+--++module Data.IntSet.Internal.IntTreeCommons+  ( Key+  , Prefix(..)+  , nomatch+  , left+  , signBranch+  , TreeTreeBranch(..)+  , treeTreeBranch+  , mask+  , branchMask+  , i2w+  , Order(..)+  ) where++import Data.Bits (Bits(..), countLeadingZeros)+import Utils.Containers.Internal.BitUtil (wordSize)++#ifdef __GLASGOW_HASKELL__+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif+++type Key = Int++-- | A @Prefix@ represents some prefix of high-order bits of an @Int@.+--+-- A @Prefix@ is usually considered in the context of a+-- 'Data.IntSet.Internal.Bin' or 'Data.IntMap.Internal.Bin'.++-- See Note [IntSet structure and invariants] in Data.IntSet.Internal and+-- Note [IntMap structure and invariants] in Data.IntMap.Internal for details.+newtype Prefix = Prefix { unPrefix :: Int }+  deriving Eq++#ifdef __GLASGOW_HASKELL__+deriving instance Lift Prefix+#endif++-- | Whether the @Int@ does not start with the given @Prefix@.+--+-- An @Int@ starts with a @Prefix@ if it shares the high bits with the internal+-- @Int@ value of the @Prefix@ up to the mask bit.+--+-- @nomatch@ is usually used to determine whether a key belongs in a @Bin@,+-- since all keys in a @Bin@ share a @Prefix@.+nomatch :: Int -> Prefix -> Bool+nomatch i p = (i `xor` px) .&. prefixMask /= 0+  where+    px = unPrefix p+    prefixMask = px `xor` (-px)+{-# INLINE nomatch #-}++-- | Whether the @Int@ is to the left of the split created by a @Bin@ with this+-- @Prefix@.+--+-- This does not imply that the @Int@ belongs in this @Bin@. That fact is+-- usually determined first using @nomatch@.+left :: Int -> Prefix -> Bool+left i p = i2w i < i2w (unPrefix p)+{-# INLINE left #-}++-- | A @TreeTreeBranch@ is returned by 'treeTreeBranch' to indicate how two+-- @Bin@s relate to each other.+--+-- Consider that @A@ and @B@ are the @Bin@s whose @Prefix@es are given to+-- @treeTreeBranch@ as the first and second arguments respectively.+data TreeTreeBranch+  = ABL  -- ^ A contains B in the left child+  | ABR  -- ^ A contains B in the right child+  | BAL  -- ^ B contains A in the left child+  | BAR  -- ^ B contains A in the right child+  | EQL  -- ^ A and B have equal prefixes+  | NOM  -- ^ A and B have prefixes that do not match++-- | Calculates how two @Bin@s relate to each other by comparing their+-- @Prefix@es.++-- Notes:+-- * pw .|. (pw-1) sets every bit below the mask bit to 1. This is the greatest+--   key the Bin can have.+-- * pw .&. (pw-1) sets the mask bit and every bit below it to 0. This is the+--   smallest key the Bin can have.+--+-- First, we compare the prefixes to each other. Then we compare a prefix+-- against the greatest/smallest keys the other prefix's Bin could have. This is+-- enough to determine how the two Bins relate to each other. The conditions can+-- be stated as:+--+-- * If pw1 from Bin A is less than pw2 from Bin B, and pw2 is <= the greatest+--   key of Bin A, then Bin A contains Bin B in its right child.+-- * ...and so on++treeTreeBranch :: Prefix -> Prefix -> TreeTreeBranch+treeTreeBranch p1 p2 = case compare pw1 pw2 of+  LT | pw2 <= greatest pw1 -> ABR+     | smallest pw2 <= pw1 -> BAL+     | otherwise           -> NOM+  GT | pw1 <= greatest pw2 -> BAR+     | smallest pw1 <= pw2 -> ABL+     | otherwise           -> NOM+  EQ                       -> EQL+  where+    pw1 = i2w (unPrefix p1)+    pw2 = i2w (unPrefix p2)+    greatest pw = pw .|. (pw-1)+    smallest pw = pw .&. (pw-1)+{-# INLINE treeTreeBranch #-}++-- | Whether this @Prefix@ splits a @Bin@ at the sign bit.+--+-- This can only be True at the top level.+-- If it is true, the left child contains non-negative keys and the right child+-- contains negative keys.+signBranch :: Prefix -> Bool+signBranch p = unPrefix p == (minBound :: Int)+{-# INLINE signBranch #-}++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@.+mask :: Key -> Int -> Int+mask i m = i .&. ((-m) `xor` m)+{-# INLINE mask #-}++-- | The first switching bit where the two prefixes disagree.+--+-- Precondition for defined behavior: p1 /= p2+branchMask :: Int -> Int -> Int+branchMask p1 p2 =+  unsafeShiftL 1 (wordSize - 1 - countLeadingZeros (p1 `xor` p2))+{-# INLINE branchMask #-}++i2w :: Int -> Word+i2w = fromIntegral+{-# INLINE i2w #-}++-- Used to compare IntSets and IntMaps+data Order+  = A_LT_B     -- holds for [0,3,4] [0,3,5,1]+  | A_Prefix_B -- holds for [0,3,4] [0,3,4,5]+  | A_EQ_B     -- holds for [0,3,4] [0,3,4]+  | B_Prefix_A -- holds for [0,3,4] [0,3]+  | A_GT_B     -- holds for [0,3,4] [0,2,5]++{--------------------------------------------------------------------+  Notes+--------------------------------------------------------------------}++-- Note [INLINE bit fiddling]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It is essential that the bit fiddling functions like nomatch, mask,+-- branchMask etc are inlined. If they do not, the memory allocation skyrockets.+-- The GHC usually gets it right, but it is disastrous if it does not. Therefore+-- we explicitly mark these functions INLINE.
src/Data/Map.hs view
@@ -1,10 +1,6 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif- #ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DataKinds, FlexibleContexts, MonoLocalBinds #-}+{-# LANGUAGE Safe #-} #endif  #include "containers.h"@@ -18,94 +14,91 @@ -- Maintainer  :  libraries@haskell.org -- Portability :  portable ----- /Note:/ You should use "Data.Map.Strict" instead of this module if: ----- * You will eventually need all the values stored.+-- = Finite Maps (lazy interface) ----- * The stored values don't represent large virtual data structures--- to be lazily computed.+-- This module re-exports the value lazy "Data.Map.Lazy" API. ----- An efficient implementation of ordered maps from keys to values--- (dictionaries).+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@. A 'Map' is strict in its keys but lazy+-- in its values. ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.+-- The functions in "Data.Map.Strict" are careful to force values before+-- installing them in a 'Map'. This is usually more efficient in cases where+-- laziness is not essential. The functions in this module do not do so. ----- >  import qualified Data.Map as Map+-- When deciding if this is the correct data structure to use, consider: --+-- * If you are using 'Prelude.Int' keys, you will get much better performance for most+-- operations using "Data.IntMap.Lazy".+--+-- * If you don't care about ordering, consider using @Data.HashMap.Lazy@ from the+-- <https://hackage.haskell.org/package/unordered-containers unordered-containers>+-- package instead.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- > import Data.Map (Map)+-- > import qualified Data.Map as Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Warning+--+-- The size of a 'Map' must not exceed @'Prelude.maxBound' :: 'Prelude.Int'@.+-- Violation of this condition is not detected and if the size limit is exceeded,+-- its behaviour is undefined.+--+--+-- == Implementation+-- -- The implementation of 'Map' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: -----    * Stephen Adams, \"/Efficient sets: a balancing act/\",---     Journal of Functional Programming 3(4):553-562, October 1993,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. --    * J. Nievergelt and E.M. Reingold, --      \"/Binary search trees of bounded balance/\", --      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104> -- --  Bounds for 'union', 'intersection', and 'difference' are as given --  by -- --    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>. ----- Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'. ----- /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of--- this condition is not detected and if the size limit is exceeded, its--- behaviour is undefined.+-- == Performance information ----- Operation comments contain the operation time complexity in--- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map.+--+-- Operations like 'lookup', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+-- -----------------------------------------------------------------------------  module Data.Map     ( module Data.Map.Lazy-#ifdef __GLASGOW_HASKELL__-    , insertWith'-    , insertWithKey'-    , insertLookupWithKey'-    , fold-    , foldWithKey-#endif     ) where  import Data.Map.Lazy--#ifdef __GLASGOW_HASKELL__-import Utils.Containers.Internal.TypeError---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.insertWith'.-insertWith' :: Whoops "Data.Map.insertWith' is gone. Use Data.Map.Strict.insertWith."-            => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWith' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.insertWithKey'.-insertWithKey' :: Whoops "Data.Map.insertWithKey' is gone. Use Data.Map.Strict.insertWithKey."-               => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKey' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.insertLookupWithKey'.-insertLookupWithKey' :: Whoops "Data.Map.insertLookupWithKey' is gone. Use Data.Map.Strict.insertLookupWithKey."-                     => (k -> a -> a -> a) -> k -> a -> Map k a-                     -> (Maybe a, Map k a)-insertLookupWithKey' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.foldr'.-fold :: Whoops "Data.Map.fold is gone. Use foldr."-     => (a -> b -> b) -> b -> Map k a -> b-fold _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'foldrWithKey'.-foldWithKey :: Whoops "Data.Map.foldWithKey is gone. Use foldrWithKey."-            => (k -> a -> b -> b) -> b -> Map k a -> b-foldWithKey _ _ _ = undefined-#endif
src/Data/Map/Internal.hs view
@@ -7,8 +7,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-}-#endif #define USE_MAGIC_PROXY 1+#endif  #ifdef USE_MAGIC_PROXY {-# LANGUAGE MagicHash #-}@@ -43,40 +43,40 @@ -- Authors importing this module are expected to track development -- closely. ----- = Description ----- An efficient implementation of maps from keys to values (dictionaries).+-- = Finite Maps (lazy interface internals) ----- Since many function names (but not the type name) clash with--- "Prelude" names, this module is usually imported @qualified@, e.g.+-- 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. ----- >  import Data.Map (Map)--- >  import qualified Data.Map 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>.+--      \"/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'. ----- Operation comments contain the operation time complexity in--- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.--- -- @since 0.5.9 ----------------------------------------------------------------------------- @@ -186,6 +186,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -288,6 +291,7 @@      -- * Filter     , filter+    , filterKeys     , filterWithKey      , takeWhileAntitone@@ -355,15 +359,18 @@     , link     , link2     , glue-    , fromDistinctAscList_linkTop-    , fromDistinctAscList_linkAll-    , fromDistinctDescList_linkTop-    , fromDistinctDescList_linkAll+    , ascLinkTop+    , ascLinkAll+    , descLinkTop+    , descLinkAll     , MaybeS(..)     , Identity(..)-    , FromDistinctMonoState(..)     , Stack(..)     , foldl'Stack+    , MapBuilder(..)+    , emptyB+    , insertB+    , finishB      -- Used by Map.Merge.Lazy     , mapWhenMissing@@ -384,8 +391,7 @@ import Data.Semigroup (Semigroup((<>))) #endif import Control.Applicative (Const (..))-import Control.DeepSeq (NFData(rnf))-import Data.Bits (shiftL, shiftR)+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf),NFData2(liftRnf2)) import qualified Data.Foldable as Foldable import Data.Bifoldable import Utils.Containers.Internal.Prelude hiding@@ -398,6 +404,7 @@ import Utils.Containers.Internal.StrictPair import Utils.Containers.Internal.StrictMaybe import Utils.Containers.Internal.BitQueue+import Utils.Containers.Internal.EqOrdUtil (EqM(..), OrdM(..)) #ifdef DEFINE_ALTERF_FALLBACK import Utils.Containers.Internal.BitUtil (wordSize) #endif@@ -411,12 +418,13 @@ 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-+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+import Text.Read hiding (lift)+#endif+import qualified Control.Category as Category  {--------------------------------------------------------------------   Operators@@ -460,11 +468,6 @@   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)@@ -481,11 +484,15 @@ deriving instance (Lift k, Lift a) => Lift (Map k a) #endif +-- | @mempty@ = 'empty' instance (Ord k) => Monoid (Map k v) where     mempty  = empty     mconcat = unions     mappend = (<>) +-- | @(<>)@ = 'union'+--+-- @since 0.5.7 instance (Ord k) => Semigroup (Map k v) where     (<>)    = union     stimes  = stimesIdempotentMonoid@@ -541,7 +548,7 @@ {-# INLINE size #-}  --- | \(O(\log n)\). Lookup the value at a key in the map.+-- | \(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.@@ -1111,8 +1118,8 @@ {-# INLINE updateWithKey #-} #endif --- | \(O(\log n)\). Lookup and update. See also 'updateWithKey'.--- The function returns changed value, if it is updated.+-- | \(O(\log n)\). Look up and update. See also 'updateWithKey'.+-- This function returns the changed value, if it is updated. -- Returns the original key value if the map entry is deleted. -- -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing@@ -1466,7 +1473,7 @@ {-# INLINABLE findIndex #-} #endif --- | \(O(\log n)\). Lookup the /index/ of a key, which is its zero-based index in+-- | \(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. --@@ -1624,8 +1631,26 @@   Minimal, Maximal --------------------------------------------------------------------} -lookupMinSure :: k -> a -> Map k a -> (k, a)-lookupMinSure k a Tip = (k, a)+-- 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.@@ -1637,7 +1662,8 @@  lookupMin :: Map k a -> Maybe (k,a) lookupMin Tip = Nothing-lookupMin (Bin _ k x l _) = Just $! lookupMinSure k x l+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. --@@ -1649,8 +1675,8 @@   | 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 :: 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.@@ -1662,7 +1688,8 @@  lookupMax :: Map k a -> Maybe (k, a) lookupMax Tip = Nothing-lookupMax (Bin _ k x _ r) = Just $! lookupMaxSure k x r+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. --@@ -2066,6 +2093,38 @@ #endif  {--------------------------------------------------------------------+  Symmetric difference+--------------------------------------------------------------------}++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- The symmetric difference of two maps.+--+-- The result contains entries whose keys appear in exactly one of the two maps.+--+-- @+-- symmetricDifference+--   (fromList [(0,\'q\'),(2,\'b\'),(4,\'w\'),(6,\'o\')])+--   (fromList [(0,\'e\'),(3,\'r\'),(6,\'t\'),(9,\'s\')])+-- ==+-- fromList [(2,\'b\'),(3,\'r\'),(4,\'w\'),(9,\'s\')]+-- @+--+-- @since 0.8+symmetricDifference :: Ord k => Map k a -> Map k a -> Map k a+symmetricDifference Tip t2 = t2+symmetricDifference t1 Tip = t1+symmetricDifference (Bin _ k x l1 r1) t2+  | found = link2 l1l2 r1r2+  | otherwise = link k x l1l2 r1r2+  where+    !(l2, found, r2) = splitMember k t2+    !l1l2 = symmetricDifference l1 l2+    !r1r2 = symmetricDifference r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE symmetricDifference #-}+#endif++{--------------------------------------------------------------------   Disjoint --------------------------------------------------------------------} -- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Check whether the key sets of two@@ -2099,7 +2158,7 @@ -- 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+-- 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")] --@@ -2111,6 +2170,22 @@ -- '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@@ -2709,7 +2784,7 @@  -- | \(O(n+m)\). An unsafe general 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 'merge' or 'mergeA'. --@@ -2747,6 +2822,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 =@@ -2872,6 +2948,19 @@ filter p m   = filterWithKey (\_ x -> p x) m +-- | \(O(n)\). Filter all keys that satisfy the predicate.+--+-- @+-- filterKeys p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- > filterKeys (> 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+--+-- @since 0.8++filterKeys :: (k -> Bool) -> Map k a -> Map k a+filterKeys p m = filterWithKey (\k _ -> p k) m+ -- | \(O(n)\). Filter all keys\/values that satisfy the predicate. -- -- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"@@ -2891,12 +2980,12 @@ 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)+  liftA3 combine (filterWithKeyA p l) (p kx x) (filterWithKeyA p r)   where-    combine True pl pr+    combine pl True pr       | pl `ptrEq` l && pr `ptrEq` r = t       | otherwise = link kx x pl pr-    combine False pl pr = link2 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,@@ -3161,6 +3250,8 @@ -- | \(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.@@ -3170,7 +3261,7 @@ -- > 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) []+mapKeys f m = finishB (foldlWithKey' (\b kx x -> insertB (f kx) x b) emptyB m) #if __GLASGOW_HASKELL__ {-# INLINABLE mapKeys #-} #endif@@ -3178,6 +3269,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@@ -3189,7 +3282,8 @@ -- Also see the performance note on 'fromListWith'.  mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a-mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []+mapKeysWith c f m =+  finishB (foldlWithKey' (\b kx x -> insertWithB c (f kx) x b) emptyB m) #if __GLASGOW_HASKELL__ {-# INLINABLE mapKeysWith #-} #endif@@ -3199,7 +3293,6 @@ -- @'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]@@ -3209,6 +3302,10 @@ -- 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@@ -3392,7 +3489,8 @@ -- -- > 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)@@ -3411,7 +3509,8 @@ -- -- > 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)@@ -3432,55 +3531,20 @@ -- 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)] = 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+fromList xs = finishB (Foldable.foldl' (\b (kx, x) -> insertB kx x b) emptyB xs)+{-# INLINE fromList #-} -- INLINE for fusion  -- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'. --+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+-- -- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")] -- > fromListWith (++) [] == empty --@@ -3516,14 +3580,14 @@ -- > 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'. --+-- 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@@ -3531,13 +3595,9 @@ -- Also see the performance note on 'fromListWith'.  fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromListWithKey f xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t-#if __GLASGOW_HASKELL__-{-# INLINABLE fromListWithKey #-}-#endif+fromListWithKey f xs =+  finishB (Foldable.foldl' (\b (kx, x) -> insertWithB (f kx) kx x b) emptyB xs)+{-# INLINE fromListWithKey #-}  -- INLINE for fusion  -- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list fusion. --@@ -3606,35 +3666,26 @@     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./ --+-- __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-  = 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+fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs+{-# 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,"b")] == fromList [(3, "b"), (5, "b")] -- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True@@ -3643,26 +3694,15 @@ -- @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+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.--- /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@@ -3670,13 +3710,14 @@ 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@@ -3688,14 +3729,15 @@ 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@@ -3704,28 +3746,23 @@ -- Also see the performance note on 'fromListWith'.  fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromAscListWithKey f xs-  = fromDistinctAscList (combineEq f xs)+fromAscListWithKey f xs = ascLinkAll (Foldable.foldl' next Nada xs)   where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq _ xs'-    = case xs' of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,zz) (x@(kx,xx):xs')-    | kx==kz    = let yy = f kx xx zz in 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 -> 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.--- /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@@ -3734,90 +3771,79 @@ -- Also see the performance note on 'fromListWith'.  fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromDescListWithKey f xs-  = fromDistinctDescList (combineEq f xs)+fromDescListWithKey f xs = descLinkAll (Foldable.foldl' next Nada xs)   where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq _ xs'-    = case xs' of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,zz) (x@(kx,xx):xs')-    | kx==kz    = let yy = f kx xx zz in combineEq' (kx,yy) xs'-    | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescListWithKey #-}-#endif+    next stk (!ky, y) = case stk of+      Push kx x r stk'+        | ky == kx -> Push ky (f ky y x) r stk'+        | Tip <- r -> descLinkTop ky y 1 (singleton kx x) stk'+        | otherwise -> Push ky y Tip stk+      Nada -> Push ky y Tip stk+{-# INLINE fromDescListWithKey #-}  -- INLINE for fusion   -- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time.--- /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 -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 #-}+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 -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 #-}+ascLinkAll :: Stack k a -> Map k a+ascLinkAll stk = foldl'Stack (\r kx x l -> link kx x l r) Tip stk+{-# INLINABLE ascLinkAll #-}  -- | \(O(n)\). Build a map from a descending list of distinct elements in linear time.--- /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"), (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)+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 -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 #-}+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 #-} -data FromDistinctMonoState k a-  = State0 !(Stack k a)-  | State1 !(Map k a) !(Stack k a)+descLinkAll :: Stack k a -> Map k a+descLinkAll stk = foldl'Stack (\l kx x r -> link kx x l r) Tip stk+{-# INLINABLE descLinkAll #-}  data Stack k a = Push !k a !(Map k a) !(Stack k a) | Nada @@ -3942,6 +3968,57 @@ data StrictTriple a b c = StrictTriple !a !b !c  {--------------------------------------------------------------------+  MapBuilder+--------------------------------------------------------------------}++-- See Note [SetBuilder] in Data.Set.Internal++data MapBuilder k a+  = BAsc !(Stack k a)+  | BMap !(Map k a)++-- Empty builder.+emptyB :: MapBuilder k a+emptyB = BAsc Nada++-- Insert a key and value. Replaces the old value if one already exists for+-- the key.+insertB :: Ord k => k -> a -> MapBuilder k a -> MapBuilder k a+insertB !ky y b = case b of+  BAsc stk -> case stk of+    Push kx x l stk' -> case compare ky kx of+      LT -> BMap (insert ky y (ascLinkAll stk))+      EQ -> BAsc (Push ky y l stk')+      GT -> case l of+        Tip -> BAsc (ascLinkTop stk' 1 (singleton kx x) ky y)+        Bin{} -> BAsc (Push ky y Tip stk)+    Nada -> BAsc (Push ky y Tip Nada)+  BMap m -> BMap (insert ky y m)+{-# INLINE insertB #-}++-- Insert a key and value. The new value is combined with the old value if one+-- already exists for the key.+insertWithB+  :: Ord k => (a -> a -> a) -> k -> a -> MapBuilder k a -> MapBuilder k a+insertWithB f !ky y b = case b of+  BAsc stk -> case stk of+    Push kx x l stk' -> case compare ky kx of+      LT -> BMap (insertWith f ky y (ascLinkAll stk))+      EQ -> BAsc (Push ky (f y x) l stk')+      GT -> case l of+        Tip -> BAsc (ascLinkTop stk' 1 (singleton kx x) ky y)+        Bin{} -> BAsc (Push ky y Tip stk)+    Nada -> BAsc (Push ky y Tip Nada)+  BMap m -> BMap (insertWith f ky y m)+{-# INLINE insertWithB #-}++-- Finalize the builder into a Map.+finishB :: MapBuilder k a -> Map k a+finishB (BAsc stk) = ascLinkAll stk+finishB (BMap m) = m+{-# INLINABLE finishB #-}++{--------------------------------------------------------------------   Utility functions that maintain the balance properties of the tree.   All constructors assume that all values in [l] < [k] and all values   in [r] > [k], and that [l] and [r] are valid trees.@@ -4008,29 +4085,23 @@ 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'+  | 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 = 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 #-}+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 = 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 #-}+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. --@@ -4053,6 +4124,31 @@   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).@@ -4121,7 +4217,14 @@ -- 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+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@@ -4145,13 +4248,12 @@                      | 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+              | {- 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"-              | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balance #-}+{-# NOINLINE balance_ #-}  -- Functions balanceL and balanceR are specialised versions of balance. -- balanceL only checks whether the left subtree is too big,@@ -4160,7 +4262,14 @@ -- 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+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@@ -4173,19 +4282,24 @@   (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 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"-              | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceL #-}+                   (_, _) -> 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 of+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@@ -4198,14 +4312,12 @@   (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 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"-              | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceR #-}+                   (_, _) -> error "Failure in Data.Map.balanceR_"+{-# NOINLINE balanceR_ #-}   {--------------------------------------------------------------------@@ -4218,42 +4330,70 @@   {---------------------------------------------------------------------  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 :-)+  Eq --------------------------------------------------------------------}+ instance (Eq k,Eq a) => Eq (Map k a) where-  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)+  m1 == m2 = liftEq2 (==) (==) m1 m2+  {-# INLINABLE (==) #-} -{---------------------------------------------------------------------  Ord---------------------------------------------------------------------}+-- | @since 0.5.9+instance Eq k => Eq1 (Map k) where+  liftEq = liftEq2 (==)+  {-# INLINE liftEq #-} -instance (Ord k, Ord v) => Ord (Map k v) where-    compare m1 m2 = compare (toAscList m1) (toAscList m2)+-- | @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 #-}+ {---------------------------------------------------------------------  Lifted instances+  Ord --------------------------------------------------------------------} --- | @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)+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 Eq k => Eq1 (Map k) where-    liftEq = liftEq2 (==)+instance Ord k => Ord1 (Map k) where+  liftCompare = liftCmp2 compare+  {-# INLINE liftCompare #-}  -- | @since 0.5.9 instance Ord2 Map where-    liftCompare2 cmpk cmpv m n =-        liftCompare (liftCompare2 cmpk cmpv) (toList m) (toList n)+  liftCompare2 = liftCmp2+  {-# INLINE liftCompare2 #-} --- | @since 0.5.9-instance Ord k => Ord1 (Map k) where-    liftCompare = liftCompare2 compare+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 =@@ -4363,11 +4503,25 @@     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-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)   readPrec = parens $ prec 10 $ do     Ident "fromList" <- lexP     xs <- readPrec
− 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
@@ -38,8 +38,9 @@ -- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>. -- -- This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:+-- Prelude functions, e.g. --+-- > import Data.Map.Lazy (Map) -- > import qualified Data.Map.Lazy as Map -- -- Note that the implementation is generally /left-biased/. Functions that take@@ -47,15 +48,6 @@ -- prefer the values in the first argument to those in the second. -- ----- == Detailed performance information------ The amortized running time is given for each operation, with \(n\) referring to--- the number of entries in the map.------ Benchmarks comparing "Data.Map.Lazy" with other dictionary implementations--- can be found at https://github.com/haskell-perf/dictionaries.------ -- == Warning -- -- The size of a 'Map' must not exceed @'Prelude.maxBound' :: 'Prelude.Int'@.@@ -68,20 +60,42 @@ -- The implementation of 'Map' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: -----    * Stephen Adams, \"/Efficient sets: a balancing act/\",---     Journal of Functional Programming 3(4):553-562, October 1993,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. --    * J. Nievergelt and E.M. Reingold, --      \"/Binary search trees of bounded balance/\", --      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104> -- --  Bounds for 'union', 'intersection', and 'difference' are as given --  by -- --    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>. --+--+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map.+--+-- Operations like 'lookup', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.Map.Lazy" with other dictionary implementations+-- can be found at https://github.com/haskell-perf/dictionaries.+-- -----------------------------------------------------------------------------  module Data.Map.Lazy (@@ -164,6 +178,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -219,6 +236,7 @@      -- * Filter     , filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -270,14 +288,9 @@     , maxViewWithKey      -- * Debugging-#ifdef __GLASGOW_HASKELL__-    , showTree-    , showTreeWith-#endif     , valid     ) where  import Data.Map.Internal-import Data.Map.Internal.DeprecatedShowTree (showTree, showTreeWith) import Data.Map.Internal.Debug (valid) import Prelude ()
src/Data/Map/Merge/Strict.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif
src/Data/Map/Strict.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-} #if defined(__GLASGOW_HASKELL__) {-# LANGUAGE Safe #-} #endif@@ -44,8 +43,9 @@ -- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>. -- -- This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:+-- Prelude functions, e.g. --+-- > import Data.Map.Strict (Map) -- > import qualified Data.Map.Strict as Map -- -- Note that the implementation is generally /left-biased/. Functions that take@@ -53,15 +53,6 @@ -- prefer the values in the first argument to those in the second. -- ----- == Detailed performance information------ The amortized running time is given for each operation, with \(n\) referring to--- the number of entries in the map.------ Benchmarks comparing "Data.Map.Strict" with other dictionary implementations--- can be found at https://github.com/haskell-perf/dictionaries.------ -- == Warning -- -- The size of a 'Map' must not exceed @maxBound::Int@. Violation of this@@ -80,21 +71,42 @@ -- The implementation of 'Map' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: -----    * Stephen Adams, \"/Efficient sets: a balancing act/\",---     Journal of Functional Programming 3(4):553-562, October 1993,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. --    * J. Nievergelt and E.M. Reingold, --      \"/Binary search trees of bounded balance/\", --      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104> -- --  Bounds for 'union', 'intersection', and 'difference' are as given --  by -- --    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>. -- --+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map.+--+-- Operations like 'lookup', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.Map.Strict" with other dictionary implementations+-- can be found at https://github.com/haskell-perf/dictionaries.+-- -----------------------------------------------------------------------------  -- See the notes at the beginning of Data.Map.Internal.@@ -180,6 +192,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -235,6 +250,7 @@      -- * Filter     , filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -287,10 +303,6 @@     , maxViewWithKey      -- * Debugging-#ifdef __GLASGOW_HASKELL__-    , showTree-    , showTreeWith-#endif     , valid     ) where
src/Data/Map/Strict/Internal.hs view
@@ -28,62 +28,44 @@ -- Authors importing this module are expected to track development -- closely. ----- = Description ----- An efficient implementation of ordered maps from keys to values--- (dictionaries).+-- = Finite Maps (strict interface internals) ----- API of this module is strict in both the keys and the values.--- If you need value-lazy maps, use "Data.Map.Lazy" instead.--- The 'Map' type is shared between the lazy and strict modules,--- meaning that the same 'Map' value can be passed to functions in--- both modules (although that is rarely needed).+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@. ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g. ----- >  import qualified Data.Map.Strict as Map+-- == Implementation -- -- The implementation of 'Map' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: -----    * Stephen Adams, \"/Efficient sets: a balancing act/\",---     Journal of Functional Programming 3(4):553-562, October 1993,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. --    * J. Nievergelt and E.M. Reingold, --      \"/Binary search trees of bounded balance/\", --      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104> -- --  Bounds for 'union', 'intersection', and 'difference' are as given --  by -- --    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.------ Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'.------ /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of--- this condition is not detected and if the size limit is exceeded, its--- behaviour is undefined.------ Operation comments contain the operation time complexity in--- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>. ----- Be aware that the 'Functor', 'Traversable' and 'Data.Data.Data' instances--- are the same as for the "Data.Map.Lazy" module, so if they are used--- on strict maps, the resulting maps will be lazy. -----------------------------------------------------------------------------  -- See the notes at the beginning of Data.Map.Internal.  module Data.Map.Strict.Internal     (-    -- * Strictness properties-    -- $strictness-     -- * Map type     Map(..)          -- instance Eq,Show,Read     , L.Size@@ -142,6 +124,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Symmetric difference+    , symmetricDifference+     -- ** Disjoint     , disjoint @@ -250,6 +235,7 @@      -- * Filter     , filter+    , filterKeys     , filterWithKey     , restrictKeys     , withoutKeys@@ -301,10 +287,6 @@     , maxViewWithKey      -- * Debugging-#ifdef __GLASGOW_HASKELL__-    , showTree-    , showTreeWith-#endif     , valid     ) where @@ -328,19 +310,24 @@   , filterAMissing   , merge   , mergeA-  , fromDistinctAscList_linkTop-  , fromDistinctAscList_linkAll-  , fromDistinctDescList_linkTop-  , fromDistinctDescList_linkAll-  , FromDistinctMonoState (..)+  , ascLinkTop+  , ascLinkAll+  , descLinkTop+  , descLinkAll   , Stack (..)+  , MapBuilder(..)+  , emptyB+  , insertB+  , finishB   , (!)   , (!?)   , (\\)   , argSet   , assocs   , atKeyImpl+#ifdef __GLASGOW_HASKELL__   , atKeyPlain+#endif   , balance   , balanceL   , balanceR@@ -359,6 +346,7 @@   , drop   , dropWhileAntitone   , filter+  , filterKeys   , filterWithKey   , findIndex   , findMax@@ -373,7 +361,6 @@   , foldrWithKey   , foldrWithKey'   , glue-  , insertMax   , intersection   , isProperSubmapOf   , isProperSubmapOfBy@@ -383,6 +370,7 @@   , keysSet   , link   , lookup+  , findWithDefault   , lookupGE   , lookupGT   , lookupIndex@@ -409,6 +397,7 @@   , splitAt   , splitLookup   , splitRoot+  , symmetricDifference   , take   , takeWhileAntitone   , toList@@ -418,9 +407,6 @@   , 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)@@ -429,7 +415,6 @@ import qualified Data.Map.Internal as L import Utils.Containers.Internal.StrictPair -import Data.Bits (shiftL, shiftR) #ifdef __GLASGOW_HASKELL__ import Data.Coerce #endif@@ -440,24 +425,6 @@  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 +437,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 --------------------------------------------------------------------} @@ -764,8 +705,8 @@ {-# INLINE updateWithKey #-} #endif --- | \(O(\log n)\). Lookup and update. See also 'updateWithKey'.--- The function returns changed value, if it is updated.+-- | \(O(\log n)\). Look up and update. See also 'updateWithKey'.+-- This function returns the changed value, if it is updated. -- Returns the original key value if the map entry is deleted. -- -- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing@@ -1222,7 +1163,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 +1202,7 @@              -> Map k a -> Map k b -> Map k c mergeWithKey f g1 g2 = go   where+    go Tip Tip = Tip     go Tip t2 = g2 t2     go t1 Tip = g1 t1     go (Bin _ kx x l1 r1) t2 =@@ -1271,7 +1213,7 @@                      _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"         Just x2 -> case f kx x x2 of                      Nothing -> link2 l' r'-                     Just x' -> link kx x' l' r'+                     Just !x' -> link kx x' l' r'       where         (l2, found, r2) = splitLookup kx t2         l' = go l1 l2@@ -1461,6 +1403,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,7 +1416,8 @@ -- Also see the performance note on 'fromListWith'.  mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a-mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []+mapKeysWith c f m =+  finishB (foldlWithKey' (\b kx x -> insertWithB c (f kx) x b) emptyB m) #if __GLASGOW_HASKELL__ {-# INLINABLE mapKeysWith #-} #endif@@ -1507,55 +1452,21 @@ -- 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'. --+-- 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 --@@ -1591,14 +1502,14 @@ -- > 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'. --+-- 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@@ -1606,13 +1517,9 @@ -- Also see the performance note on 'fromListWith'.  fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromListWithKey f xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t-#if __GLASGOW_HASKELL__-{-# INLINABLE fromListWithKey #-}-#endif+fromListWithKey f xs =+  finishB (Foldable.foldl' (\b (kx, x) -> insertWithB (f kx) kx x b) emptyB xs)+{-# INLINE fromListWithKey #-}  -- INLINE for fusion  {--------------------------------------------------------------------   Building trees from ascending/descending lists can be done in linear time.@@ -1627,8 +1534,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 +1546,14 @@ fromAscList :: Eq k => [(k,a)] -> Map k a fromAscList xs   = fromAscListWithKey (\_ x _ -> x) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscList #-}-#endif+{-# INLINE fromAscList #-}  -- INLINE for fusion  -- | \(O(n)\). Build a map from a descending list in linear time.--- /The precondition (input list is descending) is not checked./ --+-- __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,13 +1561,14 @@ 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@@ -1666,13 +1578,14 @@ 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@@ -1682,14 +1595,15 @@ 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@@ -1698,28 +1612,24 @@ -- Also see the performance note on 'fromListWith'.  fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromAscListWithKey f xs-  = fromDistinctAscList (combineEq f xs)+fromAscListWithKey f xs = ascLinkAll (Foldable.foldl' next Nada xs)   where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq _ xs'-    = case xs' of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,zz) (x@(kx,xx):xs')-    | kx==kz    = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'-    | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscListWithKey #-}-#endif+    next stk (!ky, y) = case stk of+      Push kx x l stk'+        | ky == kx -> let !y' = f ky y x in Push ky y' l stk'+        | Tip <- l -> y `seq` ascLinkTop stk' 1 (singleton kx x) ky y+        | otherwise -> push ky y Tip stk+      Nada -> push ky y Tip stk+    push kx !x = Push kx x+{-# INLINE fromAscListWithKey #-}  -- INLINE for fusion  -- | \(O(n)\). Build a map from a descending list in linear time with a -- 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@@ -1728,58 +1638,73 @@ -- Also see the performance note on 'fromListWith'.  fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromDescListWithKey f xs-  = fromDistinctDescList (combineEq f xs)+fromDescListWithKey f xs = descLinkAll (Foldable.foldl' next Nada xs)   where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq _ xs'-    = case xs' of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,zz) (x@(kx,xx):xs')-    | kx==kz    = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'-    | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescListWithKey #-}-#endif+    next stk (!ky, y) = case stk of+      Push kx x r stk'+        | ky == kx -> let !y' = f ky y x in Push ky y' r stk'+        | Tip <- r -> y `seq` descLinkTop ky y 1 (singleton kx x) stk'+        | otherwise -> push ky y Tip stk+      Nada -> push ky y Tip stk+    push kx !x = Push kx x+{-# INLINE fromDescListWithKey #-}  -- INLINE for fusion  -- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time.--- /The precondition is not checked./ --+-- __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 #-}
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>. -- -----------------------------------------------------------------------------
src/Data/Sequence/Internal.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE DeriveLift #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Trustworthy #-}@@ -46,35 +47,21 @@ -- Authors importing this module are expected to track development -- closely. ----- = Description ----- General purpose finite sequences.--- Apart from being finite and having strict operations, sequences--- also differ from lists in supporting a wider variety of operations--- efficiently.+-- = Finite sequences (internals) ----- An amortized running time is given for each operation, with \( n \) referring--- to the length of the sequence and \( i \) being the integral index used by--- some operations. These bounds hold even in a persistent (shared) setting.+-- The @'Seq' a@ type represents a finite sequence of values of type @a@. --+--+-- == Implementation+-- -- The implementation uses 2-3 finger trees annotated with sizes, -- as described in section 4.2 of -- --    * Ralf Hinze and Ross Paterson,---      \"Finger trees: a simple general-purpose data structure\",---      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.---      <http://staff.city.ac.uk/~ross/papers/FingerTree.html>------ /Note/: Many of these operations have the same names as similar--- operations on lists in the "Prelude". The ambiguity may be resolved--- using either qualification or the @hiding@ clause.------ /Warning/: The size of a 'Seq' must not exceed @maxBound::Int@.  Violation--- of this condition is not detected and if the size limit is exceeded, the--- behaviour of the sequence is undefined.  This is unlikely to occur in most--- applications, but some care may be required when using '><', '<*>', '*>', or--- '>>', particularly repeatedly and particularly in combination with--- 'replicate' or 'fromFunction'.+--      \"/Finger trees: a simple general-purpose data structure/\",+--      Journal of Functional Programming 16:2 (2006) pp 197-217.+--      <http://staff.city.ac.uk/~ross/papers/FingerTree.html>. -- -- @since 0.5.9 -----------------------------------------------------------------------------@@ -86,8 +73,6 @@ #else     Seq (..), #endif-    State(..),-    execState,     foldDigit,     foldNode,     foldWithIndexDigit,@@ -207,7 +192,7 @@ 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(..))@@ -220,29 +205,30 @@ 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(..)) import qualified Language.Haskell.TH.Syntax as TH -- See Note [ Template Haskell Dependencies ] import Language.Haskell.TH () import GHC.Generics (Generic, Generic1)-#endif  -- Array stuff, with GHC.Arr on GHC-import Data.Array (Ix, Array)-import qualified Data.Array-#ifdef __GLASGOW_HASKELL__ import qualified GHC.Arr-#endif--import Utils.Containers.Internal.Coercions ((.#), (.^#)) 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)@@ -392,33 +378,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 #-}@@ -504,8 +502,11 @@ instance NFData a => NFData (Seq a) where     rnf (Seq xs) = rnf xs +-- | @since 0.8+instance NFData1 Seq where+    liftRnf rnfx (Seq xs) = liftRnf (liftRnf rnfx) xs+ instance Monad Seq where-    return = pure     xs >>= f = foldl' add empty xs       where add ys x = ys >< f x     (>>) = (*>)@@ -908,10 +909,12 @@     (<|>) = (><)  instance Eq a => Eq (Seq a) where-    xs == ys = length xs == length ys && toList xs == toList ys+  xs == ys = liftEq (==) xs ys+  {-# INLINABLE (==) #-}  instance Ord a => Ord (Seq a) where-    compare xs ys = compare (toList xs) (toList ys)+  compare xs ys = liftCompare compare xs ys+  {-# INLINABLE compare #-}  #ifdef TESTING instance Show a => Show (Seq a) where@@ -929,14 +932,52 @@  -- | @since 0.5.9 instance Eq1 Seq where-    liftEq eq xs ys = length xs == length ys && liftEq eq (toList xs) (toList ys)+  liftEq eq xs ys =+    sameSize xs ys && sameSizeLiftEqLists eq (toList xs) (toList ys)+  {-# INLINE liftEq #-}  -- | @since 0.5.9 instance Ord1 Seq where-    liftCompare cmp xs ys = liftCompare cmp (toList xs) (toList ys)+  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 +998,14 @@     (xs,t) <- readLst s     pure (fromList xs, t) +-- | @mempty@ = 'empty' instance Monoid (Seq a) where     mempty = empty     mappend = (Semigroup.<>) --- | @since 0.5.7+-- | @(<>)@ = '(><)'+--+-- @since 0.5.7 instance Semigroup.Semigroup (Seq a) where     (<>)    = (><)     stimes = cycleNTimes . fromIntegral@@ -1101,16 +1145,16 @@         foldlNodeN f z t = foldl f z t     {-# INLINE foldl #-} -    foldr' _ z' EmptyT = z'-    foldr' f' z' (Single x') = f' x' z'-    foldr' f' z' (Deep _ pr' m' sf') =+    foldr' _  !z' EmptyT = z'+    foldr' f' !z' (Single x') = f' x' z'+    foldr' f' !z' (Deep _ pr' m' sf') =         (foldrDigit' f' $! (foldrTree' (foldrNode' f') $! (foldrDigit' f' z') sf') m') pr'       where         foldrTree' :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b-        foldrTree' _ z EmptyT = z-        foldrTree' f z (Single x) = f x $! z-        foldrTree' f z (Deep _ pr m sf) =-            (foldr' f $! (foldrTree' (foldrNodeN' f) $! (foldr' f $! z) sf) m) pr+        foldrTree' _ !z EmptyT = z+        foldrTree' f !z (Single x) = f x z+        foldrTree' f !z (Deep _ pr m sf) =+            (foldr' f $! (foldrTree' (foldrNodeN' f) $! foldr' f z sf) m) pr          foldrDigit' :: (a -> b -> b) -> b -> Digit a -> b         foldrDigit' f z t = foldr' f z t@@ -1122,17 +1166,17 @@         foldrNodeN' f t z = foldr' f z t     {-# INLINE foldr' #-} -    foldl' _ z' EmptyT = z'-    foldl' f' z' (Single x') = f' z' x'-    foldl' f' z' (Deep _ pr' m' sf') =+    foldl' _  !z' EmptyT = z'+    foldl' f' !z' (Single x') = f' z' x'+    foldl' f' !z' (Deep _ pr' m' sf') =         (foldlDigit' f' $!          (foldlTree' (foldlNode' f') $! (foldlDigit' f' z') pr') m')             sf'       where         foldlTree' :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b-        foldlTree' _ z EmptyT = z-        foldlTree' f z (Single xs) = f z xs-        foldlTree' f z (Deep _ pr m sf) =+        foldlTree' _ !z EmptyT = z+        foldlTree' f !z (Single xs) = f z xs+        foldlTree' f !z (Deep _ pr m sf) =             (foldl' f $! (foldlTree' (foldl' f) $! foldl' f z pr) m) sf          foldlDigit' :: (b -> a -> b) -> b -> Digit a -> b@@ -1170,6 +1214,12 @@     rnf (Single x) = rnf x     rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m +-- | @since 0.8+instance NFData1 FingerTree where+    liftRnf _ EmptyT = ()+    liftRnf rnfx (Single x) = rnfx x+    liftRnf rnfx (Deep _ pr m sf) = liftRnf rnfx pr `seq` liftRnf (liftRnf rnfx) m `seq` liftRnf rnfx sf+ {-# INLINE deep #-} deep            :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a deep pr m sf    =  Deep (size pr + size m + size sf) pr m sf@@ -1230,16 +1280,16 @@     foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d     {-# INLINE foldl #-} -    foldr' f z (One a) = f a z-    foldr' f z (Two a b) = f a $! f b z-    foldr' f z (Three a b c) = f a $! f b $! f c z-    foldr' f z (Four a b c d) = f a $! f b $! f c $! f d z+    foldr' f !z (One a) = f a z+    foldr' f !z (Two a b) = f a $! f b z+    foldr' f !z (Three a b c) = f a $! f b $! f c z+    foldr' f !z (Four a b c d) = f a $! f b $! f c $! f d z     {-# INLINE foldr' #-} -    foldl' f z (One a) = f z a-    foldl' f z (Two a b) = (f $! f z a) b-    foldl' f z (Three a b c) = (f $! (f $! f z a) b) c-    foldl' f z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d+    foldl' f !z (One a) = f z a+    foldl' f !z (Two a b) = (f $! f z a) b+    foldl' f !z (Three a b c) = (f $! (f $! f z a) b) c+    foldl' f !z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d     {-# INLINE foldl' #-}      foldr1 _ (One a) = a@@ -1272,6 +1322,13 @@     rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c     rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d +-- | @since 0.8+instance NFData1 Digit where+    liftRnf rnfx (One a) = rnfx a+    liftRnf rnfx (Two a b) = rnfx a `seq` rnfx b+    liftRnf rnfx (Three a b c) = rnfx a `seq` rnfx b `seq` rnfx c+    liftRnf rnfx (Four a b c d) = rnfx a `seq` rnfx b `seq` rnfx c `seq` rnfx d+ instance Sized a => Sized (Digit a) where     {-# INLINE size #-}     size = foldl1 (+) . fmap size@@ -1328,12 +1385,12 @@     foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c     {-# INLINE foldl #-} -    foldr' f z (Node2 _ a b) = f a $! f b z-    foldr' f z (Node3 _ a b c) = f a $! f b $! f c z+    foldr' f !z (Node2 _ a b) = f a $! f b z+    foldr' f !z (Node3 _ a b c) = f a $! f b $! f c z     {-# INLINE foldr' #-} -    foldl' f z (Node2 _ a b) = (f $! f z a) b-    foldl' f z (Node3 _ a b c) = (f $! (f $! f z a) b) c+    foldl' f !z (Node2 _ a b) = (f $! f z a) b+    foldl' f !z (Node3 _ a b c) = (f $! (f $! f z a) b) c     {-# INLINE foldl' #-}  instance Functor Node where@@ -1350,6 +1407,11 @@     rnf (Node2 _ a b) = rnf a `seq` rnf b     rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c +-- | @since 0.8+instance NFData1 Node where+    liftRnf rnfx (Node2 _ a b) = rnfx a `seq` rnfx b+    liftRnf rnfx (Node3 _ a b c) = rnfx a `seq` rnfx b `seq` rnfx c+ instance Sized (Node a) where     size (Node2 v _ _)      = v     size (Node3 v _ _ _)    = v@@ -1410,6 +1472,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 -------------------------------------------------------@@ -4220,7 +4286,7 @@ -- it gets a bit hard to read. fromList = Seq . mkTree . map_elem   where-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)     mkTree :: forall a' . [Elem a'] -> FingerTree (Elem a') #else     mkTree :: [Elem a] -> FingerTree (Elem a)@@ -4268,7 +4334,7 @@       where         d2 = Three x1 x2 x3         d1 = Three (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9) (Node3 3 y0 y1 y2)-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)         cont :: (Digit (Node (Elem a')), Digit (Elem a')) -> FingerTree (Node (Node (Elem a'))) -> FingerTree (Elem a') #endif         cont (!r1, !r2) !sub =@@ -4295,7 +4361,7 @@             !n10 = Node3 (3*s) n1 n2 n3      mkTreeC ::-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)                forall a b c . #endif                (b -> FingerTree (Node a) -> c)@@ -4337,7 +4403,7 @@     mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LCons y6 xs)))))))))))))))) =       mkTreeC cont2 (9*s) (getNodesC (3*s) (Node3 (3*s) y3 y4 y5) y6 xs)       where-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)         cont2 :: (b, Digit (Node (Node a)), Digit (Node a)) -> FingerTree (Node (Node (Node a))) -> c #endif         cont2 (b, r1, r2) !sub =
src/Data/Sequence/Internal/Sorting.hs view
@@ -76,7 +76,8 @@         foldWithIndexNode) import Utils.Containers.Internal.State (State(..), execState) -- | \( O(n \log n) \).  'sort' sorts the specified 'Seq' by the natural--- ordering of its elements.  The sort is stable.  If stability is not+-- ordering of its elements.  The sort is stable, meaning the order of equal+-- elements is preserved.  If stability is not -- required, 'unstableSort' can be slightly faster. -- -- @since 0.3.0@@ -84,7 +85,8 @@ sort = sortBy compare  -- | \( O(n \log n) \).  'sortBy' sorts the specified 'Seq' according to the--- specified comparator.  The sort is stable.  If stability is not required,+-- specified comparator.  The sort is stable, meaning the order of equal+-- elements is preserved.  If stability is not required, -- 'unstableSortBy' can be slightly faster. -- -- @since 0.3.0@@ -96,11 +98,11 @@         (buildIQ cmp (\s (Elem x) -> IQ s x IQNil) 0 xs)  -- | \( O(n \log n) \). 'sortOn' sorts the specified 'Seq' by comparing--- the results of a key function applied to each element. @'sortOn' f@ is+-- the results of a key function applied to each element. The sort is stable,+-- meaning the order of equal elements is preserved. @'sortOn' f@ is -- equivalent to @'sortBy' ('compare' ``Data.Function.on`` f)@, but has the -- performance advantage of only evaluating @f@ once for each element in the--- input list. This is called the decorate-sort-undecorate paradigm, or--- Schwartzian transform.+-- input 'Seq'. -- -- An example of using 'sortOn' might be to sort a 'Seq' of strings -- according to their length:@@ -151,8 +153,7 @@ -- comparing the results of a key function applied to each element. -- @'unstableSortOn' f@ is equivalent to @'unstableSortBy' ('compare' ``Data.Function.on`` f)@, -- but has the performance advantage of only evaluating @f@ once for each--- element in the input list. This is called the--- decorate-sort-undecorate paradigm, or Schwartzian transform.+-- element in the input 'Seq'. -- -- An example of using 'unstableSortOn' might be to sort a 'Seq' of strings -- according to their length:
src/Data/Set.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif @@ -23,19 +23,19 @@ -- For a walkthrough of the most commonly used functions see the -- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>. --+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- >  import Data.Set (Set)+-- >  import qualified Data.Set as Set+-- -- Note that the implementation is generally /left-biased/. Functions that take -- two sets as arguments and combine them, such as `union` and `intersection`, -- prefer the entries in the first argument to those in the second. Of course, -- this bias can only be observed when equality is an equivalence relation -- instead of structural equality. ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g. ----- >  import Data.Set (Set)--- >  import qualified Data.Set as Set------ -- == Warning -- -- The size of the set must not exceed @maxBound::Int@. Violation of@@ -48,29 +48,44 @@ -- The implementation of 'Set' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: -----    * Stephen Adams, \"/Efficient sets: a balancing act/\",+--    * Stephen Adams, \"/Efficient sets—a balancing act/\", --      Journal of Functional Programming 3(4):553-562, October 1993,---      <http://www.swiss.ai.mit.edu/~adams/BB/>.+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. --    * J. Nievergelt and E.M. Reingold, --      \"/Binary search trees of bounded balance/\", --      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104> -- --  Bounds for 'union', 'intersection', and 'difference' are as given --  by -- --    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>. --+--+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the set.+--+-- Operations like 'member', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input sets respectively.+-- -----------------------------------------------------------------------------  module Data.Set (             -- * Set type-#if !defined(TESTING)               Set          -- instance Eq,Ord,Show,Read,Data-#else-              Set(..)-#endif              -- * Construction             , empty@@ -111,8 +126,11 @@             , difference             , (\\)             , intersection+            , intersections+            , symmetricDifference             , cartesianProduct             , disjointUnion+            , Intersection(..)              -- * Filter             , S.filter@@ -170,14 +188,6 @@             , showTree             , showTreeWith             , valid--#if defined(TESTING)-            -- Internals (for testing)-            , bin-            , balanced-            , link-            , merge-#endif             ) where  import Data.Set.Internal as S
src/Data/Set/Internal.hs view
@@ -1,10 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif #ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE StandaloneDeriving #-}@@ -35,43 +33,40 @@ -- Authors importing this module are expected to track development -- closely. ----- = Description ----- An efficient implementation of sets.+-- = Finite Sets (internals) ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.+-- The @'Set' e@ type represents a set of elements of type @e@. Most operations+-- require that @e@ be an instance of the 'Ord' class. A 'Set' is strict in its+-- elements. ----- >  import Data.Set (Set)--- >  import qualified Data.Set as Set --+-- == Implementation+-- -- The implementation of 'Set' is based on /size balanced/ binary trees (or -- trees of /bounded balance/) as described by: -----    * Stephen Adams, \"/Efficient sets: a balancing act/\",+--    * Stephen Adams, \"/Efficient sets—a balancing act/\", --      Journal of Functional Programming 3(4):553-562, October 1993,---      <http://www.swiss.ai.mit.edu/~adams/BB/>.+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>. --    * J. Nievergelt and E.M. Reingold, --      \"/Binary search trees of bounded balance/\", --      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104> -- --  Bounds for 'union', 'intersection', and 'difference' are as given --  by -- --    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>. ----- Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'.  Of course, left-biasing can only be observed--- when equality is an equivalence relation instead of structural--- equality. ----- /Warning/: The size of the set must not exceed @maxBound::Int@. Violation of--- this condition is not detected and if the size limit is exceeded, the--- behavior of the set is completely undefined.--- -- @since 0.5.9 ----------------------------------------------------------------------------- @@ -156,6 +151,7 @@             , difference             , intersection             , intersections+            , symmetricDifference             , cartesianProduct             , disjointUnion             , Intersection(..)@@ -237,30 +233,29 @@ 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.Semigroup (Semigroup(..), stimesIdempotentMonoid, stimesIdempotent) import Data.Functor.Classes import Data.Functor.Identity (Identity) import qualified Data.Foldable as Foldable-import Control.DeepSeq (NFData(rnf))+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf))+import Data.List.NonEmpty (NonEmpty(..))  import Utils.Containers.Internal.StrictPair import Utils.Containers.Internal.PtrEquality+import Utils.Containers.Internal.EqOrdUtil (EqM(..), OrdM(..)) +#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+import Text.Read ( readPrec, Read (..), Lexeme (..), parens, prec+                 , lexP, readListPrecDefault )+#endif #if __GLASGOW_HASKELL__ import GHC.Exts ( build, lazy ) 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 ()+import Data.Coerce (coerce) #endif  @@ -289,17 +284,20 @@  #ifdef __GLASGOW_HASKELL__ type role Set nominal-#endif  -- | @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     mappend = (<>) --- | @since 0.5.7+-- | @(<>)@ = 'union'+--+-- @since 0.5.7 instance Ord a => Semigroup (Set a) where     (<>)    = union     stimes  = stimesIdempotentMonoid@@ -753,23 +751,29 @@   Minimal, Maximal --------------------------------------------------------------------} --- We perform call-pattern specialization manually on lookupMin--- and lookupMax. Otherwise, GHC doesn't seem to do it, which is--- unfortunate if, for example, someone uses findMin or findMax.+-- Note [Inline lookupMin]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- The core of lookupMin is implemented as lookupMinSure, a recursive function+-- that does not involve Maybes. lookupMin wraps the result of lookupMinSure in+-- a Just. We inline lookupMin so that GHC optimizations can eliminate the Maybe+-- if it is matched on at the call site.  lookupMinSure :: a -> Set a -> a lookupMinSure x Tip = x lookupMinSure _ (Bin _ x l _) = lookupMinSure x l --- | \(O(\log n)\). The minimal element of a set.+-- | \(O(\log n)\). The minimal element of the set. Returns 'Nothing' if the set+-- is empty. -- -- @since 0.5.9  lookupMin :: Set a -> Maybe a lookupMin Tip = Nothing lookupMin (Bin _ x l _) = Just $! lookupMinSure x l+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin] --- | \(O(\log n)\). The minimal element of a set.+-- | \(O(\log n)\). The minimal element of the set. Calls 'error' if the set is+-- empty. findMin :: Set a -> a findMin t   | Just r <- lookupMin t = r@@ -779,15 +783,18 @@ lookupMaxSure x Tip = x lookupMaxSure _ (Bin _ x _ r) = lookupMaxSure x r --- | \(O(\log n)\). The maximal element of a set.+-- | \(O(\log n)\). The maximal element of the set. Returns 'Nothing' if the set+-- is empty. -- -- @since 0.5.9  lookupMax :: Set a -> Maybe a lookupMax Tip = Nothing lookupMax (Bin _ x _ r) = Just $! lookupMaxSure x r+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin] --- | \(O(\log n)\). The maximal element of a set.+-- | \(O(\log n)\). The maximal element of the set. Calls 'error' if the set is+-- empty. findMax :: Set a -> a findMax t   | Just r <- lookupMax t = r@@ -883,23 +890,72 @@ {-# INLINABLE intersection #-} #endif --- | The intersection of a series of sets. Intersections are performed left-to-right.+-- | 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) = List.foldr go id ss s0-    where-      go s r acc-          | null acc = empty-          | otherwise = r (intersection acc s)+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 #-} --- | Sets form a 'Semigroup' under 'intersection'.+-- | @Set@s form a 'Semigroup' under 'intersection'.+--+-- @since 0.8 newtype Intersection a = Intersection { getIntersection :: Set a }     deriving (Show, Eq, Ord)  instance (Ord a) => Semigroup (Intersection a) where     (Intersection a) <> (Intersection b) = Intersection $ intersection a b+    {-# INLINABLE (<>) #-}+     stimes = stimesIdempotent+    {-# INLINABLE stimes #-} +    sconcat =+#ifdef __GLASGOW_HASKELL__+      coerce intersections+#else+      Intersection . intersections . fmap getIntersection+#endif+    {-# INLINABLE sconcat #-}+ {--------------------------------------------------------------------+  Symmetric difference+--------------------------------------------------------------------}++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- The symmetric difference of two sets.+--+-- The result contains elements that appear in exactly one of the two sets.+--+-- @+-- symmetricDifference (fromList [0,2,4,6]) (fromList [0,3,6,9]) == fromList [2,3,4,9]+-- @+--+-- @since 0.8+symmetricDifference :: Ord a => Set a -> Set a -> Set a+symmetricDifference Tip t2 = t2+symmetricDifference t1 Tip = t1+symmetricDifference (Bin _ x l1 r1) t2+  | found = merge l1l2 r1r2+  | otherwise = link x l1l2 r1r2+  where+    !(l2, found, r2) = splitMember x t2+    !l1l2 = symmetricDifference l1 l2+    !r1r2 = symmetricDifference r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE symmetricDifference #-}+#endif++{--------------------------------------------------------------------   Filter and partition --------------------------------------------------------------------} -- | \(O(n)\). Filter all elements that satisfy the predicate.@@ -938,24 +994,28 @@ -- | \(O(n \log n)\). -- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. --+-- If `f` is monotonically non-decreasing, this function takes \(O(n)\) time.+-- -- It's worth noting that the size of the result may be smaller if, -- for some @(x,y)@, @x \/= y && f x == f y@  map :: Ord b => (a->b) -> Set a -> Set b-map f = fromList . List.map f . toList+map f t = finishB (foldl' (\b x -> insertB (f x) b) emptyB t) #if __GLASGOW_HASKELL__ {-# INLINABLE map #-} #endif --- | \(O(n)\). The---+-- | \(O(n)\). -- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.--- /The precondition is not checked./ -- Semi-formally, we have: -- -- > and [x < y ==> f x < f y | x <- ls, y <- ls] -- >                     ==> mapMonotonic f s == map f s -- >     where ls = toList s+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'map' if the+-- precondition may not hold.  mapMonotonic :: (a->b) -> Set a -> Set b mapMonotonic _ Tip = Tip@@ -965,10 +1025,9 @@   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.+-- binary operator. ----- /Please note that fold will be deprecated in the future and removed./+{-# DEPRECATED fold "Use Data.Set.foldr instead" #-} fold :: (a -> b -> b) -> b -> Set a -> b fold = foldr {-# INLINE fold #-}@@ -1085,48 +1144,11 @@  -- | \(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.+-- If the elements are in non-decreasing order, this function takes \(O(n)\)+-- time. fromList :: Ord a => [a] -> Set a-fromList [] = Tip-fromList [x] = Bin 1 x Tip Tip-fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0-                    | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0-  where-    not_ordered _ [] = False-    not_ordered x (y : _) = x >= y-    {-# INLINE not_ordered #-}--    fromList' t0 xs = Foldable.foldl' ins t0 xs-      where ins t x = insert x t--    go !_ t [] = t-    go _ t [x] = insertMax x t-    go s l xs@(x : xss) | not_ordered x xss = fromList' l xs-                        | otherwise = case create s xss of-                            (r, ys, []) -> go (s `shiftL` 1) (link x l r) ys-                            (r, _,  ys) -> fromList' (link x l r) ys--    -- The create is returning a triple (tree, xs, ys). Both xs and ys-    -- represent not yet processed elements and only one of them can be nonempty.-    -- If ys is nonempty, the keys in ys are not ordered with respect to tree-    -- and must be inserted using fromList'. Otherwise the keys have been-    -- ordered so far.-    create !_ [] = (Tip, [], [])-    create s xs@(x : xss)-      | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss)-                                      else (Bin 1 x Tip Tip, xss, [])-      | otherwise = case create (s `shiftR` 1) xs of-                      res@(_, [], _) -> res-                      (l, [y], zs) -> (insertMax y l, [], zs)-                      (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys)-                                         | otherwise -> case create (s `shiftR` 1) yss of-                                                   (r, zs, ws) -> (link y l r, zs, ws)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromList #-}-#endif+fromList xs = finishB (Foldable.foldl' (flip insertB) emptyB xs)+{-# INLINE fromList #-}  -- INLINE for fusion  {--------------------------------------------------------------------   Building trees from ascending/descending lists can be done in linear time.@@ -1135,94 +1157,92 @@     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./+--+-- __Warning__: This function should be used only if the elements are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold. fromAscList :: Eq a => [a] -> Set a-fromAscList xs = fromDistinctAscList (combineEq xs)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscList #-}-#endif+fromAscList xs = ascLinkAll (Foldable.foldl' next Nada xs)+  where+    next stk !y = case stk of+      Push x l stk'+        | y == x -> Push y l stk'+        | Tip <- l -> ascLinkTop stk' 1 (singleton x) y+        | otherwise -> Push y Tip stk+      Nada -> Push y Tip stk+{-# INLINE fromAscList #-}  -- INLINE for fusion  -- | \(O(n)\). Build a set from a descending list in linear time.--- /The precondition (input list is descending) is not checked./ --+-- __Warning__: This function should be used only if the elements are in+-- non-increasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+-- -- @since 0.5.8 fromDescList :: Eq a => [a] -> Set a-fromDescList xs = fromDistinctDescList (combineEq xs)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescList #-}-#endif---- [combineEq xs] combines equal elements with [const] in an ordered list [xs]------ TODO: combineEq allocates an intermediate list. It *should* be better to--- make fromAscListBy and fromDescListBy the fundamental operations, and to--- implement the rest using those.-combineEq :: Eq a => [a] -> [a]-combineEq [] = []-combineEq (x : xs) = combineEq' x xs+fromDescList xs = descLinkAll (Foldable.foldl' next Nada xs)   where-    combineEq' z [] = [z]-    combineEq' z (y:ys)-      | z == y = combineEq' z ys-      | otherwise = z : combineEq' y ys+    next stk !y = case stk of+      Push x r stk'+        | y == x -> Push y r stk'+        | Tip <- r -> descLinkTop y 1 (singleton x) stk'+        | otherwise -> Push y Tip stk+      Nada -> Push y Tip stk+{-# INLINE fromDescList #-}  -- INLINE for fusion  -- | \(O(n)\). Build a set from an ascending list of distinct elements in linear time.--- /The precondition (input list is strictly ascending) is not checked./---- For some reason, when 'singleton' is used in fromDistinctAscList or in--- create, it is not inlined, so we inline it manually.+--+-- __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 = fromDistinctAscList_linkAll . Foldable.foldl' next (State0 Nada)+fromDistinctAscList xs = ascLinkAll (Foldable.foldl' next Nada xs)   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)+    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 -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 #-}+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 -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 #-}+ascLinkAll :: Stack a -> Set a+ascLinkAll stk = foldl'Stack (\r x l -> link x l r) Tip stk+{-# INLINABLE ascLinkAll #-}  -- | \(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./ --+-- __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 --- 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)+fromDistinctDescList xs = descLinkAll (Foldable.foldl' next Nada xs)   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)+    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 -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 #-}+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 -data FromDistinctMonoState a-  = State0 !(Stack a)-  | State1 !(Set a) !(Stack a)+descLinkAll :: Stack a -> Set a+descLinkAll stk = foldl'Stack (\l x r -> link x l r) Tip stk+{-# INLINABLE descLinkAll #-}  data Stack a = Push !a !(Set a) !(Stack a) | Nada @@ -1234,20 +1254,91 @@ {-# INLINE foldl'Stack #-}  {---------------------------------------------------------------------  Eq converts the set to a list. In a lazy setting, this-  actually seems one of the faster methods to compare two trees-  and it is certainly the simplest :-)+  Iterator --------------------------------------------------------------------}++-- Note [Iterator]+-- ~~~~~~~~~~~~~~~+-- Iteration, using a Stack as an iterator, is an efficient way to consume a Set+-- one element at a time. Alternately, this may be done by toAscList. toAscList+-- when consumed via List.foldr will rewrite to Set.foldr (thanks to rewrite+-- rules), which is quite efficient. However, sometimes that is not possible,+-- such as in the second arg of '==' or 'compare', where manifesting the list+-- cons cells is unavoidable and makes things slower.+--+-- Concretely, compare on Set Int using toAscList takes ~21% more time compared+-- to using Iterator, on GHC 9.6.3.+--+-- The heart of this implementation is the `iterDown` function. It walks down+-- the left spine of the tree, pushing the value and right child on the stack,+-- until a Tip is reached. The next value is now at the top of the stack. To get+-- to the value after that, `iterDown` is called again with the right child and+-- the remaining stack.++iterDown :: Set a -> Stack a -> Stack a+iterDown (Bin _ x l r) stk = iterDown l (Push x r stk)+iterDown Tip stk = stk++-- Create an iterator from a Set, starting at the smallest element.+iterator :: Set a -> Stack a+iterator s = iterDown s Nada++-- Get the next element and the remaining iterator.+iterNext :: Stack a -> Maybe (StrictPair a (Stack a))+iterNext (Push x r stk) = Just $! x :*: iterDown r stk+iterNext Nada = Nothing+{-# INLINE iterNext #-}++-- Whether there are no more elements in the iterator.+iterNull :: Stack a -> Bool+iterNull (Push _ _ _) = False+iterNull Nada = True++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+ instance Eq a => Eq (Set a) where-  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)+  s1 == s2 = liftEq (==) s1 s2+  {-# INLINABLE (==) #-} +-- | @since 0.5.9+instance Eq1 Set where+  liftEq eq s1 s2 = size s1 == size s2 && sameSizeLiftEq eq s1 s2+  {-# INLINE liftEq #-}++-- Assumes the sets are of equal size to skip the final check.+sameSizeLiftEq :: (a -> b -> Bool) -> Set a -> Set b -> Bool+sameSizeLiftEq eq s1 s2 =+  case runEqM (foldMap f s1) (iterator s2) of e :*: _ -> e+  where+    f x = EqM $ \it -> case iterNext it of+      Nothing -> False :*: it+      Just (y :*: it') -> eq x y :*: it'+{-# INLINE sameSizeLiftEq #-}+ {--------------------------------------------------------------------   Ord --------------------------------------------------------------------}  instance Ord a => Ord (Set a) where-    compare s1 s2 = compare (toAscList s1) (toAscList s2)+  compare s1 s2 = liftCmp compare s1 s2+  {-# INLINABLE compare #-} +-- | @since 0.5.9+instance Ord1 Set where+  liftCompare = liftCmp+  {-# INLINE liftCompare #-}++liftCmp :: (a -> b -> Ordering) -> Set a -> Set b -> Ordering+liftCmp cmp s1 s2 = case runOrdM (foldMap f s1) (iterator s2) of+  o :*: it -> o <> if iterNull it then EQ else LT+  where+    f x = OrdM $ \it -> case iterNext it of+      Nothing -> GT :*: it+      Just (y :*: it') -> cmp x y :*: it'+{-# INLINE liftCmp #-}+ {--------------------------------------------------------------------   Show --------------------------------------------------------------------}@@ -1256,16 +1347,6 @@     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)@@ -1274,7 +1355,7 @@   Read --------------------------------------------------------------------} instance (Read a, Ord a) => Read (Set a) where-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)   readPrec = parens $ prec 10 $ do     Ident "fromList" <- lexP     xs <- readPrec@@ -1296,6 +1377,13 @@     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 --------------------------------------------------------------------}@@ -1362,7 +1450,7 @@ {-# INLINABLE findIndex #-} #endif --- | \(O(\log n)\). Lookup the /index/ of an element, which is its zero-based index in+-- | \(O(\log n)\). Look up the /index/ of an element, which is its zero-based index in -- the sorted sequence of elements. The index is a number from /0/ up to, but not -- including, the 'size' of the set. --@@ -1550,7 +1638,56 @@       | p x = let u :*: v = go p r in link x l u :*: v       | otherwise = let u :*: v = go p l in u :*: link x v r +{--------------------------------------------------------------------+  SetBuilder+--------------------------------------------------------------------} +-- Note [SetBuilder]+-- ~~~~~~~~~~~~~~~~~+-- SetBuilder serves as an accumulator for element-by-element construction of+-- a Set. It can be used in folds to construct sets. This plays nicely with list+-- fusion if the structure folded over is a list, as in fromList and friends.+--+-- As long as the elements are in non-decreasing order, insertB accumulates them+-- in a Stack, just as fromDistinctAscList does. On encountering an element out+-- of order, it builds a Set from the Stack and switches to using insert for all+-- future elements. This gives us construction in O(n) if the elements are+-- already sorted. If not, the worst case remains O(n log n).+--+-- More complicated implementations are possible, such as repeatedly+-- accumulating runs of increasing elements in Stacks (not just once) and+-- union-ing with an accumulated Set, but this makes the worst case somewhat+-- slower (~10%).++data SetBuilder a+  = BAsc !(Stack a)+  | BSet !(Set a)++-- Empty builder.+emptyB :: SetBuilder a+emptyB = BAsc Nada++-- Insert an element. Replaces the old element if an equal element already+-- exists.+insertB :: Ord a => a -> SetBuilder a -> SetBuilder a+insertB !y b = case b of+  BAsc stk -> case stk of+    Push x l stk' -> case compare y x of+      LT -> BSet (insert y (ascLinkAll stk))+      EQ -> BAsc (Push y l stk')+      GT -> case l of+        Tip -> BAsc (ascLinkTop stk' 1 (singleton x) y)+        Bin{} -> BAsc (Push y Tip stk)+    Nada -> BAsc (Push y Tip Nada)+  BSet m -> BSet (insert y m)+{-# INLINE insertB #-}++-- Finalize the builder into a Set.+finishB :: SetBuilder a -> Set a+finishB (BAsc stk) = ascLinkAll stk+finishB (BSet s) = s+{-# INLINABLE finishB #-}+ {--------------------------------------------------------------------   Utility functions that maintain the balance properties of the tree.   All constructors assume that all values in [l] < [x] and all values@@ -1618,8 +1755,8 @@ glue Tip r = r glue l Tip = l glue l@(Bin sl xl ll lr) r@(Bin sr xr rl rr)-  | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in balanceR m l' r-  | otherwise = let !(m :*: r') = minViewSure xr rl rr in balanceL m l r'+  | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in Bin (sl+sr) m l' r+  | otherwise = let !(m :*: r') = minViewSure xr rl rr in Bin (sl+sr) m l r'  -- | \(O(\log n)\). Delete and find the minimal element. --@@ -1740,10 +1877,29 @@ -- balanceL only checks whether the left subtree is too big, -- balanceR only checks whether the right subtree is too big. +-- Note [Inlining balance]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- Benchmarks show that we benefit from inlining balanceL and balanceR, but+-- we don't want to cause code bloat from inlining these large functions.+-- As a compromise, we inline only one case: that of two Bins already balanced+-- with respect to each other.+--+-- This is the most common case for typical scenarios. For instance, for n+-- inserts there may be O(n log n) calls to balanceL/balanceR but at most O(n)+-- of them actually require rebalancing. So, inlining this common case provides+-- most of the potential benefits of inlining the full function.+ -- balanceL is called when left subtree might have been inserted to or when -- right subtree might have been deleted from. balanceL :: a -> Set a -> Set a -> Set a-balanceL x l r = case r of+balanceL x l r = case (l, r) of+  (Bin ls _ _ _, Bin rs _ _ _)+    | ls <= delta*rs -> Bin (1+ls+rs) x l r+  _ -> balanceL_ x l r+{-# INLINE balanceL #-} -- See Note [Inlining balance]++balanceL_ :: a -> Set a -> Set a -> Set a+balanceL_ x l r = case r of   Tip -> case l of            Tip -> Bin 1 x Tip Tip            (Bin _ _ Tip Tip) -> Bin 2 x l Tip@@ -1756,19 +1912,24 @@   (Bin rs _ _ _) -> case l of            Tip -> Bin (1+rs) x Tip r -           (Bin ls lx ll lr)-              | ls > delta*rs  -> case (ll, lr) of+           (Bin ls lx ll lr) -> case (ll, lr) of                    (Bin lls _ _ _, Bin lrs lrx lrl lrr)                      | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)                      | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)-                   (_, _) -> error "Failure in Data.Set.balanceL"-              | otherwise -> Bin (1+ls+rs) x l r-{-# NOINLINE balanceL #-}+                   (_, _) -> error "Failure in Data.Set.balanceL_"+{-# NOINLINE balanceL_ #-}  -- balanceR is called when right subtree might have been inserted to or when -- left subtree might have been deleted from. balanceR :: a -> Set a -> Set a -> Set a-balanceR x l r = case l of+balanceR x l r = case (l, r) of+  (Bin ls _ _ _, Bin rs _ _ _)+    | rs <= delta*ls -> Bin (1+ls+rs) x l r+  _ -> balanceR_ x l r+{-# INLINE balanceR #-} -- See Note [Inlining balance]++balanceR_ :: a -> Set a -> Set a -> Set a+balanceR_ x l r = case l of   Tip -> case r of            Tip -> Bin 1 x Tip Tip            (Bin _ _ Tip Tip) -> Bin 2 x Tip r@@ -1781,14 +1942,12 @@   (Bin ls _ _ _) -> case r of            Tip -> Bin (1+ls) x l Tip -           (Bin rs rx rl rr)-              | rs > delta*ls  -> case (rl, rr) of+           (Bin rs rx rl rr) -> case (rl, rr) of                    (Bin rls rlx rll rlr, Bin rrs _ _ _)                      | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr                      | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)-                   (_, _) -> error "Failure in Data.Set.balanceR"-              | otherwise -> Bin (1+ls+rs) x l r-{-# NOINLINE balanceR #-}+                   (_, _) -> error "Failure in Data.Set.balanceR_"+{-# NOINLINE balanceR_ #-}  {--------------------------------------------------------------------   The bin constructor maintains the size of the tree@@ -2083,24 +2242,29 @@ -- 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.+-- 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 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 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).+-- 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.
src/Data/Tree.hs view
@@ -33,6 +33,7 @@     -- * Trees and Forests       Tree(..)     , Forest+    , PostOrder(..)      -- * Construction     , unfoldTree@@ -46,6 +47,10 @@     , foldTree     , flatten     , levels+    , leaves+    , edges+    , pathsToRoot+    , pathsFromRoot      -- * Ascii Drawings     , drawTree@@ -55,17 +60,21 @@  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 import Language.Haskell.TH.Syntax (Lift) -- See Note [ Template Haskell Dependencies ] import Language.Haskell.TH ()@@ -73,8 +82,9 @@  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 +93,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 +179,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 +192,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@@ -234,7 +243,7 @@     {-# INLINABLE product #-}  #if MIN_VERSION_base(4,18,0)--- | Folds in preorder+-- | Folds in pre-order. -- -- @since 0.6.7 @@ -251,17 +260,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 +309,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 +374,8 @@  -- | Returns the elements of a tree in pre-order. --+-- @flatten == Data.Foldable.'toList'@+-- -- @ -- --   a@@ -391,7 +408,7 @@         takeWhile (not . null) $         iterate (concatMap subForest) [t] --- | Fold a tree into a "summary" value in depth-first order.+-- | Fold a tree into a "summary" value. -- -- For each node in the tree, apply @f@ to the @rootLabel@ and the result -- of applying @f@ to each @subForest@.@@ -426,13 +443,14 @@ foldTree f = go where     go (Node x ts) = f x (map go ts) --- | Build a (possibly infinite) tree from a seed value in breadth-first order.+-- | Build a (possibly infinite) tree from a seed value. -- -- @unfoldTree f b@ constructs a tree by starting with the tree -- @Node { rootLabel=b, subForest=[] }@ and repeatedly applying @f@ to each -- 'rootLabel' value in the tree's leaves to generate its 'subForest'. ----- For a monadic version see 'unfoldTreeM_BF'.+-- For a monadic version, see 'unfoldTreeM' (depth-first) and+-- 'unfoldTreeM_BF' (breadth-first). -- -- ==== __Examples__ --@@ -463,12 +481,12 @@ unfoldTree :: (b -> (a, [b])) -> b -> Tree a unfoldTree f b = let (a, bs) = f b in Node a (unfoldForest f bs) --- | Build a (possibly infinite) forest from a list of seed values in--- breadth-first order.+-- | Build a (possibly infinite) forest from a list of seed values. -- -- @unfoldForest f seeds@ invokes 'unfoldTree' on each seed value. ----- For a monadic version see 'unfoldForestM_BF'.+-- For a monadic version, see 'unfoldForestM' (depth-first) and+-- 'unfoldForestM_BF' (breadth-first). -- unfoldForest :: (b -> (a, [b])) -> [b] -> [Tree a] unfoldForest f = map (unfoldTree f)@@ -480,7 +498,7 @@     ts <- unfoldForestM f bs     return (Node a ts) --- | Monadic forest builder, in depth-first order+-- | Monadic forest builder, in depth-first order. unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m ([Tree a]) unfoldForestM f = Prelude.mapM (unfoldTreeM f) @@ -498,7 +516,7 @@         x :< _ -> x         EmptyL -> error "unfoldTreeM_BF" --- | Monadic forest builder, in breadth-first order+-- | Monadic forest builder, in breadth-first order. -- -- See 'unfoldForest' for more info. --@@ -525,6 +543,277 @@         q' :> a -> splitOnto (a:as) bs q'         EmptyR -> error "unfoldForestQ" +-- | \(O(n)\). The leaves of the tree in left-to-right order.+--+-- A leaf is a node with no children.+--+-- ==== __Examples__+--+-- >>> :{+-- leaves $+--   Node 1+--     [ Node 2+--         [ Node 4 []+--         , Node 5 []+--         ]+--     , Node 3+--         [ Node 6 []+--         ]+--     ]+-- :}+-- [4,5,6]+-- >>> leaves (Node "root" [])+-- ["root"]+--+-- @since 0.8+leaves :: Tree a -> [a]+#ifdef __GLASGOW_HASKELL__+leaves t = GHC.Exts.build $ \cons nil ->+  let go (Node x []) z = cons x z+      go (Node _ ts) z = foldr go z ts+  in go t nil+{-# INLINE leaves #-} -- Inline for list fusion+#else+leaves t =+  let go (Node x []) z = x:z+      go (Node _ ts) z = foldr go z ts+  in go t []+#endif++-- | \(O(n)\). The edges of the tree as parent-child pairs in pre-order.+--+-- A tree with \(n\) nodes has \(n-1\) edges.+--+-- ==== __Examples__+--+-- >>> :{+-- edges $+--   Node 1+--     [ Node 2+--         [ Node 4 []+--         , Node 5 []+--         ]+--     , Node 3+--         [ Node 6 []+--         ]+--     ]+-- :}+-- [(1,2),(2,4),(2,5),(1,3),(3,6)]+-- >>> edges (Node "root" [])+-- []+--+-- @since 0.8+edges :: Tree a -> [(a, a)]+#ifdef __GLASGOW_HASKELL__+edges (Node x0 ts0) = GHC.Exts.build $ \cons nil ->+  let go p = foldr (\(Node x ts) z -> cons (p, x) (go x z ts))+  in go x0 nil ts0+{-# INLINE edges #-} -- Inline for list fusion+#else+edges (Node x0 ts0) =+  let go p = foldr (\(Node x ts) z -> (p, x) : go x z ts)+  in go x0 [] ts0+#endif++-- | \(O(n)\). Labels on the paths from each node to the root.+--+-- ==== __Examples__+--+-- >>> :{+-- pathsToRoot $+--   Node 1+--     [ Node 2 []+--     , Node 3 []+--     ]+-- :}+-- Node {rootLabel = 1 :| [], subForest = [Node {rootLabel = 2 :| [1], subForest = []},Node {rootLabel = 3 :| [1], subForest = []}]}+-- >>> pathsToRoot (Node "root" [])+-- Node {rootLabel = "root" :| [], subForest = []}+--+-- @since 0.8+pathsToRoot :: Tree a -> Tree (NonEmpty a)+pathsToRoot = go []+  where+    go ps (Node x ts) = Node (x :| ps) (map (go (x:ps)) ts)++-- | Labels on the paths from the root to each node.+--+-- If the path orientation is not important, consider using 'pathsToRoot'+-- instead because it is more efficient.+--+-- ==== __Examples__+--+-- >>> :{+-- pathsFromRoot $+--   Node 1+--     [ Node 2 []+--     , Node 3 []+--     ]+-- :}+-- Node {rootLabel = 1 :| [], subForest = [Node {rootLabel = 1 :| [2], subForest = []},Node {rootLabel = 1 :| [3], subForest = []}]}+-- >>> pathsFromRoot (Node "root" [])+-- Node {rootLabel = "root" :| [], subForest = []}+--+-- @since 0.8++-- See Note [pathsFromRoot implementation]+pathsFromRoot :: Tree a -> Tree (NonEmpty a)+pathsFromRoot (Node x0 ts0) = Node (x0 :| []) (map (go (singletonBQ x0)) ts0)+  where+    go !q (Node x ts) = Node (toNonEmptyBQ q') (map (go q') ts)+      where+        !q' = snocBQ q x++-- An implementation of Chris Okasaki's banker's queue.+-- Invariant: length front >= length rear+data BQ a = BQ+  a -- head+  {-# UNPACK #-} !Word -- length front + length rear+  [a] -- front+  ![a] -- rear (reversed)++singletonBQ :: a -> BQ a+singletonBQ x = BQ x 0 [] []++snocBQ :: BQ a -> a -> BQ a+snocBQ (BQ x0 n f r) x+  | doReverse = BQ x0 (n+1) (f ++ reverse (x:r)) []+  | otherwise = BQ x0 (n+1) f (x:r)+  where+    doReverse = (n+2) .&. (n+1) == 0+    -- We reverse whenever the length of r would exceed that of f.+    -- This happens every time n+2 is a power of 2.++toNonEmptyBQ :: BQ a -> NonEmpty a+toNonEmptyBQ (BQ x0 _ f r) = case r of+  [] -> x0 :| f -- optimization, no need to rebuild f+  _ -> x0 :| (f ++ reverse r)++-- | A newtype over 'Tree' that folds and traverses in post-order.+--+-- @since 0.8+newtype PostOrder a = PostOrder { unPostOrder :: Tree a }+#ifdef __GLASGOW_HASKELL__+  deriving (Eq, Ord, Read, Show, Data, Generic, Generic1, Lift)+#else+  deriving (Eq, Ord, Read, Show)+#endif++instance Functor PostOrder where+#ifdef __GLASGOW_HASKELL__+  fmap = (coerce :: ((a -> b) -> Tree a -> Tree b)+                 -> (a -> b) -> PostOrder a -> PostOrder b)+         fmapTree+  (<$) = (coerce :: (b -> Tree a -> Tree b)+                 -> b -> PostOrder a -> PostOrder b)+         (<$)+#else+  fmap f = PostOrder . fmapTree f . unPostOrder+  (<$) x = PostOrder . (x <$) . unPostOrder+#endif++-- See Note [Implemented Foldable Tree functions]+instance Foldable PostOrder where+    fold = foldMap id+    {-# INLINABLE fold #-}++    foldMap = foldMapDefault+    {-# INLINE foldMap #-}++    foldr f z0 = \(PostOrder t) -> go t z0  -- Use a lambda to inline with two arguments+      where+        go (Node x ts) z = foldr go (f x z) ts+    {-# INLINE foldr #-}++    foldl' f z0 = \(PostOrder t) -> go z0 t  -- Use a lambda to inline with two arguments+      where+        go !z (Node x ts) =+          let !z' = foldl' go z ts+          in f z' x+    {-# INLINE foldl' #-}++    foldr1 = foldrMap1PostOrder id++    foldl1 = foldlMap1PostOrder id++    null _ = False+    {-# INLINE null #-}++    elem = any . (==)+    {-# INLINABLE elem #-}++    maximum = foldlMap1'PostOrder id max+    {-# INLINABLE maximum #-}++    minimum = foldlMap1'PostOrder id min+    {-# INLINABLE minimum #-}++    sum = foldlMap1'PostOrder id (+)+    {-# INLINABLE sum #-}++    product = foldlMap1'PostOrder id (*)+    {-# INLINABLE product #-}++instance Traversable PostOrder where+  traverse f = \(PostOrder t) -> PostOrder <$> go t+    where+      go (Node x ts) = liftA2 (flip Node) (traverse go ts) (f x)+  {-# INLINE traverse #-}++#if MIN_VERSION_base(4,18,0)+-- See Note [Implemented Foldable1 Tree functions]+instance Foldable1.Foldable1 PostOrder where+  foldMap1 f = \(PostOrder t) -> go t  -- Use a lambda to inline with one argument+    where+      go (Node x []) = f x+      go (Node x (t:ts)) =+        Foldable1.foldrMap1 go (\t' z' -> go t' <> z') (t :| ts) <> f x+  {-# INLINE foldMap1 #-}++  foldMap1' f = foldlMap1'PostOrder f (\z x -> z <> f x)+  {-# INLINE foldMap1' #-}++  toNonEmpty (PostOrder t0) = go t0 []+    where+      go (Node x []) z = x :| z+      go (Node x (t:ts)) z =+        go t (foldr (\t' z' -> foldr (:) z' (PostOrder t')) (x:z) ts)++  maximum = Foldable.maximum+  {-# INLINABLE maximum #-}++  minimum = Foldable.minimum+  {-# INLINABLE minimum #-}++  foldrMap1 = foldrMap1PostOrder++  foldlMap1' = foldlMap1'PostOrder++  foldlMap1 = foldlMap1PostOrder+#endif++foldrMap1PostOrder :: (a -> b) -> (a -> b -> b) -> PostOrder a -> b+foldrMap1PostOrder f g = \(PostOrder (Node x ts)) ->+  foldr (\t z -> foldr g z (PostOrder t)) (f x) ts+{-# INLINE foldrMap1PostOrder #-}++foldlMap1PostOrder :: (a -> b) -> (b -> a -> b) -> PostOrder a -> b+foldlMap1PostOrder f g = \(PostOrder t) -> go t+  where+    go (Node x []) = f x+    go (Node x (t:ts)) =+      g (foldl (\z t' -> foldl g z (PostOrder t')) (go t) ts) x+{-# INLINE foldlMap1PostOrder #-}++foldlMap1'PostOrder :: (a -> b) -> (b -> a -> b) -> PostOrder a -> b+foldlMap1'PostOrder f g = \(PostOrder t) -> go t+  where+    go (Node x []) = f x+    go (Node x (t:ts)) =+      let !z' = foldl' (\z t' -> foldl' g z (PostOrder t')) (go t) ts+      in g z' x+{-# INLINE foldlMap1'PostOrder #-}+ --------------------------------------------------------------------------------  -- Note [Implemented Foldable Tree functions]@@ -560,3 +849,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/BitUtil.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}+{-# LANGUAGE Trustworthy #-} #endif  #include "containers.h"@@ -31,44 +29,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 +50,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.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
@@ -16,9 +16,7 @@     fmap = liftA  instance Monad (State s) where-    {-# INLINE return #-}     {-# INLINE (>>=) #-}-    return = pure     m >>= k = State $ \ s -> case runState m s of         (s', x) -> runState (k x) s'
src/Utils/Containers/Internal/StrictMaybe.hs view
@@ -6,6 +6,9 @@ -- | Strict 'Maybe'  module Utils.Containers.Internal.StrictMaybe (MaybeS (..), maybeS, toMaybe, toMaybeS) where+#ifdef __MHS__+import Data.Foldable+#endif  data MaybeS a = NothingS | JustS !a
src/Utils/Containers/Internal/StrictPair.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)+#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE Safe #-} #endif
− src/Utils/Containers/Internal/TypeError.hs 
@@ -1,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.