containers 0.6.0.1 → 0.6.1.1

raw patch · 107 files changed

+23737/−29933 lines, 107 filesdep −ChasingBottomsdep −HUnitdep −QuickCheckdep ~basedep ~deepseqPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: ChasingBottoms, HUnit, QuickCheck, containers, criterion, ghc-prim, random, test-framework, test-framework-hunit, test-framework-quickcheck2, transformers

Dependency ranges changed: base, deepseq

API changes (from Hackage documentation)

Files

• Data/Containers/ListUtils.hs +0/−181
• Data/Graph.hs +0/−708
• Data/IntMap.hs +0/−101
• Data/IntMap/Internal.hs +0/−3435
• Data/IntMap/Internal/Debug.hs +0/−6
• Data/IntMap/Internal/DeprecatedDebug.hs +0/−17
• Data/IntMap/Lazy.hs +0/−236
• Data/IntMap/Merge/Lazy.hs +0/−104
• Data/IntMap/Merge/Strict.hs +0/−100
• Data/IntMap/Strict.hs +0/−1144
• Data/IntSet.hs +0/−166
• Data/IntSet/Internal.hs +0/−1539
• Data/Map.hs +0/−114
• Data/Map/Internal.hs +0/−4244
• Data/Map/Internal/Debug.hs +0/−144
• Data/Map/Internal/DeprecatedShowTree.hs +0/−29
• Data/Map/Lazy.hs +0/−275
• Data/Map/Merge/Lazy.hs +0/−104
• Data/Map/Merge/Strict.hs +0/−100
• Data/Map/Strict.hs +0/−290
• Data/Map/Strict/Internal.hs +0/−1727
• Data/Sequence.hs +0/−302
• Data/Sequence/Internal.hs +0/−4634
• Data/Sequence/Internal/Sorting.hs +0/−437
• Data/Set.hs +0/−179
• Data/Set/Internal.hs +0/−1889
• Data/Tree.hs +0/−417
• Utils/Containers/Internal/BitQueue.hs +0/−134
• Utils/Containers/Internal/BitUtil.hs +0/−99
• Utils/Containers/Internal/Coercions.hs +0/−44
• Utils/Containers/Internal/PtrEquality.hs +0/−51
• Utils/Containers/Internal/State.hs +0/−35
• Utils/Containers/Internal/StrictMaybe.hs +0/−31
• Utils/Containers/Internal/StrictPair.hs +0/−24
• Utils/Containers/Internal/TypeError.hs +0/−52
• benchmarks/IntMap.hs +0/−97
• benchmarks/IntSet.hs +0/−52
• benchmarks/LookupGE/IntMap.hs +0/−47
• benchmarks/LookupGE/LookupGE_IntMap.hs +0/−94
• benchmarks/LookupGE/LookupGE_Map.hs +0/−75
• benchmarks/LookupGE/Makefile +0/−3
• benchmarks/LookupGE/Map.hs +0/−46
• benchmarks/Makefile +0/−18
• benchmarks/Map.hs +0/−197
• benchmarks/Sequence.hs +0/−244
• benchmarks/Set.hs +0/−53
• benchmarks/SetOperations/Makefile +0/−3
• benchmarks/SetOperations/SetOperations-IntMap.hs +0/−6
• benchmarks/SetOperations/SetOperations-IntSet.hs +0/−6
• benchmarks/SetOperations/SetOperations-Map.hs +0/−6
• benchmarks/SetOperations/SetOperations-Set.hs +0/−6
• benchmarks/SetOperations/SetOperations.hs +0/−45
• benchmarks/bench-cmp.pl +0/−24
• benchmarks/bench-cmp.sh +0/−3
• changelog.md +35/−0
• containers.cabal +5/−518
• src/Data/Containers/ListUtils.hs +187/−0
• src/Data/Graph.hs +727/−0
• src/Data/IntMap.hs +101/−0
• src/Data/IntMap/Internal.hs +3454/−0
• src/Data/IntMap/Internal/Debug.hs +6/−0
• src/Data/IntMap/Internal/DeprecatedDebug.hs +17/−0
• src/Data/IntMap/Lazy.hs +236/−0
• src/Data/IntMap/Merge/Lazy.hs +104/−0
• src/Data/IntMap/Merge/Strict.hs +233/−0
• src/Data/IntMap/Strict.hs +253/−0
• src/Data/IntMap/Strict/Internal.hs +1153/−0
• src/Data/IntSet.hs +166/−0
• src/Data/IntSet/Internal.hs +1547/−0
• src/Data/Map.hs +114/−0
• src/Data/Map/Internal.hs +4293/−0
• src/Data/Map/Internal/Debug.hs +144/−0
• src/Data/Map/Internal/DeprecatedShowTree.hs +29/−0
• src/Data/Map/Lazy.hs +275/−0
• src/Data/Map/Merge/Lazy.hs +104/−0
• src/Data/Map/Merge/Strict.hs +106/−0
• src/Data/Map/Strict.hs +290/−0
• src/Data/Map/Strict/Internal.hs +1730/−0
• src/Data/Sequence.hs +303/−0
• src/Data/Sequence/Internal.hs +4640/−0
• src/Data/Sequence/Internal/Sorting.hs +437/−0
• src/Data/Set.hs +179/−0
• src/Data/Set/Internal.hs +1960/−0
• src/Data/Tree.hs +431/−0
• src/Utils/Containers/Internal/BitQueue.hs +134/−0
• src/Utils/Containers/Internal/BitUtil.hs +107/−0
• src/Utils/Containers/Internal/Coercions.hs +44/−0
• src/Utils/Containers/Internal/PtrEquality.hs +51/−0
• src/Utils/Containers/Internal/State.hs +35/−0
• src/Utils/Containers/Internal/StrictMaybe.hs +31/−0
• src/Utils/Containers/Internal/StrictPair.hs +24/−0
• src/Utils/Containers/Internal/TypeError.hs +52/−0
• tests/IntMapValidity.hs +0/−65
• tests/IntSetValidity.hs +0/−89
• tests/Makefile +0/−20
• tests/bitqueue-properties.hs +0/−34
• tests/graph-properties.hs +0/−111
• tests/intmap-properties.hs +0/−1166
• tests/intmap-strictness.hs +0/−125
• tests/intset-properties.hs +0/−400
• tests/intset-strictness.hs +0/−43
• tests/listutils-properties.hs +0/−60
• tests/map-properties.hs +0/−1400
• tests/map-strictness.hs +0/−125
• tests/seq-properties.hs +0/−919
• tests/set-properties.hs +0/−637
• tests/tree-properties.hs +0/−104

@@ -1,181 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE Trustworthy #-}-#endif---------------------------------------------------------------------------------- |--- Module      :  Data.Containers.ListUtils--- Copyright   :  (c) Gershom Bazerman 2018--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ This module provides efficient containers-based functions on the list type.--------------------------------------------------------------------------------module Data.Containers.ListUtils (-       nubOrd,-       nubOrdOn,-       nubInt,-       nubIntOn-       ) where--import Data.Set (Set)-import qualified Data.Set as Set-import qualified Data.IntSet as IntSet-import Data.IntSet (IntSet)-#ifdef __GLASGOW_HASKELL__-import GHC.Exts ( build )-#endif---- *** Ord-based nubbing ***----- | \( O(n \log n \). The @nubOrd@ function removes duplicate elements from a list.--- In particular, it keeps only the first occurrence of each element. By using a--- 'Set' internally it has better asymptotics than the standard 'Data.List.nub'--- function.------ ==== Strictness------ @nubOrd@ is strict in the elements of the list.------ ==== Efficiency note------ When applicable, it is almost always better to use 'nubInt' or 'nubIntOn' instead--- of this function. For example, the best way to nub a list of characters is------ @ nubIntOn fromEnum xs @-nubOrd :: Ord a => [a] -> [a]-nubOrd = nubOrdOn id-{-# INLINE nubOrd #-}---- | The @nubOrdOn@ function behaves just like 'nubOrd' except it performs--- comparisons not on the original datatype, but a user-specified projection--- from that datatype.------ ==== Strictness------ @nubOrdOn@ is strict in the values of the function applied to the--- elements of the list.-nubOrdOn :: Ord b => (a -> b) -> [a] -> [a]--- For some reason we need to write an explicit lambda here to allow this--- to inline when only applied to a function.-nubOrdOn f = \xs -> nubOrdOnExcluding f Set.empty xs-{-# INLINE nubOrdOn #-}---- Splitting nubOrdOn like this means that we don't have to worry about--- matching specifically on Set.empty in the rewrite-back rule.-nubOrdOnExcluding :: Ord b => (a -> b) -> Set b -> [a] -> [a]-nubOrdOnExcluding f = go-  where-    go _ [] = []-    go s (x:xs)-      | fx `Set.member` s = go s xs-      | otherwise = x : go (Set.insert fx s) xs-      where !fx = f x--#ifdef __GLASGOW_HASKELL__--- We want this inlinable to specialize to the necessary Ord instance.-{-# INLINABLE [1] nubOrdOnExcluding #-}--{-# RULES--- Rewrite to a fusible form.-"nubOrdOn" [~1] forall f as s. nubOrdOnExcluding  f s as =-  build (\c n -> foldr (nubOrdOnFB f c) (constNubOn n) as s)---- Rewrite back to a plain form-"nubOrdOnList" [1] forall f as s.-    foldr (nubOrdOnFB f (:)) (constNubOn []) as s =-       nubOrdOnExcluding f s as- #-}--nubOrdOnFB :: Ord b-           => (a -> b)-           -> (a -> r -> r)-           -> a-           -> (Set b -> r)-           -> Set b-           -> r-nubOrdOnFB f c x r s-  | fx `Set.member` s = r s-  | otherwise = x `c` r (Set.insert fx s)-  where !fx = f x-{-# INLINABLE [0] nubOrdOnFB #-}--constNubOn :: a -> b -> a-constNubOn x _ = x-{-# INLINE [0] constNubOn #-}-#endif----- *** Int-based nubbing ***----- | \( O(n \min(n,W)) \). The @nubInt@ function removes duplicate 'Int'--- values from a list. In particular, it keeps only the first occurrence--- of each element. By using an 'IntSet' internally, it attains better--- asymptotics than the standard 'Data.List.nub' function.------ See also 'nubIntOn', a more widely applicable generalization.------ ==== Strictness------ @nubInt@ is strict in the elements of the list.-nubInt :: [Int] -> [Int]-nubInt = nubIntOn id-{-# INLINE nubInt #-}---- | The @nubIntOn@ function behaves just like 'nubInt' except it performs--- comparisons not on the original datatype, but a user-specified projection--- from that datatype.------ ==== Strictness------ @nubIntOn@ is strict in the values of the function applied to the--- elements of the list.-nubIntOn :: (a -> Int) -> [a] -> [a]--- For some reason we need to write an explicit lambda here to allow this--- to inline when only applied to a function.-nubIntOn f = \xs -> nubIntOnExcluding f IntSet.empty xs-{-# INLINE nubIntOn #-}---- Splitting nubIntOn like this means that we don't have to worry about--- matching specifically on IntSet.empty in the rewrite-back rule.-nubIntOnExcluding :: (a -> Int) -> IntSet -> [a] -> [a]-nubIntOnExcluding f = go-  where-    go _ [] = []-    go s (x:xs)-      | fx `IntSet.member` s = go s xs-      | otherwise = x : go (IntSet.insert fx s) xs-      where !fx = f x--#ifdef __GLASGOW_HASKELL__--- We don't mark this INLINABLE because it doesn't seem obviously useful--- to inline it anywhere; the elements the function operates on are actually--- pulled from a list and installed in a list; the situation is very different--- when fusion occurs. In this case, we let GHC make the call.-{-# NOINLINE [1] nubIntOnExcluding #-}--{-# RULES-"nubIntOn" [~1] forall f as s. nubIntOnExcluding  f s as =-  build (\c n -> foldr (nubIntOnFB f c) (constNubOn n) as s)-"nubIntOnList" [1] forall f as s. foldr (nubIntOnFB f (:)) (constNubOn []) as s =-  nubIntOnExcluding f s as- #-}--nubIntOnFB :: (a -> Int)-           -> (a -> r -> r)-           -> a-           -> (IntSet -> r)-           -> IntSet-           -> r-nubIntOnFB f c x r s-  | fx `IntSet.member` s = r s-  | otherwise = x `c` r (IntSet.insert fx s)-  where !fx = f x-{-# INLINABLE [0] nubIntOnFB #-}-#endif

@@ -1,708 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE StandaloneDeriving #-}-# if __GLASGOW_HASKELL__ >= 710-{-# LANGUAGE Safe #-}-# else-{-# LANGUAGE Trustworthy #-}-# endif-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.Graph--- Copyright   :  (c) The University of Glasgow 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Portability :  portable------ = Finite Graphs------ The @'Graph'@ type is an adjacency list representation of a finite, directed--- graph with vertices of type @Int@.------ The @'SCC'@ type represents a--- <https://en.wikipedia.org/wiki/Strongly_connected_component strongly-connected component>--- of a graph.------ == Implementation------ The implementation is based on------   * /Structuring Depth-First Search Algorithms in Haskell/,---     by David King and John Launchbury.-----------------------------------------------------------------------------------module Data.Graph (--    -- * Graphs-      Graph-    , Bounds-    , Edge-    , Vertex-    , Table--    -- ** Graph Construction-    , graphFromEdges-    , graphFromEdges'-    , buildG--    -- ** Graph Properties-    , vertices-    , edges-    , outdegree-    , indegree--    -- ** Graph Transformations-    , transposeG--    -- ** Graph Algorithms-    , dfs-    , dff-    , topSort-    , components-    , scc-    , bcc-    , reachable-    , path---    -- * Strongly Connected Components-    , SCC(..)--    -- ** Construction-    , stronglyConnComp-    , stronglyConnCompR--    -- ** Conversion-    , flattenSCC-    , flattenSCCs--    -- * Trees-    , module Data.Tree--    ) where--#if USE_ST_MONAD-import Control.Monad.ST-import Data.Array.ST.Safe (newArray, readArray, writeArray)-# if USE_UNBOXED_ARRAYS-import Data.Array.ST.Safe (STUArray)-# else-import Data.Array.ST.Safe (STArray)-# endif-#else-import Data.IntSet (IntSet)-import qualified Data.IntSet as Set-#endif-import Data.Tree (Tree(Node), Forest)---- std interfaces-import Control.Applicative-#if !MIN_VERSION_base(4,8,0)-import qualified Data.Foldable as F-import Data.Traversable-#else-import Data.Foldable as F-#endif-import Control.DeepSeq (NFData(rnf))-import Data.Maybe-import Data.Array-#if USE_UNBOXED_ARRAYS-import qualified Data.Array.Unboxed as UA-import Data.Array.Unboxed ( UArray )-#else-import qualified Data.Array as UA-#endif-import Data.List-#if MIN_VERSION_base(4,9,0)-import Data.Functor.Classes-import Data.Semigroup (Semigroup (..))-#endif-#ifdef __GLASGOW_HASKELL__-import GHC.Generics (Generic, Generic1)-import Data.Data (Data)-import Data.Typeable-#endif---- Make sure we don't use Integer by mistake.-default ()------------------------------------------------------------------------------                                                                      ----      Strongly Connected Components---                                                                      ------------------------------------------------------------------------------- | Strongly connected component.-data SCC vertex = AcyclicSCC vertex     -- ^ A single vertex that is not-                                        -- in any cycle.-                | CyclicSCC  [vertex]   -- ^ A maximal set of mutually-                                        -- reachable vertices.-#if __GLASGOW_HASKELL__ >= 802-  deriving ( Eq   -- ^ @since 0.5.9-           , Show -- ^ @since 0.5.9-           , Read -- ^ @since 0.5.9-           )-#else-  deriving (Eq, Show, Read)-#endif--INSTANCE_TYPEABLE1(SCC)--#ifdef __GLASGOW_HASKELL__--- | @since 0.5.9-deriving instance Data vertex => Data (SCC vertex)---- | @since 0.5.9-deriving instance Generic1 SCC---- | @since 0.5.9-deriving instance Generic (SCC vertex)-#endif--#if MIN_VERSION_base(4,9,0)--- | @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 _ _ _ = 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--- | @since 0.5.9-instance Read1 SCC where-  liftReadsPrec rp rl = readsData $-    readsUnaryWith rp "AcyclicSCC" AcyclicSCC <>-    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---- | @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)--instance NFData a => NFData (SCC a) where-    rnf (AcyclicSCC v) = rnf v-    rnf (CyclicSCC vs) = rnf vs---- | @since 0.5.4-instance Functor SCC where-    fmap f (AcyclicSCC v) = AcyclicSCC (f v)-    fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)---- | The vertices of a list of strongly connected components.-flattenSCCs :: [SCC a] -> [a]-flattenSCCs = concatMap flattenSCC---- | The vertices of a strongly connected component.-flattenSCC :: SCC vertex -> [vertex]-flattenSCC (AcyclicSCC v) = [v]-flattenSCC (CyclicSCC vs) = vs---- | The strongly connected components of a directed graph, topologically--- sorted.-stronglyConnComp-        :: Ord key-        => [(node, key, [key])]-                -- ^ The graph: a list of nodes uniquely identified by keys,-                -- with a list of keys of nodes this node has edges to.-                -- The out-list may contain keys that don't correspond to-                -- nodes of the graph; such edges are ignored.-        -> [SCC node]--stronglyConnComp edges0-  = map get_node (stronglyConnCompR edges0)-  where-    get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n-    get_node (CyclicSCC triples)     = CyclicSCC [n | (n,_,_) <- triples]---- | The strongly connected components of a directed graph, topologically--- sorted.  The function is the same as 'stronglyConnComp', except that--- all the information about each node retained.--- This interface is used when you expect to apply 'SCC' to--- (some of) the result of 'SCC', so you don't want to lose the--- dependency information.-stronglyConnCompR-        :: Ord key-        => [(node, key, [key])]-                -- ^ The graph: a list of nodes uniquely identified by keys,-                -- with a list of keys of nodes this node has edges to.-                -- The out-list may contain keys that don't correspond to-                -- nodes of the graph; such edges are ignored.-        -> [SCC (node, key, [key])]     -- ^ Topologically sorted--stronglyConnCompR [] = []  -- added to avoid creating empty array in graphFromEdges -- SOF-stronglyConnCompR edges0-  = map decode forest-  where-    (graph, vertex_fn,_) = graphFromEdges edges0-    forest             = scc graph-    decode (Node v []) | mentions_itself v = CyclicSCC [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-    mentions_itself v = v `elem` (graph ! v)------------------------------------------------------------------------------                                                                      ----      Graphs---                                                                      ------------------------------------------------------------------------------- | Abstract representation of vertices.-type Vertex  = Int--- | Table indexed by a contiguous set of vertices.------ /Note: This is included for backwards compatibility./-type Table a = Array Vertex a--- | Adjacency list representation of a graph, mapping each vertex to its--- list of successors.-type Graph   = Array Vertex [Vertex]--- | The bounds of an @Array@.-type Bounds  = (Vertex, Vertex)--- | An edge from the first vertex to the second.-type Edge    = (Vertex, Vertex)--#if !USE_UNBOXED_ARRAYS-type UArray i a = Array i a-#endif---- | Returns the list of vertices in the graph.------ ==== __Examples__------ > vertices (buildG (0,-1) []) == []------ > vertices (buildG (0,2) [(0,1),(1,2)]) == [0,1,2]-vertices :: Graph -> [Vertex]-vertices  = indices---- | Returns the list of edges in the graph.------ ==== __Examples__------ > edges (buildG (0,-1) []) == []------ > edges (buildG (0,2) [(0,1),(1,2)]) == [(0,1),(1,2)]-edges    :: Graph -> [Edge]-edges g   = [ (v, w) | v <- vertices g, w <- g!v ]---- | Build a graph from a list of edges.------ Warning: This function will cause a runtime exception if a vertex in the edge--- list is not within the given @Bounds@.------ ==== __Examples__------ > buildG (0,-1) [] == array (0,-1) []--- > buildG (0,2) [(0,1), (1,2)] == array (0,1) [(0,[1]),(1,[2])]--- > buildG (0,2) [(0,1), (0,2), (1,2)] == array (0,2) [(0,[2,1]),(1,[2]),(2,[])]-buildG :: Bounds -> [Edge] -> Graph-buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0---- | The graph obtained by reversing all edges.------ ==== __Examples__------ > transposeG (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,[]),(1,[0]),(2,[1])]-transposeG  :: Graph -> Graph-transposeG g = buildG (bounds g) (reverseE g)--reverseE    :: Graph -> [Edge]-reverseE g   = [ (w, v) | (v, w) <- edges g ]---- | A table of the count of edges from each node.------ ==== __Examples__------ > outdegree (buildG (0,-1) []) == array (0,-1) []------ > outdegree (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,1),(1,1),(2,0)]-outdegree :: Graph -> Array Vertex Int--- This is bizarrely lazy. We build an array filled with thunks, instead--- of actually calculating anything. This is the historical behavior, and I--- suppose someone *could* be relying on it, but it might be worth finding--- out. Note that we *can't* be so lazy with indegree.-outdegree  = fmap length---- | A table of the count of edges into each node.------ ==== __Examples__------ > indegree (buildG (0,-1) []) == array (0,-1) []------ > indegree (buildG (0,2) [(0,1), (1,2)]) == array (0,2) [(0,0),(1,1),(2,1)]-indegree :: Graph -> Array Vertex Int-indegree g = accumArray (+) 0 (bounds g) [(v, 1) | (_, outs) <- assocs g, v <- outs]---- | Identical to 'graphFromEdges', except that the return value--- does not include the function which maps keys to vertices.  This--- version of 'graphFromEdges' is for backwards compatibility.-graphFromEdges'-        :: Ord key-        => [(node, key, [key])]-        -> (Graph, Vertex -> (node, key, [key]))-graphFromEdges' x = (a,b) where-    (a,b,_) = graphFromEdges x---- | Build a graph from a list of nodes uniquely identified by keys,--- with a list of keys of nodes this node should have edges to.------ This function takes an adjacency list representing a graph with vertices of--- type @key@ labeled by values of type @node@ and produces a @Graph@-based--- representation of that list. The @Graph@ result represents the /shape/ of the--- graph, and the functions describe a) how to retrieve the label and adjacent--- vertices of a given vertex, and b) how to retrive a vertex given a key.------ @(graph, nodeFromVertex, vertexFromKey) = graphFromEdges edgeList@------ * @graph :: Graph@ is the raw, array based adjacency list for the graph.--- * @nodeFromVertex :: Vertex -> (node, key, [key])@ returns the node---   associated with the given 0-based @Int@ vertex; see /warning/ below.--- * @vertexFromKey :: key -> Maybe Vertex@ returns the @Int@ vertex for the---   key if it exists in the graph, @Nothing@ otherwise.------ To safely use this API you must either extract the list of vertices directly--- from the graph or first call @vertexFromKey k@ to check if a vertex--- corresponds to the key @k@. Once it is known that a vertex exists you can use--- @nodeFromVertex@ to access the labelled node and adjacent vertices. See below--- for examples.------ Note: The out-list may contain keys that don't correspond to nodes of the--- graph; they are ignored.------ Warning: The @nodeFromVertex@ function will cause a runtime exception if the--- given @Vertex@ does not exist.------ ==== __Examples__------ An empty graph.------ > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges []--- > graph = array (0,-1) []------ A graph where the out-list references unspecified nodes (@'c'@), these are--- ignored.------ > (graph, _, _) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c'])]--- > array (0,1) [(0,[1]),(1,[])]--------- A graph with 3 vertices: ("a") -> ("b") -> ("c")------ > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c']), ("c", 'c', [])]--- > graph == array (0,2) [(0,[1]),(1,[2]),(2,[])]--- > nodeFromVertex 0 == ("a",'a',"b")--- > vertexFromKey 'a' == Just 0------ Get the label for a given key.------ > let getNodePart (n, _, _) = n--- > (graph, nodeFromVertex, vertexFromKey) = graphFromEdges [("a", 'a', ['b']), ("b", 'b', ['c']), ("c", 'c', [])]--- > getNodePart . nodeFromVertex <$> vertexFromKey 'a' == Just "A"----graphFromEdges-        :: Ord key-        => [(node, key, [key])]-        -> (Graph, Vertex -> (node, key, [key]), key -> Maybe Vertex)-graphFromEdges edges0-  = (graph, \v -> vertex_map ! v, key_vertex)-  where-    max_v           = length edges0 - 1-    bounds0         = (0,max_v) :: (Vertex, Vertex)-    sorted_edges    = sortBy lt edges0-    edges1          = zipWith (,) [0..] sorted_edges--    graph           = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_,    _, ks) <- edges1]-    key_map         = array bounds0 [(,) v k                       | (,) v (_,    k, _ ) <- edges1]-    vertex_map      = array bounds0 edges1--    (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2--    -- key_vertex :: key -> Maybe Vertex-    --  returns Nothing for non-interesting vertices-    key_vertex k   = findVertex 0 max_v-                   where-                     findVertex a b | a > b-                              = Nothing-                     findVertex a b = case compare k (key_map ! mid) of-                                   LT -> findVertex a (mid-1)-                                   EQ -> Just mid-                                   GT -> findVertex (mid+1) b-                              where-                                mid = a + (b - a) `div` 2------------------------------------------------------------------------------                                                                      ----      Depth first search---                                                                      ------------------------------------------------------------------------------- | A spanning forest of the graph, obtained from a depth-first search of--- the graph starting from each vertex in an unspecified order.-dff          :: Graph -> Forest Vertex-dff g         = dfs g (vertices g)---- | A spanning forest of the part of the graph reachable from the listed--- vertices, obtained from a depth-first search of the graph starting at--- each of the listed vertices in order.-dfs          :: Graph -> [Vertex] -> Forest Vertex-dfs g vs      = prune (bounds g) (map (generate g) vs)--generate     :: Graph -> Vertex -> Tree Vertex-generate g v  = Node v (map (generate g) (g!v))--prune        :: Bounds -> Forest Vertex -> Forest Vertex-prune bnds ts = run bnds (chop ts)--chop         :: Forest Vertex -> SetM s (Forest Vertex)-chop []       = return []-chop (Node v ts : us)-              = do-                visited <- contains v-                if visited then-                  chop us-                 else do-                  include v-                  as <- chop ts-                  bs <- chop us-                  return (Node v as : bs)---- A monad holding a set of vertices visited so far.-#if USE_ST_MONAD---- Use the ST monad if available, for constant-time primitives.--#if USE_UNBOXED_ARRAYS-newtype SetM s a = SetM { runSetM :: STUArray s Vertex Bool -> ST s a }-#else-newtype SetM s a = SetM { runSetM :: STArray  s Vertex Bool -> ST s a }-#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--include      :: Vertex -> SetM s ()-include v     = SetM $ \ m -> writeArray m v True--#else /* !USE_ST_MONAD */---- Portable implementation using IntSet.--newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) }--instance Monad (SetM s) where-    return x     = SetM $ \s -> (x, s)-    SetM v >>= f = SetM $ \s -> case v s of (x, s') -> runSetM (f x) s'--instance Functor (SetM s) where-    f `fmap` SetM v = SetM $ \s -> case v s of (x, s') -> (f x, s')-    {-# INLINE fmap #-}--instance Applicative (SetM s) 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)--#endif /* !USE_ST_MONAD */------------------------------------------------------------------------------                                                                      ----      Algorithms---                                                                      -------------------------------------------------------------------------------------------------------------------------------------------- Algorithm 1: depth first search numbering---------------------------------------------------------------preorder' :: Tree a -> [a] -> [a]-preorder' (Node a ts) = (a :) . preorderF' ts--preorderF' :: Forest a -> [a] -> [a]-preorderF' ts = foldr (.) id $ map preorder' ts--preorderF :: Forest a -> [a]-preorderF ts = preorderF' ts []--tabulate        :: Bounds -> [Vertex] -> UArray Vertex Int-tabulate bnds vs = UA.array bnds (zipWith (flip (,)) [1..] vs)--- Why zipWith (flip (,)) instead of just using zip with the--- arguments in the other order? We want the [1..] to fuse--- away, and these days that only happens when it's the first--- list argument.--preArr          :: Bounds -> Forest Vertex -> UArray Vertex Int-preArr bnds      = tabulate bnds . preorderF----------------------------------------------------------------- Algorithm 2: topological sorting---------------------------------------------------------------postorder :: Tree a -> [a] -> [a]-postorder (Node a ts) = postorderF ts . (a :)--postorderF   :: Forest a -> [a] -> [a]-postorderF ts = foldr (.) id $ map postorder ts--postOrd :: Graph -> [Vertex]-postOrd g = postorderF (dff g) []---- | A topological sort of the graph.--- The order is partially specified by the condition that a vertex /i/--- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.-topSort      :: Graph -> [Vertex]-topSort       = reverse . postOrd----------------------------------------------------------------- Algorithm 3: connected components----------------------------------------------------------------- | The connected components of a graph.--- Two vertices are connected if there is a path between them, traversing--- edges in either direction.-components   :: Graph -> Forest Vertex-components    = dff . undirected--undirected   :: Graph -> Graph-undirected g  = buildG (bounds g) (edges g ++ reverseE g)---- Algorithm 4: strongly connected components---- | The strongly connected components of a graph.-scc  :: Graph -> Forest Vertex-scc g = dfs g (reverse (postOrd (transposeG g)))----------------------------------------------------------------- Algorithm 5: Classifying edges---------------------------------------------------------------{--XXX unused code--tree              :: Bounds -> Forest Vertex -> Graph-tree bnds ts       = buildG bnds (concat (map flat ts))- where flat (Node v ts') = [ (v, w) | Node w _us <- ts' ]-                        ++ concat (map flat ts')--back              :: Graph -> Table Int -> Graph-back g post        = mapT select g- where select v ws = [ w | w <- ws, post!v < post!w ]--cross             :: Graph -> Table Int -> Table Int -> Graph-cross g pre post   = mapT select g- where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]--forward           :: Graph -> Graph -> Table Int -> Graph-forward g tree' pre = mapT select g- where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree' ! v--mapT    :: (Vertex -> a -> b) -> Array Vertex a -> Array Vertex b-mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]--}----------------------------------------------------------------- Algorithm 6: Finding reachable vertices----------------------------------------------------------------- | Returns the list of vertices reachable from a given vertex.------ ==== __Examples__------ > reachable (buildG (0,0) []) 0 == [0]------ > reachable (buildG (0,2) [(0,1), (1,2)]) 0 == [0,1,2]-reachable :: Graph -> Vertex -> [Vertex]-reachable g v = preorderF (dfs g [v])---- | Returns @True@ if the second vertex reachable from the first.------ ==== __Examples__------ > path (buildG (0,0) []) 0 0 == True------ > path (buildG (0,2) [(0,1), (1,2)]) 0 2 == True------ > path (buildG (0,2) [(0,1), (1,2)]) 2 0 == False-path :: Graph -> Vertex -> Vertex -> Bool-path g v w    = w `elem` (reachable g v)----------------------------------------------------------------- Algorithm 7: Biconnected components----------------------------------------------------------------- | The biconnected components of a graph.--- An undirected graph is biconnected if the deletion of any vertex--- leaves it connected.-bcc :: Graph -> Forest [Vertex]-bcc g = (concat . map bicomps . map (do_label g dnum)) forest- where forest = dff g-       dnum   = preArr (bounds g) forest--do_label :: Graph -> UArray Vertex Int -> Tree Vertex -> Tree (Vertex,Int,Int)-do_label g dnum (Node v ts) = Node (v, dnum UA.! v, lv) us- where us = map (do_label g dnum) ts-       lv = minimum ([dnum UA.! v] ++ [dnum UA.! w | w <- g!v]-                     ++ [lu | Node (_,_,lu) _ <- us])--bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]-bicomps (Node (v,_,_) ts)-      = [ Node (v:vs) us | (_,Node vs us) <- map collect ts]--collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])-collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)- where collected = map collect ts-       vs = concat [ ws | (lw, Node ws _) <- collected, lw<dv]-       cs = concat [ if lw<dv then us else [Node (v:ws) us]-                        | (lw, Node ws us) <- collected ]

@@ -1,101 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE DataKinds, FlexibleContexts #-}-#endif-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE MonoLocalBinds #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.IntMap--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- 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.------ These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.------ >  import Data.IntMap (IntMap)--- >  import qualified Data.IntMap as IntMap------ 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 map implementation (see "Data.Map").------    * 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.------ 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).--------------------------------------------------------------------------------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

@@ -1,3435 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE TypeFamilies #-}-#endif--{-# OPTIONS_HADDOCK not-home #-}--#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__.------ This 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--    -- * 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--    -- ** 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-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , foldr-    , foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet-    , fromSet--    -- ** Lists-    , toList-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** Ordered lists-    , toAscList-    , toDescList-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList--    -- * Filter-    , filter-    , filterWithKey-    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey--    -- * Debugging-    , showTree-    , showTreeWith--    -- * Internal types-    , Mask, Prefix, Nat--    -- * Utility-    , natFromInt-    , intFromNat-    , link-    , bin-    , binCheckLeft-    , binCheckRight-    , zero-    , nomatch-    , match-    , mask-    , maskW-    , shorter-    , branchMask-    , highestBitMask--    -- * Used by "IntMap.Merge.Lazy" and "IntMap.Merge.Strict"-    , mapWhenMissing-    , mapWhenMatched-    , lmapWhenMissing-    , contramapFirstWhenMatched-    , contramapSecondWhenMatched-    , mapGentlyWhenMissing-    , mapGentlyWhenMatched-    ) where--#if MIN_VERSION_base(4,8,0)-import Data.Functor.Identity (Identity (..))-import Control.Applicative (liftA2)-#else-import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2)-import Data.Monoid (Monoid(..))-import Data.Traversable (Traversable(traverse))-import Data.Word (Word)-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)-import Data.Functor.Classes-#endif--import Control.DeepSeq (NFData(rnf))-import Data.Bits-import qualified Data.Foldable as Foldable-import Data.Foldable (Foldable())-import Data.Maybe (fromMaybe)-import Data.Typeable-import Prelude hiding (lookup, map, filter, foldr, foldl, null)--import Data.IntSet.Internal (Key)-import qualified Data.IntSet.Internal as IntSet-import Utils.Containers.Internal.BitUtil-import Utils.Containers.Internal.StrictPair--#if __GLASGOW_HASKELL__-import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),-                  DataType, mkDataType)-import GHC.Exts (build)-#if !MIN_VERSION_base(4,8,0)-import Data.Functor ((<$))-#endif-#if __GLASGOW_HASKELL__ >= 708-import qualified GHC.Exts as GHCExts-#endif-import Text.Read-#endif-import qualified Control.Category as Category-#if __GLASGOW_HASKELL__ >= 709-import Data.Coerce-#endif----- A "Nat" is a natural machine word (an unsigned Int)-type Nat = Word--natFromInt :: Key -> Nat-natFromInt = fromIntegral-{-# INLINE natFromInt #-}--intFromNat :: Nat -> Key-intFromNat = fromIntegral-{-# INLINE intFromNat #-}--{---------------------------------------------------------------------  Types---------------------------------------------------------------------}----- | A map of integers to values @a@.---- See Note: Order of constructors-data IntMap a = Bin {-# UNPACK #-} !Prefix-                    {-# UNPACK #-} !Mask-                    !(IntMap a)-                    !(IntMap a)--- Fields:---   prefix: The most significant bits shared by all keys in this Bin.---   mask: The switching bit to determine if a key should follow the left---         or right subtree of a 'Bin'.--- Invariant: Nil is never found as a child of Bin.--- Invariant: The Mask is a power of 2. It is the largest bit position at which---            two keys of the map differ.--- Invariant: Prefix is the common high-order bits that all elements share to---            the left of the Mask bit.--- Invariant: In Bin prefix mask left right, left consists of the elements that---            don't have the mask bit set; right is all the elements that do.-              | Tip {-# UNPACK #-} !Key a-              | Nil--type Prefix = Int-type Mask   = Int----- Some stuff from "Data.IntSet.Internal", for 'restrictKeys' and--- 'withoutKeys' to use.-type IntSetPrefix = Int-type IntSetBitMap = Word--bitmapOf :: Int -> IntSetBitMap-bitmapOf x = shiftLL 1 (x .&. IntSet.suffixBitMask)-{-# INLINE bitmapOf #-}--{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}---- | /O(min(n,W))/. Find the value at a key.--- Calls 'error' when the element can not be found.------ > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map--- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'--(!) :: IntMap a -> Key -> a-(!) m k = find k m---- | /O(min(n,W))/. Find the value at a key.--- Returns 'Nothing' when the element can not be found.------ > fromList [(5,'a'), (3,'b')] !? 1 == Nothing--- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a'------ @since 0.5.11--(!?) :: IntMap a -> Key -> Maybe a-(!?) m k = lookup k m---- | Same as 'difference'.-(\\) :: IntMap a -> IntMap b -> IntMap a-m1 \\ m2 = difference m1 m2--infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}--{---------------------------------------------------------------------  Types---------------------------------------------------------------------}--instance Monoid (IntMap a) where-    mempty  = empty-    mconcat = unions-#if !(MIN_VERSION_base(4,9,0))-    mappend = union-#else-    mappend = (<>)---- | @since 0.5.7-instance Semigroup (IntMap a) where-    (<>)    = union-    stimes  = stimesIdempotentMonoid-#endif--instance Foldable.Foldable IntMap where-  fold = go-    where go Nil = mempty-          go (Tip _ v) = v-          go (Bin _ _ l r) = 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 _ _ l r) = go l `mappend` go r-  {-# INLINE foldMap #-}-  foldl' = foldl'-  {-# INLINE foldl' #-}-  foldr' = foldr'-  {-# INLINE foldr' #-}-#if MIN_VERSION_base(4,8,0)-  length = size-  {-# INLINE length #-}-  null   = null-  {-# INLINE null #-}-  toList = elems -- NB: Foldable.toList /= IntMap.toList-  {-# INLINE toList #-}-  elem = go-    where go !_ Nil = False-          go x (Tip _ y) = x == y-          go x (Bin _ _ l r) = go x l || go x r-  {-# INLINABLE elem #-}-  maximum = start-    where start Nil = error "Data.Foldable.maximum (for Data.IntMap): empty map"-          start (Tip _ y) = y-          start (Bin _ _ l r) = 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 _ _ l r) = go (start l) r--          go !m Nil = m-          go m (Tip _ y) = min m y-          go m (Bin _ _ l r) = go (go m l) r-  {-# INLINABLE minimum #-}-  sum = foldl' (+) 0-  {-# INLINABLE sum #-}-  product = foldl' (*) 1-  {-# INLINABLE product #-}-#endif--instance Traversable IntMap where-    traverse f = traverseWithKey (\_ -> f)-    {-# INLINE traverse #-}--instance NFData a => NFData (IntMap a) where-    rnf Nil = ()-    rnf (Tip _ v) = rnf v-    rnf (Bin _ _ l r) = rnf l `seq` rnf r--#if __GLASGOW_HASKELL__--{---------------------------------------------------------------------  A Data instance---------------------------------------------------------------------}---- This instance preserves data abstraction at the cost of inefficiency.--- We provide limited reflection services for the sake of data abstraction.--instance Data a => Data (IntMap a) where-  gfoldl f z im = z fromList `f` (toList im)-  toConstr _     = fromListConstr-  gunfold k z c  = case constrIndex c of-    1 -> k (z fromList)-    _ -> error "gunfold"-  dataTypeOf _   = intMapDataType-  dataCast1 f    = gcast1 f--fromListConstr :: Constr-fromListConstr = mkConstr intMapDataType "fromList" [] Prefix--intMapDataType :: DataType-intMapDataType = mkDataType "Data.IntMap.Internal.IntMap" [fromListConstr]--#endif--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is the map empty?------ > Data.IntMap.null (empty)           == True--- > Data.IntMap.null (singleton 1 'a') == False--null :: IntMap a -> Bool-null Nil = True-null _   = False-{-# INLINE null #-}---- | /O(n)/. Number of elements in the map.------ > size empty                                   == 0--- > size (singleton 1 'a')                       == 1--- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3-size :: IntMap a -> Int-size = go 0-  where-    go !acc (Bin _ _ l r) = go (go acc l) r-    go acc (Tip _ _) = 1 + acc-    go acc Nil = acc---- | /O(min(n,W))/. Is the key a member of the map?------ > member 5 (fromList [(5,'a'), (3,'b')]) == True--- > member 1 (fromList [(5,'a'), (3,'b')]) == False---- See Note: Local 'go' functions and capturing]-member :: Key -> IntMap a -> Bool-member !k = go-  where-    go (Bin p m l r) | nomatch k p m = False-                     | zero k m  = go l-                     | otherwise = go r-    go (Tip kx _) = k == kx-    go Nil = False---- | /O(min(n,W))/. Is the key not a member of the map?------ > notMember 5 (fromList [(5,'a'), (3,'b')]) == False--- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True--notMember :: Key -> IntMap a -> Bool-notMember k m = not $ member k m---- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'.---- See Note: Local 'go' functions and capturing]-lookup :: Key -> IntMap a -> Maybe a-lookup !k = go-  where-    go (Bin p m l r) | nomatch k p m = Nothing-                     | zero k m  = go l-                     | otherwise = go r-    go (Tip kx x) | k == kx   = Just x-                  | otherwise = Nothing-    go Nil = Nothing----- See Note: Local 'go' functions and capturing]-find :: Key -> IntMap a -> a-find !k = go-  where-    go (Bin p m l r) | nomatch k p m = not_found-                     | zero k m  = go l-                     | otherwise = go r-    go (Tip kx x) | k == kx   = x-                  | otherwise = not_found-    go Nil = not_found--    not_found = error ("IntMap.!: key " ++ show k ++ " is not an element of the map")---- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@--- returns the value at key @k@ or returns @def@ when the key is not an--- element of the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'---- See Note: Local 'go' functions and capturing]-findWithDefault :: a -> Key -> IntMap a -> a-findWithDefault def !k = go-  where-    go (Bin p m l r) | nomatch k p m = def-                     | zero k m  = go l-                     | otherwise = go r-    go (Tip kx x) | k == kx   = x-                  | otherwise = def-    go Nil = def---- | /O(log n)/. Find largest key smaller than the given one and return the--- corresponding (key, value) pair.------ > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing--- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')---- See Note: Local 'go' functions and capturing.-lookupLT :: Key -> IntMap a -> Maybe (Key, a)-lookupLT !k t = case t of-    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r-    _ -> go Nil t-  where-    go def (Bin p m l r)-      | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r-      | zero k m  = go def l-      | otherwise = go l r-    go def (Tip ky y)-      | k <= ky   = unsafeFindMax def-      | otherwise = Just (ky, y)-    go def Nil = unsafeFindMax def---- | /O(log n)/. Find smallest key greater than the given one and return the--- corresponding (key, value) pair.------ > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')--- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGT :: Key -> IntMap a -> Maybe (Key, a)-lookupGT !k t = case t of-    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r-    _ -> go Nil t-  where-    go def (Bin p m l r)-      | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def-      | zero k m  = go r l-      | otherwise = go def r-    go def (Tip ky y)-      | k >= ky   = unsafeFindMin def-      | otherwise = Just (ky, y)-    go def Nil = unsafeFindMin def---- | /O(log n)/. Find largest key smaller or equal to the given one and return--- the corresponding (key, value) pair.------ > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing--- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')--- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')---- See Note: Local 'go' functions and capturing.-lookupLE :: Key -> IntMap a -> Maybe (Key, a)-lookupLE !k t = case t of-    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r-    _ -> go Nil t-  where-    go def (Bin p m l r)-      | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r-      | zero k m  = go def l-      | otherwise = go l r-    go def (Tip ky y)-      | k < ky    = unsafeFindMax def-      | otherwise = Just (ky, y)-    go def Nil = unsafeFindMax def---- | /O(log n)/. Find smallest key greater or equal to the given one and return--- the corresponding (key, value) pair.------ > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')--- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')--- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGE :: Key -> IntMap a -> Maybe (Key, a)-lookupGE !k t = case t of-    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r-    _ -> go Nil t-  where-    go def (Bin p m l r)-      | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def-      | zero k m  = go r l-      | otherwise = go def r-    go def (Tip ky y)-      | k > ky    = unsafeFindMin def-      | otherwise = Just (ky, y)-    go def Nil = unsafeFindMin def----- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMin :: IntMap a -> Maybe (Key, a)-unsafeFindMin Nil = Nothing-unsafeFindMin (Tip ky y) = Just (ky, y)-unsafeFindMin (Bin _ _ l _) = unsafeFindMin l---- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMax :: IntMap a -> Maybe (Key, a)-unsafeFindMax Nil = Nothing-unsafeFindMax (Tip ky y) = Just (ky, y)-unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. The empty map.------ > empty      == fromList []--- > size empty == 0--empty :: IntMap a-empty-  = Nil-{-# INLINE empty #-}---- | /O(1)/. A map of one element.------ > singleton 1 'a'        == fromList [(1, 'a')]--- > size (singleton 1 'a') == 1--singleton :: Key -> a -> IntMap a-singleton k x-  = Tip k x-{-# INLINE singleton #-}--{---------------------------------------------------------------------  Insert---------------------------------------------------------------------}--- | /O(min(n,W))/. Insert a new key\/value pair in the map.--- If the key is already present in the map, the associated value is--- replaced with the supplied value, i.e. 'insert' is equivalent to--- @'insertWith' 'const'@.------ > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]--- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]--- > insert 5 'x' empty                         == singleton 5 'x'--insert :: Key -> a -> IntMap a -> IntMap a-insert !k x t@(Bin p m l r)-  | nomatch k p m = link k (Tip k x) p t-  | zero k m      = Bin p m (insert k x l) r-  | otherwise     = Bin p m l (insert k x r)-insert k x t@(Tip ky _)-  | k==ky         = Tip k x-  | otherwise     = link k (Tip k x) ky t-insert k x Nil = Tip k x---- right-biased insertion, used by 'union'--- | /O(min(n,W))/. Insert with a combining function.--- @'insertWith' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert @f new_value old_value@.------ > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"--insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWith f k x t-  = insertWithKey (\_ x' y' -> f x' y') k x t---- | /O(min(n,W))/. Insert with a combining function.--- @'insertWithKey' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert @f key new_value old_value@.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"--insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWithKey f !k x t@(Bin p m l r)-  | nomatch k p m = link k (Tip k x) p t-  | zero k m      = Bin p m (insertWithKey f k x l) r-  | otherwise     = Bin p m l (insertWithKey f k x r)-insertWithKey f k x t@(Tip ky y)-  | k == ky       = Tip k (f k x y)-  | otherwise     = link k (Tip k x) ky t-insertWithKey _ k x Nil = Tip k x---- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)--- is a pair where the first element is equal to (@'lookup' k map@)--- and the second element equal to (@'insertWithKey' f k x map@).------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])--- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])--- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")------ This is how to define @insertLookup@ using @insertLookupWithKey@:------ > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t--- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])--- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])--insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)-insertLookupWithKey f !k x t@(Bin p m l r)-  | nomatch k p m = (Nothing,link k (Tip k x) p t)-  | zero k m      = let (found,l') = insertLookupWithKey f k x l-                    in (found,Bin p m l' r)-  | otherwise     = let (found,r') = insertLookupWithKey f k x r-                    in (found,Bin p m l r')-insertLookupWithKey f k x t@(Tip ky y)-  | k == ky       = (Just y,Tip k (f k x y))-  | otherwise     = (Nothing,link k (Tip k x) ky t)-insertLookupWithKey _ k x Nil = (Nothing,Tip k x)---{---------------------------------------------------------------------  Deletion---------------------------------------------------------------------}--- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not--- a member of the map, the original map is returned.------ > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > delete 5 empty                         == empty--delete :: Key -> IntMap a -> IntMap a-delete !k t@(Bin p m l r)-  | nomatch k p m = t-  | zero k m      = binCheckLeft p m (delete k l) r-  | otherwise     = binCheckRight p m l (delete k r)-delete k t@(Tip ky _)-  | k == ky       = Nil-  | otherwise     = t-delete _k Nil = Nil---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjust ("new " ++) 7 empty                         == empty--adjust ::  (a -> a) -> Key -> IntMap a -> IntMap a-adjust f k m-  = adjustWithKey (\_ x -> f x) k m---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > let f key x = (show key) ++ ":new " ++ x--- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjustWithKey f 7 empty                         == empty--adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a-adjustWithKey f !k t@(Bin p m l r)-  | nomatch k p m = t-  | zero k m      = Bin p m (adjustWithKey f k l) r-  | otherwise     = Bin p m l (adjustWithKey f k r)-adjustWithKey f k t@(Tip ky y)-  | k == ky       = Tip ky (f k y)-  | otherwise     = t-adjustWithKey _ _ Nil = Nil----- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f x = if x == "a" then Just "new a" else Nothing--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--update ::  (a -> Maybe a) -> Key -> IntMap a -> IntMap a-update f-  = updateWithKey (\_ x -> f x)---- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a-updateWithKey f !k t@(Bin p m l r)-  | nomatch k p m = t-  | zero k m      = binCheckLeft p m (updateWithKey f k l) r-  | otherwise     = binCheckRight p m l (updateWithKey f k r)-updateWithKey f k t@(Tip ky y)-  | k == ky       = case (f k y) of-                      Just y' -> Tip ky y'-                      Nothing -> Nil-  | otherwise     = t-updateWithKey _ _ Nil = Nil---- | /O(min(n,W))/. Lookup and update.--- The function returns original value, if it is updated.--- This is different behavior than 'Data.Map.updateLookupWithKey'.--- Returns the original key value if the map entry is deleted.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])--- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])--- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")--updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)-updateLookupWithKey f !k t@(Bin p m l r)-  | nomatch k p m = (Nothing,t)-  | zero k m      = let !(found,l') = updateLookupWithKey f k l-                    in (found,binCheckLeft p m l' r)-  | otherwise     = let !(found,r') = updateLookupWithKey f k r-                    in (found,binCheckRight p m l r')-updateLookupWithKey f k t@(Tip ky y)-  | k==ky         = case (f k y) of-                      Just y' -> (Just y,Tip ky y')-                      Nothing -> (Just y,Nil)-  | otherwise     = (Nothing,t)-updateLookupWithKey _ _ Nil = (Nothing,Nil)------ | /O(min(n,W))/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.--- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.-alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a-alter f !k t@(Bin p m l r)-  | nomatch k p m = case f Nothing of-                      Nothing -> t-                      Just x -> link k (Tip k x) p t-  | zero k m      = binCheckLeft p m (alter f k l) r-  | otherwise     = binCheckRight p m l (alter f k r)-alter f k t@(Tip ky y)-  | k==ky         = case f (Just y) of-                      Just x -> Tip ky x-                      Nothing -> Nil-  | otherwise     = case f Nothing of-                      Just x -> link k (Tip k x) ky t-                      Nothing -> Tip ky y-alter f k Nil     = case f Nothing of-                      Just x -> Tip k x-                      Nothing -> Nil---- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at--- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,--- or update a value in an 'IntMap'.  In short : @'lookup' k <$> 'alterF' f k m = f--- ('lookup' k m)@.------ Example:------ @--- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)--- interactiveAlter k m = alterF f k m where---   f Nothing -> do---      putStrLn $ show k ++---          " was not found in the map. Would you like to add it?"---      getUserResponse1 :: IO (Maybe String)---   f (Just old) -> do---      putStrLn "The key is currently bound to " ++ show old ++---          ". Would you like to change or delete it?"---      getUserresponse2 :: IO (Maybe String)--- @------ 'alterF' is the most general operation for working with an individual--- key that may or may not be in a given map.------ Note: 'alterF' is a flipped version of the 'at' combinator from--- 'Control.Lens.At'.------ @since 0.5.8--alterF :: Functor f-       => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)--- This implementation was stolen from 'Control.Lens.At'.-alterF f k m = (<$> f mv) $ \fres ->-  case fres of-    Nothing -> maybe m (const (delete k m)) mv-    Just v' -> insert k v' m-  where mv = lookup k m--{---------------------------------------------------------------------  Union---------------------------------------------------------------------}--- | The union of a list of maps.------ > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- >     == fromList [(3, "b"), (5, "a"), (7, "C")]--- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]--- >     == fromList [(3, "B3"), (5, "A3"), (7, "C")]--unions :: Foldable f => f (IntMap a) -> IntMap a-unions xs-  = Foldable.foldl' union empty xs---- | The union of a list of maps, with a combining operation.------ > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]--unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a-unionsWith f ts-  = Foldable.foldl' (unionWith f) empty ts---- | /O(n+m)/. The (left-biased) union of two maps.--- It prefers the first map when duplicate keys are encountered,--- i.e. (@'union' == 'unionWith' 'const'@).------ > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]--union :: IntMap a -> IntMap a -> IntMap a-union m1 m2-  = mergeWithKey' Bin const id id m1 m2---- | /O(n+m)/. The union with a combining function.------ > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]--unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a-unionWith f m1 m2-  = unionWithKey (\_ x y -> f x y) m1 m2---- | /O(n+m)/. The union with a combining function.------ > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]--unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a-unionWithKey f m1 m2-  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | /O(n+m)/. Difference between two maps (based on keys).------ > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"--difference :: IntMap a -> IntMap b -> IntMap a-difference m1 m2-  = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2---- | /O(n+m)/. Difference with a combining function.------ > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing--- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])--- >     == singleton 3 "b:B"--differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a-differenceWith f m1 m2-  = differenceWithKey (\_ x y -> f x y) m1 m2---- | /O(n+m)/. Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference).--- If it returns (@'Just' y@), the element is updated with a new value @y@.------ > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing--- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])--- >     == singleton 3 "3:b|B"--differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a-differenceWithKey f m1 m2-  = mergeWithKey f id (const Nil) m1 m2----- TODO(wrengr): re-verify that asymptotic bound--- | /O(n+m)/. Remove all the keys in a given set from a map.------ @--- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.notMember`` s) m--- @------ @since 0.5.8-withoutKeys :: IntMap a -> IntSet.IntSet -> IntMap a-withoutKeys t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)-    | shorter m1 m2  = difference1-    | shorter m2 m1  = difference2-    | p1 == p2       = bin p1 m1 (withoutKeys l1 l2) (withoutKeys r1 r2)-    | otherwise      = t1-    where-    difference1-        | nomatch p2 p1 m1  = t1-        | zero p2 m1        = binCheckLeft p1 m1 (withoutKeys l1 t2) r1-        | otherwise         = binCheckRight p1 m1 l1 (withoutKeys r1 t2)-    difference2-        | nomatch p1 p2 m2  = t1-        | zero p1 m2        = withoutKeys t1 l2-        | otherwise         = withoutKeys t1 r2-withoutKeys t1@(Bin p1 m1 _ _) (IntSet.Tip p2 bm2) =-    let minbit = bitmapOf p1-        lt_minbit = minbit - 1-        maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))-        gt_maxbit = maxbit `xor` complement (maxbit - 1)-    -- TODO(wrengr): should we manually inline/unroll 'updatePrefix'-    -- and 'withoutBM' here, in order to avoid redundant case analyses?-    in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)-withoutKeys t1@(Bin _ _ _ _) IntSet.Nil = t1-withoutKeys t1@(Tip k1 _) t2-    | k1 `IntSet.member` t2 = Nil-    | otherwise = t1-withoutKeys Nil _ = Nil---updatePrefix-    :: IntSetPrefix -> IntMap a -> (IntMap a -> IntMap a) -> IntMap a-updatePrefix !kp t@(Bin p m l r) f-    | m .&. IntSet.suffixBitMask /= 0 =-        if p .&. IntSet.prefixBitMask == kp then f t else t-    | nomatch kp p m = t-    | zero kp m      = binCheckLeft p m (updatePrefix kp l f) r-    | otherwise      = binCheckRight p m l (updatePrefix kp r f)-updatePrefix kp t@(Tip kx _) f-    | kx .&. IntSet.prefixBitMask == kp = f t-    | otherwise = t-updatePrefix _ Nil _ = Nil---withoutBM :: IntSetBitMap -> IntMap a -> IntMap a-withoutBM 0 t = t-withoutBM bm (Bin p m l r) =-    let leftBits = bitmapOf (p .|. m) - 1-        bmL = bm .&. leftBits-        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)-    in  bin p m (withoutBM bmL l) (withoutBM bmR r)-withoutBM bm t@(Tip k _)-    -- TODO(wrengr): need we manually inline 'IntSet.Member' here?-    | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = Nil-    | otherwise = t-withoutBM _ Nil = Nil---{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).------ > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"--intersection :: IntMap a -> IntMap b -> IntMap a-intersection m1 m2-  = mergeWithKey' bin const (const Nil) (const Nil) m1 m2----- TODO(wrengr): re-verify that asymptotic bound--- | /O(n+m)/. The restriction of a map to the keys in a set.------ @--- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``IntSet.member`` s) m--- @------ @since 0.5.8-restrictKeys :: IntMap a -> IntSet.IntSet -> IntMap a-restrictKeys t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)-    | shorter m1 m2  = intersection1-    | shorter m2 m1  = intersection2-    | p1 == p2       = bin p1 m1 (restrictKeys l1 l2) (restrictKeys r1 r2)-    | otherwise      = Nil-    where-    intersection1-        | nomatch p2 p1 m1  = Nil-        | zero p2 m1        = restrictKeys l1 t2-        | otherwise         = restrictKeys r1 t2-    intersection2-        | nomatch p1 p2 m2  = Nil-        | zero p1 m2        = restrictKeys t1 l2-        | otherwise         = restrictKeys t1 r2-restrictKeys t1@(Bin p1 m1 _ _) (IntSet.Tip p2 bm2) =-    let minbit = bitmapOf p1-        ge_minbit = complement (minbit - 1)-        maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))-        le_maxbit = maxbit .|. (maxbit - 1)-    -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'-    -- and 'restrictBM' here, in order to avoid redundant case analyses?-    in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)-restrictKeys (Bin _ _ _ _) IntSet.Nil = Nil-restrictKeys t1@(Tip k1 _) t2-    | k1 `IntSet.member` t2 = t1-    | otherwise = Nil-restrictKeys Nil _ = Nil----- | /O(min(n,W))/. Restrict to the sub-map with all keys matching--- a key prefix.-lookupPrefix :: IntSetPrefix -> IntMap a -> IntMap a-lookupPrefix !kp t@(Bin p m l r)-    | m .&. IntSet.suffixBitMask /= 0 =-        if p .&. IntSet.prefixBitMask == kp then t else Nil-    | nomatch kp p m = Nil-    | zero kp m      = lookupPrefix kp l-    | otherwise      = lookupPrefix kp r-lookupPrefix kp t@(Tip kx _)-    | (kx .&. IntSet.prefixBitMask) == kp = t-    | otherwise = Nil-lookupPrefix _ Nil = Nil---restrictBM :: IntSetBitMap -> IntMap a -> IntMap a-restrictBM 0 _ = Nil-restrictBM bm (Bin p m l r) =-    let leftBits = bitmapOf (p .|. m) - 1-        bmL = bm .&. leftBits-        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)-    in  bin p m (restrictBM bmL l) (restrictBM bmR r)-restrictBM bm t@(Tip k _)-    -- TODO(wrengr): need we manually inline 'IntSet.Member' here?-    | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = t-    | otherwise = Nil-restrictBM _ Nil = Nil----- | /O(n+m)/. The intersection with a combining function.------ > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"--intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c-intersectionWith f m1 m2-  = intersectionWithKey (\_ x y -> f x y) m1 m2---- | /O(n+m)/. The intersection with a combining function.------ > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar--- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"--intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c-intersectionWithKey f m1 m2-  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2--{---------------------------------------------------------------------  MergeWithKey---------------------------------------------------------------------}---- | /O(n+m)/. A high-performance universal combining function. Using--- 'mergeWithKey', all combining functions can be defined without any loss of--- efficiency (with exception of 'union', 'difference' and 'intersection',--- where sharing of some nodes is lost with 'mergeWithKey').------ Please make sure you know what is going on when using 'mergeWithKey',--- otherwise you can be surprised by unexpected code growth or even--- corruption of the data structure.------ When 'mergeWithKey' is given three arguments, it is inlined to the call--- site. You should therefore use 'mergeWithKey' only to define your custom--- combining functions. For example, you could define 'unionWithKey',--- 'differenceWithKey' and 'intersectionWithKey' as------ > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2--- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2--- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2------ When calling @'mergeWithKey' combine only1 only2@, a function combining two--- 'IntMap's is created, such that------ * if a key is present in both maps, it is passed with both corresponding---   values to the @combine@ function. Depending on the result, the key is either---   present in the result with specified value, or is left out;------ * a nonempty subtree present only in the first map is passed to @only1@ and---   the output is added to the result;------ * a nonempty subtree present only in the second map is passed to @only2@ and---   the output is added to the result.------ The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.--- The values can be modified arbitrarily. Most common variants of @only1@ and--- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or--- @'filterWithKey' f@ could be used for any @f@.--mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)-             -> IntMap a -> IntMap b -> IntMap c-mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2-  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.-        combine = \(Tip k1 x1) (Tip _k2 x2) ->-          case f k1 x1 x2 of-            Nothing -> Nil-            Just x -> Tip k1 x-        {-# INLINE combine #-}-{-# INLINE mergeWithKey #-}---- Slightly more general version of mergeWithKey. It differs in the following:------ * the combining function operates on maps instead of keys and values. The---   reason is to enable sharing in union, difference and intersection.------ * mergeWithKey' is given an equivalent of bin. The reason is that in union*,---   Bin constructor can be used, because we know both subtrees are nonempty.--mergeWithKey' :: (Prefix -> Mask -> IntMap c -> IntMap c -> IntMap c)-              -> (IntMap a -> IntMap b -> IntMap c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)-              -> IntMap a -> IntMap b -> IntMap c-mergeWithKey' bin' f g1 g2 = go-  where-    go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-      | shorter m1 m2  = merge1-      | shorter m2 m1  = merge2-      | p1 == p2       = bin' p1 m1 (go l1 l2) (go r1 r2)-      | otherwise      = maybe_link p1 (g1 t1) p2 (g2 t2)-      where-        merge1 | nomatch p2 p1 m1  = maybe_link p1 (g1 t1) p2 (g2 t2)-               | zero p2 m1        = bin' p1 m1 (go l1 t2) (g1 r1)-               | otherwise         = bin' p1 m1 (g1 l1) (go r1 t2)-        merge2 | nomatch p1 p2 m2  = maybe_link p1 (g1 t1) p2 (g2 t2)-               | zero p1 m2        = bin' p2 m2 (go t1 l2) (g2 r2)-               | otherwise         = bin' p2 m2 (g2 l2) (go t1 r2)--    go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1'-      where-        merge0 t2 k2 t1@(Bin p1 m1 l1 r1)-          | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2)-          | zero k2 m1 = bin' p1 m1 (merge0 t2 k2 l1) (g1 r1)-          | otherwise  = bin' p1 m1 (g1 l1) (merge0 t2 k2 r1)-        merge0 t2 k2 t1@(Tip k1 _)-          | k1 == k2 = f t1 t2-          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)-        merge0 t2 _  Nil = g2 t2--    go t1@(Bin _ _ _ _) Nil = g1 t1--    go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'-      where-        merge0 t1 k1 t2@(Bin p2 m2 l2 r2)-          | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2)-          | zero k1 m2 = bin' p2 m2 (merge0 t1 k1 l2) (g2 r2)-          | otherwise  = bin' p2 m2 (g2 l2) (merge0 t1 k1 r2)-        merge0 t1 k1 t2@(Tip k2 _)-          | k1 == k2 = f t1 t2-          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)-        merge0 t1 _  Nil = g1 t1--    go Nil t2 = g2 t2--    maybe_link _ Nil _ t2 = t2-    maybe_link _ t1 _ Nil = t1-    maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2-    {-# INLINE maybe_link #-}-{-# INLINE mergeWithKey' #-}---{---------------------------------------------------------------------  mergeA---------------------------------------------------------------------}---- | A tactic for dealing with keys present in one map but not the--- other in 'merge' or 'mergeA'.------ A tactic of type @WhenMissing f k x z@ is an abstract representation--- of a function of type @Key -> x -> f (Maybe z)@.------ @since 0.5.9--data WhenMissing f x y = WhenMissing-  { missingSubtree :: IntMap x -> f (IntMap y)-  , missingKey :: Key -> x -> f (Maybe y)}---- | @since 0.5.9-instance (Applicative f, Monad f) => Functor (WhenMissing f x) where-  fmap = mapWhenMissing-  {-# INLINE fmap #-}----- | @since 0.5.9-instance (Applicative f, Monad f) => Category.Category (WhenMissing f)-  where-    id = preserveMissing-    f . g =-      traverseMaybeMissing $ \ k x -> do-        y <- missingKey g k x-        case y of-          Nothing -> pure Nothing-          Just q  -> missingKey f k q-    {-# INLINE id #-}-    {-# INLINE (.) #-}----- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.------ @since 0.5.9-instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where-  pure x = mapMissing (\ _ _ -> x)-  f <*> g =-    traverseMaybeMissing $ \k x -> do-      res1 <- missingKey f k x-      case res1 of-        Nothing -> pure Nothing-        Just r  -> (pure $!) . fmap r =<< missingKey g k x-  {-# INLINE pure #-}-  {-# INLINE (<*>) #-}----- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.------ @since 0.5.9-instance (Applicative f, Monad f) => Monad (WhenMissing f x) where-#if !MIN_VERSION_base(4,8,0)-  return = pure-#endif-  m >>= f =-    traverseMaybeMissing $ \k x -> do-      res1 <- missingKey m k x-      case res1 of-        Nothing -> pure Nothing-        Just r  -> missingKey (f r) k x-  {-# INLINE (>>=) #-}----- | Map covariantly over a @'WhenMissing' f x@.------ @since 0.5.9-mapWhenMissing-  :: (Applicative f, Monad f)-  => (a -> b)-  -> WhenMissing f x a-  -> WhenMissing f x b-mapWhenMissing f t = WhenMissing-  { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'-  , missingKey     = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }-{-# INLINE mapWhenMissing #-}----- | Map covariantly over a @'WhenMissing' f x@, using only a--- 'Functor f' constraint.-mapGentlyWhenMissing-  :: Functor f-  => (a -> b)-  -> WhenMissing f x a-  -> WhenMissing f x b-mapGentlyWhenMissing f t = WhenMissing-  { missingSubtree = \m -> fmap f <$> missingSubtree t m-  , missingKey     = \k x -> fmap f <$> missingKey t k x }-{-# INLINE mapGentlyWhenMissing #-}----- | Map covariantly over a @'WhenMatched' f k x@, using only a--- 'Functor f' constraint.-mapGentlyWhenMatched-  :: Functor f-  => (a -> b)-  -> WhenMatched f x y a-  -> WhenMatched f x y b-mapGentlyWhenMatched f t =-  zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y-{-# INLINE mapGentlyWhenMatched #-}----- | Map contravariantly over a @'WhenMissing' f _ x@.------ @since 0.5.9-lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x-lmapWhenMissing f t = WhenMissing-  { missingSubtree = \m -> missingSubtree t (fmap f m)-  , missingKey     = \k x -> missingKey t k (f x) }-{-# INLINE lmapWhenMissing #-}----- | Map contravariantly over a @'WhenMatched' f _ y z@.------ @since 0.5.9-contramapFirstWhenMatched-  :: (b -> a)-  -> WhenMatched f a y z-  -> WhenMatched f b y z-contramapFirstWhenMatched f t =-  WhenMatched $ \k x y -> runWhenMatched t k (f x) y-{-# INLINE contramapFirstWhenMatched #-}----- | Map contravariantly over a @'WhenMatched' f x _ z@.------ @since 0.5.9-contramapSecondWhenMatched-  :: (b -> a)-  -> WhenMatched f x a z-  -> WhenMatched f x b z-contramapSecondWhenMatched f t =-  WhenMatched $ \k x y -> runWhenMatched t k x (f y)-{-# INLINE contramapSecondWhenMatched #-}---#if !MIN_VERSION_base(4,8,0)-newtype Identity a = Identity {runIdentity :: a}--instance Functor Identity where-    fmap f (Identity x) = Identity (f x)--instance Applicative Identity where-    pure = Identity-    Identity f <*> Identity x = Identity (f x)-#endif---- | A tactic for dealing with keys present in one map but not the--- other in 'merge'.------ A tactic of type @SimpleWhenMissing x z@ is an abstract--- representation of a function of type @Key -> x -> Maybe z@.------ @since 0.5.9-type SimpleWhenMissing = WhenMissing Identity----- | A tactic for dealing with keys present in both maps in 'merge'--- or 'mergeA'.------ A tactic of type @WhenMatched f x y z@ is an abstract representation--- of a function of type @Key -> x -> y -> f (Maybe z)@.------ @since 0.5.9-newtype WhenMatched f x y z = WhenMatched-  { matchedKey :: Key -> x -> y -> f (Maybe z) }----- | Along with zipWithMaybeAMatched, witnesses the isomorphism--- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@.------ @since 0.5.9-runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z)-runWhenMatched = matchedKey-{-# INLINE runWhenMatched #-}----- | Along with traverseMaybeMissing, witnesses the isomorphism--- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@.------ @since 0.5.9-runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y)-runWhenMissing = missingKey-{-# INLINE runWhenMissing #-}----- | @since 0.5.9-instance Functor f => Functor (WhenMatched f x y) where-  fmap = mapWhenMatched-  {-# INLINE fmap #-}----- | @since 0.5.9-instance (Monad f, Applicative f) => Category.Category (WhenMatched f x)-  where-    id = zipWithMatched (\_ _ y -> y)-    f . g =-      zipWithMaybeAMatched $ \k x y -> do-        res <- runWhenMatched g k x y-        case res of-          Nothing -> pure Nothing-          Just r  -> runWhenMatched f k x r-    {-# INLINE id #-}-    {-# INLINE (.) #-}----- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@------ @since 0.5.9-instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where-  pure x = zipWithMatched (\_ _ _ -> x)-  fs <*> xs =-    zipWithMaybeAMatched $ \k x y -> do-      res <- runWhenMatched fs k x y-      case res of-        Nothing -> pure Nothing-        Just r  -> (pure $!) . fmap r =<< runWhenMatched xs k x y-  {-# INLINE pure #-}-  {-# INLINE (<*>) #-}----- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@------ @since 0.5.9-instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where-#if !MIN_VERSION_base(4,8,0)-  return = pure-#endif-  m >>= f =-    zipWithMaybeAMatched $ \k x y -> do-      res <- runWhenMatched m k x y-      case res of-        Nothing -> pure Nothing-        Just r  -> runWhenMatched (f r) k x y-  {-# INLINE (>>=) #-}----- | Map covariantly over a @'WhenMatched' f x y@.------ @since 0.5.9-mapWhenMatched-  :: Functor f-  => (a -> b)-  -> WhenMatched f x y a-  -> WhenMatched f x y b-mapWhenMatched f (WhenMatched g) =-  WhenMatched $ \k x y -> fmap (fmap f) (g k x y)-{-# INLINE mapWhenMatched #-}----- | A tactic for dealing with keys present in both maps in 'merge'.------ A tactic of type @SimpleWhenMatched x y z@ is an abstract--- representation of a function of type @Key -> x -> y -> Maybe z@.------ @since 0.5.9-type SimpleWhenMatched = WhenMatched Identity----- | When a key is found in both maps, apply a function to the key--- and values and use the result in the merged map.------ > zipWithMatched--- >   :: (Key -> x -> y -> z)--- >   -> SimpleWhenMatched x y z------ @since 0.5.9-zipWithMatched-  :: Applicative f-  => (Key -> x -> y -> z)-  -> WhenMatched f x y z-zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y-{-# INLINE zipWithMatched #-}----- | When a key is found in both maps, apply a function to the key--- and values to produce an action and use its result in the merged--- map.------ @since 0.5.9-zipWithAMatched-  :: Applicative f-  => (Key -> x -> y -> f z)-  -> WhenMatched f x y z-zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y-{-# INLINE zipWithAMatched #-}----- | When a key is found in both maps, apply a function to the key--- and values and maybe use the result in the merged map.------ > zipWithMaybeMatched--- >   :: (Key -> x -> y -> Maybe z)--- >   -> SimpleWhenMatched x y z------ @since 0.5.9-zipWithMaybeMatched-  :: Applicative f-  => (Key -> x -> y -> Maybe z)-  -> WhenMatched f x y z-zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y-{-# INLINE zipWithMaybeMatched #-}----- | When a key is found in both maps, apply a function to the key--- and values, perform the resulting action, and maybe use the--- result in the merged map.------ This is the fundamental 'WhenMatched' tactic.------ @since 0.5.9-zipWithMaybeAMatched-  :: (Key -> x -> y -> f (Maybe z))-  -> WhenMatched f x y z-zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y-{-# INLINE zipWithMaybeAMatched #-}----- | Drop all the entries whose keys are missing from the other--- map.------ > dropMissing :: SimpleWhenMissing x y------ prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)------ but @dropMissing@ is much faster.------ @since 0.5.9-dropMissing :: Applicative f => WhenMissing f x y-dropMissing = WhenMissing-  { missingSubtree = const (pure Nil)-  , missingKey     = \_ _ -> pure Nothing }-{-# INLINE dropMissing #-}----- | Preserve, unchanged, the entries whose keys are missing from--- the other map.------ > preserveMissing :: SimpleWhenMissing x x------ prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)------ but @preserveMissing@ is much faster.------ @since 0.5.9-preserveMissing :: Applicative f => WhenMissing f x x-preserveMissing = WhenMissing-  { missingSubtree = pure-  , missingKey     = \_ v -> pure (Just v) }-{-# INLINE preserveMissing #-}----- | Map over the entries whose keys are missing from the other map.------ > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y------ prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)------ but @mapMissing@ is somewhat faster.------ @since 0.5.9-mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y-mapMissing f = WhenMissing-  { missingSubtree = \m -> pure $! mapWithKey f m-  , missingKey     = \k x -> pure $ Just (f k x) }-{-# INLINE mapMissing #-}----- | Map over the entries whose keys are missing from the other--- map, optionally removing some. This is the most powerful--- 'SimpleWhenMissing' tactic, but others are usually more efficient.------ > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y------ prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))------ but @mapMaybeMissing@ uses fewer unnecessary 'Applicative'--- operations.------ @since 0.5.9-mapMaybeMissing-  :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y-mapMaybeMissing f = WhenMissing-  { missingSubtree = \m -> pure $! mapMaybeWithKey f m-  , missingKey     = \k x -> pure $! f k x }-{-# INLINE mapMaybeMissing #-}----- | Filter the entries whose keys are missing from the other map.------ > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x------ prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x------ but this should be a little faster.------ @since 0.5.9-filterMissing-  :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x-filterMissing f = WhenMissing-  { missingSubtree = \m -> pure $! filterWithKey f m-  , missingKey     = \k x -> pure $! if f k x then Just x else Nothing }-{-# INLINE filterMissing #-}----- | Filter the entries whose keys are missing from the other map--- using some 'Applicative' action.------ > filterAMissing f = Merge.Lazy.traverseMaybeMissing $--- >   \k x -> (\b -> guard b *> Just x) <$> f k x------ but this should be a little faster.------ @since 0.5.9-filterAMissing-  :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x-filterAMissing f = WhenMissing-  { missingSubtree = \m -> filterWithKeyA f m-  , missingKey     = \k x -> bool Nothing (Just x) <$> f k x }-{-# INLINE filterAMissing #-}----- | /O(n)/. Filter keys and values using an 'Applicative' predicate.-filterWithKeyA-  :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a)-filterWithKeyA _ Nil           = pure Nil-filterWithKeyA f t@(Tip k x)   = (\b -> if b then t else Nil) <$> f k x-filterWithKeyA f (Bin p m l r) =-    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.-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) = 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       = liftA2 (bin p2 m2) (merge2 l2) (g2t r2)-          | otherwise        = liftA2 (bin 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       = liftA2 (bin p1 m1) (merge1 l1) (g1t r1)-          | otherwise        = liftA2 (bin 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       = liftA2 (bin p1 m1)   (go  l1 l2) (go r1 r2)-      | otherwise      = liftA2 (link_ p1 p2) (g1t t1)    (g2t   t2)-      where-        merge1 | nomatch p2 p1 m1  = liftA2 (link_ p1 p2) (g1t t1)    (g2t t2)-               | zero p2 m1        = liftA2 (bin p1 m1)   (go  l1 t2) (g1t r1)-               | otherwise         = liftA2 (bin p1 m1)   (g1t l1)    (go  r1 t2)-        merge2 | nomatch p1 p2 m2  = liftA2 (link_ p1 p2) (g1t t1)    (g2t    t2)-               | zero p1 m2        = liftA2 (bin p2 m2)   (go  t1 l2) (g2t    r2)-               | otherwise         = liftA2 (bin 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 #-}--    link_ _  _  Nil t2  = t2-    link_ _  _  t1  Nil = t1-    link_ p1 p2 t1  t2  = link p1 t1 p2 t2-    {-# INLINE link_ #-}--    -- | 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 = liftA2 (bin p m) t1 t2-      | otherwise = liftA2 (bin p m) t2 t1-      where-        m = branchMask p1 p2-        p = mask p1 m-    {-# INLINE linkA #-}-{-# 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- @m1@ and @m2@ are not equal,- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following- expressions are all 'True':--  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-- But the following are all 'False':--  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])-  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])-  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])--}-isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool-isProperSubmapOfBy predicate t1 t2-  = case submapCmp predicate t1 t2 of-      LT -> True-      _  -> False--submapCmp :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Ordering-submapCmp predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  | shorter m1 m2  = GT-  | shorter m2 m1  = submapCmpLt-  | p1 == p2       = submapCmpEq-  | otherwise      = GT  -- disjoint-  where-    submapCmpLt | nomatch p1 p2 m2  = GT-                | zero p1 m2        = submapCmp predicate t1 l2-                | otherwise         = submapCmp predicate t1 r2-    submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of-                    (GT,_ ) -> GT-                    (_ ,GT) -> GT-                    (EQ,EQ) -> EQ-                    _       -> LT--submapCmp _         (Bin _ _ _ _) _  = GT-submapCmp predicate (Tip kx x) (Tip ky y)-  | (kx == ky) && predicate x y = EQ-  | otherwise                   = GT  -- disjoint-submapCmp predicate (Tip k x) t-  = case lookup k t of-     Just y | predicate x y -> LT-     _                      -> GT -- disjoint-submapCmp _    Nil Nil = EQ-submapCmp _    Nil _   = LT---- | /O(n+m)/. Is this a submap?--- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).-isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool-isSubmapOf m1 m2-  = isSubmapOfBy (==) m1 m2--{- | /O(n+m)/.- The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if- all keys in @m1@ are in @m2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following- expressions are all 'True':--  > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])-- But the following are all 'False':--  > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])-  > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])-  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])--}-isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool-isSubmapOfBy predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  | shorter m1 m2  = False-  | shorter m2 m1  = match p1 p2 m2 &&-                       if zero p1 m2-                       then isSubmapOfBy predicate t1 l2-                       else isSubmapOfBy predicate t1 r2-  | otherwise      = (p1==p2) && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2-isSubmapOfBy _         (Bin _ _ _ _) _ = False-isSubmapOfBy predicate (Tip k x) t     = case lookup k t of-                                         Just y  -> predicate x y-                                         Nothing -> False-isSubmapOfBy _         Nil _           = True--{---------------------------------------------------------------------  Mapping---------------------------------------------------------------------}--- | /O(n)/. Map a function over all values in the map.------ > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]--map :: (a -> b) -> IntMap a -> IntMap b-map f = go-  where-    go (Bin p m l r) = Bin p m (go l) (go r)-    go (Tip k x)     = Tip k (f x)-    go Nil           = Nil--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] map #-}-{-# RULES-"map/map" forall f g xs . map f (map g xs) = map (f . g) xs- #-}-#endif-#if __GLASGOW_HASKELL__ >= 709--- Safe coercions were introduced in 7.8, but did not play well with RULES yet.-{-# RULES-"map/coerce" map coerce = coerce- #-}-#endif---- | /O(n)/. Map a function over all values in the map.------ > let f key x = (show key) ++ ":" ++ x--- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]--mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b-mapWithKey f t-  = case t of-      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)-      Tip k x     -> Tip k (f k x)-      Nil         -> Nil--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] mapWithKey #-}-{-# RULES-"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =-  mapWithKey (\k a -> f k (g k a)) xs-"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =-  mapWithKey (\k a -> f k (g a)) xs-"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =-  mapWithKey (\k a -> f (g k a)) xs- #-}-#endif---- | /O(n)/.--- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@--- That is, behaves exactly like a regular 'traverse' except that the traversing--- function also has access to the key associated with a value.------ > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])--- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing-traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b)-traverseWithKey f = go-  where-    go Nil = pure Nil-    go (Tip k v) = Tip k <$> f k v-    go (Bin p m l r) = 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 -> 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 @'mapAccumR'@ 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 -> let (a1,r') = mapAccumRWithKey f a r-                         (a2,l') = mapAccumRWithKey f a1 l-                     in (a2,Bin p m l' r')-      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')-      Nil         -> (a,Nil)---- | /O(n*min(n,W))/.--- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the value at the greatest of the--- original keys is retained.------ > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])                        == fromList [(4, "b"), (6, "a")]--- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"--- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"--mapKeys :: (Key->Key) -> IntMap a -> IntMap a-mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []---- | /O(n*min(n,W))/.--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the associated values will be--- combined using @c@.------ > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"--mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a-mapKeysWith c f-  = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []---- | /O(n*min(n,W))/.--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@--- is strictly monotonic.--- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.--- /The precondition is not checked./--- Semi-formally, we have:------ > and [x < y ==> f x < f y | x <- ls, y <- ls]--- >                     ==> mapKeysMonotonic f s == mapKeys f s--- >     where ls = keys s------ This means that @f@ maps distinct original keys to distinct resulting keys.--- This function has slightly better performance than 'mapKeys'.------ > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]--mapKeysMonotonic :: (Key->Key) -> IntMap a -> IntMap a-mapKeysMonotonic f-  = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) []--{---------------------------------------------------------------------  Filter---------------------------------------------------------------------}--- | /O(n)/. Filter all values that satisfy some predicate.------ > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty--- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty--filter :: (a -> Bool) -> IntMap a -> IntMap a-filter p m-  = filterWithKey (\_ x -> p x) m---- | /O(n)/. Filter all keys\/values that satisfy some predicate.------ > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a-filterWithKey predicate = go-    where-    go Nil           = Nil-    go t@(Tip k x)   = if predicate k x then t else Nil-    go (Bin p m l r) = bin p m (go l) (go r)---- | /O(n)/. Partition the map according to some predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)-partition p m-  = partitionWithKey (\_ x -> p x) m---- | /O(n)/. Partition the map according to some predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")--- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)-partitionWithKey predicate0 t0 = toPair $ go predicate0 t0-  where-    go predicate t =-      case t of-        Bin p m l r ->-          let (l1 :*: l2) = go predicate l-              (r1 :*: r2) = go predicate r-          in bin p m l1 r1 :*: bin p m l2 r2-        Tip k x-          | predicate k x -> (t :*: Nil)-          | otherwise     -> (Nil :*: t)-        Nil -> (Nil :*: Nil)---- | /O(n)/. Map values and collect the 'Just' results.------ > let f x = if x == "a" then Just "new a" else Nothing--- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"--mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b-mapMaybe f = mapMaybeWithKey (\_ x -> f x)---- | /O(n)/. Map keys\/values and collect the 'Just' results.------ > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing--- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"--mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b-mapMaybeWithKey f (Bin p m l r)-  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)-mapMaybeWithKey f (Tip k x) = case f k x of-  Just y  -> Tip k y-  Nothing -> Nil-mapMaybeWithKey _ Nil = Nil---- | /O(n)/. Map values and separate the 'Left' and 'Right' results.------ > let f a = if a < "c" then Left a else Right a--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])--- >--- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)-mapEither f m-  = mapEitherWithKey (\_ x -> f x) m---- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.------ > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])--- >--- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])--mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)-mapEitherWithKey f0 t0 = toPair $ go f0 t0-  where-    go f (Bin p m l r) =-      bin p m l1 r1 :*: bin p m l2 r2-      where-        (l1 :*: l2) = go f l-        (r1 :*: r2) = go f r-    go f (Tip k x) = case f k x of-      Left y  -> (Tip k y :*: Nil)-      Right z -> (Nil :*: Tip k z)-    go _ Nil = (Nil :*: Nil)---- | /O(min(n,W))/. The expression (@'split' k map@) is a pair @(map1,map2)@--- where all keys in @map1@ are lower than @k@ and all keys in--- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.------ > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])--- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")--- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)--- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)--split :: Key -> IntMap a -> (IntMap a, IntMap a)-split k t =-  case t of-    Bin _ m l r-      | m < 0 ->-        if k >= 0 -- handle negative numbers.-        then-          case go k l of-            (lt :*: gt) ->-              let !lt' = union r lt-              in (lt', gt)-        else-          case go k r of-            (lt :*: gt) ->-              let !gt' = union gt l-              in (lt, gt')-    _ -> case go k t of-          (lt :*: gt) -> (lt, gt)-  where-    go k' t'@(Bin p m l r)-      | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t'-      | zero k' m = case go k' l of (lt :*: gt) -> lt :*: union gt r-      | otherwise = case go k' r of (lt :*: gt) -> union l lt :*: gt-    go k' t'@(Tip ky _)-      | k' > ky   = (t' :*: Nil)-      | k' < ky   = (Nil :*: t')-      | otherwise = (Nil :*: Nil)-    go _ Nil = (Nil :*: Nil)---data SplitLookup a = SplitLookup !(IntMap a) !(Maybe a) !(IntMap a)--mapLT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a-mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt-{-# INLINE mapLT #-}--mapGT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a-mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt)-{-# INLINE mapGT #-}---- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot--- key was found in the original map.------ > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])--- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")--- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")--- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)--- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)--splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a)-splitLookup k t =-  case-    case t of-      Bin _ m l r-        | m < 0 ->-          if k >= 0 -- handle negative numbers.-          then mapLT (union r) (go k l)-          else mapGT (`union` l) (go k r)-      _ -> go k t-  of SplitLookup lt fnd gt -> (lt, fnd, gt)-  where-    go k' t'@(Bin p m l r)-      | nomatch k' p m =-          if k' > p-          then SplitLookup t' Nothing Nil-          else SplitLookup Nil Nothing t'-      | zero k' m = mapGT (`union` r) (go k' l)-      | otherwise = mapLT (union l) (go k' r)-    go k' t'@(Tip ky y)-      | k' > ky   = SplitLookup t'  Nothing  Nil-      | k' < ky   = SplitLookup Nil Nothing  t'-      | otherwise = SplitLookup Nil (Just y) Nil-    go _ Nil      = SplitLookup Nil Nothing  Nil--{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | /O(n)/. Fold the values in the map using the given right-associative--- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.------ For example,------ > elems map = foldr (:) [] map------ > let f a len = len + (length a)--- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-foldr :: (a -> b -> b) -> b -> IntMap a -> b-foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z l) r -- put negative numbers before-      | otherwise -> go (go z r) l-    _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip _ x)     = f x z'-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr #-}---- | /O(n)/. A strict version of 'foldr'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldr' :: (a -> b -> b) -> b -> IntMap a -> b-foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z l) r -- put negative numbers before-      | otherwise -> go (go z r) l-    _ -> go z t-  where-    go !z' Nil          = z'-    go z' (Tip _ x)     = f x z'-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr' #-}---- | /O(n)/. Fold the values in the map using the given left-associative--- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.------ For example,------ > elems = reverse . foldl (flip (:)) []------ > let f len a = len + (length a)--- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-foldl :: (a -> b -> a) -> a -> IntMap b -> a-foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z r) l -- put negative numbers before-      | otherwise -> go (go z l) r-    _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip _ x)     = f z' x-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl #-}---- | /O(n)/. A strict version of 'foldl'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldl' :: (a -> b -> a) -> a -> IntMap b -> a-foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z r) l -- put negative numbers before-      | otherwise -> go (go z l) r-    _ -> go z t-  where-    go !z' Nil          = z'-    go z' (Tip _ x)     = f z' x-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl' #-}---- | /O(n)/. Fold the keys and values in the map using the given right-associative--- binary operator, such that--- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.------ For example,------ > keys map = foldrWithKey (\k x ks -> k:ks) [] map------ > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"-foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b-foldrWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z l) r -- put negative numbers before-      | otherwise -> go (go z r) l-    _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip kx x)    = f kx x z'-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldrWithKey #-}---- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b-foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z l) r -- put negative numbers before-      | otherwise -> go (go z r) l-    _ -> go z t-  where-    go !z' Nil          = z'-    go z' (Tip kx x)    = f kx x z'-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldrWithKey' #-}---- | /O(n)/. Fold the keys and values in the map using the given left-associative--- binary operator, such that--- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.------ For example,------ > keys = reverse . foldlWithKey (\ks k x -> k:ks) []------ > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"-foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a-foldlWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z r) l -- put negative numbers before-      | otherwise -> go (go z l) r-    _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip kx x)    = f z' kx x-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldlWithKey #-}---- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a-foldlWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of-    Bin _ m l r-      | m < 0 -> go (go z r) l -- put negative numbers before-      | otherwise -> go (go z l) r-    _ -> go z t-  where-    go !z' Nil          = z'-    go z' (Tip kx x)    = f z' kx x-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldlWithKey' #-}---- | /O(n)/. Fold the keys and values in the map using the given monoid, such that------ @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@------ This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.------ @since 0.5.4-foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m-foldMapWithKey f = go-  where-    go Nil           = mempty-    go (Tip kx x)    = f kx x-    go (Bin _ _ l r) = go l `mappend` go r-{-# INLINE foldMapWithKey #-}--{---------------------------------------------------------------------  List variations---------------------------------------------------------------------}--- | /O(n)/.--- Return all elements of the map in the ascending order of their keys.--- Subject to list fusion.------ > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]--- > elems empty == []--elems :: IntMap a -> [a]-elems = foldr (:) []---- | /O(n)/. Return all keys of the map in ascending order. Subject to list--- fusion.------ > keys (fromList [(5,"a"), (3,"b")]) == [3,5]--- > keys empty == []--keys  :: IntMap a -> [Key]-keys = foldrWithKey (\k _ ks -> k : ks) []---- | /O(n)/. An alias for 'toAscList'. Returns all key\/value pairs in the--- map in ascending key order. Subject to list fusion.------ > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > assocs empty == []--assocs :: IntMap a -> [(Key,a)]-assocs = toAscList---- | /O(n*min(n,W))/. The set of all keys of the map.------ > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]--- > keysSet empty == Data.IntSet.empty--keysSet :: IntMap a -> IntSet.IntSet-keysSet Nil = IntSet.Nil-keysSet (Tip kx _) = IntSet.singleton kx-keysSet (Bin p m l r)-  | m .&. IntSet.suffixBitMask == 0 = IntSet.Bin p m (keysSet l) (keysSet r)-  | otherwise = IntSet.Tip (p .&. IntSet.prefixBitMask) (computeBm (computeBm 0 l) r)-  where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'-        computeBm acc (Tip kx _) = acc .|. IntSet.bitmapOf kx-        computeBm _   Nil = error "Data.IntSet.keysSet: Nil"---- | /O(n)/. Build a map from a set of keys and a function which for each key--- computes its value.------ > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]--- > fromSet undefined Data.IntSet.empty == empty--fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a-fromSet _ IntSet.Nil = Nil-fromSet f (IntSet.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)-fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)-  where-    -- This is slightly complicated, as we to convert the dense-    -- representation of IntSet into tree representation of IntMap.-    ---    -- We are given a nonzero bit mask 'bmask' of 'bits' bits with-    -- prefix 'prefix'. We split bmask into halves corresponding-    -- to left and right subtree. If they are both nonempty, we-    -- create a Bin node, otherwise exactly one of them is nonempty-    -- and we construct the IntMap from that half.-    buildTree g !prefix !bmask bits = case bits of-      0 -> Tip prefix (g prefix)-      _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of-        bits2-          | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->-              buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2-          | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->-              buildTree g prefix bmask bits2-          | otherwise ->-              Bin prefix bits2-                (buildTree g prefix bmask bits2)-                (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)--{---------------------------------------------------------------------  Lists---------------------------------------------------------------------}-#if __GLASGOW_HASKELL__ >= 708--- | @since 0.5.6.2-instance GHCExts.IsList (IntMap a) where-  type Item (IntMap a) = (Key,a)-  fromList = fromList-  toList   = toList-#endif---- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list--- fusion.------ > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > toList empty == []--toList :: IntMap a -> [(Key,a)]-toList = toAscList---- | /O(n)/. Convert the map to a list of key\/value pairs where the--- keys are in ascending order. Subject to list fusion.------ > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--toAscList :: IntMap a -> [(Key,a)]-toAscList = foldrWithKey (\k x xs -> (k,x):xs) []---- | /O(n)/. Convert the map to a list of key\/value pairs where the keys--- are in descending order. Subject to list fusion.------ > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]--toDescList :: IntMap a -> [(Key,a)]-toDescList = foldlWithKey (\xs k x -> (k,x):xs) []---- List fusion for the list generating functions.-#if __GLASGOW_HASKELL__--- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.--- They are important to convert unfused methods back, see mapFB in prelude.-foldrFB :: (Key -> a -> b -> b) -> b -> IntMap a -> b-foldrFB = foldrWithKey-{-# INLINE[0] foldrFB #-}-foldlFB :: (a -> Key -> b -> a) -> a -> IntMap b -> a-foldlFB = foldlWithKey-{-# INLINE[0] foldlFB #-}---- Inline assocs and toList, so that we need to fuse only toAscList.-{-# INLINE assocs #-}-{-# INLINE toList #-}---- The fusion is enabled up to phase 2 included. If it does not succeed,--- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to--- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were--- used in a list fusion, otherwise it would go away in phase 1), and let compiler--- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to--- inline it before phase 0, otherwise the fusion rules would not fire at all.-{-# NOINLINE[0] elems #-}-{-# NOINLINE[0] keys #-}-{-# NOINLINE[0] toAscList #-}-{-# NOINLINE[0] toDescList #-}-{-# RULES "IntMap.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}-{-# RULES "IntMap.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}-{-# RULES "IntMap.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}-{-# RULES "IntMap.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}-{-# RULES "IntMap.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}-{-# RULES "IntMap.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}-{-# RULES "IntMap.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}-{-# RULES "IntMap.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}-#endif----- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.------ > fromList [] == empty--- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]--- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]--fromList :: [(Key,a)] -> IntMap a-fromList xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x)  = insert k x t---- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.------ > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")]--- > fromListWith (++) [] == empty--fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a-fromListWith f xs-  = fromListWithKey (\_ x y -> f x y) xs---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]--- > fromListWithKey f [] == empty--fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a-fromListWithKey f xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t---- | /O(n)/. Build a map from a list of key\/value pairs where--- the keys are in ascending order.------ > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]--fromAscList :: [(Key,a)] -> IntMap a-fromAscList xs-  = fromAscListWithKey (\_ x _ -> x) xs---- | /O(n)/. Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./------ > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]--fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a-fromAscListWith f xs-  = fromAscListWithKey (\_ x y -> f x y) xs---- | /O(n)/. Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")]--fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a-fromAscListWithKey _ []         = Nil-fromAscListWithKey f (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)-  where-    -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-    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---- | /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")]--#if __GLASGOW_HASKELL__-fromDistinctAscList :: forall a. [(Key,a)] -> IntMap a-#else-fromDistinctAscList ::            [(Key,a)] -> IntMap a-#endif-fromDistinctAscList []         = Nil-fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada-  where-    work (kx,vx) []            stk = finish kx (Tip kx vx) stk-    work (kx,vx) (z@(kz,_):zs) stk = reduce z zs (branchMask kx kz) kx (Tip kx vx) stk--#if __GLASGOW_HASKELL__-    reduce :: (Key,a) -> [(Key,a)] -> Mask -> Prefix -> IntMap a -> Stack a -> IntMap a-#endif-    reduce z zs _ px tx Nada = work z zs (Push px tx Nada)-    reduce z zs m px tx stk@(Push py ty stk') =-        let mxy = branchMask px py-            pxy = mask px mxy-        in  if shorter m mxy-            then reduce z zs m pxy (Bin pxy mxy ty tx) stk'-            else work z zs (Push px tx stk)--    finish _  t  Nada = t-    finish px tx (Push py ty stk) = finish p (link py ty px tx) stk-        where m = branchMask px py-              p = mask px m--data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada---{---------------------------------------------------------------------  Eq---------------------------------------------------------------------}-instance Eq a => Eq (IntMap a) where-  t1 == t2  = equal t1 t2-  t1 /= t2  = nequal t1 t2--equal :: Eq a => IntMap a -> IntMap a -> Bool-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)-equal (Tip kx x) (Tip ky y)-  = (kx == ky) && (x==y)-equal Nil Nil = True-equal _   _   = False--nequal :: Eq a => IntMap a -> IntMap a -> Bool-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)-nequal (Tip kx x) (Tip ky y)-  = (kx /= ky) || (x/=y)-nequal Nil Nil = False-nequal _   _   = True--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Eq1 IntMap where-  liftEq eq (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-    = (m1 == m2) && (p1 == p2) && (liftEq eq l1 l2) && (liftEq eq r1 r2)-  liftEq eq (Tip kx x) (Tip ky y)-    = (kx == ky) && (eq x y)-  liftEq _eq Nil Nil = True-  liftEq _eq _   _   = False-#endif--{---------------------------------------------------------------------  Ord---------------------------------------------------------------------}--instance Ord a => Ord (IntMap a) where-    compare m1 m2 = compare (toList m1) (toList m2)--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Ord1 IntMap where-  liftCompare cmp m n =-    liftCompare (liftCompare cmp) (toList m) (toList n)-#endif--{---------------------------------------------------------------------  Functor---------------------------------------------------------------------}--instance Functor IntMap where-    fmap = map--#ifdef __GLASGOW_HASKELL__-    a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r)-    a <$ Tip k _     = Tip k a-    _ <$ Nil         = Nil-#endif--{---------------------------------------------------------------------  Show---------------------------------------------------------------------}--instance Show a => Show (IntMap a) where-  showsPrec d m   = showParen (d > 10) $-    showString "fromList " . shows (toList m)--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Show1 IntMap where-    liftShowsPrec sp sl d m =-        showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)-      where-        sp' = liftShowsPrec sp sl-        sl' = liftShowList sp sl-#endif--{---------------------------------------------------------------------  Read---------------------------------------------------------------------}-instance (Read e) => Read (IntMap e) where-#ifdef __GLASGOW_HASKELL__-  readPrec = parens $ prec 10 $ do-    Ident "fromList" <- lexP-    xs <- readPrec-    return (fromList xs)--  readListPrec = readListPrecDefault-#else-  readsPrec p = readParen (p > 10) $ \ r -> do-    ("fromList",s) <- lex r-    (xs,t) <- reads s-    return (fromList xs,t)-#endif--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Read1 IntMap where-    liftReadsPrec rp rl = readsData $-        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList-      where-        rp' = liftReadsPrec rp rl-        rl' = liftReadList rp rl-#endif--{---------------------------------------------------------------------  Typeable---------------------------------------------------------------------}--INSTANCE_TYPEABLE1(IntMap)--{---------------------------------------------------------------------  Helpers---------------------------------------------------------------------}-{---------------------------------------------------------------------  Link---------------------------------------------------------------------}-link :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a-link p1 t1 p2 t2-  | zero p1 m = Bin p m t1 t2-  | otherwise = Bin p m t2 t1-  where-    m = branchMask p1 p2-    p = mask p1 m-{-# INLINE link #-}--{---------------------------------------------------------------------  @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 .&. (complement (m-1) `xor` m))-{-# INLINE maskW #-}---- | Does the left switching bit specify a shorter prefix?-shorter :: Mask -> Mask -> Bool-shorter m1 m2-  = (natFromInt m1) > (natFromInt m2)-{-# INLINE shorter #-}---- | The first switching bit where the two prefixes disagree.-branchMask :: Prefix -> Prefix -> Mask-branchMask p1 p2-  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))-{-# INLINE branchMask #-}--{---------------------------------------------------------------------  Utilities---------------------------------------------------------------------}---- | /O(1)/.  Decompose a map into pieces based on the structure--- of the underlying tree. This function is useful for consuming a--- map in parallel.------ No guarantee is made as to the sizes of the pieces; an internal, but--- deterministic process determines this.  However, it is guaranteed that the--- pieces returned will be in ascending order (all elements in the first submap--- less than all elements in the second, and so on).------ Examples:------ > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==--- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]------ > splitRoot empty == []------  Note that the current implementation does not return more than two submaps,---  but you should not depend on this behaviour because it can change in the---  future without notice.-splitRoot :: IntMap a -> [IntMap a]-splitRoot orig =-  case orig of-    Nil -> []-    x@(Tip _ _) -> [x]-    Bin _ m l r | m < 0 -> [r, l]-                | otherwise -> [l, r]-{-# INLINE splitRoot #-}---{---------------------------------------------------------------------  Debugging---------------------------------------------------------------------}---- | /O(n)/. Show the tree that implements the map. The tree is shown--- in a compressed, hanging format.-showTree :: Show a => IntMap a -> String-showTree s-  = showTreeWith True False s---{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows- the tree that implements the map. If @hang@ is- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If- @wide@ is 'True', an extra wide version is shown.--}-showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String-showTreeWith hang wide t-  | hang      = (showsTreeHang wide [] t) ""-  | otherwise = (showsTree wide [] [] t) ""--showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS-showsTree wide lbars rbars t = case t of-  Bin p m l r ->-    showsTree wide (withBar rbars) (withEmpty rbars) r .-    showWide wide rbars .-    showsBars lbars . showString (showBin p m) . showString "\n" .-    showWide wide lbars .-    showsTree wide (withEmpty lbars) (withBar lbars) l-  Tip k x ->-    showsBars lbars .-    showString " " . shows k . showString ":=" . shows x . showString "\n"-  Nil -> showsBars lbars . showString "|\n"--showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS-showsTreeHang wide bars t = case t of-  Bin p m l r ->-    showsBars bars . showString (showBin p m) . showString "\n" .-    showWide wide bars .-    showsTreeHang wide (withBar bars) l .-    showWide wide bars .-    showsTreeHang wide (withEmpty bars) r-  Tip k x ->-    showsBars bars .-    showString " " . shows k . showString ":=" . shows x . showString "\n"-  Nil -> showsBars bars . showString "|\n"--showBin :: Prefix -> Mask -> String-showBin _ _-  = "*" -- ++ show (p,m)--showWide :: Bool -> [String] -> String -> String-showWide wide bars-  | wide      = showString (concat (reverse bars)) . showString "|\n"-  | otherwise = id--showsBars :: [String] -> ShowS-showsBars bars-  = case bars of-      [] -> id-      _  -> showString (concat (reverse (tail bars))) . showString node--node :: String-node = "+--"--withBar, withEmpty :: [String] -> [String]-withBar bars   = "|  ":bars-withEmpty bars = "   ":bars

@@ -1,6 +0,0 @@-module Data.IntMap.Internal.Debug-  ( showTree-  , showTreeWith-  ) where--import Data.IntMap.Internal

@@ -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

@@ -1,236 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.IntMap.Lazy--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable--------- = Finite Int Maps (lazy interface)------ 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:------ > 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.--------- == 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--- 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,---      <http://citeseer.ist.psu.edu/okasaki98fast.html>------    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve---      Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),---      October 1968, pages 514-534.-----------------------------------------------------------------------------------module Data.IntMap.Lazy (-    -- * Map type-#if !defined(TESTING)-    IntMap, Key          -- instance Eq,Show-#else-    IntMap(..), Key          -- instance Eq,Show-#endif--    -- * Construction-    , empty-    , singleton-    , fromSet--    -- ** From Unordered Lists-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** From Ascending Lists-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList--    -- * Insertion-    , insert-    , insertWith-    , insertWithKey-    , insertLookupWithKey--    -- * Deletion\/Update-    , delete-    , adjust-    , adjustWithKey-    , update-    , updateWithKey-    , updateLookupWithKey-    , alter-    , alterF--    -- * Query-    -- ** Lookup-    , IM.lookup-    , (!?)-    , (!)-    , findWithDefault-    , member-    , notMember-    , lookupLT-    , lookupGT-    , lookupLE-    , lookupGE--    -- ** Size-    , IM.null-    , size--    -- * Combine--    -- ** Union-    , union-    , unionWith-    , unionWithKey-    , unions-    , unionsWith--    -- ** Difference-    , difference-    , (\\)-    , differenceWith-    , differenceWithKey--    -- ** Intersection-    , intersection-    , intersectionWith-    , intersectionWithKey--    -- ** Universal combining function-    , mergeWithKey--    -- * Traversal-    -- ** Map-    , IM.map-    , mapWithKey-    , traverseWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , IM.foldr-    , IM.foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet--    -- ** Lists-    , toList--    -- ** Ordered lists-    , toAscList-    , toDescList--    -- * Filter-    , IM.filter-    , filterWithKey-    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey--#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

@@ -1,104 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}-#define USE_MAGIC_PROXY 1-#endif--#if USE_MAGIC_PROXY-{-# LANGUAGE MagicHash #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.IntMap.Merge.Lazy--- Copyright   :  (c) wren romano 2016--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ This module defines an API for writing functions that merge two--- maps. The key functions are 'merge' and 'mergeA'.--- Each of these can be used with several different \"merge tactics\".------ The 'merge' and 'mergeA' functions are shared by--- the lazy and strict modules. Only the choice of merge tactics--- determines strictness. If you use 'Data.Map.Merge.Strict.mapMissing'--- from "Data.Map.Merge.Strict" then the results will be forced before--- they are inserted. If you use 'Data.Map.Merge.Lazy.mapMissing' from--- this module then they will not.------ == Efficiency note------ The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing'--- tactics are included because they are valid. However, they are--- inefficient in many cases and should usually be avoided. The instances--- for 'WhenMatched' tactics should not pose any major efficiency problems.------ @since 0.5.9--module Data.IntMap.Merge.Lazy (-    -- ** Simple merge tactic types-      SimpleWhenMissing-    , SimpleWhenMatched--    -- ** General combining function-    , merge--    -- *** @WhenMatched@ tactics-    , zipWithMaybeMatched-    , zipWithMatched--    -- *** @WhenMissing@ tactics-    , mapMaybeMissing-    , dropMissing-    , preserveMissing-    , mapMissing-    , filterMissing--    -- ** Applicative merge tactic types-    , WhenMissing-    , WhenMatched--    -- ** Applicative general combining function-    , 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--    -- *** Covariant maps for tactics-    , mapWhenMissing-    , mapWhenMatched--    -- *** Contravariant maps for tactics-    , lmapWhenMissing-    , contramapFirstWhenMatched-    , contramapSecondWhenMatched--    -- *** Miscellaneous tactic functions-    , runWhenMatched-    , runWhenMissing-    ) where--import Data.IntMap.Internal

@@ -1,100 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}-#define USE_MAGIC_PROXY 1-#endif--#if USE_MAGIC_PROXY-{-# LANGUAGE MagicHash #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.IntMap.Merge.Strict--- Copyright   :  (c) wren romano 2016--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ This module defines an API for writing functions that merge two--- maps. The key functions are 'merge' and 'mergeA'.--- Each of these can be used with several different \"merge tactics\".------ The 'merge' and 'mergeA' functions are shared by--- the lazy and strict modules. Only the choice of merge tactics--- determines strictness. If you use 'Data.Map.Merge.Strict.mapMissing'--- from this module then the results will be forced before they are--- inserted. If you use 'Data.Map.Merge.Lazy.mapMissing' from--- "Data.Map.Merge.Lazy" then they will not.------ == Efficiency note------ The 'Category', 'Applicative', and 'Monad' instances for 'WhenMissing'--- tactics are included because they are valid. However, they are--- inefficient in many cases and should usually be avoided. The instances--- for 'WhenMatched' tactics should not pose any major efficiency problems.------ @since 0.5.9--module Data.IntMap.Merge.Strict (-    -- ** Simple merge tactic types-      SimpleWhenMissing-    , SimpleWhenMatched--    -- ** General combining function-    , merge--    -- *** @WhenMatched@ tactics-    , zipWithMaybeMatched-    , zipWithMatched--    -- *** @WhenMissing@ tactics-    , mapMaybeMissing-    , dropMissing-    , preserveMissing-    , mapMissing-    , filterMissing--    -- ** Applicative merge tactic types-    , WhenMissing-    , WhenMatched--    -- ** Applicative general combining function-    , 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--    -- ** Covariant maps for tactics-    , mapWhenMissing-    , mapWhenMatched--    -- ** Miscellaneous functions on tactics--    , runWhenMatched-    , runWhenMissing-    ) where--import Data.IntMap.Internal

@@ -1,1144 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.IntMap.Strict--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- 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 a 'Map'. 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.--------- == 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--- the same 'IntMap' value can be passed to functions in both modules. This--- means that the 'Functor', 'Traversable' and '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).--------- == 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,---      <http://citeseer.ist.psu.edu/okasaki98fast.html>------    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve---      Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),---      October 1968, pages 514-534.------------------------------------------------------------------------------------- See the notes at the beginning of Data.IntMap.Internal.--module Data.IntMap.Strict (-    -- * Map type-#if !defined(TESTING)-    IntMap, Key          -- instance Eq,Show-#else-    IntMap(..), Key          -- instance Eq,Show-#endif--    -- * Construction-    , empty-    , singleton-    , fromSet--    -- ** From Unordered Lists-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** From Ascending Lists-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList--    -- * Insertion-    , insert-    , insertWith-    , insertWithKey-    , insertLookupWithKey--    -- * Deletion\/Update-    , delete-    , adjust-    , adjustWithKey-    , update-    , updateWithKey-    , updateLookupWithKey-    , alter-    , alterF--    -- * Query-    -- ** Lookup-    , lookup-    , (!?)-    , (!)-    , findWithDefault-    , member-    , notMember-    , lookupLT-    , lookupGT-    , lookupLE-    , lookupGE--    -- ** Size-    , null-    , size--    -- * Combine--    -- ** Union-    , union-    , unionWith-    , unionWithKey-    , unions-    , unionsWith--    -- ** Difference-    , difference-    , (\\)-    , differenceWith-    , differenceWithKey--    -- ** Intersection-    , intersection-    , intersectionWith-    , intersectionWithKey--    -- ** Universal combining function-    , mergeWithKey--    -- * Traversal-    -- ** Map-    , map-    , mapWithKey-    , traverseWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , foldr-    , foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet--    -- ** Lists-    , toList---- ** Ordered lists-    , toAscList-    , toDescList--    -- * Filter-    , filter-    , filterWithKey-    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey--#ifdef __GLASGOW_HASKELL__-    -- * Debugging-    , showTree-    , showTreeWith-#endif-    ) where--import Prelude hiding (lookup,map,filter,foldr,foldl,null)--import Data.Bits-import qualified Data.IntMap.Internal as L-import Data.IntMap.Internal-  ( IntMap (..)-  , Key-  , Prefix-  , Mask-  , mask-  , branchMask-  , shorter-  , nomatch-  , zero-  , natFromInt-  , intFromNat-  , bin-  , binCheckLeft-  , binCheckRight-  , link--  , (\\)-  , (!)-  , (!?)-  , empty-  , assocs-  , filter-  , filterWithKey-  , findMin-  , findMax-  , foldMapWithKey-  , foldr-  , foldl-  , foldr'-  , foldl'-  , foldlWithKey-  , foldrWithKey-  , foldlWithKey'-  , foldrWithKey'-  , keysSet-  , mergeWithKey'-  , delete-  , deleteMin-  , deleteMax-  , deleteFindMax-  , deleteFindMin-  , difference-  , elems-  , intersection-  , isProperSubmapOf-  , isProperSubmapOfBy-  , isSubmapOf-  , isSubmapOfBy-  , lookup-  , lookupLE-  , lookupGE-  , lookupLT-  , lookupGT-  , lookupMin-  , lookupMax-  , minView-  , maxView-  , minViewWithKey-  , maxViewWithKey-  , keys-  , mapKeys-  , mapKeysMonotonic-  , member-  , notMember-  , null-  , partition-  , partitionWithKey-  , restrictKeys-  , size-  , split-  , splitLookup-  , splitRoot-  , toAscList-  , toDescList-  , toList-  , union-  , 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.StrictPair-#if !MIN_VERSION_base(4,8,0)-import Data.Functor((<$>))-#endif-import Control.Applicative (Applicative (..), liftA2)-import qualified Data.Foldable as Foldable-import Data.Foldable (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.------ > 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 =-  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)-    Tip ky _-      | k==ky         -> Tip k x-      | otherwise     -> link k (Tip k x) ky t-    Nil -> Tip k x---- right-biased insertion, used by 'union'--- | /O(min(n,W))/. Insert with a combining function.--- @'insertWith' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert @f new_value old_value@.------ > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"--insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a-insertWith f k x t-  = insertWithKey (\_ x' y' -> f x' y') k x t---- | /O(min(n,W))/. Insert with a combining function.--- @'insertWithKey' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert @f key new_value old_value@.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"------ If the key exists in the map, this function is lazy in @value@ but strict--- in the result of @f@.--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)-    Tip ky y-      | k==ky         -> Tip k $! f k x y-      | otherwise     -> link k (singleton k x) ky t-    Nil -> singleton k x---- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)--- is a pair where the first element is equal to (@'lookup' k map@)--- and the second element equal to (@'insertWithKey' f k x map@).------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])--- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])--- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")------ This is how to define @insertLookup@ using @insertLookupWithKey@:------ > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t--- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])--- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])--insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)-insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0-  where-    go f k x t =-      case t of-        Bin p m l r-          | nomatch k p m -> Nothing :*: link k (singleton k x) p t-          | zero k m      -> let (found :*: l') = go f k x l in (found :*: Bin p m l' r)-          | otherwise     -> let (found :*: r') = go f k x r in (found :*: Bin p m l r')-        Tip ky y-          | k==ky         -> (Just y :*: (Tip k $! f k x y))-          | otherwise     -> (Nothing :*: link k (singleton k x) ky t)-        Nil -> Nothing :*: (singleton k x)---{---------------------------------------------------------------------  Deletion---------------------------------------------------------------------}--- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjust ("new " ++) 7 empty                         == empty--adjust ::  (a -> a) -> Key -> IntMap a -> IntMap a-adjust f k m-  = adjustWithKey (\_ x -> f x) k m---- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > let f key x = (show key) ++ ":new " ++ x--- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjustWithKey f 7 empty                         == empty--adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a-adjustWithKey f !k t =-  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)-    Tip ky y-      | k==ky         -> Tip ky $! f k y-      | otherwise     -> t-    Nil -> Nil---- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f x = if x == "a" then Just "new a" else Nothing--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--update ::  (a -> Maybe a) -> Key -> IntMap a -> IntMap a-update f-  = updateWithKey (\_ x -> f x)---- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a-updateWithKey f !k t =-  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)-    Tip ky y-      | k==ky         -> case f k y of-                           Just !y' -> Tip ky y'-                           Nothing -> Nil-      | otherwise     -> t-    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 f0 !k0 t0 = toPair $ go f0 k0 t0-  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')-        Tip ky y-          | k==ky         -> case f k y of-                               Just !y' -> (Just y :*: Tip ky y')-                               Nothing  -> (Just y :*: Nil)-          | otherwise     -> (Nothing :*: t)-        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 =-  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)-    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 -> t-    Nil               -> case f Nothing of-                           Just !x -> Tip k x-                           Nothing -> Nil---- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at--- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,--- or update a value in an 'IntMap'.  In short : @'lookup' k <$> 'alterF' f k m = f--- ('lookup' k m)@.------ Example:------ @--- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)--- interactiveAlter k m = alterF f k m where---   f Nothing -> do---      putStrLn $ show k ++---          " was not found in the map. Would you like to add it?"---      getUserResponse1 :: IO (Maybe String)---   f (Just old) -> do---      putStrLn "The key is currently bound to " ++ show old ++---          ". Would you like to change or delete it?"---      getUserresponse2 :: IO (Maybe String)--- @------ 'alterF' is the most general operation for working with an individual--- key that may or may not be in a given map.---- Note: 'alterF' is a flipped version of the 'at' combinator from--- 'Control.Lens.At'.------ @since 0.5.8--alterF :: Functor f-       => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)--- This implementation was modified 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, 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 union with a combining function.------ > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]--unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a-unionWith f m1 m2-  = unionWithKey (\_ x y -> f x y) m1 m2---- | /O(n+m)/. The union with a combining function.------ > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]--unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a-unionWithKey f m1 m2-  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) id id m1 m2--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}---- | /O(n+m)/. Difference 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--{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}---- | /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 #-}--{---------------------------------------------------------------------  Min\/Max---------------------------------------------------------------------}---- | /O(log n)/. Update the value at the minimal key.------ > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]--- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMinWithKey :: (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(log n)/. Update the value at the maximal key.------ > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]--- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMaxWithKey :: (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"---- | /O(log n)/. Update the value at the maximal key.------ > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]--- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a-updateMax f = updateMaxWithKey (const f)---- | /O(log n)/. Update the value at the minimal key.------ > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]--- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a-updateMin f = updateMinWithKey (const f)---{---------------------------------------------------------------------  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 (\x -> f $! g x) xs-"map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs- #-}-#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__--- Pay close attention to strictness here. We need to force the--- intermediate result for map f . map g, and we need to refrain--- from forcing it for map f . L.map g, etc.------ TODO Consider moving map and mapWithKey to IntMap.Internal so we can write--- non-orphan RULES for things like L.map f (map g xs). We'd need a new function--- for this, and we'd have to pay attention to simplifier phases. Something like------ 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)-{-# 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/mapWithKeyL" forall f g xs . mapWithKey f (L.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-"mapWithKey/mapL" forall f g xs . mapWithKey f (L.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-"map/mapWithKeyL" forall f g xs . map f (L.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) = (\ !v' -> Tip k v') <$> f k v-    go (Bin p m l r) = 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.  Strict in--- the accumulating argument and the both elements of the--- result of the function.-mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccumL f0 a0 t0 = toPair $ go f0 a0 t0-  where-    go f a t-      = case t of-          Bin p m l r -> let (a1 :*: l') = go f a l-                             (a2 :*: r') = go 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 @'mapAccumR'@ threads an accumulating--- argument through the map in descending order of keys.-mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)-mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0-  where-    go f a t-      = case t of-          Bin p m l r -> let (a1 :*: r') = go f a r-                             (a2 :*: l') = go 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*log n)/.--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the associated values will be--- combined using @c@.------ > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"--mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a-mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []--{---------------------------------------------------------------------  Filter---------------------------------------------------------------------}--- | /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)--{---------------------------------------------------------------------  Conversions---------------------------------------------------------------------}---- | /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---------------------------------------------------------------------}--- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.------ > fromList [] == empty--- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]--- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]--fromList :: [(Key,a)] -> IntMap a-fromList xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x)  = insert k x t---- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.------ > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]--- > fromListWith (++) [] == empty--fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a-fromListWith f xs-  = fromListWithKey (\_ x y -> f x y) xs---- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.------ > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]--- > fromListWith (++) [] == empty--fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a-fromListWithKey f xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t---- | /O(n)/. Build a map from a list of key\/value pairs where--- the keys are in ascending order.------ > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]--fromAscList :: [(Key,a)] -> IntMap a-fromAscList xs-  = fromAscListWithKey (\_ x _ -> x) xs---- | /O(n)/. Build a map from a list of key\/value pairs where--- the keys are in ascending order, with a combining function on equal keys.--- /The precondition (input list is ascending) is not checked./------ > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]--fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a-fromAscListWith f xs-  = fromAscListWithKey (\_ x y -> f x y) xs---- | /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")]--fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a-fromAscListWithKey _ []         = Nil-fromAscListWithKey f (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)-  where-    -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-    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---- | /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 []         = Nil-fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada-  where-    work (kx,!vx) []            stk = finish kx (Tip kx vx) stk-    work (kx,!vx) (z@(kz,_):zs) stk = reduce z zs (branchMask kx kz) kx (Tip kx vx) stk--    reduce :: (Key,a) -> [(Key,a)] -> Mask -> Prefix -> IntMap a -> Stack a -> IntMap a-    reduce z zs _ px tx Nada = work z zs (Push px tx Nada)-    reduce z zs m px tx stk@(Push py ty stk') =-        let mxy = branchMask px py-            pxy = mask px mxy-        in  if shorter m mxy-                 then reduce z zs m pxy (Bin pxy mxy ty tx) stk'-                 else work z zs (Push px tx stk)--    finish _  t  Nada = t-    finish px tx (Push py ty stk) = finish p (link py ty px tx) stk-        where m = branchMask px py-              p = mask px m--data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada

@@ -1,166 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.IntSet--- Copyright   :  (c) Daan Leijen 2002---                (c) Joachim Breitner 2011--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable--------- = Finite Int Sets------ The @'IntSet'@ type represents a set of elements of type @Int@.------ For a walkthrough of the most commonly used functions see their--- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>.------ 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--------- == 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--- (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://citeseer.ist.psu.edu/okasaki98fast.html>------    * 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--- 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.-----------------------------------------------------------------------------------module Data.IntSet (-            -- * Strictness properties-            -- $strictness--            -- * Set type-#if !defined(TESTING)-              IntSet          -- instance Eq,Show-#else-              IntSet(..)      -- instance Eq,Show-#endif-            , Key--            -- * Construction-            , empty-            , singleton-            , fromList-            , fromAscList-            , fromDistinctAscList--            -- * Insertion-            , insert--            -- * Deletion-            , delete--            -- * Query-            , member-            , notMember-            , lookupLT-            , lookupGT-            , lookupLE-            , lookupGE-            , IS.null-            , size-            , isSubsetOf-            , isProperSubsetOf-            , disjoint--            -- * Combine-            , union-            , unions-            , difference-            , (\\)-            , intersection--            -- * Filter-            , IS.filter-            , partition-            , split-            , splitMember-            , splitRoot--            -- * Map-            , IS.map--            -- * Folds-            , IS.foldr-            , IS.foldl-            -- ** Strict folds-            , foldr'-            , foldl'-            -- ** Legacy folds-            , fold--            -- * Min\/Max-            , findMin-            , findMax-            , deleteMin-            , deleteMax-            , deleteFindMin-            , deleteFindMax-            , maxView-            , minView--            -- * Conversion--            -- ** List-            , elems-            , toList-            , toAscList-            , toDescList--            -- * 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

@@ -1,1539 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE TypeFamilies #-}-#endif--{-# OPTIONS_HADDOCK not-home #-}--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.IntSet.Internal--- Copyright   :  (c) Daan Leijen 2002---                (c) Joachim Breitner 2011--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ = WARNING------ This module is considered __internal__.------ The Package Versioning Policy __does not apply__.------ This 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://citeseer.ist.psu.edu/okasaki98fast.html>------    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve---      Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),---      October 1968, pages 514-534.------ Additionally, this implementation places bitmaps in the leaves of the tree.--- Their size is the natural size of a machine word (32 or 64 bits) and greatly--- reduce memory footprint and execution times for dense sets, e.g. sets where--- it is likely that many values lie close to each other. The asymptotics are--- not affected by this optimization.------ Many operations have a worst-case complexity of /O(min(n,W))/.--- This means that the operation can become linear in the number of--- elements with a maximum of /W/ -- the number of bits in an 'Int'--- (32 or 64).------ @since 0.5.9---------------------------------------------------------------------------------- [Note: INLINE bit fiddling]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~--- It is essential that the bit fiddling functions like mask, zero, branchMask--- etc are inlined. If they do not, the memory allocation skyrockets. The GHC--- usually gets it right, but it is disastrous if it does not. Therefore we--- explicitly mark these functions INLINE.----- [Note: Local 'go' functions and capturing]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Care must be taken when using 'go' function which captures an argument.--- Sometimes (for example when the argument is passed to a data constructor,--- as in insert), GHC heap-allocates more than necessary. Therefore C-- code--- must be checked for increased allocation when creating and modifying such--- functions.----- [Note: Order of constructors]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The order of constructors of IntSet matters when considering performance.--- Currently in GHC 7.0, when type has 3 constructors, they are matched from--- the first to the last -- the best performance is achieved when the--- constructors are ordered by frequency.--- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil--- improves the benchmark by circa 10%.--module Data.IntSet.Internal (-    -- * Set type-      IntSet(..), Key -- instance Eq,Show-    , Prefix, Mask, BitMap--    -- * Operators-    , (\\)--    -- * Query-    , null-    , size-    , member-    , notMember-    , lookupLT-    , lookupGT-    , lookupLE-    , lookupGE-    , isSubsetOf-    , isProperSubsetOf-    , disjoint--    -- * Construction-    , empty-    , singleton-    , insert-    , delete--    -- * Combine-    , union-    , unions-    , difference-    , intersection--    -- * Filter-    , filter-    , partition-    , split-    , splitMember-    , splitRoot--    -- * Map-    , map--    -- * 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.DeepSeq (NFData(rnf))-import Data.Bits-import qualified Data.List as List-import Data.Maybe (fromMaybe)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-import Data.Word (Word)-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)-#endif-import Data.Typeable-import Prelude hiding (filter, foldr, foldl, null, map)--import Utils.Containers.Internal.BitUtil-import Utils.Containers.Internal.StrictPair--#if __GLASGOW_HASKELL__-import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), DataType, mkDataType)-import Text.Read-#endif--#if __GLASGOW_HASKELL__-import GHC.Exts (Int(..), build)-#if __GLASGOW_HASKELL__ >= 708-import qualified GHC.Exts as GHCExts-#endif-import GHC.Prim (indexInt8OffAddr#)-#endif--import qualified Data.Foldable as Foldable-import Data.Foldable (Foldable())--infixl 9 \\{-This comment teaches CPP correct behaviour -}---- A "Nat" is a natural machine word (an unsigned Int)-type Nat = Word--natFromInt :: Int -> Nat-natFromInt i = fromIntegral i-{-# INLINE natFromInt #-}--intFromNat :: Nat -> Int-intFromNat w = fromIntegral w-{-# INLINE intFromNat #-}--{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}--- | /O(n+m)/. See 'difference'.-(\\) :: IntSet -> IntSet -> IntSet-m1 \\ m2 = difference m1 m2--{---------------------------------------------------------------------  Types---------------------------------------------------------------------}---- | A set of integers.---- See Note: Order of constructors-data IntSet = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntSet !IntSet--- Invariant: Nil is never found as a child of Bin.--- Invariant: The Mask is a power of 2.  It is the largest bit position at which---            two elements of the set differ.--- Invariant: Prefix is the common high-order bits that all elements share to---            the left of the Mask bit.--- Invariant: In Bin prefix mask left right, left consists of the elements that---            don't have the mask bit set; right is all the elements that do.-            | Tip {-# UNPACK #-} !Prefix {-# UNPACK #-} !BitMap--- Invariant: The Prefix is zero for the last 5 (on 32 bit arches) or 6 bits---            (on 64 bit arches). The values of the set represented by a tip---            are the prefix plus the indices of the set bits in the bit map.-            | Nil---- A number stored in a set is stored as--- * Prefix (all but last 5-6 bits) and--- * BitMap (last 5-6 bits stored as a bitmask)---   Last 5-6 bits are called a Suffix.--type Prefix = Int-type Mask   = Int-type BitMap = Word-type Key    = Int--instance Monoid IntSet where-    mempty  = empty-    mconcat = unions-#if !(MIN_VERSION_base(4,9,0))-    mappend = union-#else-    mappend = (<>)---- | @since 0.5.7-instance Semigroup IntSet where-    (<>)    = union-    stimes  = stimesIdempotentMonoid-#endif--#if __GLASGOW_HASKELL__--{---------------------------------------------------------------------  A Data instance---------------------------------------------------------------------}---- This instance preserves data abstraction at the cost of inefficiency.--- We provide limited reflection services for the sake of data abstraction.--instance Data IntSet where-  gfoldl f z is = z fromList `f` (toList is)-  toConstr _     = fromListConstr-  gunfold k z c  = case constrIndex c of-    1 -> k (z fromList)-    _ -> error "gunfold"-  dataTypeOf _   = intSetDataType--fromListConstr :: Constr-fromListConstr = mkConstr intSetDataType "fromList" [] Prefix--intSetDataType :: DataType-intSetDataType = mkDataType "Data.IntSet.Internal.IntSet" [fromListConstr]--#endif--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is the set empty?-null :: IntSet -> Bool-null Nil = True-null _   = False-{-# INLINE null #-}---- | /O(n)/. Cardinality of the set.-size :: IntSet -> Int-size = go 0-  where-    go !acc (Bin _ _ l r) = go (go acc l) r-    go acc (Tip _ bm) = acc + bitcount 0 bm-    go acc Nil = acc---- | /O(min(n,W))/. Is the value a member of the set?---- See Note: Local 'go' functions and capturing.-member :: Key -> IntSet -> Bool-member !x = go-  where-    go (Bin p m l r)-      | nomatch x p m = False-      | zero x m      = go l-      | otherwise     = go r-    go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0-    go Nil = False---- | /O(min(n,W))/. Is the element not in the set?-notMember :: Key -> IntSet -> Bool-notMember k = not . member k---- | /O(log n)/. Find largest element smaller than the given one.------ > lookupLT 3 (fromList [3, 5]) == Nothing--- > lookupLT 5 (fromList [3, 5]) == Just 3---- See Note: Local 'go' functions and capturing.-lookupLT :: Key -> IntSet -> Maybe Key-lookupLT !x t = case t of-    Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r-    _ -> go Nil t-  where-    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r-                         | zero x m  = go def l-                         | otherwise = go l r-    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm-                       | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT-                       | otherwise = unsafeFindMax def-                       where maskLT = (bitmapOf x - 1) .&. bm-    go def Nil = unsafeFindMax def----- | /O(log n)/. Find smallest element greater than the given one.------ > lookupGT 4 (fromList [3, 5]) == Just 5--- > lookupGT 5 (fromList [3, 5]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGT :: Key -> IntSet -> Maybe Key-lookupGT !x t = case t of-    Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r-    _ -> go Nil t-  where-    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def-                         | zero x m  = go r l-                         | otherwise = go def r-    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm-                       | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT-                       | otherwise = unsafeFindMin def-                       where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm-    go def Nil = unsafeFindMin def----- | /O(log n)/. Find largest element smaller or equal to the given one.------ > lookupLE 2 (fromList [3, 5]) == Nothing--- > lookupLE 4 (fromList [3, 5]) == Just 3--- > lookupLE 5 (fromList [3, 5]) == Just 5---- See Note: Local 'go' functions and capturing.-lookupLE :: Key -> IntSet -> Maybe Key-lookupLE !x t = case t of-    Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r-    _ -> go Nil t-  where-    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r-                         | zero x m  = go def l-                         | otherwise = go l r-    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm-                       | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE-                       | otherwise = unsafeFindMax def-                       where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm-    go def Nil = unsafeFindMax def----- | /O(log n)/. Find smallest element greater or equal to the given one.------ > lookupGE 3 (fromList [3, 5]) == Just 3--- > lookupGE 4 (fromList [3, 5]) == Just 5--- > lookupGE 6 (fromList [3, 5]) == Nothing---- See Note: Local 'go' functions and capturing.-lookupGE :: Key -> IntSet -> Maybe Key-lookupGE !x t = case t of-    Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r-    _ -> go Nil t-  where-    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def-                         | zero x m  = go r l-                         | otherwise = go def r-    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm-                       | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE-                       | otherwise = unsafeFindMin def-                       where maskGE = (- (bitmapOf x)) .&. bm-    go def Nil = unsafeFindMin def------ Helper function for lookupGE and lookupGT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMin :: IntSet -> Maybe Key-unsafeFindMin Nil = Nothing-unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm-unsafeFindMin (Bin _ _ l _) = unsafeFindMin l---- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is--- given, it has m > 0.-unsafeFindMax :: IntSet -> Maybe Key-unsafeFindMax Nil = Nothing-unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm-unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. The empty set.-empty :: IntSet-empty-  = Nil-{-# INLINE empty #-}---- | /O(1)/. A set of one element.-singleton :: Key -> IntSet-singleton x-  = Tip (prefixOf x) (bitmapOf x)-{-# INLINE singleton #-}--{---------------------------------------------------------------------  Insert---------------------------------------------------------------------}--- | /O(min(n,W))/. Add a value to the set. There is no left- or right bias for--- IntSets.-insert :: Key -> IntSet -> IntSet-insert !x = insertBM (prefixOf x) (bitmapOf x)---- Helper function for insert and union.-insertBM :: Prefix -> BitMap -> IntSet -> IntSet-insertBM !kx !bm t@(Bin p m l r)-  | nomatch kx p m = link kx (Tip kx bm) p t-  | zero kx m      = Bin p m (insertBM kx bm l) r-  | otherwise      = Bin p m l (insertBM kx bm r)-insertBM kx bm t@(Tip kx' bm')-  | kx' == kx = Tip kx' (bm .|. bm')-  | otherwise = link kx (Tip kx bm) kx' t-insertBM kx bm Nil = Tip kx bm---- | /O(min(n,W))/. Delete a value in the set. Returns the--- original set when the value was not present.-delete :: Key -> IntSet -> IntSet-delete !x = deleteBM (prefixOf x) (bitmapOf x)---- Deletes all values mentioned in the BitMap from the set.--- Helper function for delete and difference.-deleteBM :: Prefix -> BitMap -> IntSet -> IntSet-deleteBM !kx !bm t@(Bin p m l r)-  | nomatch kx p m = t-  | zero kx m      = bin p m (deleteBM kx bm l) r-  | otherwise      = bin p m l (deleteBM kx bm r)-deleteBM kx bm t@(Tip kx' bm')-  | kx' == kx = tip kx (bm' .&. complement bm)-  | otherwise = t-deleteBM _ _ Nil = Nil---{---------------------------------------------------------------------  Union---------------------------------------------------------------------}--- | The union of a list of sets.-unions :: Foldable f => f IntSet -> IntSet-unions xs-  = Foldable.foldl' union empty xs----- | /O(n+m)/. The union of two sets.-union :: IntSet -> IntSet -> IntSet-union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = union1-  | shorter m2 m1  = union2-  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)-  | otherwise      = link p1 t1 p2 t2-  where-    union1  | nomatch p2 p1 m1  = link p1 t1 p2 t2-            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1-            | otherwise         = Bin p1 m1 l1 (union r1 t2)--    union2  | nomatch p1 p2 m2  = link p1 t1 p2 t2-            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2-            | otherwise         = Bin p2 m2 l2 (union t1 r2)--union t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t-union t@(Bin _ _ _ _) Nil = t-union (Tip kx bm) t = insertBM kx bm t-union Nil t = t---{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | /O(n+m)/. Difference between two sets.-difference :: IntSet -> IntSet -> IntSet-difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = difference1-  | shorter m2 m1  = difference2-  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)-  | otherwise      = t1-  where-    difference1 | nomatch p2 p1 m1  = t1-                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1-                | otherwise         = bin p1 m1 l1 (difference r1 t2)--    difference2 | nomatch p1 p2 m2  = t1-                | zero p1 m2        = difference t1 l2-                | otherwise         = difference t1 r2--difference t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t-difference t@(Bin _ _ _ _) Nil = t--difference t1@(Tip kx bm) t2 = differenceTip t2-  where differenceTip (Bin p2 m2 l2 r2) | nomatch kx p2 m2 = t1-                                        | zero kx m2 = differenceTip l2-                                        | otherwise = differenceTip r2-        differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2)-                                    | otherwise = t1-        differenceTip Nil = t1--difference Nil _     = Nil----{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | /O(n+m)/. The intersection of two sets.-intersection :: IntSet -> IntSet -> IntSet-intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = intersection1-  | shorter m2 m1  = intersection2-  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)-  | otherwise      = Nil-  where-    intersection1 | nomatch p2 p1 m1  = Nil-                  | zero p2 m1        = intersection l1 t2-                  | otherwise         = intersection r1 t2--    intersection2 | nomatch p1 p2 m2  = Nil-                  | zero p1 m2        = intersection t1 l2-                  | otherwise         = intersection t1 r2--intersection t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1-  where intersectBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = Nil-                                      | zero kx2 m1       = intersectBM l1-                                      | otherwise         = intersectBM r1-        intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)-                                  | otherwise = Nil-        intersectBM Nil = Nil--intersection (Bin _ _ _ _) Nil = Nil--intersection (Tip kx1 bm1) t2 = intersectBM t2-  where intersectBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = Nil-                                      | zero kx1 m2       = intersectBM l2-                                      | otherwise         = intersectBM r2-        intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)-                                  | otherwise = Nil-        intersectBM Nil = Nil--intersection Nil _ = Nil--{---------------------------------------------------------------------  Subset---------------------------------------------------------------------}--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).-isProperSubsetOf :: IntSet -> IntSet -> Bool-isProperSubsetOf t1 t2-  = case subsetCmp t1 t2 of-      LT -> True-      _  -> False--subsetCmp :: IntSet -> IntSet -> Ordering-subsetCmp t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  | shorter m1 m2  = GT-  | shorter m2 m1  = case subsetCmpLt of-                       GT -> GT-                       _  -> LT-  | p1 == p2       = subsetCmpEq-  | otherwise      = GT  -- disjoint-  where-    subsetCmpLt | nomatch p1 p2 m2  = GT-                | zero p1 m2        = subsetCmp t1 l2-                | otherwise         = subsetCmp t1 r2-    subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of-                    (GT,_ ) -> GT-                    (_ ,GT) -> GT-                    (EQ,EQ) -> EQ-                    _       -> LT--subsetCmp (Bin _ _ _ _) _  = GT-subsetCmp (Tip kx1 bm1) (Tip kx2 bm2)-  | kx1 /= kx2                  = GT -- disjoint-  | bm1 == bm2                  = EQ-  | bm1 .&. complement bm2 == 0 = LT-  | otherwise                   = GT-subsetCmp t1@(Tip kx _) (Bin p m l r)-  | nomatch kx p m = GT-  | zero kx m      = case subsetCmp t1 l of GT -> GT ; _ -> LT-  | otherwise      = case subsetCmp t1 r of GT -> GT ; _ -> LT-subsetCmp (Tip _ _) Nil = GT -- disjoint-subsetCmp Nil Nil = EQ-subsetCmp Nil _   = LT---- | /O(n+m)/. Is this a subset?--- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.--isSubsetOf :: IntSet -> IntSet -> Bool-isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  | shorter m1 m2  = False-  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2-                                                      else isSubsetOf t1 r2)-  | otherwise      = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2-isSubsetOf (Bin _ _ _ _) _  = False-isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0-isSubsetOf t1@(Tip kx _) (Bin p m l r)-  | nomatch kx p m = False-  | zero kx m      = isSubsetOf t1 l-  | otherwise      = isSubsetOf t1 r-isSubsetOf (Tip _ _) Nil = False-isSubsetOf Nil _         = True---{---------------------------------------------------------------------  Disjoint---------------------------------------------------------------------}--- | /O(n+m)/. Check whether two sets are disjoint (i.e. their intersection---   is empty).------ > disjoint (fromList [2,4,6])   (fromList [1,3])     == True--- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False--- > disjoint (fromList [1,2])     (fromList [1,2,3,4]) == False--- > disjoint (fromList [])        (fromList [])        == True------ @since 0.5.11-disjoint :: IntSet -> IntSet -> Bool-disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)-  | shorter m1 m2  = disjoint1-  | shorter m2 m1  = disjoint2-  | p1 == p2       = disjoint l1 l2 && disjoint r1 r2-  | otherwise      = True-  where-    disjoint1 | nomatch p2 p1 m1  = True-              | zero p2 m1        = disjoint l1 t2-              | otherwise         = disjoint r1 t2--    disjoint2 | nomatch p1 p2 m2  = True-              | zero p1 m2        = disjoint t1 l2-              | otherwise         = disjoint t1 r2--disjoint t1@(Bin _ _ _ _) (Tip kx2 bm2) = disjointBM t1-  where disjointBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = True-                                     | zero kx2 m1       = disjointBM l1-                                     | otherwise         = disjointBM r1-        disjointBM (Tip kx1 bm1) | kx1 == kx2 = (bm1 .&. bm2) == 0-                                 | otherwise = True-        disjointBM Nil = True--disjoint (Bin _ _ _ _) Nil = True--disjoint (Tip kx1 bm1) t2 = disjointBM t2-  where disjointBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = True-                                     | zero kx1 m2       = disjointBM l2-                                     | otherwise         = disjointBM r2-        disjointBM (Tip kx2 bm2) | kx1 == kx2 = (bm1 .&. bm2) == 0-                                 | otherwise = True-        disjointBM Nil = True--disjoint Nil _ = True---{---------------------------------------------------------------------  Filter---------------------------------------------------------------------}--- | /O(n)/. Filter all elements that satisfy some predicate.-filter :: (Key -> Bool) -> IntSet -> IntSet-filter predicate t-  = case t of-      Bin p m l r-        -> bin p m (filter predicate l) (filter predicate r)-      Tip kx bm-        -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm)-      Nil -> Nil-  where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi-                         | otherwise           = bm-        {-# INLINE bitPred #-}---- | /O(n)/. partition the set according to some predicate.-partition :: (Key -> Bool) -> IntSet -> (IntSet,IntSet)-partition predicate0 t0 = toPair $ go predicate0 t0-  where-    go predicate t-      = case t of-          Bin p m l r-            -> let (l1 :*: l2) = go predicate l-                   (r1 :*: r2) = go predicate r-               in bin p m l1 r1 :*: bin p m l2 r2-          Tip kx bm-            -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm-               in  tip kx bm1 :*: tip kx (bm `xor` bm1)-          Nil -> (Nil :*: Nil)-      where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi-                             | otherwise           = bm-            {-# INLINE bitPred #-}----- | /O(min(n,W))/. The expression (@'split' x set@) is a pair @(set1,set2)@--- where @set1@ comprises the elements of @set@ less than @x@ and @set2@--- comprises the elements of @set@ greater than @x@.------ > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])-split :: Key -> IntSet -> (IntSet,IntSet)-split x t =-  case t of-      Bin _ m l r-          | m < 0 -> if x >= 0  -- handle negative numbers.-                     then case go x l of (lt :*: gt) -> let !lt' = union lt r-                                                        in (lt', gt)-                     else case go x r of (lt :*: gt) -> let !gt' = union gt l-                                                        in (lt, gt')-      _ -> case go x t of-          (lt :*: gt) -> (lt, gt)-  where-    go !x' t'@(Bin p m l r)-        | match x' p m = if zero x' m-                         then case go x' l of-                             (lt :*: gt) -> lt :*: union gt r-                         else case go x' r of-                             (lt :*: gt) -> union lt l :*: gt-        | otherwise   = if x' < p then (Nil :*: t')-                        else (t' :*: Nil)-    go x' t'@(Tip kx' bm)-        | kx' > x'          = (Nil :*: t')-          -- equivalent to kx' > prefixOf x'-        | kx' < prefixOf x' = (t' :*: Nil)-        | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)-            where lowerBitmap = bitmapOf x' - 1-                  higherBitmap = complement (lowerBitmap + bitmapOf x')-    go _ Nil = (Nil :*: Nil)---- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot--- element was found in the original set.-splitMember :: Key -> IntSet -> (IntSet,Bool,IntSet)-splitMember x t =-  case t of-      Bin _ m l r | m < 0 -> if x >= 0-                             then case go x l of-                                 (lt, fnd, gt) -> let !lt' = union lt r-                                                  in (lt', fnd, gt)-                             else case go x r of-                                 (lt, fnd, gt) -> let !gt' = union gt l-                                                  in (lt, fnd, gt')-      _ -> go x t-  where-    go x' t'@(Bin p m l r)-        | match x' p m = if zero x' m-                         then case go x' l of-                             (lt, fnd, gt) -> (lt, fnd, union gt r)-                         else case go x' r of-                             (lt, fnd, gt) -> (union lt l, fnd, gt)-        | otherwise   = if x' < p then (Nil, False, t') else (t', False, Nil)-    go x' t'@(Tip kx' bm)-        | kx' > x'          = (Nil, False, t')-          -- equivalent to kx' > prefixOf x'-        | kx' < prefixOf x' = (t', False, Nil)-        | otherwise = let !lt = tip kx' (bm .&. lowerBitmap)-                          !found = (bm .&. bitmapOfx') /= 0-                          !gt = tip kx' (bm .&. higherBitmap)-                      in (lt, found, gt)-            where bitmapOfx' = bitmapOf x'-                  lowerBitmap = bitmapOfx' - 1-                  higherBitmap = complement (lowerBitmap + bitmapOfx')-    go _ Nil = (Nil, False, Nil)--{-----------------------------------------------------------------------  Min/Max-----------------------------------------------------------------------}---- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set--- stripped of that element, or 'Nothing' if passed an empty set.-maxView :: IntSet -> Maybe (Key, IntSet)-maxView t =-  case t of Nil -> Nothing-            Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, bin p m l' r)-            _ -> Just (go t)-  where-    go (Bin p m l r) = case go r of (result, r') -> (result, bin p m l r')-    go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))-    go Nil = error "maxView Nil"---- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set--- stripped of that element, or 'Nothing' if passed an empty set.-minView :: IntSet -> Maybe (Key, IntSet)-minView t =-  case t of Nil -> Nothing-            Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, bin p m l r')-            _ -> Just (go t)-  where-    go (Bin p m l r) = case go l of (result, l') -> (result, bin p m l' r)-    go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))-    go Nil = error "minView Nil"---- | /O(min(n,W))/. Delete and find the minimal element.------ > deleteFindMin set = (findMin set, deleteMin set)-deleteFindMin :: IntSet -> (Key, IntSet)-deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView---- | /O(min(n,W))/. Delete and find the maximal element.------ > deleteFindMax set = (findMax set, deleteMax set)-deleteFindMax :: IntSet -> (Key, IntSet)-deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView----- | /O(min(n,W))/. The minimal element of the set.-findMin :: IntSet -> Key-findMin Nil = error "findMin: empty set has no minimal element"-findMin (Tip kx bm) = kx + lowestBitSet bm-findMin (Bin _ m l r)-  |   m < 0   = find r-  | otherwise = find l-    where find (Tip kx bm) = kx + lowestBitSet bm-          find (Bin _ _ l' _) = find l'-          find Nil            = error "findMin Nil"---- | /O(min(n,W))/. The maximal element of a set.-findMax :: IntSet -> Key-findMax Nil = error "findMax: empty set has no maximal element"-findMax (Tip kx bm) = kx + highestBitSet bm-findMax (Bin _ m l r)-  |   m < 0   = find l-  | otherwise = find r-    where find (Tip kx bm) = kx + highestBitSet bm-          find (Bin _ _ _ r') = find r'-          find Nil            = error "findMax Nil"----- | /O(min(n,W))/. Delete the minimal element. Returns an empty set if the set is empty.------ Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#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--{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | /O(n)/. Fold the elements in the set using the given right-associative--- binary operator. This function is an equivalent of 'foldr' and is present--- for compatibility only.------ /Please note that fold will be deprecated in the future and removed./-fold :: (Key -> b -> b) -> b -> IntSet -> b-fold = foldr-{-# INLINE fold #-}---- | /O(n)/. Fold the elements in the set using the given right-associative--- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.------ For example,------ > toAscList set = foldr (:) [] set-foldr :: (Key -> b -> b) -> b -> IntSet -> b-foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before-                        | otherwise -> go (go z r) l-            _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip kx bm)   = foldrBits kx f z' bm-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr #-}---- | /O(n)/. A strict version of 'foldr'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldr' :: (Key -> b -> b) -> b -> IntSet -> b-foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before-                        | otherwise -> go (go z r) l-            _ -> go z t-  where-    go !z' Nil           = z'-    go z' (Tip kx bm)   = foldr'Bits kx f z' bm-    go z' (Bin _ _ l r) = go (go z' r) l-{-# INLINE foldr' #-}---- | /O(n)/. Fold the elements in the set using the given left-associative--- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.------ For example,------ > toDescList set = foldl (flip (:)) [] set-foldl :: (a -> Key -> a) -> a -> IntSet -> a-foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before-                        | otherwise -> go (go z l) r-            _ -> go z t-  where-    go z' Nil           = z'-    go z' (Tip kx bm)   = foldlBits kx f z' bm-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl #-}---- | /O(n)/. A strict version of 'foldl'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldl' :: (a -> Key -> a) -> a -> IntSet -> a-foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.-  case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before-                        | otherwise -> go (go z l) r-            _ -> go z t-  where-    go !z' Nil           = z'-    go z' (Tip kx bm)   = foldl'Bits kx f z' bm-    go z' (Bin _ _ l r) = go (go z' l) r-{-# INLINE foldl' #-}--{---------------------------------------------------------------------  List variations---------------------------------------------------------------------}--- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order.--- Subject to list fusion.-elems :: IntSet -> [Key]-elems-  = toAscList--{---------------------------------------------------------------------  Lists---------------------------------------------------------------------}-#if __GLASGOW_HASKELL__ >= 708--- | @since 0.5.6.2-instance GHCExts.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 = build (\c n -> foldrFB c n s) #-}-{-# RULES "IntSet.toAscListBack" [1] foldrFB (:) [] = toAscList #-}-{-# RULES "IntSet.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}-{-# RULES "IntSet.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}-#endif----- | /O(n*min(n,W))/. Create a set from a list of integers.-fromList :: [Key] -> IntSet-fromList xs-  = Foldable.foldl' ins empty xs-  where-    ins t x  = insert x t---- | /O(n)/. Build a set from an ascending list of elements.--- /The precondition (input list is ascending) is not checked./-fromAscList :: [Key] -> IntSet-fromAscList [] = Nil-fromAscList (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)-  where-    combineEq x' [] = [x']-    combineEq x' (x:xs)-      | x==x'     = combineEq x' xs-      | otherwise = x' : combineEq x xs---- | /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 []         = Nil-fromDistinctAscList (z0 : zs0) = work (prefixOf z0) (bitmapOf z0) zs0 Nada-  where-    -- 'work' accumulates all values that go into one tip, before passing this Tip-    -- to 'reduce'-    work kx bm []     stk = finish kx (Tip kx bm) stk-    work kx bm (z:zs) stk | kx == prefixOf z = work kx (bm .|. bitmapOf z) zs stk-    work kx bm (z:zs) stk = reduce z zs (branchMask z kx) kx (Tip kx bm) stk--    reduce z zs _ px tx Nada = work (prefixOf z) (bitmapOf z) zs (Push px tx Nada)-    reduce z zs m px tx stk@(Push py ty stk') =-        let mxy = branchMask px py-            pxy = mask px mxy-        in  if shorter m mxy-                 then reduce z zs m pxy (Bin pxy mxy ty tx) stk'-                 else work (prefixOf z) (bitmapOf z) zs (Push px tx stk)--    finish _  t  Nada = t-    finish px tx (Push py ty stk) = finish p (link py ty px tx) stk-        where m = branchMask px py-              p = mask px m--data Stack = Push {-# UNPACK #-} !Prefix !IntSet !Stack | Nada---{---------------------------------------------------------------------  Eq---------------------------------------------------------------------}-instance Eq IntSet where-  t1 == t2  = equal t1 t2-  t1 /= t2  = nequal t1 t2--equal :: IntSet -> IntSet -> Bool-equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)-equal (Tip kx1 bm1) (Tip kx2 bm2)-  = kx1 == kx2 && bm1 == bm2-equal Nil Nil = True-equal _   _   = False--nequal :: IntSet -> IntSet -> Bool-nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)-  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)-nequal (Tip kx1 bm1) (Tip kx2 bm2)-  = kx1 /= kx2 || bm1 /= bm2-nequal Nil Nil = False-nequal _   _   = True--{---------------------------------------------------------------------  Ord---------------------------------------------------------------------}--instance Ord IntSet where-    compare s1 s2 = compare (toAscList s1) (toAscList s2)-    -- tentative implementation. See if more efficient exists.--{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance Show IntSet where-  showsPrec p xs = showParen (p > 10) $-    showString "fromList " . shows (toList xs)--{---------------------------------------------------------------------  Read---------------------------------------------------------------------}-instance Read IntSet where-#ifdef __GLASGOW_HASKELL__-  readPrec = parens $ prec 10 $ do-    Ident "fromList" <- lexP-    xs <- readPrec-    return (fromList xs)--  readListPrec = readListPrecDefault-#else-  readsPrec p = readParen (p > 10) $ \ r -> do-    ("fromList",s) <- lex r-    (xs,t) <- reads s-    return (fromList xs,t)-#endif--{---------------------------------------------------------------------  Typeable---------------------------------------------------------------------}--INSTANCE_TYPEABLE0(IntSet)--{---------------------------------------------------------------------  NFData---------------------------------------------------------------------}---- The IntSet constructors consist only of strict fields of Ints and--- IntSets, thus the default NFData instance which evaluates to whnf--- should suffice-instance NFData IntSet where rnf x = seq x ()--{---------------------------------------------------------------------  Debugging---------------------------------------------------------------------}--- | /O(n)/. Show the tree that implements the set. The tree is shown--- in a compressed, hanging format.-showTree :: IntSet -> String-showTree s-  = showTreeWith True False s---{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows- the tree that implements the set. If @hang@ is- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If- @wide@ is 'True', an extra wide version is shown.--}-showTreeWith :: Bool -> Bool -> IntSet -> String-showTreeWith hang wide t-  | hang      = (showsTreeHang wide [] t) ""-  | otherwise = (showsTree wide [] [] t) ""--showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS-showsTree wide lbars rbars t-  = case t of-      Bin p m l r-          -> showsTree wide (withBar rbars) (withEmpty rbars) r .-             showWide wide rbars .-             showsBars lbars . showString (showBin p m) . showString "\n" .-             showWide wide lbars .-             showsTree wide (withEmpty lbars) (withBar lbars) l-      Tip kx bm-          -> showsBars lbars . showString " " . shows kx . showString " + " .-                                                showsBitMap bm . showString "\n"-      Nil -> showsBars lbars . showString "|\n"--showsTreeHang :: Bool -> [String] -> IntSet -> ShowS-showsTreeHang wide bars t-  = case t of-      Bin p m l r-          -> showsBars bars . showString (showBin p m) . showString "\n" .-             showWide wide bars .-             showsTreeHang wide (withBar bars) l .-             showWide wide bars .-             showsTreeHang wide (withEmpty bars) r-      Tip kx bm-          -> showsBars bars . showString " " . shows kx . showString " + " .-                                               showsBitMap bm . showString "\n"-      Nil -> showsBars bars . showString "|\n"--showBin :: Prefix -> Mask -> String-showBin _ _-  = "*" -- ++ show (p,m)--showWide :: Bool -> [String] -> String -> String-showWide wide bars-  | wide      = showString (concat (reverse bars)) . showString "|\n"-  | otherwise = id--showsBars :: [String] -> ShowS-showsBars [] = id-showsBars bars = showString (concat (reverse (tail bars))) . showString node--showsBitMap :: Word -> ShowS-showsBitMap = showString . showBitMap--showBitMap :: Word -> String-showBitMap w = show $ foldrBits 0 (:) [] w--node :: String-node           = "+--"--withBar, withEmpty :: [String] -> [String]-withBar bars   = "|  ":bars-withEmpty bars = "   ":bars---{---------------------------------------------------------------------  Helpers---------------------------------------------------------------------}-{---------------------------------------------------------------------  Link---------------------------------------------------------------------}-link :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet-link p1 t1 p2 t2-  | zero p1 m = Bin p m t1 t2-  | otherwise = Bin p m t2 t1-  where-    m = branchMask p1 p2-    p = mask p1 m-{-# INLINE link #-}--{---------------------------------------------------------------------  @bin@ assures that we never have empty trees within a tree.---------------------------------------------------------------------}-bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet-bin _ _ l Nil = l-bin _ _ Nil r = r-bin p m l r   = Bin p m l r-{-# INLINE bin #-}--{---------------------------------------------------------------------  @tip@ assures that we never have empty bitmaps within a tree.---------------------------------------------------------------------}-tip :: Prefix -> BitMap -> IntSet-tip _ 0 = Nil-tip kx bm = Tip kx bm-{-# INLINE tip #-}---{-----------------------------------------------------------------------  Functions that generate Prefix and BitMap of a Key or a Suffix.-----------------------------------------------------------------------}--suffixBitMask :: Int-#if MIN_VERSION_base(4,7,0)-suffixBitMask = finiteBitSize (undefined::Word) - 1-#else-suffixBitMask = bitSize (undefined::Word) - 1-#endif-{-# INLINE suffixBitMask #-}--prefixBitMask :: Int-prefixBitMask = complement suffixBitMask-{-# INLINE prefixBitMask #-}--prefixOf :: Int -> Prefix-prefixOf x = x .&. prefixBitMask-{-# INLINE prefixOf #-}--suffixOf :: Int -> Int-suffixOf x = x .&. suffixBitMask-{-# INLINE suffixOf #-}--bitmapOfSuffix :: Int -> BitMap-bitmapOfSuffix s = 1 `shiftLL` s-{-# INLINE bitmapOfSuffix #-}--bitmapOf :: Int -> BitMap-bitmapOf x = bitmapOfSuffix (suffixOf x)-{-# INLINE bitmapOf #-}---{---------------------------------------------------------------------  Endian independent bit twiddling---------------------------------------------------------------------}--- Returns True iff the bits set in i and the Mask m are disjoint.-zero :: Int -> Mask -> Bool-zero i m-  = (natFromInt i) .&. (natFromInt m) == 0-{-# INLINE zero #-}--nomatch,match :: Int -> Prefix -> Mask -> Bool-nomatch i p m-  = (mask i m) /= p-{-# INLINE nomatch #-}--match i p m-  = (mask i m) == p-{-# INLINE match #-}---- Suppose a is largest such that 2^a divides 2*m.--- Then mask i m is i with the low a bits zeroed out.-mask :: Int -> Mask -> Prefix-mask i m-  = maskW (natFromInt i) (natFromInt m)-{-# INLINE mask #-}--{---------------------------------------------------------------------  Big endian operations---------------------------------------------------------------------}-maskW :: Nat -> Nat -> Prefix-maskW i m-  = intFromNat (i .&. (complement (m-1) `xor` m))-{-# INLINE maskW #-}--shorter :: Mask -> Mask -> Bool-shorter m1 m2-  = (natFromInt m1) > (natFromInt m2)-{-# INLINE shorter #-}--branchMask :: Prefix -> Prefix -> Mask-branchMask p1 p2-  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))-{-# INLINE branchMask #-}--{-----------------------------------------------------------------------  To get best performance, we provide fast implementations of-  lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.-  If the intel bsf and bsr instructions ever become GHC primops,-  this code should be reimplemented using these.--  Performance of this code is crucial for folds, toList, filter, partition.--  The signatures of methods in question are placed after this comment.-----------------------------------------------------------------------}--lowestBitSet :: Nat -> Int-highestBitSet :: Nat -> Int-foldlBits :: Int -> (a -> Int -> a) -> a -> Nat -> a-foldl'Bits :: Int -> (a -> Int -> a) -> a -> Nat -> a-foldrBits :: Int -> (Int -> a -> a) -> a -> Nat -> a-foldr'Bits :: Int -> (Int -> a -> a) -> a -> Nat -> a--{-# INLINE lowestBitSet #-}-{-# INLINE highestBitSet #-}-{-# INLINE foldlBits #-}-{-# INLINE foldl'Bits #-}-{-# INLINE foldrBits #-}-{-# INLINE foldr'Bits #-}--#if defined(__GLASGOW_HASKELL__) && (WORD_SIZE_IN_BITS==32 || WORD_SIZE_IN_BITS==64)-{-----------------------------------------------------------------------  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 :: Nat -> Int-{-# INLINE indexOfTheOnlyBit #-}-indexOfTheOnlyBit bitmask =-  I# (lsbArray `indexInt8OffAddr#` unboxInt (intFromNat ((bitmask * magic) `shiftRL` offset)))-  where unboxInt (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.--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--lowestBitSet x = indexOfTheOnlyBit (lowestBitMask x)--highestBitSet x = indexOfTheOnlyBit (highestBitMask x)--foldlBits prefix f z bitmap = go bitmap z-  where go 0 acc = acc-        go bm acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))-          where-            !bitmask = lowestBitMask bm-            !bi = indexOfTheOnlyBit bitmask--foldl'Bits prefix f z bitmap = go bitmap z-  where go 0 acc = acc-        go bm !acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))-          where !bitmask = lowestBitMask bm-                !bi = indexOfTheOnlyBit bitmask--foldrBits prefix f z bitmap = go (revNat bitmap) z-  where go 0 acc = acc-        go bm acc = go (bm `xor` bitmask) ((f $! (prefix+(WORD_SIZE_IN_BITS-1)-bi)) acc)-          where !bitmask = lowestBitMask bm-                !bi = indexOfTheOnlyBit bitmask---foldr'Bits prefix f z bitmap = go (revNat bitmap) z-  where go 0 acc = acc-        go bm !acc = go (bm `xor` bitmask) ((f $! (prefix+(WORD_SIZE_IN_BITS-1)-bi)) acc)-          where !bitmask = lowestBitMask bm-                !bi = indexOfTheOnlyBit bitmask--#else-{-----------------------------------------------------------------------  In general case we use logarithmic implementation of-  lowestBitSet and highestBitSet, which works up to bit sizes of 64.--  Folds are linear scans.-----------------------------------------------------------------------}--lowestBitSet n0 =-    let (n1,b1) = if n0 .&. 0xFFFFFFFF /= 0 then (n0,0)  else (n0 `shiftRL` 32, 32)-        (n2,b2) = if n1 .&. 0xFFFF /= 0     then (n1,b1) else (n1 `shiftRL` 16, 16+b1)-        (n3,b3) = if n2 .&. 0xFF /= 0       then (n2,b2) else (n2 `shiftRL` 8,  8+b2)-        (n4,b4) = if n3 .&. 0xF /= 0        then (n3,b3) else (n3 `shiftRL` 4,  4+b3)-        (n5,b5) = if n4 .&. 0x3 /= 0        then (n4,b4) else (n4 `shiftRL` 2,  2+b4)-        b6      = if n5 .&. 0x1 /= 0        then     b5  else                   1+b5-    in b6--highestBitSet n0 =-    let (n1,b1) = if n0 .&. 0xFFFFFFFF00000000 /= 0 then (n0 `shiftRL` 32, 32)    else (n0,0)-        (n2,b2) = if n1 .&. 0xFFFF0000 /= 0         then (n1 `shiftRL` 16, 16+b1) else (n1,b1)-        (n3,b3) = if n2 .&. 0xFF00 /= 0             then (n2 `shiftRL` 8,  8+b2)  else (n2,b2)-        (n4,b4) = if n3 .&. 0xF0 /= 0               then (n3 `shiftRL` 4,  4+b3)  else (n3,b3)-        (n5,b5) = if n4 .&. 0xC /= 0                then (n4 `shiftRL` 2,  2+b4)  else (n4,b4)-        b6      = if n5 .&. 0x2 /= 0                then                   1+b5   else     b5-    in b6--foldlBits prefix f z bm = let lb = lowestBitSet bm-                          in  go (prefix+lb) z (bm `shiftRL` lb)-  where go !_ acc 0 = acc-        go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)-                    | otherwise     = go (bi + 1)    acc     (n `shiftRL` 1)--foldl'Bits prefix f z bm = let lb = lowestBitSet bm-                           in  go (prefix+lb) z (bm `shiftRL` lb)-  where go !_ !acc 0 = acc-        go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)-                    | otherwise     = go (bi + 1)    acc     (n `shiftRL` 1)--foldrBits prefix f z bm = let lb = lowestBitSet bm-                          in  go (prefix+lb) (bm `shiftRL` lb)-  where go !_ 0 = z-        go bi n | n `testBit` 0 = f bi (go (bi + 1) (n `shiftRL` 1))-                | otherwise     =       go (bi + 1) (n `shiftRL` 1)--foldr'Bits prefix f z bm = let lb = lowestBitSet bm-                           in  go (prefix+lb) (bm `shiftRL` lb)-  where-        go !_ 0 = z-        go bi n | n `testBit` 0 = f bi $! go (bi + 1) (n `shiftRL` 1)-                | otherwise     =         go (bi + 1) (n `shiftRL` 1)--#endif---{---------------------------------------------------------------------  Utilities---------------------------------------------------------------------}---- | /O(1)/.  Decompose a set into pieces based on the structure of the underlying--- tree.  This function is useful for consuming a set in parallel.------ No guarantee is made as to the sizes of the pieces; an internal, but--- deterministic process determines this.  However, it is guaranteed that the--- pieces returned will be in ascending order (all elements in the first submap--- less than all elements in the second, and so on).------ Examples:------ > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]--- > splitRoot empty == []------  Note that the current implementation does not return more than two subsets,---  but you should not depend on this behaviour because it can change in the---  future without notice. Also, the current version does not continue---  splitting all the way to individual singleton sets -- it stops at some---  point.-splitRoot :: IntSet -> [IntSet]-splitRoot Nil = []--- NOTE: we don't currently split below Tip, but we could.-splitRoot x@(Tip _ _) = [x]-splitRoot (Bin _ m l r) | m < 0 = [r, l]-                        | otherwise = [l, r]-{-# INLINE splitRoot #-}