packages feed

containers 0.6.0.1 → 0.8

raw patch · 108 files changed

Files

− Data/Containers/ListUtils.hs 
@@ -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
− Data/Graph.hs 
@@ -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 ]
− Data/IntMap.hs 
@@ -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
− Data/IntMap/Internal.hs 
@@ -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
− Data/IntMap/Internal/Debug.hs 
@@ -1,6 +0,0 @@-module Data.IntMap.Internal.Debug-  ( showTree-  , showTreeWith-  ) where--import Data.IntMap.Internal
− Data/IntMap/Internal/DeprecatedDebug.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts, DataKinds, MonoLocalBinds #-}--module Data.IntMap.Internal.DeprecatedDebug where-import Data.IntMap.Internal (IntMap)--import Utils.Containers.Internal.TypeError----- | 'showTree' has moved to 'Data.IntMap.Internal.Debug.showTree'-showTree :: Whoops "Data.IntMap.showTree has moved to Data.IntMap.Internal.Debug.showTree"-         => IntMap a -> String-showTree _ = undefined---- | 'showTreeWith' has moved to 'Data.IntMap.Internal.Debug.showTreeWith'-showTreeWith :: Whoops "Data.IntMap.showTreeWith has moved to Data.IntMap.Internal.Debug.showTreeWith"-             => Bool -> Bool -> IntMap a -> String-showTreeWith _ _ _ = undefined
− Data/IntMap/Lazy.hs 
@@ -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
− Data/IntMap/Merge/Lazy.hs 
@@ -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
− Data/IntMap/Merge/Strict.hs 
@@ -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
− Data/IntMap/Strict.hs 
@@ -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
− Data/IntSet.hs 
@@ -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
− Data/IntSet/Internal.hs 
@@ -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 #-}
− Data/Map.hs 
@@ -1,114 +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.Map--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ /Note:/ You should use "Data.Map.Strict" instead of this module if:------ * You will eventually need all the values stored.------ * The stored values don't represent large virtual data structures--- to be lazily computed.------ An efficient implementation of ordered maps from keys to values--- (dictionaries).------ These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.------ >  import qualified Data.Map as Map------ The implementation of 'Map' is based on /size balanced/ binary trees (or--- trees of /bounded balance/) as described by:------    * Stephen Adams, \"/Efficient sets: a balancing act/\",---     Journal of Functional Programming 3(4):553-562, October 1993,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.---    * J. Nievergelt and E.M. Reingold,---      \"/Binary search trees of bounded balance/\",---      SIAM journal of computing 2(1), March 1973.------  Bounds for 'union', 'intersection', and 'difference' are as given---  by------    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.------ Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'.------ /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of--- this condition is not detected and if the size limit is exceeded, its--- behaviour is undefined.------ Operation comments contain the operation time complexity in--- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).--------------------------------------------------------------------------------module Data.Map-    ( module Data.Map.Lazy-#ifdef __GLASGOW_HASKELL__-    , insertWith'-    , insertWithKey'-    , insertLookupWithKey'-    , fold-    , foldWithKey-#endif-    ) where--import Data.Map.Lazy--#ifdef __GLASGOW_HASKELL__-import Utils.Containers.Internal.TypeError---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.insertWith'.-insertWith' :: Whoops "Data.Map.insertWith' is gone. Use Data.Map.Strict.insertWith."-            => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWith' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.insertWithKey'.-insertWithKey' :: Whoops "Data.Map.insertWithKey' is gone. Use Data.Map.Strict.insertWithKey."-               => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKey' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'Data.Map.Strict.insertLookupWithKey'.-insertLookupWithKey' :: Whoops "Data.Map.insertLookupWithKey' is gone. Use Data.Map.Strict.insertLookupWithKey."-                     => (k -> a -> a -> a) -> k -> a -> Map k a-                     -> (Maybe a, Map k a)-insertLookupWithKey' _ _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'foldr'.-fold :: Whoops "Data.Map.fold is gone. Use foldr."-     => (a -> b -> b) -> b -> Map k a -> b-fold _ _ _ = undefined---- | This function is being removed and is no longer usable.--- Use 'foldrWithKey'.-foldWithKey :: Whoops "Data.Map.foldWithKey is gone. Use foldrWithKey."-            => (k -> a -> b -> b) -> b -> Map k a -> b-foldWithKey _ _ _ = undefined-#endif
− Data/Map/Internal.hs 
@@ -1,4244 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}-#define USE_MAGIC_PROXY 1-#endif--#ifdef USE_MAGIC_PROXY-{-# LANGUAGE MagicHash #-}-#endif--{-# OPTIONS_HADDOCK not-home #-}--#include "containers.h"--#if !(WORD_SIZE_IN_BITS >= 61)-#define DEFINE_ALTERF_FALLBACK 1-#endif---------------------------------------------------------------------------------- |--- Module      :  Data.Map.Internal--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ = WARNING------ This module is considered __internal__.------ The Package Versioning Policy __does not apply__.------ 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 maps from keys to values (dictionaries).------ Since many function names (but not the type name) clash with--- "Prelude" names, this module is usually imported @qualified@, e.g.------ >  import Data.Map (Map)--- >  import qualified Data.Map as Map------ The implementation of 'Map' is based on /size balanced/ binary trees (or--- trees of /bounded balance/) as described by:------    * Stephen Adams, \"/Efficient sets: a balancing act/\",---     Journal of Functional Programming 3(4):553-562, October 1993,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.---    * J. Nievergelt and E.M. Reingold,---      \"/Binary search trees of bounded balance/\",---      SIAM journal of computing 2(1), March 1973.------  Bounds for 'union', 'intersection', and 'difference' are as given---  by------    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.------ Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'.------ Operation comments contain the operation time complexity in--- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.------ @since 0.5.9---------------------------------------------------------------------------------- [Note: Using INLINABLE]--- ~~~~~~~~~~~~~~~~~~~~~~~--- It is crucial to the performance that the functions specialize on the Ord--- type when possible. GHC 7.0 and higher does this by itself when it sees th--- unfolding of a function -- that is why all public functions are marked--- INLINABLE (that exposes the unfolding).----- [Note: Using INLINE]--- ~~~~~~~~~~~~~~~~~~~~--- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.--- We mark the functions that just navigate down the tree (lookup, insert,--- delete and similar). That navigation code gets inlined and thus specialized--- when possible. There is a price to pay -- code growth. The code INLINED is--- therefore only the tree navigation, all the real work (rebalancing) is not--- INLINED by using a NOINLINE.------ All methods marked INLINE have to be nonrecursive -- a 'go' function doing--- the real work is provided.----- [Note: Type of local 'go' function]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- If the local 'go' function uses an Ord class, it sometimes heap-allocates--- the Ord dictionary when the 'go' function does not have explicit type.--- In that case we give 'go' explicit type. But this slightly decrease--- performance, as the resulting 'go' function can float out to top level.----- [Note: Local 'go' functions and capturing]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- As opposed to Map, when 'go' function captures an argument, increased--- heap-allocation can occur: sometimes in a polymorphic function, the 'go'--- floats out of its enclosing function and then it heap-allocates the--- dictionary and the argument. Maybe it floats out too late and strictness--- analyzer cannot see that these could be passed on stack.------- [Note: Order of constructors]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The order of constructors of Map matters when considering performance.--- Currently in GHC 7.0, when type has 2 constructors, a forward conditional--- jump is made when successfully matching second constructor. Successful match--- of first constructor results in the forward jump not taken.--- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip--- improves the benchmark by up to 10% on x86.--module Data.Map.Internal (-    -- * Map type-      Map(..)          -- instance Eq,Show,Read-    , Size--    -- * Operators-    , (!), (!?), (\\)--    -- * Query-    , null-    , size-    , member-    , notMember-    , lookup-    , findWithDefault-    , lookupLT-    , lookupGT-    , lookupLE-    , lookupGE--    -- * Construction-    , empty-    , singleton--    -- ** Insertion-    , insert-    , insertWith-    , insertWithKey-    , insertLookupWithKey--    -- ** Delete\/Update-    , delete-    , adjust-    , adjustWithKey-    , update-    , updateWithKey-    , updateLookupWithKey-    , alter-    , alterF--    -- * Combine--    -- ** Union-    , union-    , unionWith-    , unionWithKey-    , unions-    , unionsWith--    -- ** Difference-    , difference-    , differenceWith-    , differenceWithKey--    -- ** Intersection-    , intersection-    , intersectionWith-    , intersectionWithKey--    -- ** 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--    -- * Traversal-    -- ** Map-    , map-    , mapWithKey-    , traverseWithKey-    , traverseMaybeWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , foldr-    , foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet-    , fromSet--    -- ** Lists-    , toList-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** Ordered lists-    , toAscList-    , toDescList-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList-    , fromDescList-    , fromDescListWith-    , fromDescListWithKey-    , fromDistinctDescList--    -- * Filter-    , filter-    , filterWithKey--    , takeWhileAntitone-    , dropWhileAntitone-    , spanAntitone--    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Indexed-    , lookupIndex-    , findIndex-    , elemAt-    , updateAt-    , deleteAt-    , take-    , drop-    , splitAt--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey--    -- Used by the strict version-    , AreWeStrict (..)-    , atKeyImpl-#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)-    , atKeyPlain-#endif-    , bin-    , balance-    , balanceL-    , balanceR-    , delta-    , insertMax-    , link-    , link2-    , glue-    , MaybeS(..)-    , Identity(..)--    -- Used by Map.Merge.Lazy-    , mapWhenMissing-    , mapWhenMatched-    , lmapWhenMissing-    , contramapFirstWhenMatched-    , contramapSecondWhenMatched-    , mapGentlyWhenMissing-    , mapGentlyWhenMatched-    ) where--#if MIN_VERSION_base(4,8,0)-import Data.Functor.Identity (Identity (..))-import Control.Applicative (liftA3)-#else-import Control.Applicative (Applicative(..), (<$>), liftA3)-import Data.Monoid (Monoid(..))-import Data.Traversable (Traversable(traverse))-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Functor.Classes-import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)-#endif-import Control.Applicative (Const (..))-import Control.DeepSeq (NFData(rnf))-import Data.Bits (shiftL, shiftR)-import qualified Data.Foldable as Foldable-import Data.Foldable (Foldable())-import Data.Typeable-import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop)--import qualified Data.Set.Internal as Set-import Data.Set.Internal (Set)-import Utils.Containers.Internal.PtrEquality (ptrEq)-import Utils.Containers.Internal.StrictPair-import Utils.Containers.Internal.StrictMaybe-import Utils.Containers.Internal.BitQueue-#ifdef DEFINE_ALTERF_FALLBACK-import Utils.Containers.Internal.BitUtil (wordSize)-#endif--#if __GLASGOW_HASKELL__-import GHC.Exts (build, lazy)-#if !MIN_VERSION_base(4,8,0)-import Data.Functor ((<$))-#endif-#ifdef USE_MAGIC_PROXY-import GHC.Exts (Proxy#, proxy# )-#endif-#if __GLASGOW_HASKELL__ >= 708-import qualified GHC.Exts as GHCExts-#endif-import Text.Read hiding (lift)-import Data.Data-import qualified Control.Category as Category-#endif-#if __GLASGOW_HASKELL__ >= 708-import Data.Coerce-#endif---{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}-infixl 9 !,!?,\\ ------ | /O(log n)/. Find the value at a key.--- Calls 'error' when the element can not be found.------ > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map--- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'--(!) :: Ord k => Map k a -> k -> a-(!) m k = find k m-#if __GLASGOW_HASKELL__-{-# INLINE (!) #-}-#endif---- | /O(log n)/. Find the value at a key.--- Returns 'Nothing' when the element can not be found.------ prop> fromList [(5, 'a'), (3, 'b')] !? 1 == Nothing--- prop> fromList [(5, 'a'), (3, 'b')] !? 5 == Just 'a'------ @since 0.5.9--(!?) :: Ord k => Map k a -> k -> Maybe a-(!?) m k = lookup k m-#if __GLASGOW_HASKELL__-{-# INLINE (!?) #-}-#endif---- | Same as 'difference'.-(\\) :: Ord k => Map k a -> Map k b -> Map k a-m1 \\ m2 = difference m1 m2-#if __GLASGOW_HASKELL__-{-# INLINE (\\) #-}-#endif--{---------------------------------------------------------------------  Size balanced trees.---------------------------------------------------------------------}--- | A Map from keys @k@ to values @a@.---- See Note: Order of constructors-data Map k a  = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)-              | Tip--type Size     = Int--#if __GLASGOW_HASKELL__ >= 708-type role Map nominal representational-#endif--instance (Ord k) => Monoid (Map k v) where-    mempty  = empty-    mconcat = unions-#if !(MIN_VERSION_base(4,9,0))-    mappend = union-#else-    mappend = (<>)--instance (Ord k) => Semigroup (Map k v) where-    (<>)    = union-    stimes  = stimesIdempotentMonoid-#endif--#if __GLASGOW_HASKELL__--{---------------------------------------------------------------------  A Data instance---------------------------------------------------------------------}---- This instance preserves data abstraction at the cost of inefficiency.--- We provide limited reflection services for the sake of data abstraction.--instance (Data k, Data a, Ord k) => Data (Map k a) where-  gfoldl f z m   = z fromList `f` toList m-  toConstr _     = fromListConstr-  gunfold k z c  = case constrIndex c of-    1 -> k (z fromList)-    _ -> error "gunfold"-  dataTypeOf _   = mapDataType-  dataCast2 f    = gcast2 f--fromListConstr :: Constr-fromListConstr = mkConstr mapDataType "fromList" [] Prefix--mapDataType :: DataType-mapDataType = mkDataType "Data.Map.Internal.Map" [fromListConstr]--#endif--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is the map empty?------ > Data.Map.null (empty)           == True--- > Data.Map.null (singleton 1 'a') == False--null :: Map k a -> Bool-null Tip      = True-null (Bin {}) = False-{-# INLINE null #-}---- | /O(1)/. The number of elements in the map.------ > size empty                                   == 0--- > size (singleton 1 'a')                       == 1--- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3--size :: Map k a -> Int-size Tip              = 0-size (Bin sz _ _ _ _) = sz-{-# INLINE size #-}----- | /O(log n)/. Lookup the value at a key in the map.------ The function will return the corresponding value as @('Just' value)@,--- or 'Nothing' if the key isn't in the map.------ An example of using @lookup@:------ > import Prelude hiding (lookup)--- > import Data.Map--- >--- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])--- > deptCountry = fromList([("IT","USA"), ("Sales","France")])--- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])--- >--- > employeeCurrency :: String -> Maybe String--- > employeeCurrency name = do--- >     dept <- lookup name employeeDept--- >     country <- lookup dept deptCountry--- >     lookup country countryCurrency--- >--- > main = do--- >     putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))--- >     putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))------ The output of this program:------ >   John's currency: Just "Euro"--- >   Pete's currency: Nothing-lookup :: Ord k => k -> Map k a -> Maybe a-lookup = go-  where-    go !_ Tip = Nothing-    go k (Bin _ kx x l r) = case compare k kx of-      LT -> go k l-      GT -> go k r-      EQ -> Just x-#if __GLASGOW_HASKELL__-{-# INLINABLE lookup #-}-#else-{-# INLINE lookup #-}-#endif---- | /O(log n)/. Is the key a member of the map? See also 'notMember'.------ > member 5 (fromList [(5,'a'), (3,'b')]) == True--- > member 1 (fromList [(5,'a'), (3,'b')]) == False-member :: Ord k => k -> Map k a -> Bool-member = go-  where-    go !_ Tip = False-    go k (Bin _ kx _ l r) = case compare k kx of-      LT -> go k l-      GT -> go k r-      EQ -> True-#if __GLASGOW_HASKELL__-{-# INLINABLE member #-}-#else-{-# INLINE member #-}-#endif---- | /O(log n)/. Is the key not a member of the map? See also 'member'.------ > notMember 5 (fromList [(5,'a'), (3,'b')]) == False--- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True--notMember :: Ord k => k -> Map k a -> Bool-notMember k m = not $ member k m-#if __GLASGOW_HASKELL__-{-# INLINABLE notMember #-}-#else-{-# INLINE notMember #-}-#endif---- | /O(log n)/. Find the value at a key.--- Calls 'error' when the element can not be found.-find :: Ord k => k -> Map k a -> a-find = go-  where-    go !_ Tip = error "Map.!: given key is not an element in the map"-    go k (Bin _ kx x l r) = case compare k kx of-      LT -> go k l-      GT -> go k r-      EQ -> x-#if __GLASGOW_HASKELL__-{-# INLINABLE find #-}-#else-{-# INLINE find #-}-#endif---- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns--- the value at key @k@ or returns default value @def@--- when the key is not in the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'-findWithDefault :: Ord k => a -> k -> Map k a -> a-findWithDefault = go-  where-    go def !_ Tip = def-    go def k (Bin _ kx x l r) = case compare k kx of-      LT -> go def k l-      GT -> go def k r-      EQ -> x-#if __GLASGOW_HASKELL__-{-# INLINABLE findWithDefault #-}-#else-{-# INLINE findWithDefault #-}-#endif---- | /O(log n)/. Find largest key smaller than the given one and return the--- corresponding (key, value) pair.------ > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing--- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')-lookupLT :: Ord k => k -> Map k v -> Maybe (k, v)-lookupLT = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l-                                 | otherwise = goJust k kx x r--    goJust !_ kx' x' Tip = Just (kx', x')-    goJust k kx' x' (Bin _ kx x l r) | k <= kx = goJust k kx' x' l-                                     | otherwise = goJust k kx x r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupLT #-}-#else-{-# INLINE lookupLT #-}-#endif---- | /O(log n)/. Find smallest key greater than the given one and return the--- corresponding (key, value) pair.------ > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')--- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing-lookupGT :: Ord k => k -> Map k v -> Maybe (k, v)-lookupGT = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l-                                 | otherwise = goNothing k r--    goJust !_ kx' x' Tip = Just (kx', x')-    goJust k kx' x' (Bin _ kx x l r) | k < kx = goJust k kx x l-                                     | otherwise = goJust k kx' x' r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupGT #-}-#else-{-# INLINE lookupGT #-}-#endif---- | /O(log n)/. Find largest key smaller or equal to the given one and return--- the corresponding (key, value) pair.------ > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing--- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')--- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')-lookupLE :: Ord k => k -> Map k v -> Maybe (k, v)-lookupLE = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goNothing k l-                                                        EQ -> Just (kx, x)-                                                        GT -> goJust k kx x r--    goJust !_ kx' x' Tip = Just (kx', x')-    goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx' x' l-                                                            EQ -> Just (kx, x)-                                                            GT -> goJust k kx x r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupLE #-}-#else-{-# INLINE lookupLE #-}-#endif---- | /O(log n)/. Find smallest key greater or equal to the given one and return--- the corresponding (key, value) pair.------ > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')--- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')--- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing-lookupGE :: Ord k => k -> Map k v -> Maybe (k, v)-lookupGE = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l-                                                        EQ -> Just (kx, x)-                                                        GT -> goNothing k r--    goJust !_ kx' x' Tip = Just (kx', x')-    goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l-                                                            EQ -> Just (kx, x)-                                                            GT -> goJust k kx' x' r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupGE #-}-#else-{-# INLINE lookupGE #-}-#endif--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. The empty map.------ > empty      == fromList []--- > size empty == 0--empty :: Map k a-empty = Tip-{-# INLINE empty #-}---- | /O(1)/. A map with a single element.------ > singleton 1 'a'        == fromList [(1, 'a')]--- > size (singleton 1 'a') == 1--singleton :: k -> a -> Map k a-singleton k x = Bin 1 k x Tip Tip-{-# INLINE singleton #-}--{---------------------------------------------------------------------  Insertion---------------------------------------------------------------------}--- | /O(log n)/. Insert a new key and value in the map.--- If the key is already present in the map, the associated value is--- replaced with the supplied value. 'insert' is equivalent to--- @'insertWith' 'const'@.------ > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]--- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]--- > insert 5 'x' empty                         == singleton 5 'x'---- See Note: Type of local 'go' function--- See Note: Avoiding worker/wrapper-insert :: Ord k => k -> a -> Map k a -> Map k a-insert kx0 = go kx0 kx0-  where-    -- Unlike insertR, we only get sharing here-    -- when the inserted value is at the same address-    -- as the present value. We try anyway; this condition-    -- seems particularly likely to occur in 'union'.-    go :: Ord k => k -> k -> a -> Map k a -> Map k a-    go orig !_  x Tip = singleton (lazy orig) x-    go orig !kx x t@(Bin sz ky y l r) =-        case compare kx ky of-            LT | l' `ptrEq` l -> t-               | otherwise -> balanceL ky y l' r-               where !l' = go orig kx x l-            GT | r' `ptrEq` r -> t-               | otherwise -> balanceR ky y l r'-               where !r' = go orig kx x r-            EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t-               | otherwise -> Bin sz (lazy orig) x l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insert #-}-#else-{-# INLINE insert #-}-#endif--#ifndef __GLASGOW_HASKELL__-lazy :: a -> a-lazy a = a-#endif---- [Note: Avoiding worker/wrapper]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- 'insert' has to go to great lengths to get pointer equality right and--- to prevent unnecessary allocation. The trouble is that GHC *really* wants--- to unbox the key and throw away the boxed one. This is bad for us, because--- we want to compare the pointer of the box we are given to the one already--- present if they compare EQ. It's also bad for us because it leads to the--- key being *reboxed* if it's actually stored in the map. Ugh! So we pass the--- 'go' function *two copies* of the key we're given. One of them we use for--- comparisons; the other we keep in our pocket. To prevent worker/wrapper from--- messing with the copy in our pocket, we sprinkle about calls to the magical--- function 'lazy'. This is all horrible, but it seems to work okay.----- Insert a new key and value in the map if it is not already present.--- Used by `union`.---- See Note: Type of local 'go' function--- See Note: Avoiding worker/wrapper-insertR :: Ord k => k -> a -> Map k a -> Map k a-insertR kx0 = go kx0 kx0-  where-    go :: Ord k => k -> k -> a -> Map k a -> Map k a-    go orig !_  x Tip = singleton (lazy orig) x-    go orig !kx x t@(Bin _ ky y l r) =-        case compare kx ky of-            LT | l' `ptrEq` l -> t-               | otherwise -> balanceL ky y l' r-               where !l' = go orig kx x l-            GT | r' `ptrEq` r -> t-               | otherwise -> balanceR ky y l r'-               where !r' = go orig kx x r-            EQ -> t-#if __GLASGOW_HASKELL__-{-# INLINABLE insertR #-}-#else-{-# INLINE insertR #-}-#endif---- | /O(log n)/. Insert with a function, combining new value and old value.--- @'insertWith' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key, f new_value old_value)@.------ > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"--insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWith = go-  where-    -- We have no hope of making pointer equality tricks work-    -- here, because lazy insertWith *always* changes the tree,-    -- either adding a new entry or replacing an element with a-    -- thunk.-    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-    go _ !kx x Tip = singleton kx x-    go f !kx x (Bin sy ky y l r) =-        case compare kx ky of-            LT -> balanceL ky y (go f kx x l) r-            GT -> balanceR ky y l (go f kx x r)-            EQ -> Bin sy kx (f x y) l r--#if __GLASGOW_HASKELL__-{-# INLINABLE insertWith #-}-#else-{-# INLINE insertWith #-}-#endif---- | A helper function for 'unionWith'. When the key is already in--- the map, the key is left alone, not replaced. The combining--- function is flipped--it is applied to the old value and then the--- new value.--insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithR = go-  where-    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-    go _ !kx x Tip = singleton kx x-    go f !kx x (Bin sy ky y l r) =-        case compare kx ky of-            LT -> balanceL ky y (go f kx x l) r-            GT -> balanceR ky y l (go f kx x r)-            EQ -> Bin sy ky (f y x) l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insertWithR #-}-#else-{-# INLINE insertWithR #-}-#endif---- | /O(log n)/. Insert with a function, combining key, new value and old value.--- @'insertWithKey' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key,f key new_value old_value)@.--- Note that the key passed to f is the same key passed to 'insertWithKey'.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"---- See Note: Type of local 'go' function-insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKey = go-  where-    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-    go _ !kx x Tip = singleton kx x-    go f kx x (Bin sy ky y l r) =-        case compare kx ky of-            LT -> balanceL ky y (go f kx x l) r-            GT -> balanceR ky y l (go f kx x r)-            EQ -> Bin sy kx (f kx x y) l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insertWithKey #-}-#else-{-# INLINE insertWithKey #-}-#endif---- | A helper function for 'unionWithKey'. When the key is already in--- the map, the key is left alone, not replaced. The combining--- function is flipped--it is applied to the old value and then the--- new value.-insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKeyR = go-  where-    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-    go _ !kx x Tip = singleton kx x-    go f kx x (Bin sy ky y l r) =-        case compare kx ky of-            LT -> balanceL ky y (go f kx x l) r-            GT -> balanceR ky y l (go f kx x r)-            EQ -> Bin sy ky (f ky y x) l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insertWithKeyR #-}-#else-{-# INLINE insertWithKeyR #-}-#endif---- | /O(log n)/. Combines insert operation with old value retrieval.--- The expression (@'insertLookupWithKey' f k x map@)--- is a pair where the first element is equal to (@'lookup' k map@)--- and the second element equal to (@'insertWithKey' f k x map@).------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])--- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])--- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")------ This is how to define @insertLookup@ using @insertLookupWithKey@:------ > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t--- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])--- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])---- See Note: Type of local 'go' function-insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a-                    -> (Maybe a, Map k a)-insertLookupWithKey f0 k0 x0 = toPair . go f0 k0 x0-  where-    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)-    go _ !kx x Tip = (Nothing :*: singleton kx x)-    go f kx x (Bin sy ky y l r) =-        case compare kx ky of-            LT -> let !(found :*: l') = go f kx x l-                      !t' = balanceL ky y l' r-                  in (found :*: t')-            GT -> let !(found :*: r') = go f kx x r-                      !t' = balanceR ky y l r'-                  in (found :*: t')-            EQ -> (Just y :*: Bin sy kx (f kx x y) l r)-#if __GLASGOW_HASKELL__-{-# INLINABLE insertLookupWithKey #-}-#else-{-# INLINE insertLookupWithKey #-}-#endif--{---------------------------------------------------------------------  Deletion---------------------------------------------------------------------}--- | /O(log n)/. Delete a key and its value from the map. When the key is not--- a member of the map, the original map is returned.------ > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > delete 5 empty                         == empty---- See Note: Type of local 'go' function-delete :: Ord k => k -> Map k a -> Map k a-delete = go-  where-    go :: Ord k => k -> Map k a -> Map k a-    go !_ Tip = Tip-    go k t@(Bin _ kx x l r) =-        case compare k kx of-            LT | l' `ptrEq` l -> t-               | otherwise -> balanceR kx x l' r-               where !l' = go k l-            GT | r' `ptrEq` r -> t-               | otherwise -> balanceL kx x l r'-               where !r' = go k r-            EQ -> glue l r-#if __GLASGOW_HASKELL__-{-# INLINABLE delete #-}-#else-{-# INLINE delete #-}-#endif---- | /O(log n)/. Update a value at a specific key with the result of the provided function.--- When the key is not--- a member of the map, the original map is returned.------ > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjust ("new " ++) 7 empty                         == empty--adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a-adjust f = adjustWithKey (\_ x -> f x)-#if __GLASGOW_HASKELL__-{-# INLINABLE adjust #-}-#else-{-# INLINE adjust #-}-#endif---- | /O(log n)/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > let f key x = (show key) ++ ":new " ++ x--- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjustWithKey f 7 empty                         == empty--adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a-adjustWithKey = go-  where-    go :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a-    go _ !_ Tip = Tip-    go f k (Bin sx kx x l r) =-        case compare k kx of-           LT -> Bin sx kx x (go f k l) r-           GT -> Bin sx kx x l (go f k r)-           EQ -> Bin sx kx (f kx x) l r-#if __GLASGOW_HASKELL__-{-# INLINABLE adjustWithKey #-}-#else-{-# INLINE adjustWithKey #-}-#endif---- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f x = if x == "a" then Just "new a" else Nothing--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a-update f = updateWithKey (\_ x -> f x)-#if __GLASGOW_HASKELL__-{-# INLINABLE update #-}-#else-{-# INLINE update #-}-#endif---- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the--- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound--- to the new value @y@.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"---- See Note: Type of local 'go' function-updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a-updateWithKey = go-  where-    go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a-    go _ !_ Tip = Tip-    go f k(Bin sx kx x l r) =-        case compare k kx of-           LT -> balanceR kx x (go f k l) r-           GT -> balanceL kx x l (go f k r)-           EQ -> case f kx x of-                   Just x' -> Bin sx kx x' l r-                   Nothing -> glue l r-#if __GLASGOW_HASKELL__-{-# INLINABLE updateWithKey #-}-#else-{-# INLINE updateWithKey #-}-#endif---- | /O(log n)/. Lookup and update. See also 'updateWithKey'.--- The function returns changed value, if it is updated.--- Returns the original key value if the map entry is deleted.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])--- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])--- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")---- See Note: Type of local 'go' function-updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)-updateLookupWithKey f0 k0 = toPair . go f0 k0- where-   go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)-   go _ !_ Tip = (Nothing :*: Tip)-   go f k (Bin sx kx x l r) =-          case compare k kx of-               LT -> let !(found :*: l') = go f k l-                         !t' = balanceR kx x l' r-                     in (found :*: t')-               GT -> let !(found :*: r') = go f k r-                         !t' = balanceL kx x l r'-                     in (found :*: t')-               EQ -> case f kx x of-                       Just x' -> (Just x' :*: Bin sx kx x' l r)-                       Nothing -> let !glued = glue l r-                                  in (Just x :*: glued)-#if __GLASGOW_HASKELL__-{-# INLINABLE updateLookupWithKey #-}-#else-{-# INLINE updateLookupWithKey #-}-#endif---- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.--- 'alter' can be used to insert, delete, or update a value in a 'Map'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.------ > let f _ = Nothing--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- >--- > let f _ = Just "c"--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]---- See Note: Type of local 'go' function-alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a-alter = go-  where-    go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a-    go f !k Tip = case f Nothing of-               Nothing -> Tip-               Just x  -> singleton k x--    go f k (Bin sx kx x l r) = case compare k kx of-               LT -> balance kx x (go f k l) r-               GT -> balance kx x l (go f k r)-               EQ -> case f (Just x) of-                       Just x' -> Bin sx kx x' l r-                       Nothing -> glue l r-#if __GLASGOW_HASKELL__-{-# INLINABLE alter #-}-#else-{-# INLINE alter #-}-#endif---- Used to choose the appropriate alterF implementation.-data AreWeStrict = Strict | Lazy---- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at--- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,--- or update a value in a 'Map'.  In short: @'lookup' k \<$\> 'alterF' f k m = f--- ('lookup' k m)@.------ Example:------ @--- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)--- interactiveAlter k m = alterF f k m where---   f Nothing -> do---      putStrLn $ show k ++---          " was not found in the map. Would you like to add it?"---      getUserResponse1 :: IO (Maybe String)---   f (Just old) -> do---      putStrLn "The key is currently bound to " ++ show old ++---          ". Would you like to change or delete it?"---      getUserresponse2 :: IO (Maybe String)--- @------ 'alterF' is the most general operation for working with an individual--- key that may or may not be in a given map. When used with trivial--- functors like 'Identity' and 'Const', it is often slightly slower than--- more specialized combinators like 'lookup' and 'insert'. However, when--- the functor is non-trivial and key comparison is not particularly cheap,--- it is the fastest way.------ Note on rewrite rules:------ This module includes GHC rewrite rules to optimize 'alterF' for--- the 'Const' and 'Identity' functors. In general, these rules--- improve performance. The sole exception is that when using--- 'Identity', deleting a key that is already absent takes longer--- than it would without the rules. If you expect this to occur--- a very large fraction of the time, you might consider using a--- private copy of the 'Identity' type.------ Note: 'alterF' is a flipped version of the 'at' combinator from--- 'Control.Lens.At'.------ @since 0.5.8-alterF :: (Functor f, Ord k)-       => (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)-alterF f k m = atKeyImpl Lazy k f m--#ifndef __GLASGOW_HASKELL__-{-# INLINE alterF #-}-#else-{-# INLINABLE [2] alterF #-}---- We can save a little time by recognizing the special case of--- `Control.Applicative.Const` and just doing a lookup.-{-# RULES-"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m- #-}--#if MIN_VERSION_base(4,8,0)--- base 4.8 and above include Data.Functor.Identity, so we can--- save a pretty decent amount of time by handling it specially.-{-# RULES-"alterF/Identity" forall k f . alterF f k = atKeyIdentity k f- #-}-#endif-#endif--atKeyImpl :: (Functor f, Ord k) =>-      AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)-#ifdef DEFINE_ALTERF_FALLBACK-atKeyImpl strict !k f m--- It doesn't seem sensible to worry about overflowing the queue--- if the word size is 61 or more. If I calculate it correctly,--- that would take a map with nearly a quadrillion entries.-  | wordSize < 61 && size m >= alterFCutoff = alterFFallback strict k f m-#endif-atKeyImpl strict !k f m = case lookupTrace k m of-  TraceResult mv q -> (<$> f mv) $ \ fres ->-    case fres of-      Nothing -> case mv of-                   Nothing -> m-                   Just old -> deleteAlong old q m-      Just new -> case strict of-         Strict -> new `seq` case mv of-                      Nothing -> insertAlong q k new m-                      Just _ -> replaceAlong q new m-         Lazy -> case mv of-                      Nothing -> insertAlong q k new m-                      Just _ -> replaceAlong q new m--{-# INLINE atKeyImpl #-}--#ifdef DEFINE_ALTERF_FALLBACK-alterFCutoff :: Int-#if WORD_SIZE_IN_BITS == 32-alterFCutoff = 55744454-#else-alterFCutoff = case wordSize of-      30 -> 17637893-      31 -> 31356255-      32 -> 55744454-      x -> (4^(x*2-2)) `quot` (3^(x*2-2))  -- Unlikely-#endif-#endif--data TraceResult a = TraceResult (Maybe a) {-# UNPACK #-} !BitQueue---- Look up a key and return a result indicating whether it was found--- and what path was taken.-lookupTrace :: Ord k => k -> Map k a -> TraceResult a-lookupTrace = go emptyQB-  where-    go :: Ord k => BitQueueB -> k -> Map k a -> TraceResult a-    go !q !_ Tip = TraceResult Nothing (buildQ q)-    go q k (Bin _ kx x l r) = case compare k kx of-      LT -> (go $! q `snocQB` False) k l-      GT -> (go $! q `snocQB` True) k r-      EQ -> TraceResult (Just x) (buildQ q)---- GHC 7.8 doesn't manage to unbox the queue properly--- unless we explicitly inline this function. This stuff--- is a bit touchy, unfortunately.-#if __GLASGOW_HASKELL__ >= 710-{-# INLINABLE lookupTrace #-}-#else-{-# INLINE lookupTrace #-}-#endif---- Insert at a location (which will always be a leaf)--- described by the path passed in.-insertAlong :: BitQueue -> k -> a -> Map k a -> Map k a-insertAlong !_ kx x Tip = singleton kx x-insertAlong q kx x (Bin sz ky y l r) =-  case unconsQ q of-        Just (False, tl) -> balanceL ky y (insertAlong tl kx x l) r-        Just (True,tl) -> balanceR ky y l (insertAlong tl kx x r)-        Nothing -> Bin sz kx x l r  -- Shouldn't happen---- Delete from a location (which will always be a node)--- described by the path passed in.------ This is fairly horrifying! We don't actually have any--- use for the old value we're deleting. But if GHC sees--- that, then it will allocate a thunk representing the--- Map with the key deleted before we have any reason to--- believe we'll actually want that. This transformation--- enhances sharing, but we don't care enough about that.--- So deleteAlong needs to take the old value, and we need--- to convince GHC somehow that it actually uses it. We--- can't NOINLINE deleteAlong, because that would prevent--- the BitQueue from being unboxed. So instead we pass the--- old value to a NOINLINE constant function and then--- convince GHC that we use the result throughout the--- computation. Doing the obvious thing and just passing--- the value itself through the recursion costs 3-4% time,--- so instead we convert the value to a magical zero-width--- proxy that's ultimately erased.-deleteAlong :: any -> BitQueue -> Map k a -> Map k a-deleteAlong old !q0 !m = go (bogus old) q0 m where-#ifdef USE_MAGIC_PROXY-  go :: Proxy# () -> BitQueue -> Map k a -> Map k a-#else-  go :: any -> BitQueue -> Map k a -> Map k a-#endif-  go !_ !_ Tip = Tip-  go foom q (Bin _ ky y l r) =-      case unconsQ q of-        Just (False, tl) -> balanceR ky y (go foom tl l) r-        Just (True, tl) -> balanceL ky y l (go foom tl r)-        Nothing -> glue l r--#ifdef USE_MAGIC_PROXY-{-# NOINLINE bogus #-}-bogus :: a -> Proxy# ()-bogus _ = proxy#-#else--- No point hiding in this case.-{-# INLINE bogus #-}-bogus :: a -> a-bogus a = a-#endif---- Replace the value found in the node described--- by the given path with a new one.-replaceAlong :: BitQueue -> a -> Map k a -> Map k a-replaceAlong !_ _ Tip = Tip -- Should not happen-replaceAlong q  x (Bin sz ky y l r) =-      case unconsQ q of-        Just (False, tl) -> Bin sz ky y (replaceAlong tl x l) r-        Just (True,tl) -> Bin sz ky y l (replaceAlong tl x r)-        Nothing -> Bin sz ky x l r--#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)-atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)-atKeyIdentity k f t = Identity $ atKeyPlain Lazy k (coerce f) t-{-# INLINABLE atKeyIdentity #-}--atKeyPlain :: Ord k => AreWeStrict -> k -> (Maybe a -> Maybe a) -> Map k a -> Map k a-atKeyPlain strict k0 f0 t = case go k0 f0 t of-    AltSmaller t' -> t'-    AltBigger t' -> t'-    AltAdj t' -> t'-    AltSame -> t-  where-    go :: Ord k => k -> (Maybe a -> Maybe a) -> Map k a -> Altered k a-    go !k f Tip = case f Nothing of-                   Nothing -> AltSame-                   Just x  -> case strict of-                     Lazy -> AltBigger $ singleton k x-                     Strict -> x `seq` (AltBigger $ singleton k x)--    go k f (Bin sx kx x l r) = case compare k kx of-                   LT -> case go k f l of-                           AltSmaller l' -> AltSmaller $ balanceR kx x l' r-                           AltBigger l' -> AltBigger $ balanceL kx x l' r-                           AltAdj l' -> AltAdj $ Bin sx kx x l' r-                           AltSame -> AltSame-                   GT -> case go k f r of-                           AltSmaller r' -> AltSmaller $ balanceL kx x l r'-                           AltBigger r' -> AltBigger $ balanceR kx x l r'-                           AltAdj r' -> AltAdj $ Bin sx kx x l r'-                           AltSame -> AltSame-                   EQ -> case f (Just x) of-                           Just x' -> case strict of-                             Lazy -> AltAdj $ Bin sx kx x' l r-                             Strict -> x' `seq` (AltAdj $ Bin sx kx x' l r)-                           Nothing -> AltSmaller $ glue l r-{-# INLINE atKeyPlain #-}--data Altered k a = AltSmaller !(Map k a) | AltBigger !(Map k a) | AltAdj !(Map k a) | AltSame-#endif--#ifdef DEFINE_ALTERF_FALLBACK--- When the map is too large to use a bit queue, we fall back to--- this much slower version which uses a more "natural" implementation--- improved with Yoneda to avoid repeated fmaps. This works okayish for--- some operations, but it's pretty lousy for lookups.-alterFFallback :: (Functor f, Ord k)-   => AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)-alterFFallback Lazy k f t = alterFYoneda k (\m q -> q <$> f m) t id-alterFFallback Strict k f t = alterFYoneda k (\m q -> q . forceMaybe <$> f m) t id-  where-    forceMaybe Nothing = Nothing-    forceMaybe may@(Just !_) = may-{-# NOINLINE alterFFallback #-}--alterFYoneda :: Ord k =>-      k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b-alterFYoneda = go-  where-    go :: Ord k =>-      k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b-    go !k f Tip g = f Nothing $ \ mx -> case mx of-      Nothing -> g Tip-      Just x -> g (singleton k x)-    go k f (Bin sx kx x l r) g = case compare k kx of-               LT -> go k f l (\m -> g (balance kx x m r))-               GT -> go k f r (\m -> g (balance kx x l m))-               EQ -> f (Just x) $ \ mx' -> case mx' of-                       Just x' -> g (Bin sx kx x' l r)-                       Nothing -> g (glue l r)-{-# INLINE alterFYoneda #-}-#endif--{---------------------------------------------------------------------  Indexing---------------------------------------------------------------------}--- | /O(log n)/. Return the /index/ of a key, which is its zero-based index in--- the sequence sorted by keys. The index is a number from /0/ up to, but not--- including, the 'size' of the map. Calls 'error' when the key is not--- a 'member' of the map.------ > findIndex 2 (fromList [(5,"a"), (3,"b")])    Error: element is not in the map--- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0--- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1--- > findIndex 6 (fromList [(5,"a"), (3,"b")])    Error: element is not in the map---- See Note: Type of local 'go' function-findIndex :: Ord k => k -> Map k a -> Int-findIndex = go 0-  where-    go :: Ord k => Int -> k -> Map k a -> Int-    go !_   !_ Tip  = error "Map.findIndex: element is not in the map"-    go idx k (Bin _ kx _ l r) = case compare k kx of-      LT -> go idx k l-      GT -> go (idx + size l + 1) k r-      EQ -> idx + size l-#if __GLASGOW_HASKELL__-{-# INLINABLE findIndex #-}-#endif---- | /O(log n)/. Lookup the /index/ of a key, which is its zero-based index in--- the sequence sorted by keys. The index is a number from /0/ up to, but not--- including, the 'size' of the map.------ > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")]))   == False--- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0--- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1--- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")]))   == False---- See Note: Type of local 'go' function-lookupIndex :: Ord k => k -> Map k a -> Maybe Int-lookupIndex = go 0-  where-    go :: Ord k => Int -> k -> Map k a -> Maybe Int-    go !_  !_ Tip  = Nothing-    go idx k (Bin _ kx _ l r) = case compare k kx of-      LT -> go idx k l-      GT -> go (idx + size l + 1) k r-      EQ -> Just $! idx + size l-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupIndex #-}-#endif---- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based--- index in the sequence sorted by keys. If the /index/ is out of range (less--- than zero, greater or equal to 'size' of the map), 'error' is called.------ > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")--- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")--- > elemAt 2 (fromList [(5,"a"), (3,"b")])    Error: index out of range--elemAt :: Int -> Map k a -> (k,a)-elemAt !_ Tip = error "Map.elemAt: index out of range"-elemAt i (Bin _ kx x l r)-  = case compare i sizeL of-      LT -> elemAt i l-      GT -> elemAt (i-sizeL-1) r-      EQ -> (kx,x)-  where-    sizeL = size l---- | Take a given number of entries in key order, beginning--- with the smallest keys.------ @--- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'--- @------ @since 0.5.8--take :: Int -> Map k a -> Map k a-take i m | i >= size m = m-take i0 m0 = go i0 m0-  where-    go i !_ | i <= 0 = Tip-    go !_ Tip = Tip-    go i (Bin _ kx x l r) =-      case compare i sizeL of-        LT -> go i l-        GT -> link kx x l (go (i - sizeL - 1) r)-        EQ -> l-      where sizeL = size l---- | Drop a given number of entries in key order, beginning--- with the smallest keys.------ @--- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'--- @------ @since 0.5.8-drop :: Int -> Map k a -> Map k a-drop i m | i >= size m = Tip-drop i0 m0 = go i0 m0-  where-    go i m | i <= 0 = m-    go !_ Tip = Tip-    go i (Bin _ kx x l r) =-      case compare i sizeL of-        LT -> link kx x (go i l) r-        GT -> go (i - sizeL - 1) r-        EQ -> insertMin kx x r-      where sizeL = size l---- | /O(log n)/. Split a map at a particular index.------ @--- splitAt !n !xs = ('take' n xs, 'drop' n xs)--- @------ @since 0.5.8-splitAt :: Int -> Map k a -> (Map k a, Map k a)-splitAt i0 m0-  | i0 >= size m0 = (m0, Tip)-  | otherwise = toPair $ go i0 m0-  where-    go i m | i <= 0 = Tip :*: m-    go !_ Tip = Tip :*: Tip-    go i (Bin _ kx x l r)-      = case compare i sizeL of-          LT -> case go i l of-                  ll :*: lr -> ll :*: link kx x lr r-          GT -> case go (i - sizeL - 1) r of-                  rl :*: rr -> link kx x l rl :*: rr-          EQ -> l :*: insertMin kx x r-      where sizeL = size l---- | /O(log n)/. Update the element at /index/, i.e. by its zero-based index in--- the sequence sorted by keys. If the /index/ is out of range (less than zero,--- greater or equal to 'size' of the map), 'error' is called.------ > updateAt (\ _ _ -> Just "x") 0    (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]--- > updateAt (\ _ _ -> Just "x") 1    (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]--- > updateAt (\ _ _ -> Just "x") 2    (fromList [(5,"a"), (3,"b")])    Error: index out of range--- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range--- > updateAt (\_ _  -> Nothing)  0    (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--- > updateAt (\_ _  -> Nothing)  1    (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > updateAt (\_ _  -> Nothing)  2    (fromList [(5,"a"), (3,"b")])    Error: index out of range--- > updateAt (\_ _  -> Nothing)  (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range--updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a-updateAt f !i t =-  case t of-    Tip -> error "Map.updateAt: index out of range"-    Bin sx kx x l r -> case compare i sizeL of-      LT -> balanceR kx x (updateAt f i l) r-      GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)-      EQ -> case f kx x of-              Just x' -> Bin sx kx x' l r-              Nothing -> glue l r-      where-        sizeL = size l---- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in--- the sequence sorted by keys. If the /index/ is out of range (less than zero,--- greater or equal to 'size' of the map), 'error' is called.------ > deleteAt 0  (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--- > deleteAt 1  (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > deleteAt 2 (fromList [(5,"a"), (3,"b")])     Error: index out of range--- > deleteAt (-1) (fromList [(5,"a"), (3,"b")])  Error: index out of range--deleteAt :: Int -> Map k a -> Map k a-deleteAt !i t =-  case t of-    Tip -> error "Map.deleteAt: index out of range"-    Bin _ kx x l r -> case compare i sizeL of-      LT -> balanceR kx x (deleteAt i l) r-      GT -> balanceL kx x l (deleteAt (i-sizeL-1) r)-      EQ -> glue l r-      where-        sizeL = size l---{---------------------------------------------------------------------  Minimal, Maximal---------------------------------------------------------------------}--lookupMinSure :: k -> a -> Map k a -> (k, a)-lookupMinSure k a Tip = (k, a)-lookupMinSure _ _ (Bin _ k a l _) = lookupMinSure k a l---- | /O(log n)/. The minimal key of the map. Returns 'Nothing' if the map is empty.------ > lookupMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b")--- > findMin empty = Nothing------ @since 0.5.9--lookupMin :: Map k a -> Maybe (k,a)-lookupMin Tip = Nothing-lookupMin (Bin _ k x l _) = Just $! lookupMinSure k x l---- | /O(log n)/. The minimal key of the map. Calls 'error' if the map is empty.------ > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")--- > findMin empty                            Error: empty map has no minimal element--findMin :: Map k a -> (k,a)-findMin t-  | Just r <- lookupMin t = r-  | otherwise = error "Map.findMin: empty map has no minimal element"---- | /O(log n)/. The maximal key of the map. Calls 'error' if the map is empty.------ > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")--- > findMax empty                            Error: empty map has no maximal element--lookupMaxSure :: k -> a -> Map k a -> (k, a)-lookupMaxSure k a Tip = (k, a)-lookupMaxSure _ _ (Bin _ k a _ r) = lookupMaxSure k a r---- | /O(log n)/. The maximal key of the map. Returns 'Nothing' if the map is empty.------ > lookupMax (fromList [(5,"a"), (3,"b")]) == Just (5,"a")--- > lookupMax empty = Nothing------ @since 0.5.9--lookupMax :: Map k a -> Maybe (k, a)-lookupMax Tip = Nothing-lookupMax (Bin _ k x _ r) = Just $! lookupMaxSure k x r--findMax :: Map k a -> (k,a)-findMax t-  | Just r <- lookupMax t = r-  | otherwise = error "Map.findMax: empty map has no maximal element"---- | /O(log n)/. Delete the minimal key. Returns an empty map if the map is empty.------ > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]--- > deleteMin empty == empty--deleteMin :: Map k a -> Map k a-deleteMin (Bin _ _  _ Tip r)  = r-deleteMin (Bin _ kx x l r)    = balanceR kx x (deleteMin l) r-deleteMin Tip                 = Tip---- | /O(log n)/. Delete the maximal key. Returns an empty map if the map is empty.------ > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]--- > deleteMax empty == empty--deleteMax :: Map k a -> Map k a-deleteMax (Bin _ _  _ l Tip)  = l-deleteMax (Bin _ kx x l r)    = balanceL kx x l (deleteMax r)-deleteMax Tip                 = Tip---- | /O(log n)/. Update the value at the minimal key.------ > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]--- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMin :: (a -> Maybe a) -> Map k a -> Map k a-updateMin f m-  = updateMinWithKey (\_ x -> f x) m---- | /O(log n)/. Update the value at the maximal key.------ > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]--- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMax :: (a -> Maybe a) -> Map k a -> Map k a-updateMax f m-  = updateMaxWithKey (\_ x -> f x) m----- | /O(log n)/. Update the value at the minimal key.------ > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]--- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-updateMinWithKey _ Tip                 = Tip-updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of-                                           Nothing -> r-                                           Just x' -> Bin sx kx x' Tip r-updateMinWithKey f (Bin _ kx x l r)    = balanceR kx x (updateMinWithKey f l) r---- | /O(log n)/. Update the value at the maximal key.------ > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]--- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-updateMaxWithKey _ Tip                 = Tip-updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of-                                           Nothing -> l-                                           Just x' -> Bin sx kx x' l Tip-updateMaxWithKey f (Bin _ kx x l r)    = balanceL kx x l (updateMaxWithKey f r)---- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")--- > minViewWithKey empty == Nothing--minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)-minViewWithKey Tip = Nothing-minViewWithKey (Bin _ k x l r) = Just $-  case minViewSure k x l r of-    MinView km xm t -> ((km, xm), t)--- We inline this to give GHC the best possible chance of getting--- rid of the Maybe and pair constructors, as well as the thunk under--- the Just.-{-# INLINE minViewWithKey #-}---- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and--- the map stripped of that element, or 'Nothing' if passed an empty map.------ > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")--- > maxViewWithKey empty == Nothing--maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)-maxViewWithKey Tip = Nothing-maxViewWithKey (Bin _ k x l r) = Just $-  case maxViewSure k x l r of-    MaxView km xm t -> ((km, xm), t)--- See note on inlining at minViewWithKey-{-# INLINE maxViewWithKey #-}---- | /O(log n)/. Retrieves the value associated with minimal key of the--- map, and the map stripped of that element, or 'Nothing' if passed an--- empty map.------ > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")--- > minView empty == Nothing--minView :: Map k a -> Maybe (a, Map k a)-minView t = case minViewWithKey t of-              Nothing -> Nothing-              Just ~((_, x), t') -> Just (x, t')---- | /O(log n)/. Retrieves the value associated with maximal key of the--- map, and the map stripped of that element, or 'Nothing' if passed an--- empty map.------ > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")--- > maxView empty == Nothing--maxView :: Map k a -> Maybe (a, Map k a)-maxView t = case maxViewWithKey t of-              Nothing -> Nothing-              Just ~((_, x), t') -> Just (x, t')--{---------------------------------------------------------------------  Union.---------------------------------------------------------------------}--- | The union of a list of maps:---   (@'unions' == 'Prelude.foldl' 'union' 'empty'@).------ > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- >     == fromList [(3, "b"), (5, "a"), (7, "C")]--- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]--- >     == fromList [(3, "B3"), (5, "A3"), (7, "C")]--unions :: (Foldable f, Ord k) => f (Map k a) -> Map k a-unions ts-  = Foldable.foldl' union empty ts-#if __GLASGOW_HASKELL__-{-# INLINABLE unions #-}-#endif---- | The union of a list of maps, with a combining operation:---   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).------ > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]--unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a-unionsWith f ts-  = Foldable.foldl' (unionWith f) empty ts-#if __GLASGOW_HASKELL__-{-# INLINABLE unionsWith #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/.--- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.--- It prefers @t1@ when duplicate keys are encountered,--- i.e. (@'union' == 'unionWith' 'const'@).------ > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]--union :: Ord k => Map k a -> Map k a -> Map k a-union t1 Tip  = t1-union t1 (Bin _ k x Tip Tip) = insertR k x t1-union (Bin _ k x Tip Tip) t2 = insert k x t2-union Tip t2 = t2-union t1@(Bin _ k1 x1 l1 r1) t2 = case split k1 t2 of-  (l2, r2) | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1-           | otherwise -> link k1 x1 l1l2 r1r2-           where !l1l2 = union l1 l2-                 !r1r2 = union r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE union #-}-#endif--{---------------------------------------------------------------------  Union with a combining function---------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function.------ > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]--unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a--- QuickCheck says pointer equality never happens here.-unionWith _f t1 Tip = t1-unionWith f t1 (Bin _ k x Tip Tip) = insertWithR f k x t1-unionWith f (Bin _ k x Tip Tip) t2 = insertWith f k x t2-unionWith _f Tip t2 = t2-unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of-  (l2, mb, r2) -> case mb of-      Nothing -> link k1 x1 l1l2 r1r2-      Just x2 -> link k1 (f x1 x2) l1l2 r1r2-    where !l1l2 = unionWith f l1 l2-          !r1r2 = unionWith f r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE unionWith #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/.--- Union with a combining function.------ > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]--unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a-unionWithKey _f t1 Tip = t1-unionWithKey f t1 (Bin _ k x Tip Tip) = insertWithKeyR f k x t1-unionWithKey f (Bin _ k x Tip Tip) t2 = insertWithKey f k x t2-unionWithKey _f Tip t2 = t2-unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of-  (l2, mb, r2) -> case mb of-      Nothing -> link k1 x1 l1l2 r1r2-      Just x2 -> link k1 (f k1 x1 x2) l1l2 r1r2-    where !l1l2 = unionWithKey f l1 l2-          !r1r2 = unionWithKey f r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE unionWithKey #-}-#endif--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}---- We don't currently attempt to use any pointer equality tricks for--- 'difference'. To do so, we'd have to match on the first argument--- and split the second. Unfortunately, the proof of the time bound--- relies on doing it the way we do, and it's not clear whether that--- bound holds the other way.---- | /O(m*log(n\/m + 1)), m <= n/. Difference of two maps.--- Return elements of the first map not existing in the second map.------ > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"--difference :: Ord k => Map k a -> Map k b -> Map k a-difference Tip _   = Tip-difference t1 Tip  = t1-difference t1 (Bin _ k _ l2 r2) = case split k t1 of-  (l1, r1)-    | size l1l2 + size r1r2 == size t1 -> t1-    | otherwise -> link2 l1l2 r1r2-    where-      !l1l2 = difference l1 l2-      !r1r2 = difference r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE difference #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Remove all keys in a 'Set' from a 'Map'.------ @--- m \`withoutKeys\` s = 'filterWithKey' (\k _ -> k ``Set.notMember`` s) m--- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s--- @------ @since 0.5.8--withoutKeys :: Ord k => Map k a -> Set k -> Map k a-withoutKeys Tip _ = Tip-withoutKeys m Set.Tip = m-withoutKeys m (Set.Bin _ k ls rs) = case splitMember k m of-  (lm, b, rm)-     | not b && lm' `ptrEq` lm && rm' `ptrEq` rm -> m-     | otherwise -> link2 lm' rm'-     where-       !lm' = withoutKeys lm ls-       !rm' = withoutKeys rm rs-#if __GLASGOW_HASKELL__-{-# INLINABLE withoutKeys #-}-#endif---- | /O(n+m)/. Difference with a combining function.--- When two equal keys are--- encountered, the combining function is applied to the values of these keys.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@.------ > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing--- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])--- >     == singleton 3 "b:B"-differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a-differenceWith f = merge preserveMissing dropMissing $-       zipWithMaybeMatched (\_ x y -> f x y)-#if __GLASGOW_HASKELL__-{-# INLINABLE differenceWith #-}-#endif---- | /O(n+m)/. Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@.------ > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing--- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])--- >     == singleton 3 "3:b|B"--differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a-differenceWithKey f =-  merge preserveMissing dropMissing (zipWithMaybeMatched f)-#if __GLASGOW_HASKELL__-{-# INLINABLE differenceWithKey #-}-#endif---{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. Intersection of two maps.--- Return data in the first map for the keys existing in both maps.--- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).------ > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"--intersection :: Ord k => Map k a -> Map k b -> Map k a-intersection Tip _ = Tip-intersection _ Tip = Tip-intersection t1@(Bin _ k x l1 r1) t2-  | mb = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1-         then t1-         else link k x l1l2 r1r2-  | otherwise = link2 l1l2 r1r2-  where-    !(l2, mb, r2) = splitMember k t2-    !l1l2 = intersection l1 l2-    !r1r2 = intersection r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE intersection #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Restrict a 'Map' to only those keys--- found in a 'Set'.------ @--- m \`restrictKeys\` s = 'filterWithKey' (\k _ -> k ``Set.member`` s) m--- m \`restrictKeys\` s = m ``intersect`` 'fromSet' (const ()) s--- @------ @since 0.5.8-restrictKeys :: Ord k => Map k a -> Set k -> Map k a-restrictKeys Tip _ = Tip-restrictKeys _ Set.Tip = Tip-restrictKeys m@(Bin _ k x l1 r1) s-  | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1-        then m-        else link k x l1l2 r1r2-  | otherwise = link2 l1l2 r1r2-  where-    !(l2, b, r2) = Set.splitMember k s-    !l1l2 = restrictKeys l1 l2-    !r1r2 = restrictKeys r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE restrictKeys #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.------ > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"--intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c--- We have no hope of pointer equality tricks here because every single--- element in the result will be a thunk.-intersectionWith _f Tip _ = Tip-intersectionWith _f _ Tip = Tip-intersectionWith f (Bin _ k x1 l1 r1) t2 = case mb of-    Just x2 -> link k (f x1 x2) l1l2 r1r2-    Nothing -> link2 l1l2 r1r2-  where-    !(l2, mb, r2) = splitLookup k t2-    !l1l2 = intersectionWith f l1 l2-    !r1r2 = intersectionWith f r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE intersectionWith #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.------ > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar--- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"--intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c-intersectionWithKey _f Tip _ = Tip-intersectionWithKey _f _ Tip = Tip-intersectionWithKey f (Bin _ k x1 l1 r1) t2 = case mb of-    Just x2 -> link k (f k x1 x2) l1l2 r1r2-    Nothing -> link2 l1l2 r1r2-  where-    !(l2, mb, r2) = splitLookup k t2-    !l1l2 = intersectionWithKey f l1 l2-    !r1r2 = intersectionWithKey f r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE intersectionWithKey #-}-#endif--#if !MIN_VERSION_base (4,8,0)--- | The identity type.-newtype Identity a = Identity { runIdentity :: a }-#if __GLASGOW_HASKELL__ == 708-instance Functor Identity where-  fmap = coerce-instance Applicative Identity where-  (<*>) = coerce-  pure = Identity-#else-instance Functor Identity where-  fmap f (Identity a) = Identity (f a)-instance Applicative Identity where-  Identity f <*> Identity x = Identity (f x)-  pure = Identity-#endif-#endif---- | A tactic for dealing with keys present in one map but not the other in--- 'merge' or 'mergeA'.------ A tactic of type @ WhenMissing f k x z @ is an abstract representation--- of a function of type @ k -> x -> f (Maybe z) @.------ @since 0.5.9--data WhenMissing f k x y = WhenMissing-  { missingSubtree :: Map k x -> f (Map k y)-  , missingKey :: k -> x -> f (Maybe y)}---- | @since 0.5.9-instance (Applicative f, Monad f) => Functor (WhenMissing f k x) where-  fmap = mapWhenMissing-  {-# INLINE fmap #-}---- | @since 0.5.9-instance (Applicative f, Monad f)-         => Category.Category (WhenMissing f k) where-  id = preserveMissing-  f . g = traverseMaybeMissing $-    \ k x -> missingKey g k x >>= \y ->-         case y of-           Nothing -> pure Nothing-           Just q -> missingKey f k q-  {-# INLINE id #-}-  {-# INLINE (.) #-}---- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.------ @since 0.5.9-instance (Applicative f, Monad f) => Applicative (WhenMissing f k x) where-  pure x = mapMissing (\ _ _ -> x)-  f <*> g = traverseMaybeMissing $ \k x -> do-         res1 <- missingKey f k x-         case res1 of-           Nothing -> pure Nothing-           Just r -> (pure $!) . fmap r =<< missingKey g k x-  {-# INLINE pure #-}-  {-# INLINE (<*>) #-}---- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.------ @since 0.5.9-instance (Applicative f, Monad f) => Monad (WhenMissing f k x) where-#if !MIN_VERSION_base(4,8,0)-  return = pure-#endif-  m >>= f = traverseMaybeMissing $ \k x -> do-         res1 <- missingKey m k x-         case res1 of-           Nothing -> pure Nothing-           Just r -> missingKey (f r) k x-  {-# INLINE (>>=) #-}---- | Map covariantly over a @'WhenMissing' f k x@.------ @since 0.5.9-mapWhenMissing :: (Applicative f, Monad f)-               => (a -> b)-               -> WhenMissing f k x a -> WhenMissing f k x b-mapWhenMissing f t = WhenMissing-    { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'-    , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }-{-# INLINE mapWhenMissing #-}---- | Map covariantly over a @'WhenMissing' f k x@, using only a 'Functor f'--- constraint.-mapGentlyWhenMissing :: Functor f-               => (a -> b)-               -> WhenMissing f k x a -> WhenMissing f k x b-mapGentlyWhenMissing f t = WhenMissing-    { missingSubtree = \m -> fmap f <$> missingSubtree t m-    , missingKey = \k x -> fmap f <$> missingKey t k x }-{-# INLINE mapGentlyWhenMissing #-}---- | Map covariantly over a @'WhenMatched' f k x@, using only a 'Functor f'--- constraint.-mapGentlyWhenMatched :: Functor f-               => (a -> b)-               -> WhenMatched f k x y a -> WhenMatched f k x y b-mapGentlyWhenMatched f t = zipWithMaybeAMatched $-  \k x y -> fmap f <$> runWhenMatched t k x y-{-# INLINE mapGentlyWhenMatched #-}---- | Map contravariantly over a @'WhenMissing' f k _ x@.------ @since 0.5.9-lmapWhenMissing :: (b -> a) -> WhenMissing f k a x -> WhenMissing f k b x-lmapWhenMissing f t = WhenMissing-  { missingSubtree = \m -> missingSubtree t (fmap f m)-  , missingKey = \k x -> missingKey t k (f x) }-{-# INLINE lmapWhenMissing #-}---- | Map contravariantly over a @'WhenMatched' f k _ y z@.------ @since 0.5.9-contramapFirstWhenMatched :: (b -> a)-                          -> WhenMatched f k a y z-                          -> WhenMatched f k b y z-contramapFirstWhenMatched f t = WhenMatched $-  \k x y -> runWhenMatched t k (f x) y-{-# INLINE contramapFirstWhenMatched #-}---- | Map contravariantly over a @'WhenMatched' f k x _ z@.------ @since 0.5.9-contramapSecondWhenMatched :: (b -> a)-                           -> WhenMatched f k x a z-                           -> WhenMatched f k x b z-contramapSecondWhenMatched f t = WhenMatched $-  \k x y -> runWhenMatched t k x (f y)-{-# INLINE contramapSecondWhenMatched #-}---- | A tactic for dealing with keys present in one map but not the other in--- 'merge'.------ A tactic of type @ SimpleWhenMissing k x z @ is an abstract representation--- of a function of type @ k -> x -> Maybe z @.------ @since 0.5.9-type SimpleWhenMissing = WhenMissing Identity---- | A tactic for dealing with keys present in both--- maps in 'merge' or 'mergeA'.------ A tactic of type @ WhenMatched f k x y z @ is an abstract representation--- of a function of type @ k -> x -> y -> f (Maybe z) @.------ @since 0.5.9-newtype WhenMatched f k x y z = WhenMatched-  { matchedKey :: k -> x -> y -> f (Maybe z) }---- | Along with zipWithMaybeAMatched, witnesses the isomorphism between--- @WhenMatched f k x y z@ and @k -> x -> y -> f (Maybe z)@.------ @since 0.5.9-runWhenMatched :: WhenMatched f k x y z -> k -> x -> y -> f (Maybe z)-runWhenMatched = matchedKey-{-# INLINE runWhenMatched #-}---- | Along with traverseMaybeMissing, witnesses the isomorphism between--- @WhenMissing f k x y@ and @k -> x -> f (Maybe y)@.------ @since 0.5.9-runWhenMissing :: WhenMissing f k x y -> k -> x -> f (Maybe y)-runWhenMissing = missingKey-{-# INLINE runWhenMissing #-}---- | @since 0.5.9-instance Functor f => Functor (WhenMatched f k x y) where-  fmap = mapWhenMatched-  {-# INLINE fmap #-}---- | @since 0.5.9-instance (Monad f, Applicative f) => Category.Category (WhenMatched f k x) where-  id = zipWithMatched (\_ _ y -> y)-  f . g = zipWithMaybeAMatched $-            \k x y -> do-              res <- runWhenMatched g k x y-              case res of-                Nothing -> pure Nothing-                Just r -> runWhenMatched f k x r-  {-# INLINE id #-}-  {-# INLINE (.) #-}---- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @------ @since 0.5.9-instance (Monad f, Applicative f) => Applicative (WhenMatched f k x y) where-  pure x = zipWithMatched (\_ _ _ -> x)-  fs <*> xs = zipWithMaybeAMatched $ \k x y -> do-    res <- runWhenMatched fs k x y-    case res of-      Nothing -> pure Nothing-      Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y-  {-# INLINE pure #-}-  {-# INLINE (<*>) #-}---- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @------ @since 0.5.9-instance (Monad f, Applicative f) => Monad (WhenMatched f k x y) where-#if !MIN_VERSION_base(4,8,0)-  return = pure-#endif-  m >>= f = zipWithMaybeAMatched $ \k x y -> do-    res <- runWhenMatched m k x y-    case res of-      Nothing -> pure Nothing-      Just r -> runWhenMatched (f r) k x y-  {-# INLINE (>>=) #-}---- | Map covariantly over a @'WhenMatched' f k x y@.------ @since 0.5.9-mapWhenMatched :: Functor f-               => (a -> b)-               -> WhenMatched f k x y a-               -> WhenMatched f k x y b-mapWhenMatched f (WhenMatched g) = WhenMatched $ \k x y -> fmap (fmap f) (g k x y)-{-# INLINE mapWhenMatched #-}---- | A tactic for dealing with keys present in both maps in 'merge'.------ A tactic of type @ SimpleWhenMatched k x y z @ is an abstract representation--- of a function of type @ k -> x -> y -> Maybe z @.------ @since 0.5.9-type SimpleWhenMatched = WhenMatched Identity---- | When a key is found in both maps, apply a function to the--- key and values and use the result in the merged map.------ @--- zipWithMatched :: (k -> x -> y -> z)---                -> SimpleWhenMatched k x y z--- @------ @since 0.5.9-zipWithMatched :: Applicative f-               => (k -> x -> y -> z)-               -> WhenMatched f k x y z-zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y-{-# INLINE zipWithMatched #-}---- | When a key is found in both maps, apply a function to the--- key and values to produce an action and use its result in the merged map.------ @since 0.5.9-zipWithAMatched :: Applicative f-                => (k -> x -> y -> f z)-                -> WhenMatched f k x y z-zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y-{-# INLINE zipWithAMatched #-}---- | When a key is found in both maps, apply a function to the--- key and values and maybe use the result in the merged map.------ @--- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)---                     -> SimpleWhenMatched k x y z--- @------ @since 0.5.9-zipWithMaybeMatched :: Applicative f-                    => (k -> x -> y -> Maybe z)-                    -> WhenMatched f k x y z-zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y-{-# INLINE zipWithMaybeMatched #-}---- | When a key is found in both maps, apply a function to the--- key and values, perform the resulting action, and maybe use--- the result in the merged map.------ This is the fundamental 'WhenMatched' tactic.------ @since 0.5.9-zipWithMaybeAMatched :: (k -> x -> y -> f (Maybe z))-                     -> WhenMatched f k x y z-zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y-{-# INLINE zipWithMaybeAMatched #-}---- | Drop all the entries whose keys are missing from the other--- map.------ @--- dropMissing :: SimpleWhenMissing k x y--- @------ prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)------ but @dropMissing@ is much faster.------ @since 0.5.9-dropMissing :: Applicative f => WhenMissing f k x y-dropMissing = WhenMissing-  { missingSubtree = const (pure Tip)-  , missingKey = \_ _ -> pure Nothing }-{-# INLINE dropMissing #-}---- | Preserve, unchanged, the entries whose keys are missing from--- the other map.------ @--- preserveMissing :: SimpleWhenMissing k x x--- @------ prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)------ but @preserveMissing@ is much faster.------ @since 0.5.9-preserveMissing :: Applicative f => WhenMissing f k x x-preserveMissing = WhenMissing-  { missingSubtree = pure-  , missingKey = \_ v -> pure (Just v) }-{-# INLINE preserveMissing #-}---- | Map over the entries whose keys are missing from the other map.------ @--- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y--- @------ prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)------ but @mapMissing@ is somewhat faster.------ @since 0.5.9-mapMissing :: Applicative f => (k -> x -> y) -> WhenMissing f k x y-mapMissing f = WhenMissing-  { missingSubtree = \m -> pure $! mapWithKey f m-  , missingKey = \ k x -> pure $ Just (f k x) }-{-# INLINE mapMissing #-}---- | Map over the entries whose keys are missing from the other map,--- optionally removing some. This is the most powerful 'SimpleWhenMissing'--- tactic, but others are usually more efficient.------ @--- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y--- @------ prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))------ but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.------ @since 0.5.9-mapMaybeMissing :: Applicative f => (k -> x -> Maybe y) -> WhenMissing f k x y-mapMaybeMissing f = WhenMissing-  { missingSubtree = \m -> pure $! mapMaybeWithKey f m-  , missingKey = \k x -> pure $! f k x }-{-# INLINE mapMaybeMissing #-}---- | Filter the entries whose keys are missing from the other map.------ @--- filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing k x x--- @------ prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x------ but this should be a little faster.------ @since 0.5.9-filterMissing :: Applicative f-              => (k -> x -> Bool) -> WhenMissing f k x x-filterMissing f = WhenMissing-  { missingSubtree = \m -> pure $! filterWithKey f m-  , missingKey = \k x -> pure $! if f k x then Just x else Nothing }-{-# INLINE filterMissing #-}---- | Filter the entries whose keys are missing from the other map--- using some 'Applicative' action.------ @--- filterAMissing f = Merge.Lazy.traverseMaybeMissing $---   \k x -> (\b -> guard b *> Just x) <$> f k x--- @------ but this should be a little faster.------ @since 0.5.9-filterAMissing :: Applicative f-              => (k -> x -> f Bool) -> WhenMissing f k x x-filterAMissing f = WhenMissing-  { missingSubtree = \m -> filterWithKeyA f m-  , missingKey = \k x -> bool Nothing (Just x) <$> f k x }-{-# INLINE filterAMissing #-}---- | This wasn't in Data.Bool until 4.7.0, so we define it here-bool :: a -> a -> Bool -> a-bool f _ False = f-bool _ t True  = t---- | Traverse over the entries whose keys are missing from the other map.------ @since 0.5.9-traverseMissing :: Applicative f-                    => (k -> x -> f y) -> WhenMissing f k x y-traverseMissing f = WhenMissing-  { missingSubtree = traverseWithKey f-  , missingKey = \k x -> Just <$> f k x }-{-# INLINE traverseMissing #-}---- | Traverse over the entries whose keys are missing from the other map,--- optionally producing values to put in the result.--- This is the most powerful 'WhenMissing' tactic, but others are usually--- more efficient.------ @since 0.5.9-traverseMaybeMissing :: Applicative f-                      => (k -> x -> f (Maybe y)) -> WhenMissing f k x y-traverseMaybeMissing f = WhenMissing-  { missingSubtree = traverseMaybeWithKey f-  , missingKey = f }-{-# INLINE traverseMaybeMissing #-}---- | Merge two maps.------ @merge@ takes two 'WhenMissing' tactics, a 'WhenMatched'--- tactic and two maps. It uses the tactics to merge the maps.--- Its behavior is best understood via its fundamental tactics,--- 'mapMaybeMissing' and 'zipWithMaybeMatched'.------ Consider------ @--- merge (mapMaybeMissing g1)---              (mapMaybeMissing g2)---              (zipWithMaybeMatched f)---              m1 m2--- @------ Take, for example,------ @--- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ @merge@ will first ''align'' these maps by key:------ @--- m1 = [(0, 'a'), (1, 'b'),               (3,'c'), (4, 'd')]--- m2 =           [(1, "one"), (2, "two"),          (4, "three")]--- @------ It will then pass the individual entries and pairs of entries--- to @g1@, @g2@, or @f@ as appropriate:------ @--- maybes = [g1 0 'a', f 1 'b' "one", g2 2 "two", g1 3 'c', f 4 'd' "three"]--- @------ This produces a 'Maybe' for each key:------ @--- keys =     0        1          2           3        4--- results = [Nothing, Just True, Just False, Nothing, Just True]--- @------ Finally, the @Just@ results are collected into a map:------ @--- return value = [(1, True), (2, False), (4, True)]--- @------ The other tactics below are optimizations or simplifications of--- 'mapMaybeMissing' for special cases. Most importantly,------ * 'dropMissing' drops all the keys.--- * 'preserveMissing' leaves all the entries alone.------ When 'merge' is given three arguments, it is inlined at the call--- site. To prevent excessive inlining, you should typically use 'merge'--- to define your custom combining functions.--------- Examples:------ prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)--- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)--- prop> differenceWith f = merge diffPreserve diffDrop f--- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)--- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)------ @since 0.5.9-merge :: Ord k-             => SimpleWhenMissing k a c -- ^ What to do with keys in @m1@ but not @m2@-             -> SimpleWhenMissing k b c -- ^ What to do with keys in @m2@ but not @m1@-             -> SimpleWhenMatched k a b c -- ^ What to do with keys in both @m1@ and @m2@-             -> Map k a -- ^ Map @m1@-             -> Map k b -- ^ Map @m2@-             -> Map k c-merge g1 g2 f m1 m2 = runIdentity $-  mergeA g1 g2 f m1 m2-{-# INLINE merge #-}---- | An applicative version of 'merge'.------ @mergeA@ takes two 'WhenMissing' tactics, a 'WhenMatched'--- tactic and two maps. It uses the tactics to merge the maps.--- Its behavior is best understood via its fundamental tactics,--- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.------ Consider------ @--- mergeA (traverseMaybeMissing g1)---               (traverseMaybeMissing g2)---               (zipWithMaybeAMatched f)---               m1 m2--- @------ Take, for example,------ @--- m1 = [(0, 'a'), (1, 'b'), (3,'c'), (4, 'd')]--- m2 = [(1, "one"), (2, "two"), (4, "three")]--- @------ @mergeA@ will first ''align'' these maps by key:------ @--- m1 = [(0, 'a'), (1, 'b'),               (3,'c'), (4, 'd')]--- m2 =           [(1, "one"), (2, "two"),          (4, "three")]--- @------ It will then pass the individual entries and pairs of entries--- to @g1@, @g2@, or @f@ as appropriate:------ @--- actions = [g1 0 'a', f 1 'b' "one", g2 2 "two", g1 3 'c', f 4 'd' "three"]--- @------ Next, it will perform the actions in the @actions@ list in order from--- left to right.------ @--- keys =     0        1          2           3        4--- results = [Nothing, Just True, Just False, Nothing, Just True]--- @------ Finally, the @Just@ results are collected into a map:------ @--- return value = [(1, True), (2, False), (4, True)]--- @------ The other tactics below are optimizations or simplifications of--- 'traverseMaybeMissing' for special cases. Most importantly,------ * 'dropMissing' drops all the keys.--- * 'preserveMissing' leaves all the entries alone.--- * 'mapMaybeMissing' does not use the 'Applicative' context.------ When 'mergeA' is given three arguments, it is inlined at the call--- site. To prevent excessive inlining, you should generally only use--- 'mergeA' to define custom combining functions.------ @since 0.5.9-mergeA-  :: (Applicative f, Ord k)-  => WhenMissing f k a c -- ^ What to do with keys in @m1@ but not @m2@-  -> WhenMissing f k b c -- ^ What to do with keys in @m2@ but not @m1@-  -> WhenMatched f k a b c -- ^ What to do with keys in both @m1@ and @m2@-  -> Map k a -- ^ Map @m1@-  -> Map k b -- ^ Map @m2@-  -> f (Map k c)-mergeA-    WhenMissing{missingSubtree = g1t, missingKey = g1k}-    WhenMissing{missingSubtree = g2t}-    (WhenMatched f) = go-  where-    go t1 Tip = g1t t1-    go Tip t2 = g2t t2-    go (Bin _ kx x1 l1 r1) t2 = case splitLookup kx t2 of-      (l2, mx2, r2) -> case mx2 of-          Nothing -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')-                        l1l2 (g1k kx x1) r1r2-          Just x2 -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')-                        l1l2 (f kx x1 x2) r1r2-        where-          !l1l2 = go l1 l2-          !r1r2 = go r1 r2-{-# INLINE mergeA #-}---{---------------------------------------------------------------------  MergeWithKey---------------------------------------------------------------------}---- | /O(n+m)/. An unsafe general combining function.------ WARNING: This function can produce corrupt maps and its results--- may depend on the internal structures of its inputs. Users should--- prefer 'merge' or 'mergeA'.------ When 'mergeWithKey' is given three arguments, it is inlined to the call--- site. You should therefore use 'mergeWithKey' only to define custom--- combining functions. For example, you could define 'unionWithKey',--- 'differenceWithKey' and 'intersectionWithKey' as------ > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2--- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2--- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2------ When calling @'mergeWithKey' combine only1 only2@, a function combining two--- 'Map's is created, such that------ * if a key is present in both maps, it is passed with both corresponding---   values to the @combine@ function. Depending on the result, the key is either---   present in the result with specified value, or is left out;------ * a nonempty subtree present only in the first map is passed to @only1@ and---   the output is added to the result;------ * a nonempty subtree present only in the second map is passed to @only2@ and---   the output is added to the result.------ The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.--- The values can be modified arbitrarily. Most common variants of @only1@ and--- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@,--- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@.--mergeWithKey :: Ord k-             => (k -> a -> b -> Maybe c)-             -> (Map k a -> Map k c)-             -> (Map k b -> Map k c)-             -> Map k a -> Map k b -> Map k c-mergeWithKey f g1 g2 = go-  where-    go Tip t2 = g2 t2-    go t1 Tip = g1 t1-    go (Bin _ kx x l1 r1) t2 =-      case found of-        Nothing -> case g1 (singleton kx x) of-                     Tip -> link2 l' r'-                     (Bin _ _ x' Tip Tip) -> link kx x' l' r'-                     _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"-        Just x2 -> case f kx x x2 of-                     Nothing -> link2 l' r'-                     Just x' -> link kx x' l' r'-      where-        (l2, found, r2) = splitLookup kx t2-        l' = go l1 l2-        r' = go r1 r2-{-# INLINE mergeWithKey #-}--{---------------------------------------------------------------------  Submap---------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/.--- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).----isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool-isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2-#if __GLASGOW_HASKELL__-{-# INLINABLE isSubmapOf #-}-#endif--{- | /O(m*log(n\/m + 1)), m <= n/.- The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if- all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when- applied to their respective values. For example, the following- expressions are all 'True':-- > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])-- But the following are all 'False':-- > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (<)  (fromList [('a',1)]) (fromList [('a',1),('b',2)])- > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])----}-isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool-isSubmapOfBy f t1 t2-  = (size t1 <= size t2) && (submap' f t1 t2)-#if __GLASGOW_HASKELL__-{-# INLINABLE isSubmapOfBy #-}-#endif--submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool-submap' _ Tip _ = True-submap' _ _ Tip = False-submap' f (Bin _ kx x l r) t-  = case found of-      Nothing -> False-      Just y  -> f x y && submap' f l lt && submap' f r gt-  where-    (lt,found,gt) = splitLookup kx t-#if __GLASGOW_HASKELL__-{-# INLINABLE submap' #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).--- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).-isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool-isProperSubmapOf m1 m2-  = isProperSubmapOfBy (==) m1 m2-#if __GLASGOW_HASKELL__-{-# INLINABLE isProperSubmapOf #-}-#endif--{- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).- The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when- @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 :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool-isProperSubmapOfBy f t1 t2-  = (size t1 < size t2) && (submap' f t1 t2)-#if __GLASGOW_HASKELL__-{-# INLINABLE isProperSubmapOfBy #-}-#endif--{---------------------------------------------------------------------  Filter and partition---------------------------------------------------------------------}--- | /O(n)/. Filter all values that satisfy the predicate.------ > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty--- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty--filter :: (a -> Bool) -> Map k a -> Map k a-filter p m-  = filterWithKey (\_ x -> p x) m---- | /O(n)/. Filter all keys\/values that satisfy the predicate.------ > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a-filterWithKey _ Tip = Tip-filterWithKey p t@(Bin _ kx x l r)-  | p kx x    = if pl `ptrEq` l && pr `ptrEq` r-                then t-                else link kx x pl pr-  | otherwise = link2 pl pr-  where !pl = filterWithKey p l-        !pr = filterWithKey p r---- | /O(n)/. Filter keys and values using an 'Applicative'--- predicate.-filterWithKeyA :: Applicative f => (k -> a -> f Bool) -> Map k a -> f (Map k a)-filterWithKeyA _ Tip = pure Tip-filterWithKeyA p t@(Bin _ kx x l r) =-  liftA3 combine (p kx x) (filterWithKeyA p l) (filterWithKeyA p r)-  where-    combine True pl pr-      | pl `ptrEq` l && pr `ptrEq` r = t-      | otherwise = link kx x pl pr-    combine False pl pr = link2 pl pr---- | /O(log n)/. Take while a predicate on the keys holds.--- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,--- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.------ @--- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'--- takeWhileAntitone p = 'filterWithKey' (\k _ -> p k)--- @------ @since 0.5.8--takeWhileAntitone :: (k -> Bool) -> Map k a -> Map k a-takeWhileAntitone _ Tip = Tip-takeWhileAntitone p (Bin _ kx x l r)-  | p kx = link kx x l (takeWhileAntitone p r)-  | otherwise = takeWhileAntitone p l---- | /O(log n)/. Drop while a predicate on the keys holds.--- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,--- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.------ @--- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'--- dropWhileAntitone p = 'filterWithKey' (\k -> not (p k))--- @------ @since 0.5.8--dropWhileAntitone :: (k -> Bool) -> Map k a -> Map k a-dropWhileAntitone _ Tip = Tip-dropWhileAntitone p (Bin _ kx x l r)-  | p kx = dropWhileAntitone p r-  | otherwise = link kx x (dropWhileAntitone p l) r---- | /O(log n)/. Divide a map at the point where a predicate on the keys stops holding.--- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,--- @j \< k ==\> p j \>= p k@.------ @--- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)--- spanAntitone p xs = partition p xs--- @------ Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map--- at some /unspecified/ point where the predicate switches from holding to not--- holding (where the predicate is seen to hold before the first key and to fail--- after the last key).------ @since 0.5.8--spanAntitone :: (k -> Bool) -> Map k a -> (Map k a, Map k a)-spanAntitone p0 m = toPair (go p0 m)-  where-    go _ Tip = Tip :*: Tip-    go p (Bin _ kx x l r)-      | p kx = let u :*: v = go p r in link kx x l u :*: v-      | otherwise = let u :*: v = go p l in u :*: link kx x v r---- | /O(n)/. Partition the map according to a predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partition :: (a -> Bool) -> Map k a -> (Map k a,Map k a)-partition p m-  = partitionWithKey (\_ x -> p x) m---- | /O(n)/. Partition the map according to a predicate. The first--- map contains all elements that satisfy the predicate, the second all--- elements that fail the predicate. See also 'split'.------ > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")--- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)--- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])--partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)-partitionWithKey p0 t0 = toPair $ go p0 t0-  where-    go _ Tip = (Tip :*: Tip)-    go p t@(Bin _ kx x l r)-      | p kx x    = (if l1 `ptrEq` l && r1 `ptrEq` r-                     then t-                     else link kx x l1 r1) :*: link2 l2 r2-      | otherwise = link2 l1 r1 :*:-                    (if l2 `ptrEq` l && r2 `ptrEq` r-                     then t-                     else link kx x l2 r2)-      where-        (l1 :*: l2) = go p l-        (r1 :*: r2) = go p r---- | /O(n)/. Map values and collect the 'Just' results.------ > let f x = if x == "a" then Just "new a" else Nothing--- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"--mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b-mapMaybe f = mapMaybeWithKey (\_ x -> f x)---- | /O(n)/. Map keys\/values and collect the 'Just' results.------ > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing--- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"--mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b-mapMaybeWithKey _ Tip = Tip-mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of-  Just y  -> link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)-  Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r)---- | /O(n)/. Traverse keys\/values and collect the 'Just' results.------ @since 0.5.8-traverseMaybeWithKey :: Applicative f-                     => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)-traverseMaybeWithKey = go-  where-    go _ Tip = pure Tip-    go f (Bin _ kx x Tip Tip) = maybe Tip (\x' -> Bin 1 kx x' Tip Tip) <$> f kx x-    go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r)-      where-        combine !l' mx !r' = case mx of-          Nothing -> link2 l' r'-          Just x' -> link kx x' l' r'---- | /O(n)/. Map values and separate the 'Left' and 'Right' results.------ > let f a = if a < "c" then Left a else Right a--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])--- >--- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)-mapEither f m-  = mapEitherWithKey (\_ x -> f x) m---- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.------ > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])--- >--- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])--mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)-mapEitherWithKey f0 t0 = toPair $ go f0 t0-  where-    go _ Tip = (Tip :*: Tip)-    go f (Bin _ kx x l r) = case f kx x of-      Left y  -> link kx y l1 r1 :*: link2 l2 r2-      Right z -> link2 l1 r1 :*: link kx z l2 r2-     where-        (l1 :*: l2) = go f l-        (r1 :*: r2) = go f r--{---------------------------------------------------------------------  Mapping---------------------------------------------------------------------}--- | /O(n)/. Map a function over all values in the map.------ > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]--map :: (a -> b) -> Map k a -> Map k b-map f = go where-  go Tip = Tip-  go (Bin sx kx x l r) = Bin sx kx (f x) (go l) (go r)--- We use a `go` function to allow `map` to inline. This makes--- a big difference if someone uses `map (const x) m` instead--- of `x <$ m`; it doesn't seem to do any harm.--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] map #-}-{-# RULES-"map/map" forall f g xs . map f (map g xs) = map (f . g) xs- #-}-#endif-#if __GLASGOW_HASKELL__ >= 709--- Safe coercions were introduced in 7.8, but did not work well with RULES yet.-{-# RULES-"map/coerce" map coerce = coerce- #-}-#endif---- | /O(n)/. Map a function over all values in the map.------ > let f key x = (show key) ++ ":" ++ x--- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]--mapWithKey :: (k -> a -> b) -> Map k a -> Map k b-mapWithKey _ Tip = Tip-mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] mapWithKey #-}-{-# RULES-"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =-  mapWithKey (\k a -> f k (g k a)) xs-"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =-  mapWithKey (\k a -> f k (g a)) xs-"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =-  mapWithKey (\k a -> f (g k a)) xs- #-}-#endif---- | /O(n)/.--- @'traverseWithKey' f m == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@--- That is, behaves exactly like a regular 'traverse' except that the traversing--- function also has access to the key associated with a value.------ > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])--- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing-traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)-traverseWithKey f = go-  where-    go Tip = pure Tip-    go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v-    go (Bin s k v l r) = liftA3 (flip (Bin s k)) (go l) (f k v) (go r)-{-# INLINE traverseWithKey #-}---- | /O(n)/. The function 'mapAccum' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a b = (a ++ b, b ++ "X")--- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])--mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccum f a m-  = mapAccumWithKey (\a' _ x' -> f a' x') a m---- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])--mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumWithKey f a t-  = mapAccumL f a t---- | /O(n)/. The function 'mapAccumL' threads an accumulating--- argument through the map in ascending order of keys.-mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumL _ a Tip               = (a,Tip)-mapAccumL f a (Bin sx kx x l r) =-  let (a1,l') = mapAccumL f a l-      (a2,x') = f a1 kx x-      (a3,r') = mapAccumL f a2 r-  in (a3,Bin sx kx x' l' r')---- | /O(n)/. The function 'mapAccumR' threads an accumulating--- argument through the map in descending order of keys.-mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumRWithKey _ a Tip = (a,Tip)-mapAccumRWithKey f a (Bin sx kx x l r) =-  let (a1,r') = mapAccumRWithKey f a r-      (a2,x') = f a1 kx x-      (a3,l') = mapAccumRWithKey f a2 l-  in (a3,Bin sx kx x' l' r')---- | /O(n*log n)/.--- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the value at the greatest of the--- original keys is retained.------ > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])                        == fromList [(4, "b"), (6, "a")]--- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"--- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"--mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a-mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []-#if __GLASGOW_HASKELL__-{-# INLINABLE mapKeys #-}-#endif---- | /O(n*log n)/.--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the associated values will be--- combined using @c@. The value at the greater of the two original keys--- is used as the first argument to @c@.------ > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"--mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a-mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []-#if __GLASGOW_HASKELL__-{-# INLINABLE mapKeysWith #-}-#endif----- | /O(n)/.--- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@--- is strictly monotonic.--- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.--- /The precondition is not checked./--- Semi-formally, we have:------ > and [x < y ==> f x < f y | x <- ls, y <- ls]--- >                     ==> mapKeysMonotonic f s == mapKeys f s--- >     where ls = keys s------ This means that @f@ maps distinct original keys to distinct resulting keys.--- This function has better performance than 'mapKeys'.------ > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]--- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True--- > valid (mapKeysMonotonic (\ _ -> 1)     (fromList [(5,"a"), (3,"b")])) == False--mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a-mapKeysMonotonic _ Tip = Tip-mapKeysMonotonic f (Bin sz k x l r) =-    Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)--{---------------------------------------------------------------------  Folds---------------------------------------------------------------------}---- | /O(n)/. Fold the values in the map using the given right-associative--- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.------ For example,------ > elems map = foldr (:) [] map------ > let f a len = len + (length a)--- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-foldr :: (a -> b -> b) -> b -> Map k a -> b-foldr f z = go z-  where-    go z' Tip             = z'-    go z' (Bin _ _ x l r) = go (f x (go z' r)) l-{-# INLINE foldr #-}---- | /O(n)/. A strict version of 'foldr'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldr' :: (a -> b -> b) -> b -> Map k a -> b-foldr' f z = go z-  where-    go !z' Tip             = z'-    go z' (Bin _ _ x l r) = go (f x (go z' r)) l-{-# INLINE foldr' #-}---- | /O(n)/. Fold the values in the map using the given left-associative--- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.------ For example,------ > elems = reverse . foldl (flip (:)) []------ > let f len a = len + (length a)--- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4-foldl :: (a -> b -> a) -> a -> Map k b -> a-foldl f z = go z-  where-    go z' Tip             = z'-    go z' (Bin _ _ x l r) = go (f (go z' l) x) r-{-# INLINE foldl #-}---- | /O(n)/. A strict version of 'foldl'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldl' :: (a -> b -> a) -> a -> Map k b -> a-foldl' f z = go z-  where-    go !z' Tip             = z'-    go z' (Bin _ _ x l r) = go (f (go z' l) x) r-{-# INLINE foldl' #-}---- | /O(n)/. Fold the keys and values in the map using the given right-associative--- binary operator, such that--- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.------ For example,------ > keys map = foldrWithKey (\k x ks -> k:ks) [] map------ > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"-foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b-foldrWithKey f z = go z-  where-    go z' Tip             = z'-    go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l-{-# INLINE foldrWithKey #-}---- | /O(n)/. A strict version of 'foldrWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b-foldrWithKey' f z = go z-  where-    go !z' Tip              = z'-    go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l-{-# INLINE foldrWithKey' #-}---- | /O(n)/. Fold the keys and values in the map using the given left-associative--- binary operator, such that--- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.------ For example,------ > keys = reverse . foldlWithKey (\ks k x -> k:ks) []------ > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"--- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"-foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a-foldlWithKey f z = go z-  where-    go z' Tip              = z'-    go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r-{-# INLINE foldlWithKey #-}---- | /O(n)/. A strict version of 'foldlWithKey'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a-foldlWithKey' f z = go z-  where-    go !z' Tip              = z'-    go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r-{-# INLINE foldlWithKey' #-}---- | /O(n)/. Fold the keys and values in the map using the given monoid, such that------ @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@------ This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.------ @since 0.5.4-foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m-foldMapWithKey f = go-  where-    go Tip             = mempty-    go (Bin 1 k v _ _) = f k v-    go (Bin _ k v l r) = go l `mappend` (f k v `mappend` go r)-{-# INLINE foldMapWithKey #-}--{---------------------------------------------------------------------  List variations---------------------------------------------------------------------}--- | /O(n)/.--- Return all elements of the map in the ascending order of their keys.--- Subject to list fusion.------ > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]--- > elems empty == []--elems :: Map k a -> [a]-elems = foldr (:) []---- | /O(n)/. Return all keys of the map in ascending order. Subject to list--- fusion.------ > keys (fromList [(5,"a"), (3,"b")]) == [3,5]--- > keys empty == []--keys  :: Map k a -> [k]-keys = foldrWithKey (\k _ ks -> k : ks) []---- | /O(n)/. An alias for 'toAscList'. Return all key\/value pairs in the map--- in ascending key order. Subject to list fusion.------ > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > assocs empty == []--assocs :: Map k a -> [(k,a)]-assocs m-  = toAscList m---- | /O(n)/. The set of all keys of the map.------ > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]--- > keysSet empty == Data.Set.empty--keysSet :: Map k a -> Set.Set k-keysSet Tip = Set.Tip-keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r)---- | /O(n)/. Build a map from a set of keys and a function which for each key--- computes its value.------ > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]--- > fromSet undefined Data.Set.empty == empty--fromSet :: (k -> a) -> Set.Set k -> Map k a-fromSet _ Set.Tip = Tip-fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r)--{---------------------------------------------------------------------  Lists-  use [foldlStrict] to reduce demand on the control-stack---------------------------------------------------------------------}-#if __GLASGOW_HASKELL__ >= 708--- | @since 0.5.6.2-instance (Ord k) => GHCExts.IsList (Map k v) where-  type Item (Map k v) = (k,v)-  fromList = fromList-  toList   = toList-#endif---- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.--- If the list contains more than one value for the same key, the last value--- for the key is retained.------ If the keys of the list are ordered, linear-time implementation is used,--- with the performance equal to 'fromDistinctAscList'.------ > fromList [] == empty--- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]--- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]---- For some reason, when 'singleton' is used in fromList or in--- create, it is not inlined, so we inline it manually.-fromList :: Ord k => [(k,a)] -> Map k a-fromList [] = Tip-fromList [(kx, x)] = Bin 1 kx x Tip Tip-fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = fromList' (Bin 1 kx0 x0 Tip Tip) xs0-                           | otherwise = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0-  where-    not_ordered _ [] = False-    not_ordered kx ((ky,_) : _) = kx >= ky-    {-# INLINE not_ordered #-}--    fromList' t0 xs = Foldable.foldl' ins t0 xs-      where ins t (k,x) = insert k x t--    go !_ t [] = t-    go _ t [(kx, x)] = insertMax kx x t-    go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs-                              | otherwise = case create s xss of-                                  (r, ys, []) -> go (s `shiftL` 1) (link kx x l r) ys-                                  (r, _,  ys) -> fromList' (link kx x l r) ys--    -- The create is returning a triple (tree, xs, ys). Both xs and ys-    -- represent not yet processed elements and only one of them can be nonempty.-    -- If ys is nonempty, the keys in ys are not ordered with respect to tree-    -- and must be inserted using fromList'. Otherwise the keys have been-    -- ordered so far.-    create !_ [] = (Tip, [], [])-    create s xs@(xp : xss)-      | s == 1 = case xp of (kx, x) | not_ordered kx xss -> (Bin 1 kx x Tip Tip, [], xss)-                                    | otherwise -> (Bin 1 kx x Tip Tip, xss, [])-      | otherwise = case create (s `shiftR` 1) xs of-                      res@(_, [], _) -> res-                      (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs)-                      (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)-                                               | otherwise -> case create (s `shiftR` 1) yss of-                                                   (r, zs, ws) -> (link ky y l r, zs, ws)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromList #-}-#endif---- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.------ > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]--- > fromListWith (++) [] == empty--fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a-fromListWith f xs-  = fromListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromListWith #-}-#endif---- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.------ > let f k a1 a2 = (show k) ++ a1 ++ a2--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]--- > fromListWithKey f [] == empty--fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromListWithKey f xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t-#if __GLASGOW_HASKELL__-{-# INLINABLE fromListWithKey #-}-#endif---- | /O(n)/. Convert the map to a list of key\/value pairs. Subject to list fusion.------ > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--- > toList empty == []--toList :: Map k a -> [(k,a)]-toList = toAscList---- | /O(n)/. Convert the map to a list of key\/value pairs where the keys are--- in ascending order. Subject to list fusion.------ > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]--toAscList :: Map k a -> [(k,a)]-toAscList = foldrWithKey (\k x xs -> (k,x):xs) []---- | /O(n)/. Convert the map to a list of key\/value pairs where the keys--- are in descending order. Subject to list fusion.------ > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]--toDescList :: Map k a -> [(k,a)]-toDescList = foldlWithKey (\xs k x -> (k,x):xs) []---- List fusion for the list generating functions.-#if __GLASGOW_HASKELL__--- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.--- They are important to convert unfused methods back, see mapFB in prelude.-foldrFB :: (k -> a -> b -> b) -> b -> Map k a -> b-foldrFB = foldrWithKey-{-# INLINE[0] foldrFB #-}-foldlFB :: (a -> k -> b -> a) -> a -> Map k b -> a-foldlFB = foldlWithKey-{-# INLINE[0] foldlFB #-}---- Inline assocs and toList, so that we need to fuse only toAscList.-{-# INLINE assocs #-}-{-# INLINE toList #-}---- The fusion is enabled up to phase 2 included. If it does not succeed,--- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to--- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were--- used in a list fusion, otherwise it would go away in phase 1), and let compiler--- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to--- inline it before phase 0, otherwise the fusion rules would not fire at all.-{-# NOINLINE[0] elems #-}-{-# NOINLINE[0] keys #-}-{-# NOINLINE[0] toAscList #-}-{-# NOINLINE[0] toDescList #-}-{-# RULES "Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}-{-# RULES "Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}-{-# RULES "Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}-{-# RULES "Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}-{-# RULES "Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}-{-# RULES "Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}-{-# RULES "Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}-{-# RULES "Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}-#endif--{---------------------------------------------------------------------  Building trees from ascending/descending lists can be done in linear time.--  Note that if [xs] is ascending that:-    fromAscList xs       == fromList xs-    fromAscListWith f xs == fromListWith f xs---------------------------------------------------------------------}--- | /O(n)/. Build a map from an ascending list in linear time.--- /The precondition (input list is ascending) is not checked./------ > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]--- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True--- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False--fromAscList :: Eq k => [(k,a)] -> Map k a-fromAscList xs-  = fromDistinctAscList (combineEq xs)-  where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq xs'-    = case xs' of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,_) (x@(kx,xx):xs')-    | kx==kz    = combineEq' (kx,xx) xs'-    | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscList #-}-#endif---- | /O(n)/. Build a map from a descending list in linear time.--- /The precondition (input list is descending) is not checked./------ > fromDescList [(5,"a"), (3,"b")]          == fromList [(3, "b"), (5, "a")]--- > fromDescList [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "b")]--- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True--- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False------ @since 0.5.8--fromDescList :: Eq k => [(k,a)] -> Map k a-fromDescList xs = fromDistinctDescList (combineEq xs)-  where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq xs'-    = case xs' of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,_) (x@(kx,xx):xs')-    | kx==kz    = combineEq' (kx,xx) xs'-    | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescList #-}-#endif---- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.--- /The precondition (input list is ascending) is not checked./------ > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]--- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True--- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False--fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a-fromAscListWith f xs-  = fromAscListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscListWith #-}-#endif---- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys.--- /The precondition (input list is descending) is not checked./------ > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")]--- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True--- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False------ @since 0.5.8--fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a-fromDescListWith f xs-  = fromDescListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescListWith #-}-#endif---- | /O(n)/. Build a map from an ascending list in linear time with a--- combining function for equal keys.--- /The precondition (input list is ascending) is not checked./------ > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2--- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]--- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True--- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False--fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromAscListWithKey f xs-  = fromDistinctAscList (combineEq f xs)-  where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq _ xs'-    = case xs' of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,zz) (x@(kx,xx):xs')-    | kx==kz    = let yy = f kx xx zz in combineEq' (kx,yy) xs'-    | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscListWithKey #-}-#endif---- | /O(n)/. Build a map from a descending list in linear time with a--- combining function for equal keys.--- /The precondition (input list is descending) is not checked./------ > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2--- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]--- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True--- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False-fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromDescListWithKey f xs-  = fromDistinctDescList (combineEq f xs)-  where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq _ xs'-    = case xs' of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,zz) (x@(kx,xx):xs')-    | kx==kz    = let yy = f kx xx zz in combineEq' (kx,yy) xs'-    | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescListWithKey #-}-#endif----- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.--- /The precondition is not checked./------ > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]--- > valid (fromDistinctAscList [(3,"b"), (5,"a")])          == True--- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False---- For some reason, when 'singleton' is used in fromDistinctAscList or in--- create, it is not inlined, so we inline it manually.-fromDistinctAscList :: [(k,a)] -> Map k a-fromDistinctAscList [] = Tip-fromDistinctAscList ((kx0, x0) : xs0) = go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0-  where-    go !_ t [] = t-    go s l ((kx, x) : xs) = case create s xs of-                                (r :*: ys) -> let !t' = link kx x l r-                                              in go (s `shiftL` 1) t' ys--    create !_ [] = (Tip :*: [])-    create s xs@(x' : xs')-      | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')-      | otherwise = case create (s `shiftR` 1) xs of-                      res@(_ :*: []) -> res-                      (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of-                        (r :*: zs) -> (link ky y l r :*: zs)---- | /O(n)/. Build a map from a descending list of distinct elements in linear time.--- /The precondition is not checked./------ > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]--- > valid (fromDistinctDescList [(5,"a"), (3,"b")])          == True--- > valid (fromDistinctDescList [(5,"a"), (5,"b"), (3,"b")]) == False------ @since 0.5.8---- For some reason, when 'singleton' is used in fromDistinctDescList or in--- create, it is not inlined, so we inline it manually.-fromDistinctDescList :: [(k,a)] -> Map k a-fromDistinctDescList [] = Tip-fromDistinctDescList ((kx0, x0) : xs0) = go (1 :: Int) (Bin 1 kx0 x0 Tip Tip) xs0-  where-     go !_ t [] = t-     go s r ((kx, x) : xs) = case create s xs of-                               (l :*: ys) -> let !t' = link kx x l r-                                             in go (s `shiftL` 1) t' ys--     create !_ [] = (Tip :*: [])-     create s xs@(x' : xs')-       | s == 1 = case x' of (kx, x) -> (Bin 1 kx x Tip Tip :*: xs')-       | otherwise = case create (s `shiftR` 1) xs of-                       res@(_ :*: []) -> res-                       (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of-                         (l :*: zs) -> (link ky y l r :*: zs)--{---- Functions very similar to these were used to implement--- hedge union, intersection, and difference algorithms that we no--- longer use. These functions, however, seem likely to be useful--- in their own right, so I'm leaving them here in case we end up--- exporting them.--{---------------------------------------------------------------------  [filterGt b t] filter all keys >[b] from tree [t]-  [filterLt b t] filter all keys <[b] from tree [t]---------------------------------------------------------------------}-filterGt :: Ord k => k -> Map k v -> Map k v-filterGt !_ Tip = Tip-filterGt !b (Bin _ kx x l r) =-  case compare b kx of LT -> link kx x (filterGt b l) r-                       EQ -> r-                       GT -> filterGt b r-#if __GLASGOW_HASKELL__-{-# INLINABLE filterGt #-}-#endif--filterLt :: Ord k => k -> Map k v -> Map k v-filterLt !_ Tip = Tip-filterLt !b (Bin _ kx x l r) =-  case compare kx b of LT -> link kx x l (filterLt b r)-                       EQ -> l-                       GT -> filterLt b l-#if __GLASGOW_HASKELL__-{-# INLINABLE filterLt #-}-#endif--}--{---------------------------------------------------------------------  Split---------------------------------------------------------------------}--- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@ where--- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.--- Any key equal to @k@ is found in neither @map1@ nor @map2@.------ > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])--- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")--- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")--- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)--- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)--split :: Ord k => k -> Map k a -> (Map k a,Map k a)-split !k0 t0 = toPair $ go k0 t0-  where-    go k t =-      case t of-        Tip            -> Tip :*: Tip-        Bin _ kx x l r -> case compare k kx of-          LT -> let (lt :*: gt) = go k l in lt :*: link kx x gt r-          GT -> let (lt :*: gt) = go k r in link kx x l lt :*: gt-          EQ -> (l :*: r)-#if __GLASGOW_HASKELL__-{-# INLINABLE split #-}-#endif---- | /O(log n)/. The expression (@'splitLookup' k map@) splits a map just--- like 'split' but also returns @'lookup' k map@.------ > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])--- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")--- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")--- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)--- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)-splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)-splitLookup k0 m = case go k0 m of-     StrictTriple l mv r -> (l, mv, r)-  where-    go :: Ord k => k -> Map k a -> StrictTriple (Map k a) (Maybe a) (Map k a)-    go !k t =-      case t of-        Tip            -> StrictTriple Tip Nothing Tip-        Bin _ kx x l r -> case compare k kx of-          LT -> let StrictTriple lt z gt = go k l-                    !gt' = link kx x gt r-                in StrictTriple lt z gt'-          GT -> let StrictTriple lt z gt = go k r-                    !lt' = link kx x l lt-                in StrictTriple lt' z gt-          EQ -> StrictTriple l (Just x) r-#if __GLASGOW_HASKELL__-{-# INLINABLE splitLookup #-}-#endif---- | A variant of 'splitLookup' that indicates only whether the--- key was present, rather than producing its value. This is used to--- implement 'intersection' to avoid allocating unnecessary 'Just'--- constructors.-splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)-splitMember k0 m = case go k0 m of-     StrictTriple l mv r -> (l, mv, r)-  where-    go :: Ord k => k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)-    go !k t =-      case t of-        Tip            -> StrictTriple Tip False Tip-        Bin _ kx x l r -> case compare k kx of-          LT -> let StrictTriple lt z gt = go k l-                    !gt' = link kx x gt r-                in StrictTriple lt z gt'-          GT -> let StrictTriple lt z gt = go k r-                    !lt' = link kx x l lt-                in StrictTriple lt' z gt-          EQ -> StrictTriple l True r-#if __GLASGOW_HASKELL__-{-# INLINABLE splitMember #-}-#endif--data StrictTriple a b c = StrictTriple !a !b !c--{---------------------------------------------------------------------  Utility functions that maintain the balance properties of the tree.-  All constructors assume that all values in [l] < [k] and all values-  in [r] > [k], and that [l] and [r] are valid trees.--  In order of sophistication:-    [Bin sz k x l r]  The type constructor.-    [bin k x l r]     Maintains the correct size, assumes that both [l]-                      and [r] are balanced with respect to each other.-    [balance k x l r] Restores the balance and size.-                      Assumes that the original tree was balanced and-                      that [l] or [r] has changed by at most one element.-    [link k x l r]    Restores balance and size.--  Furthermore, we can construct a new tree from two trees. Both operations-  assume that all values in [l] < all values in [r] and that [l] and [r]-  are valid:-    [glue l r]        Glues [l] and [r] together. Assumes that [l] and-                      [r] are already balanced with respect to each other.-    [link2 l r]       Merges two trees and restores balance.---------------------------------------------------------------------}--{---------------------------------------------------------------------  Link---------------------------------------------------------------------}-link :: k -> a -> Map k a -> Map k a -> Map k a-link kx x Tip r  = insertMin kx x r-link kx x l Tip  = insertMax kx x l-link kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)-  | delta*sizeL < sizeR  = balanceL kz z (link kx x l lz) rz-  | delta*sizeR < sizeL  = balanceR ky y ly (link kx x ry r)-  | otherwise            = bin kx x l r----- insertMin and insertMax don't perform potentially expensive comparisons.-insertMax,insertMin :: k -> a -> Map k a -> Map k a-insertMax kx x t-  = case t of-      Tip -> singleton kx x-      Bin _ ky y l r-          -> balanceR ky y l (insertMax kx x r)--insertMin kx x t-  = case t of-      Tip -> singleton kx x-      Bin _ ky y l r-          -> balanceL ky y (insertMin kx x l) r--{---------------------------------------------------------------------  [link2 l r]: merges two trees.---------------------------------------------------------------------}-link2 :: Map k a -> Map k a -> Map k a-link2 Tip r   = r-link2 l Tip   = l-link2 l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)-  | delta*sizeL < sizeR = balanceL ky y (link2 l ly) ry-  | delta*sizeR < sizeL = balanceR kx x lx (link2 rx r)-  | otherwise           = glue l r--{---------------------------------------------------------------------  [glue l r]: glues two trees together.-  Assumes that [l] and [r] are already balanced with respect to each other.---------------------------------------------------------------------}-glue :: Map k a -> Map k a -> Map k a-glue Tip r = r-glue l Tip = l-glue l@(Bin sl kl xl ll lr) r@(Bin sr kr xr rl rr)-  | sl > sr = let !(MaxView km m l') = maxViewSure kl xl ll lr in balanceR km m l' r-  | otherwise = let !(MinView km m r') = minViewSure kr xr rl rr in balanceL km m l r'--data MinView k a = MinView !k a !(Map k a)-data MaxView k a = MaxView !k a !(Map k a)--minViewSure :: k -> a -> Map k a -> Map k a -> MinView k a-minViewSure = go-  where-    go k x Tip r = MinView k x r-    go k x (Bin _ kl xl ll lr) r =-      case go kl xl ll lr of-        MinView km xm l' -> MinView km xm (balanceR k x l' r)-{-# NOINLINE minViewSure #-}--maxViewSure :: k -> a -> Map k a -> Map k a -> MaxView k a-maxViewSure = go-  where-    go k x l Tip = MaxView k x l-    go k x l (Bin _ kr xr rl rr) =-      case go kr xr rl rr of-        MaxView km xm r' -> MaxView km xm (balanceL k x l r')-{-# NOINLINE maxViewSure #-}---- | /O(log n)/. Delete and find the minimal element.------ > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])--- > deleteFindMin                                            Error: can not return the minimal element of an empty map--deleteFindMin :: Map k a -> ((k,a),Map k a)-deleteFindMin t = case minViewWithKey t of-  Nothing -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)-  Just res -> res---- | /O(log n)/. Delete and find the maximal element.------ > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])--- > deleteFindMax empty                                      Error: can not return the maximal element of an empty map--deleteFindMax :: Map k a -> ((k,a),Map k a)-deleteFindMax t = case maxViewWithKey t of-  Nothing -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)-  Just res -> res--{---------------------------------------------------------------------  [balance l x r] balances two trees with value x.-  The sizes of the trees should balance after decreasing the-  size of one of them. (a rotation).--  [delta] is the maximal relative difference between the sizes of-          two trees, it corresponds with the [w] in Adams' paper.-  [ratio] is the ratio between an outer and inner sibling of the-          heavier subtree in an unbalanced setting. It determines-          whether a double or single rotation should be performed-          to restore balance. It is corresponds with the inverse-          of $\alpha$ in Adam's article.--  Note that according to the Adam's paper:-  - [delta] should be larger than 4.646 with a [ratio] of 2.-  - [delta] should be larger than 3.745 with a [ratio] of 1.534.--  But the Adam's paper is erroneous:-  - It can be proved that for delta=2 and delta>=5 there does-    not exist any ratio that would work.-  - Delta=4.5 and ratio=2 does not work.--  That leaves two reasonable variants, delta=3 and delta=4,-  both with ratio=2.--  - A lower [delta] leads to a more 'perfectly' balanced tree.-  - A higher [delta] performs less rebalancing.--  In the benchmarks, delta=3 is faster on insert operations,-  and delta=4 has slightly better deletes. As the insert speedup-  is larger, we currently use delta=3.----------------------------------------------------------------------}-delta,ratio :: Int-delta = 3-ratio = 2---- The balance function is equivalent to the following:------   balance :: k -> a -> Map k a -> Map k a -> Map k a---   balance k x l r---     | sizeL + sizeR <= 1    = Bin sizeX k x l r---     | sizeR > delta*sizeL   = rotateL k x l r---     | sizeL > delta*sizeR   = rotateR k x l r---     | otherwise             = Bin sizeX k x l r---     where---       sizeL = size l---       sizeR = size r---       sizeX = sizeL + sizeR + 1------   rotateL :: a -> b -> Map a b -> Map a b -> Map a b---   rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r---                                     | otherwise               = doubleL k x l r------   rotateR :: a -> b -> Map a b -> Map a b -> Map a b---   rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r---                                     | otherwise               = doubleR k x l r------   singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b---   singleL k1 x1 t1 (Bin _ k2 x2 t2 t3)  = bin k2 x2 (bin k1 x1 t1 t2) t3---   singleR k1 x1 (Bin _ k2 x2 t1 t2) t3  = bin k2 x2 t1 (bin k1 x1 t2 t3)------   doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b---   doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)---   doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)------ It is only written in such a way that every node is pattern-matched only once.--balance :: k -> a -> Map k a -> Map k a -> Map k a-balance k x l r = case l of-  Tip -> case r of-           Tip -> Bin 1 k x Tip Tip-           (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r-           (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr-           (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)-           (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))-             | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr-             | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)--  (Bin ls lk lx ll lr) -> case r of-           Tip -> case (ll, lr) of-                    (Tip, Tip) -> Bin 2 k x l Tip-                    (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)-                    ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)-                    ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr))-                      | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)-                      | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)-           (Bin rs rk rx rl rr)-              | rs > delta*ls  -> case (rl, rr) of-                   (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)-                     | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr-                     | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)-                   (_, _) -> error "Failure in Data.Map.balance"-              | ls > delta*rs  -> case (ll, lr) of-                   (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)-                     | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)-                     | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)-                   (_, _) -> error "Failure in Data.Map.balance"-              | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balance #-}---- Functions balanceL and balanceR are specialised versions of balance.--- balanceL only checks whether the left subtree is too big,--- balanceR only checks whether the right subtree is too big.---- balanceL is called when left subtree might have been inserted to or when--- right subtree might have been deleted from.-balanceL :: k -> a -> Map k a -> Map k a -> Map k a-balanceL k x l r = case r of-  Tip -> case l of-           Tip -> Bin 1 k x Tip Tip-           (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip-           (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)-           (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)-           (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))-             | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)-             | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)--  (Bin rs _ _ _ _) -> case l of-           Tip -> Bin (1+rs) k x Tip r--           (Bin ls lk lx ll lr)-              | ls > delta*rs  -> case (ll, lr) of-                   (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)-                     | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)-                     | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)-                   (_, _) -> error "Failure in Data.Map.balanceL"-              | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceL #-}---- balanceR is called when right subtree might have been inserted to or when--- left subtree might have been deleted from.-balanceR :: k -> a -> Map k a -> Map k a -> Map k a-balanceR k x l r = case l of-  Tip -> case r of-           Tip -> Bin 1 k x Tip Tip-           (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r-           (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr-           (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)-           (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))-             | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr-             | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)--  (Bin ls _ _ _ _) -> case r of-           Tip -> Bin (1+ls) k x l Tip--           (Bin rs rk rx rl rr)-              | rs > delta*ls  -> case (rl, rr) of-                   (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)-                     | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr-                     | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)-                   (_, _) -> error "Failure in Data.Map.balanceR"-              | otherwise -> Bin (1+ls+rs) k x l r-{-# NOINLINE balanceR #-}---{---------------------------------------------------------------------  The bin constructor maintains the size of the tree---------------------------------------------------------------------}-bin :: k -> a -> Map k a -> Map k a -> Map k a-bin k x l r-  = Bin (size l + size r + 1) k x l r-{-# INLINE bin #-}---{---------------------------------------------------------------------  Eq converts the tree to a list. In a lazy setting, this-  actually seems one of the faster methods to compare two trees-  and it is certainly the simplest :-)---------------------------------------------------------------------}-instance (Eq k,Eq a) => Eq (Map k a) where-  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)--{---------------------------------------------------------------------  Ord---------------------------------------------------------------------}--instance (Ord k, Ord v) => Ord (Map k v) where-    compare m1 m2 = compare (toAscList m1) (toAscList m2)--#if MIN_VERSION_base(4,9,0)-{---------------------------------------------------------------------  Lifted instances---------------------------------------------------------------------}---- | @since 0.5.9-instance Eq2 Map where-    liftEq2 eqk eqv m n =-        size m == size n && liftEq (liftEq2 eqk eqv) (toList m) (toList n)---- | @since 0.5.9-instance Eq k => Eq1 (Map k) where-    liftEq = liftEq2 (==)---- | @since 0.5.9-instance Ord2 Map where-    liftCompare2 cmpk cmpv m n =-        liftCompare (liftCompare2 cmpk cmpv) (toList m) (toList n)---- | @since 0.5.9-instance Ord k => Ord1 (Map k) where-    liftCompare = liftCompare2 compare---- | @since 0.5.9-instance Show2 Map where-    liftShowsPrec2 spk slk spv slv d m =-        showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)-      where-        sp = liftShowsPrec2 spk slk spv slv-        sl = liftShowList2 spk slk spv slv---- | @since 0.5.9-instance Show k => Show1 (Map k) where-    liftShowsPrec = liftShowsPrec2 showsPrec showList---- | @since 0.5.9-instance (Ord k, Read k) => Read1 (Map k) where-    liftReadsPrec rp rl = readsData $-        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList-      where-        rp' = liftReadsPrec rp rl-        rl' = liftReadList rp rl-#endif--{---------------------------------------------------------------------  Functor---------------------------------------------------------------------}-instance Functor (Map k) where-  fmap f m  = map f m-#ifdef __GLASGOW_HASKELL__-  _ <$ Tip = Tip-  a <$ (Bin sx kx _ l r) = Bin sx kx a (a <$ l) (a <$ r)-#endif--instance Traversable (Map k) where-  traverse f = traverseWithKey (\_ -> f)-  {-# INLINE traverse #-}--instance Foldable.Foldable (Map k) where-  fold = go-    where go Tip = mempty-          go (Bin 1 _ v _ _) = v-          go (Bin _ _ v l r) = go l `mappend` (v `mappend` go r)-  {-# INLINABLE fold #-}-  foldr = foldr-  {-# INLINE foldr #-}-  foldl = foldl-  {-# INLINE foldl #-}-  foldMap f t = go t-    where go Tip = mempty-          go (Bin 1 _ v _ _) = f v-          go (Bin _ _ v l r) = go l `mappend` (f v `mappend` go r)-  {-# INLINE foldMap #-}-  foldl' = foldl'-  {-# INLINE foldl' #-}-  foldr' = foldr'-  {-# INLINE foldr' #-}-#if MIN_VERSION_base(4,8,0)-  length = size-  {-# INLINE length #-}-  null   = null-  {-# INLINE null #-}-  toList = elems -- NB: Foldable.toList /= Map.toList-  {-# INLINE toList #-}-  elem = go-    where go !_ Tip = False-          go x (Bin _ _ v l r) = x == v || go x l || go x r-  {-# INLINABLE elem #-}-  maximum = start-    where start Tip = error "Data.Foldable.maximum (for Data.Map): empty map"-          start (Bin _ _ v l r) = go (go v l) r--          go !m Tip = m-          go m (Bin _ _ v l r) = go (go (max m v) l) r-  {-# INLINABLE maximum #-}-  minimum = start-    where start Tip = error "Data.Foldable.minimum (for Data.Map): empty map"-          start (Bin _ _ v l r) = go (go v l) r--          go !m Tip = m-          go m (Bin _ _ v l r) = go (go (min m v) l) r-  {-# INLINABLE minimum #-}-  sum = foldl' (+) 0-  {-# INLINABLE sum #-}-  product = foldl' (*) 1-  {-# INLINABLE product #-}-#endif--instance (NFData k, NFData a) => NFData (Map k a) where-    rnf Tip = ()-    rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r--{---------------------------------------------------------------------  Read---------------------------------------------------------------------}-instance (Ord k, Read k, Read e) => Read (Map k e) where-#ifdef __GLASGOW_HASKELL__-  readPrec = parens $ prec 10 $ do-    Ident "fromList" <- lexP-    xs <- readPrec-    return (fromList xs)--  readListPrec = readListPrecDefault-#else-  readsPrec p = readParen (p > 10) $ \ r -> do-    ("fromList",s) <- lex r-    (xs,t) <- reads s-    return (fromList xs,t)-#endif--{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance (Show k, Show a) => Show (Map k a) where-  showsPrec d m  = showParen (d > 10) $-    showString "fromList " . shows (toList m)--{---------------------------------------------------------------------  Typeable---------------------------------------------------------------------}--INSTANCE_TYPEABLE2(Map)--{---------------------------------------------------------------------  Utilities---------------------------------------------------------------------}---- | /O(1)/.  Decompose a map into pieces based on the structure of the underlying--- 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] ['a'..])) ==--- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d')],fromList [(5,'e'),(6,'f')]]------ > splitRoot empty == []------  Note that the current implementation does not return more than three submaps,---  but you should not depend on this behaviour because it can change in the---  future without notice.------ @since 0.5.4-splitRoot :: Map k b -> [Map k b]-splitRoot orig =-  case orig of-    Tip           -> []-    Bin _ k v l r -> [l, singleton k v, r]-{-# INLINE splitRoot #-}
− Data/Map/Internal/Debug.hs 
@@ -1,144 +0,0 @@-{-# LANGUAGE CPP #-}-#include "containers.h"--module Data.Map.Internal.Debug where--import Data.Map.Internal (Map (..), size, delta)-import Control.Monad (guard)---- | /O(n)/. Show the tree that implements the map. The tree is shown--- in a compressed, hanging format. See 'showTreeWith'.-showTree :: (Show k,Show a) => Map k a -> String-showTree m-  = showTreeWith showElem True False m-  where-    showElem k x  = show k ++ ":=" ++ show x---{- | /O(n)/. The expression (@'showTreeWith' showelem hang wide map@) shows- the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is- 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If- @wide@ is 'True', an extra wide version is shown.-->  Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]->  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t->  (4,())->  +--(2,())->  |  +--(1,())->  |  +--(3,())->  +--(5,())->->  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t->  (4,())->  |->  +--(2,())->  |  |->  |  +--(1,())->  |  |->  |  +--(3,())->  |->  +--(5,())->->  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t->  +--(5,())->  |->  (4,())->  |->  |  +--(3,())->  |  |->  +--(2,())->     |->     +--(1,())---}-showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String-showTreeWith showelem hang wide t-  | hang      = (showsTreeHang showelem wide [] t) ""-  | otherwise = (showsTree showelem wide [] [] t) ""--showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS-showsTree showelem wide lbars rbars t-  = case t of-      Tip -> showsBars lbars . showString "|\n"-      Bin _ kx x Tip Tip-          -> showsBars lbars . showString (showelem kx x) . showString "\n"-      Bin _ kx x l r-          -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .-             showWide wide rbars .-             showsBars lbars . showString (showelem kx x) . showString "\n" .-             showWide wide lbars .-             showsTree showelem wide (withEmpty lbars) (withBar lbars) l--showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS-showsTreeHang showelem wide bars t-  = case t of-      Tip -> showsBars bars . showString "|\n"-      Bin _ kx x Tip Tip-          -> showsBars bars . showString (showelem kx x) . showString "\n"-      Bin _ kx x l r-          -> showsBars bars . showString (showelem kx x) . showString "\n" .-             showWide wide bars .-             showsTreeHang showelem wide (withBar bars) l .-             showWide wide bars .-             showsTreeHang showelem wide (withEmpty bars) r--showWide :: Bool -> [String] -> String -> String-showWide wide bars-  | wide      = showString (concat (reverse bars)) . showString "|\n"-  | otherwise = id--showsBars :: [String] -> ShowS-showsBars bars-  = case bars of-      [] -> id-      _  -> showString (concat (reverse (tail bars))) . showString node--node :: String-node           = "+--"--withBar, withEmpty :: [String] -> [String]-withBar bars   = "|  ":bars-withEmpty bars = "   ":bars--{---------------------------------------------------------------------  Assertions---------------------------------------------------------------------}--- | /O(n)/. Test if the internal map structure is valid.------ > valid (fromAscList [(3,"b"), (5,"a")]) == True--- > valid (fromAscList [(5,"a"), (3,"b")]) == False--valid :: Ord k => Map k a -> Bool-valid t-  = balanced t && ordered t && validsize t---- | Test if the keys are ordered correctly.-ordered :: Ord a => Map a b -> Bool-ordered t-  = bounded (const True) (const True) t-  where-    bounded lo hi t'-      = case t' of-          Tip              -> True-          Bin _ kx _ l r  -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r---- | Test if a map obeys the balance invariants.-balanced :: Map k a -> Bool-balanced t-  = case t of-      Tip            -> True-      Bin _ _ _ l r  -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&-                        balanced l && balanced r---- | Test if each node of a map reports its size correctly.-validsize :: Map a b -> Bool-validsize t = case slowSize t of-      Nothing -> False-      Just _ -> True-  where-    slowSize Tip = Just 0-    slowSize (Bin sz _ _ l r) = do-            ls <- slowSize l-            rs <- slowSize r-            guard (sz == ls + rs + 1)-            return sz
− Data/Map/Internal/DeprecatedShowTree.hs 
@@ -1,29 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts, DataKinds #-}-#if __GLASGOW_HASKELL__ >= 800-{-# LANGUAGE MonoLocalBinds #-}-#endif-#if __GLASGOW_HASKELL__ < 710--- Why do we need this? Guess it doesn't matter; this is all--- going away soon.-{-# LANGUAGE Trustworthy #-}-#endif--#include "containers.h"---- | This module simply holds disabled copies of functions from--- Data.Map.Internal.Debug.-module Data.Map.Internal.DeprecatedShowTree where--import Data.Map.Internal (Map)-import Utils.Containers.Internal.TypeError---- | This function has moved to 'Data.Map.Internal.Debug.showTree'.-showTree :: Whoops "showTree has moved to Data.Map.Internal.Debug.showTree."-         => Map k a -> String-showTree _ = undefined---- | This function has moved to 'Data.Map.Internal.Debug.showTreeWith'.-showTreeWith ::-      Whoops "showTreeWith has moved to Data.Map.Internal.Debug.showTreeWith."-   => (k -> a -> String) -> Bool -> Bool -> Map k a -> String-showTreeWith _ _ _ _ = undefined
− Data/Map/Lazy.hs 
@@ -1,275 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.Map.Lazy--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable--------- = Finite Maps (lazy interface)------ The @'Map' k v@ type represents a finite map (sometimes called a dictionary)--- from keys of type @k@ to values of type @v@. A 'Map' is strict in its keys but lazy--- in its values.------ The functions in "Data.Map.Strict" are careful to force values before--- installing them in a 'Map'. This is usually more efficient in cases where--- laziness is not essential. The functions in this module do not do so.------ When deciding if this is the correct data structure to use, consider:------ * If you are using 'Int' keys, you will get much better performance for most--- operations using "Data.IntMap.Lazy".------ * If you don't care about ordering, consider using @Data.HashMap.Lazy@ from the--- <https://hackage.haskell.org/package/unordered-containers unordered-containers>--- package instead.------ For a walkthrough of the most commonly used functions see the--- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.------ This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:------ > import qualified Data.Map.Lazy as Map------ Note that the implementation is generally /left-biased/. Functions that take--- two maps as arguments and combine them, such as `union` and `intersection`,--- prefer the values in the first argument to those in the second.--------- == Detailed performance information------ The amortized running time is given for each operation, with /n/ referring to--- the number of entries in the map.------ Benchmarks comparing "Data.Map.Lazy" with other dictionary implementations--- can be found at https://github.com/haskell-perf/dictionaries.--------- == Warning------ The size of a 'Map' must not exceed @maxBound::Int@. Violation of this--- condition is not detected and if the size limit is exceeded, its behaviour is--- undefined.--------- == Implementation------ The implementation of 'Map' is based on /size balanced/ binary trees (or--- trees of /bounded balance/) as described by:------    * Stephen Adams, \"/Efficient sets: a balancing act/\",---     Journal of Functional Programming 3(4):553-562, October 1993,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.---    * J. Nievergelt and E.M. Reingold,---      \"/Binary search trees of bounded balance/\",---      SIAM journal of computing 2(1), March 1973.------  Bounds for 'union', 'intersection', and 'difference' are as given---  by------    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.-----------------------------------------------------------------------------------module Data.Map.Lazy (-    -- * Map type-    Map              -- instance Eq,Show,Read--    -- * Construction-    , empty-    , singleton-    , fromSet--    -- ** From Unordered Lists-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** From Ascending Lists-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList--    -- ** From Descending Lists-    , fromDescList-    , fromDescListWith-    , fromDescListWithKey-    , fromDistinctDescList--    -- * 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--    -- ** General combining functions-    -- | See "Data.Map.Merge.Lazy"--    -- ** Unsafe general combining function--    , mergeWithKey--    -- * Traversal-    -- ** Map-    , map-    , mapWithKey-    , traverseWithKey-    , traverseMaybeWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , foldr-    , foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet--    -- ** Lists-    , toList--    -- ** Ordered lists-    , toAscList-    , toDescList--    -- * Filter-    , filter-    , filterWithKey-    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey-    , takeWhileAntitone-    , dropWhileAntitone-    , spanAntitone--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Indexed-    , lookupIndex-    , findIndex-    , elemAt-    , updateAt-    , deleteAt-    , take-    , drop-    , splitAt--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey--    -- * Debugging-#ifdef __GLASGOW_HASKELL__-    , showTree-    , showTreeWith-#endif-    , valid-    ) where--import Data.Map.Internal-import Data.Map.Internal.DeprecatedShowTree (showTree, showTreeWith)-import Data.Map.Internal.Debug (valid)-import Prelude ()
− Data/Map/Merge/Lazy.hs 
@@ -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.Map.Merge.Lazy--- Copyright   :  (c) David Feuer 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.Map.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.Map.Internal
− Data/Map/Merge/Strict.hs 
@@ -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.Map.Merge.Strict--- Copyright   :  (c) David Feuer 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.Map.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.Map.Strict.Internal
− Data/Map/Strict.hs 
@@ -1,290 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.Map.Strict--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable--------- = Finite Maps (strict interface)------ The @'Map' k v@ type represents a finite map (sometimes called a dictionary)--- from keys of type @k@ to values of type @v@.------ 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.Map.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.------ When deciding if this is the correct data structure to use, consider:------ * If you are using 'Int' keys, you will get much better performance for most--- operations using "Data.IntMap.Strict".------ * If you don't care about ordering, consider use @Data.HashMap.Strict@ from the--- <https://hackage.haskell.org/package/unordered-containers unordered-containers>--- package instead.------ For a walkthrough of the most commonly used functions see the--- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.------ This module is intended to be imported qualified, to avoid name clashes with--- Prelude functions:------ > import qualified Data.Map.Strict as Map------ Note that the implementation is generally /left-biased/. Functions that take--- two maps as arguments and combine them, such as `union` and `intersection`,--- prefer the values in the first argument to those in the second.--------- == Detailed performance information------ The amortized running time is given for each operation, with /n/ referring to--- the number of entries in the map.------ Benchmarks comparing "Data.Map.Strict" with other dictionary implementations--- can be found at https://github.com/haskell-perf/dictionaries.--------- == Warning------ The size of a 'Map' must not exceed @maxBound::Int@. Violation of this--- condition is not detected and if the size limit is exceeded, its behaviour is--- undefined.------ The 'Map' type is shared between the lazy and strict modules, meaning that--- the same 'Map' value can be passed to functions in both modules. This means--- that the 'Functor', 'Traversable' and 'Data' instances are the same as for--- the "Data.Map.Lazy" module, so if they are used the resulting maps may contain--- suspended values (thunks).--------- == Implementation------ The implementation of 'Map' is based on /size balanced/ binary trees (or--- trees of /bounded balance/) as described by:------    * Stephen Adams, \"/Efficient sets: a balancing act/\",---     Journal of Functional Programming 3(4):553-562, October 1993,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.---    * J. Nievergelt and E.M. Reingold,---      \"/Binary search trees of bounded balance/\",---      SIAM journal of computing 2(1), March 1973.------  Bounds for 'union', 'intersection', and 'difference' are as given---  by------    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.---------------------------------------------------------------------------------------- See the notes at the beginning of Data.Map.Internal.--module Data.Map.Strict-    (-    -- * Map type-    Map              -- instance Eq,Show,Read--    -- * Construction-    , empty-    , singleton-    , fromSet--    -- ** From Unordered Lists-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** From Ascending Lists-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList--    -- ** From Descending Lists-    , fromDescList-    , fromDescListWith-    , fromDescListWithKey-    , fromDistinctDescList--    -- * 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--    -- ** General combining functions-    -- | See "Data.Map.Merge.Strict"--    -- ** Deprecated general combining function--    , mergeWithKey--    -- * Traversal-    -- ** Map-    , map-    , mapWithKey-    , traverseWithKey-    , traverseMaybeWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , foldr-    , foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet--    -- ** Lists-    , toList--    -- ** Ordered lists-    , toAscList-    , toDescList--    -- * Filter-    , filter-    , filterWithKey-    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey--    , takeWhileAntitone-    , dropWhileAntitone-    , spanAntitone--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Indexed-    , lookupIndex-    , findIndex-    , elemAt-    , updateAt-    , deleteAt-    , take-    , drop-    , splitAt--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey--    -- * Debugging-#ifdef __GLASGOW_HASKELL__-    , showTree-    , showTreeWith-#endif-    , valid-    ) where--import Data.Map.Strict.Internal-import Prelude ()
− Data/Map/Strict/Internal.hs 
@@ -1,1727 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif-{-# OPTIONS_HADDOCK not-home #-}--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.Map.Strict.Internal--- Copyright   :  (c) Daan Leijen 2002---                (c) Andriy Palamarchuk 2008--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ = WARNING------ This module is considered __internal__.------ The Package Versioning Policy __does not apply__.------ 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 ordered maps from keys to values--- (dictionaries).------ API of this module is strict in both the keys and the values.--- If you need value-lazy maps, use "Data.Map.Lazy" instead.--- The 'Map' type is shared between the lazy and strict modules,--- meaning that the same 'Map' value can be passed to functions in--- both modules (although that is rarely needed).------ These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.------ >  import qualified Data.Map.Strict as Map------ The implementation of 'Map' is based on /size balanced/ binary trees (or--- trees of /bounded balance/) as described by:------    * Stephen Adams, \"/Efficient sets: a balancing act/\",---     Journal of Functional Programming 3(4):553-562, October 1993,---     <http://www.swiss.ai.mit.edu/~adams/BB/>.---    * J. Nievergelt and E.M. Reingold,---      \"/Binary search trees of bounded balance/\",---      SIAM journal of computing 2(1), March 1973.------  Bounds for 'union', 'intersection', and 'difference' are as given---  by------    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.------ Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'.------ /Warning/: The size of the map must not exceed @maxBound::Int@. Violation of--- this condition is not detected and if the size limit is exceeded, its--- behaviour is undefined.------ Operation comments contain the operation time complexity in--- the Big-O notation (<http://en.wikipedia.org/wiki/Big_O_notation>).------ Be aware that the 'Functor', 'Traversable' and 'Data' instances--- are the same as for the "Data.Map.Lazy" module, so if they are used--- on strict maps, the resulting maps will be lazy.---------------------------------------------------------------------------------- See the notes at the beginning of Data.Map.Internal.--module Data.Map.Strict.Internal-    (-    -- * Strictness properties-    -- $strictness--    -- * Map type-    Map(..)          -- instance Eq,Show,Read-    , L.Size--    -- * 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-    , merge-    , runWhenMatched-    , runWhenMissing--    -- *** @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--    -- *** Covariant maps for tactics-    , mapWhenMissing-    , mapWhenMatched--    -- ** Deprecated general combining function--    , mergeWithKey--    -- * Traversal-    -- ** Map-    , map-    , mapWithKey-    , traverseWithKey-    , traverseMaybeWithKey-    , mapAccum-    , mapAccumWithKey-    , mapAccumRWithKey-    , mapKeys-    , mapKeysWith-    , mapKeysMonotonic--    -- * Folds-    , foldr-    , foldl-    , foldrWithKey-    , foldlWithKey-    , foldMapWithKey--    -- ** Strict folds-    , foldr'-    , foldl'-    , foldrWithKey'-    , foldlWithKey'--    -- * Conversion-    , elems-    , keys-    , assocs-    , keysSet-    , fromSet--    -- ** Lists-    , toList-    , fromList-    , fromListWith-    , fromListWithKey--    -- ** Ordered lists-    , toAscList-    , toDescList-    , fromAscList-    , fromAscListWith-    , fromAscListWithKey-    , fromDistinctAscList-    , fromDescList-    , fromDescListWith-    , fromDescListWithKey-    , fromDistinctDescList--    -- * Filter-    , filter-    , filterWithKey-    , restrictKeys-    , withoutKeys-    , partition-    , partitionWithKey-    , takeWhileAntitone-    , dropWhileAntitone-    , spanAntitone--    , mapMaybe-    , mapMaybeWithKey-    , mapEither-    , mapEitherWithKey--    , split-    , splitLookup-    , splitRoot--    -- * Submap-    , isSubmapOf, isSubmapOfBy-    , isProperSubmapOf, isProperSubmapOfBy--    -- * Indexed-    , lookupIndex-    , findIndex-    , elemAt-    , updateAt-    , deleteAt-    , take-    , drop-    , splitAt--    -- * Min\/Max-    , lookupMin-    , lookupMax-    , findMin-    , findMax-    , deleteMin-    , deleteMax-    , deleteFindMin-    , deleteFindMax-    , updateMin-    , updateMax-    , updateMinWithKey-    , updateMaxWithKey-    , minView-    , maxView-    , minViewWithKey-    , maxViewWithKey--    -- * Debugging-#if defined(__GLASGOW_HASKELL__)-    , showTree-    , showTreeWith-#endif-    , valid-    ) where--import Prelude hiding (lookup,map,filter,foldr,foldl,null,take,drop,splitAt)--import Data.Map.Internal-  ( Map (..)-  , AreWeStrict (..)-  , WhenMissing (..)-  , WhenMatched (..)-  , runWhenMatched-  , runWhenMissing-  , SimpleWhenMissing-  , SimpleWhenMatched-  , preserveMissing-  , dropMissing-  , filterMissing-  , filterAMissing-  , merge-  , mergeA-  , (!)-  , (!?)-  , (\\)-  , assocs-  , atKeyImpl-#if MIN_VERSION_base(4,8,0)-  , atKeyPlain-#endif-  , balance-  , balanceL-  , balanceR-  , elemAt-  , elems-  , empty-  , delete-  , deleteAt-  , deleteFindMax-  , deleteFindMin-  , deleteMin-  , deleteMax-  , difference-  , drop-  , dropWhileAntitone-  , filter-  , filterWithKey-  , findIndex-  , findMax-  , findMin-  , foldl-  , foldl'-  , foldlWithKey-  , foldlWithKey'-  , foldMapWithKey-  , foldr-  , foldr'-  , foldrWithKey-  , foldrWithKey'-  , glue-  , insertMax-  , intersection-  , isProperSubmapOf-  , isProperSubmapOfBy-  , isSubmapOf-  , isSubmapOfBy-  , keys-  , keysSet-  , link-  , lookup-  , lookupGE-  , lookupGT-  , lookupIndex-  , lookupLE-  , lookupLT-  , lookupMin-  , lookupMax-  , mapKeys-  , mapKeysMonotonic-  , maxView-  , maxViewWithKey-  , member-  , link2-  , minView-  , minViewWithKey-  , notMember-  , null-  , partition-  , partitionWithKey-  , restrictKeys-  , size-  , spanAntitone-  , split-  , splitAt-  , splitLookup-  , splitRoot-  , take-  , takeWhileAntitone-  , toList-  , toAscList-  , toDescList-  , union-  , unions-  , withoutKeys )--#if defined(__GLASGOW_HASKELL__)-import Data.Map.Internal.DeprecatedShowTree (showTree, showTreeWith)-#endif-import Data.Map.Internal.Debug (valid)--import Control.Applicative (Const (..), liftA3)-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (Applicative (..), (<$>))-#endif-import qualified Data.Set.Internal as Set-import qualified Data.Map.Internal as L-import Utils.Containers.Internal.StrictPair--import Data.Bits (shiftL, shiftR)-#if __GLASGOW_HASKELL__ >= 709-import Data.Coerce-#endif--#if __GLASGOW_HASKELL__ && MIN_VERSION_base(4,8,0)-import Data.Functor.Identity (Identity (..))-#endif--import qualified Data.Foldable as Foldable-import Data.Foldable (Foldable())---- $strictness------ This module satisfies the following strictness properties:------ 1. Key arguments are evaluated to WHNF;------ 2. Keys and values are evaluated to WHNF before they are stored in---    the map.------ Here's an example illustrating the first property:------ > delete undefined m  ==  undefined------ Here are some examples that illustrate the second property:------ > map (\ v -> undefined) m  ==  undefined      -- m is not empty--- > mapKeys (\ k -> undefined) m  ==  undefined  -- m is not empty---- [Note: Pointer equality for sharing]------ We use pointer equality to enhance sharing between the arguments--- of some functions and their results. Notably, we use it--- for insert, delete, union, intersection, and difference. We do--- *not* use it for functions, like insertWith, unionWithKey,--- intersectionWith, etc., that allow the user to modify the elements.--- While we *could* do so, we would only get sharing under fairly--- narrow conditions and at a relatively high cost. It does not seem--- worth the price.--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}---- | /O(log n)/. The expression @('findWithDefault' def k map)@ returns--- the value at key @k@ or returns default value @def@--- when the key is not in the map.------ > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'--- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'---- See Map.Internal.Note: Local 'go' functions and capturing-findWithDefault :: Ord k => a -> k -> Map k a -> a-findWithDefault def k = k `seq` go-  where-    go Tip = def-    go (Bin _ kx x l r) = case compare k kx of-      LT -> go l-      GT -> go r-      EQ -> x-#if __GLASGOW_HASKELL__-{-# INLINABLE findWithDefault #-}-#else-{-# INLINE findWithDefault #-}-#endif--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}---- | /O(1)/. A map with a single element.------ > singleton 1 'a'        == fromList [(1, 'a')]--- > size (singleton 1 'a') == 1--singleton :: k -> a -> Map k a-singleton k x = x `seq` Bin 1 k x Tip Tip-{-# INLINE singleton #-}--{---------------------------------------------------------------------  Insertion---------------------------------------------------------------------}--- | /O(log n)/. Insert a new key and value in the map.--- If the key is already present in the map, the associated value is--- replaced with the supplied value. 'insert' is equivalent to--- @'insertWith' 'const'@.------ > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]--- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]--- > insert 5 'x' empty                         == singleton 5 'x'---- See Map.Internal.Note: Type of local 'go' function-insert :: Ord k => k -> a -> Map k a -> Map k a-insert = go-  where-    go :: Ord k => k -> a -> Map k a -> Map k a-    go !kx !x Tip = singleton kx x-    go kx x (Bin sz ky y l r) =-        case compare kx ky of-            LT -> balanceL ky y (go kx x l) r-            GT -> balanceR ky y l (go kx x r)-            EQ -> Bin sz kx x l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insert #-}-#else-{-# INLINE insert #-}-#endif---- | /O(log n)/. Insert with a function, combining new value and old value.--- @'insertWith' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key, f new_value old_value)@.------ > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]--- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"--insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWith = go-  where-    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-    go _ !kx x Tip = singleton kx x-    go f !kx x (Bin sy ky y l r) =-        case compare kx ky of-            LT -> balanceL ky y (go f kx x l) r-            GT -> balanceR ky y l (go f kx x r)-            EQ -> let !y' = f x y in Bin sy kx y' l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insertWith #-}-#else-{-# INLINE insertWith #-}-#endif--insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithR = go-  where-    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a-    go _ !kx x Tip = singleton kx x-    go f !kx x (Bin sy ky y l r) =-        case compare kx ky of-            LT -> balanceL ky y (go f kx x l) r-            GT -> balanceR ky y l (go f kx x r)-            EQ -> let !y' = f y x in Bin sy ky y' l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insertWithR #-}-#else-{-# INLINE insertWithR #-}-#endif---- | /O(log n)/. Insert with a function, combining key, new value and old value.--- @'insertWithKey' f key value mp@--- will insert the pair (key, value) into @mp@ if key does--- not exist in the map. If the key does exist, the function will--- insert the pair @(key,f key new_value old_value)@.--- Note that the key passed to f is the same key passed to 'insertWithKey'.------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]--- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]--- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"---- See Map.Internal.Note: Type of local 'go' function-insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKey = go-  where-    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-    -- Forcing `kx` may look redundant, but it's possible `compare` will-    -- be lazy.-    go _ !kx x Tip = singleton kx x-    go f kx x (Bin sy ky y l r) =-        case compare kx ky of-            LT -> balanceL ky y (go f kx x l) r-            GT -> balanceR ky y l (go f kx x r)-            EQ -> let !x' = f kx x y-                  in Bin sy kx x' l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insertWithKey #-}-#else-{-# INLINE insertWithKey #-}-#endif--insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-insertWithKeyR = go-  where-    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a-    -- Forcing `kx` may look redundant, but it's possible `compare` will-    -- be lazy.-    go _ !kx x Tip = singleton kx x-    go f kx x (Bin sy ky y l r) =-        case compare kx ky of-            LT -> balanceL ky y (go f kx x l) r-            GT -> balanceR ky y l (go f kx x r)-            EQ -> let !y' = f ky y x-                  in Bin sy ky y' l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insertWithKeyR #-}-#else-{-# INLINE insertWithKeyR #-}-#endif---- | /O(log n)/. Combines insert operation with old value retrieval.--- The expression (@'insertLookupWithKey' f k x map@)--- is a pair where the first element is equal to (@'lookup' k map@)--- and the second element equal to (@'insertWithKey' f k x map@).------ > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])--- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])--- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")------ This is how to define @insertLookup@ using @insertLookupWithKey@:------ > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t--- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])--- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])---- See Map.Internal.Note: Type of local 'go' function-insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a-                    -> (Maybe a, Map k a)-insertLookupWithKey f0 kx0 x0 t0 = toPair $ go f0 kx0 x0 t0-  where-    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)-    go _ !kx x Tip = Nothing :*: singleton kx x-    go f kx x (Bin sy ky y l r) =-        case compare kx ky of-            LT -> let (found :*: l') = go f kx x l-                  in found :*: balanceL ky y l' r-            GT -> let (found :*: r') = go f kx x r-                  in found :*: balanceR ky y l r'-            EQ -> let x' = f kx x y-                  in x' `seq` (Just y :*: Bin sy kx x' l r)-#if __GLASGOW_HASKELL__-{-# INLINABLE insertLookupWithKey #-}-#else-{-# INLINE insertLookupWithKey #-}-#endif--{---------------------------------------------------------------------  Deletion---------------------------------------------------------------------}---- | /O(log n)/. Update a value at a specific key with the result of the provided function.--- When the key is not--- a member of the map, the original map is returned.------ > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjust ("new " ++) 7 empty                         == empty--adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a-adjust f = adjustWithKey (\_ x -> f x)-#if __GLASGOW_HASKELL__-{-# INLINABLE adjust #-}-#else-{-# INLINE adjust #-}-#endif---- | /O(log n)/. Adjust a value at a specific key. When the key is not--- a member of the map, the original map is returned.------ > let f key x = (show key) ++ ":new " ++ x--- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > adjustWithKey f 7 empty                         == empty--adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a-adjustWithKey = go-  where-    go :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a-    go _ !_ Tip = Tip-    go f k (Bin sx kx x l r) =-        case compare k kx of-           LT -> Bin sx kx x (go f k l) r-           GT -> Bin sx kx x l (go f k r)-           EQ -> Bin sx kx x' l r-             where !x' = f kx x-#if __GLASGOW_HASKELL__-{-# INLINABLE adjustWithKey #-}-#else-{-# INLINE adjustWithKey #-}-#endif---- | /O(log n)/. The expression (@'update' f k map@) updates the value @x@--- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is--- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.------ > let f x = if x == "a" then Just "new a" else Nothing--- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]--- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a-update f = updateWithKey (\_ x -> f x)-#if __GLASGOW_HASKELL__-{-# INLINABLE update #-}-#else-{-# INLINE update #-}-#endif---- | /O(log n)/. The expression (@'updateWithKey' f k map@) updates the--- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',--- the element is deleted. If it is (@'Just' y@), the key @k@ is bound--- to the new value @y@.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]--- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"---- See Map.Internal.Note: Type of local 'go' function-updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a-updateWithKey = go-  where-    go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a-    go _ !_ Tip = Tip-    go f k(Bin sx kx x l r) =-        case compare k kx of-           LT -> balanceR kx x (go f k l) r-           GT -> balanceL kx x l (go f k r)-           EQ -> case f kx x of-                   Just x' -> x' `seq` Bin sx kx x' l r-                   Nothing -> glue l r-#if __GLASGOW_HASKELL__-{-# INLINABLE updateWithKey #-}-#else-{-# INLINE updateWithKey #-}-#endif---- | /O(log n)/. Lookup and update. See also 'updateWithKey'.--- The function returns changed value, if it is updated.--- Returns the original key value if the map entry is deleted.------ > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])--- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])--- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")---- See Map.Internal.Note: Type of local 'go' function-updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)-updateLookupWithKey f0 k0 t0 = toPair $ go f0 k0 t0- where-   go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)-   go _ !_ Tip = (Nothing :*: Tip)-   go f k (Bin sx kx x l r) =-          case compare k kx of-               LT -> let (found :*: l') = go f k l-                     in found :*: balanceR kx x l' r-               GT -> let (found :*: r') = go f k r-                     in found :*: balanceL kx x l r'-               EQ -> case f kx x of-                       Just x' -> x' `seq` (Just x' :*: Bin sx kx x' l r)-                       Nothing -> (Just x :*: glue l r)-#if __GLASGOW_HASKELL__-{-# INLINABLE updateLookupWithKey #-}-#else-{-# INLINE updateLookupWithKey #-}-#endif---- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.--- 'alter' can be used to insert, delete, or update a value in a 'Map'.--- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.------ > let f _ = Nothing--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- >--- > let f _ = Just "c"--- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]--- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]---- See Map.Internal.Note: Type of local 'go' function-alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a-alter = go-  where-    go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a-    go f !k Tip = case f Nothing of-               Nothing -> Tip-               Just x  -> singleton k x--    go f k (Bin sx kx x l r) = case compare k kx of-               LT -> balance kx x (go f k l) r-               GT -> balance kx x l (go f k r)-               EQ -> case f (Just x) of-                       Just x' -> x' `seq` Bin sx kx x' l r-                       Nothing -> glue l r-#if __GLASGOW_HASKELL__-{-# INLINABLE alter #-}-#else-{-# INLINE alter #-}-#endif---- | /O(log n)/. The expression (@'alterF' f k map@) alters the value @x@ at @k@, or absence thereof.--- 'alterF' can be used to inspect, insert, delete, or update a value in a 'Map'.--- In short: @'lookup' k \<$\> 'alterF' f k m = f ('lookup' k m)@.------ Example:------ @--- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)--- interactiveAlter k m = alterF f k m where---   f Nothing -> do---      putStrLn $ show k ++---          " was not found in the map. Would you like to add it?"---      getUserResponse1 :: IO (Maybe String)---   f (Just old) -> do---      putStrLn "The key is currently bound to " ++ show old ++---          ". Would you like to change or delete it?"---      getUserresponse2 :: IO (Maybe String)--- @------ 'alterF' is the most general operation for working with an individual--- key that may or may not be in a given map. When used with trivial--- functors like 'Identity' and 'Const', it is often slightly slower than--- more specialized combinators like 'lookup' and 'insert'. However, when--- the functor is non-trivial and key comparison is not particularly cheap,--- it is the fastest way.------ Note on rewrite rules:------ This module includes GHC rewrite rules to optimize 'alterF' for--- the 'Const' and 'Identity' functors. In general, these rules--- improve performance. The sole exception is that when using--- 'Identity', deleting a key that is already absent takes longer--- than it would without the rules. If you expect this to occur--- a very large fraction of the time, you might consider using a--- private copy of the 'Identity' type.------ Note: 'alterF' is a flipped version of the 'at' combinator from--- 'Control.Lens.At'.-alterF :: (Functor f, Ord k)-       => (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)-alterF f k m = atKeyImpl Strict k f m--#ifndef __GLASGOW_HASKELL__-{-# INLINE alterF #-}-#else-{-# INLINABLE [2] alterF #-}---- We can save a little time by recognizing the special case of--- `Control.Applicative.Const` and just doing a lookup.-{-# RULES-"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m- #-}-#if MIN_VERSION_base(4,8,0)--- base 4.8 and above include Data.Functor.Identity, so we can--- save a pretty decent amount of time by handling it specially.-{-# RULES-"alterF/Identity" forall k f . alterF f k = atKeyIdentity k f- #-}--atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)-atKeyIdentity k f t = Identity $ atKeyPlain Strict k (coerce f) t-{-# INLINABLE atKeyIdentity #-}-#endif-#endif--{---------------------------------------------------------------------  Indexing---------------------------------------------------------------------}---- | /O(log n)/. Update the element at /index/. Calls 'error' when an--- invalid index is used.------ > updateAt (\ _ _ -> Just "x") 0    (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]--- > updateAt (\ _ _ -> Just "x") 1    (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]--- > updateAt (\ _ _ -> Just "x") 2    (fromList [(5,"a"), (3,"b")])    Error: index out of range--- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range--- > updateAt (\_ _  -> Nothing)  0    (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--- > updateAt (\_ _  -> Nothing)  1    (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--- > updateAt (\_ _  -> Nothing)  2    (fromList [(5,"a"), (3,"b")])    Error: index out of range--- > updateAt (\_ _  -> Nothing)  (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range--updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a-updateAt f i t = i `seq`-  case t of-    Tip -> error "Map.updateAt: index out of range"-    Bin sx kx x l r -> case compare i sizeL of-      LT -> balanceR kx x (updateAt f i l) r-      GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)-      EQ -> case f kx x of-              Just x' -> x' `seq` Bin sx kx x' l r-              Nothing -> glue l r-      where-        sizeL = size l--{---------------------------------------------------------------------  Minimal, Maximal---------------------------------------------------------------------}---- | /O(log n)/. Update the value at the minimal key.------ > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]--- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMin :: (a -> Maybe a) -> Map k a -> Map k a-updateMin f m-  = updateMinWithKey (\_ x -> f x) m---- | /O(log n)/. Update the value at the maximal key.------ > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]--- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMax :: (a -> Maybe a) -> Map k a -> Map k a-updateMax f m-  = updateMaxWithKey (\_ x -> f x) m----- | /O(log n)/. Update the value at the minimal key.------ > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]--- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"--updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-updateMinWithKey _ Tip                 = Tip-updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of-                                           Nothing -> r-                                           Just x' -> x' `seq` Bin sx kx x' Tip r-updateMinWithKey f (Bin _ kx x l r)    = balanceR kx x (updateMinWithKey f l) r---- | /O(log n)/. Update the value at the maximal key.------ > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]--- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"--updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a-updateMaxWithKey _ Tip                 = Tip-updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of-                                           Nothing -> l-                                           Just x' -> x' `seq` Bin sx kx x' l Tip-updateMaxWithKey f (Bin _ kx x l r)    = balanceL kx x l (updateMaxWithKey f r)--{---------------------------------------------------------------------  Union.---------------------------------------------------------------------}---- | The union of a list of maps, with a combining operation:---   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).------ > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]--- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]--unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a-unionsWith f ts-  = Foldable.foldl' (unionWith f) empty ts-#if __GLASGOW_HASKELL__-{-# INLINABLE unionsWith #-}-#endif--{---------------------------------------------------------------------  Union with a combining function---------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. Union with a combining function.------ > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]--unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a-unionWith _f t1 Tip = t1-unionWith f t1 (Bin _ k x Tip Tip) = insertWithR f k x t1-unionWith f (Bin _ k x Tip Tip) t2 = insertWith f k x t2-unionWith _f Tip t2 = t2-unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of-  (l2, mb, r2) -> link k1 x1' (unionWith f l1 l2) (unionWith f r1 r2)-    where !x1' = maybe x1 (f x1) mb-#if __GLASGOW_HASKELL__-{-# INLINABLE unionWith #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/.--- Union with a combining function.------ > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]--unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a-unionWithKey _f t1 Tip = t1-unionWithKey f t1 (Bin _ k x Tip Tip) = insertWithKeyR f k x t1-unionWithKey f (Bin _ k x Tip Tip) t2 = insertWithKey f k x t2-unionWithKey _f Tip t2 = t2-unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of-  (l2, mb, r2) -> link k1 x1' (unionWithKey f l1 l2) (unionWithKey f r1 r2)-    where !x1' = maybe x1 (f k1 x1) mb-#if __GLASGOW_HASKELL__-{-# INLINABLE unionWithKey #-}-#endif--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}---- | /O(n+m)/. Difference with a combining function.--- When two equal keys are--- encountered, the combining function is applied to the values of these keys.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@.------ > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing--- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])--- >     == singleton 3 "b:B"--differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a-differenceWith f = merge preserveMissing dropMissing (zipWithMaybeMatched $ \_ x1 x2 -> f x1 x2)-#if __GLASGOW_HASKELL__-{-# INLINABLE differenceWith #-}-#endif---- | /O(n+m)/. Difference with a combining function. When two equal keys are--- encountered, the combining function is applied to the key and both values.--- If it returns 'Nothing', the element is discarded (proper set difference). If--- it returns (@'Just' y@), the element is updated with a new value @y@.------ > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing--- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])--- >     == singleton 3 "3:b|B"--differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a-differenceWithKey f = merge preserveMissing dropMissing (zipWithMaybeMatched f)-#if __GLASGOW_HASKELL__-{-# INLINABLE differenceWithKey #-}-#endif---{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}---- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.------ > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"--intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c-intersectionWith _f Tip _ = Tip-intersectionWith _f _ Tip = Tip-intersectionWith f (Bin _ k x1 l1 r1) t2 = case mb of-    Just x2 -> let !x1' = f x1 x2 in link k x1' l1l2 r1r2-    Nothing -> link2 l1l2 r1r2-  where-    !(l2, mb, r2) = splitLookup k t2-    !l1l2 = intersectionWith f l1 l2-    !r1r2 = intersectionWith f r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE intersectionWith #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. Intersection with a combining function.------ > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar--- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"--intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c-intersectionWithKey _f Tip _ = Tip-intersectionWithKey _f _ Tip = Tip-intersectionWithKey f (Bin _ k x1 l1 r1) t2 = case mb of-    Just x2 -> let !x1' = f k x1 x2 in link k x1' l1l2 r1r2-    Nothing -> link2 l1l2 r1r2-  where-    !(l2, mb, r2) = splitLookup k t2-    !l1l2 = intersectionWithKey f l1 l2-    !r1r2 = intersectionWithKey f r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE intersectionWithKey #-}-#endif---- | Map covariantly over a @'WhenMissing' f k x@.-mapWhenMissing :: Functor f => (a -> b) -> WhenMissing f k x a -> WhenMissing f k x b-mapWhenMissing f q = WhenMissing-  { missingSubtree = fmap (map f) . missingSubtree q-  , missingKey = \k x -> fmap (forceMaybe . fmap f) $ missingKey q k x}---- | Map covariantly over a @'WhenMatched' f k x y@.-mapWhenMatched :: Functor f => (a -> b) -> WhenMatched f k x y a -> WhenMatched f k x y b-mapWhenMatched f q = WhenMatched-  { matchedKey = \k x y -> fmap (forceMaybe . fmap f) $ runWhenMatched q k x y }---- | When a key is found in both maps, apply a function to the--- key and values and maybe use the result in the merged map.------ @--- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)---                     -> SimpleWhenMatched k x y z--- @-zipWithMaybeMatched :: Applicative f-                    => (k -> x -> y -> Maybe z)-                    -> WhenMatched f k x y z-zipWithMaybeMatched f = WhenMatched $-  \k x y -> pure $! forceMaybe $! 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.-zipWithMaybeAMatched :: Applicative f-                     => (k -> x -> y -> f (Maybe z))-                     -> WhenMatched f k x y z-zipWithMaybeAMatched f = WhenMatched $-  \ k x y -> forceMaybe <$> f k x y-{-# INLINE zipWithMaybeAMatched #-}---- | 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.-zipWithAMatched :: Applicative f-                => (k -> x -> y -> f z)-                -> WhenMatched f k x y z-zipWithAMatched f = WhenMatched $-  \ k x y -> (Just $!) <$> f k x y-{-# INLINE zipWithAMatched #-}---- | When a key is found in both maps, apply a function to the--- key and values and use the result in the merged map.------ @--- zipWithMatched :: (k -> x -> y -> z)---                -> SimpleWhenMatched k x y z--- @-zipWithMatched :: Applicative f-               => (k -> x -> y -> z) -> WhenMatched f k x y z-zipWithMatched f = WhenMatched $-  \k x y -> pure $! Just $! f k x y-{-# INLINE zipWithMatched #-}---- | Map over the entries whose keys are missing from the other map,--- optionally removing some. This is the most powerful 'SimpleWhenMissing'--- tactic, but others are usually more efficient.------ @--- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y--- @------ prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))------ but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.-mapMaybeMissing :: Applicative f => (k -> x -> Maybe y) -> WhenMissing f k x y-mapMaybeMissing f = WhenMissing-  { missingSubtree = \m -> pure $! mapMaybeWithKey f m-  , missingKey = \k x -> pure $! forceMaybe $! f k x }-{-# INLINE mapMaybeMissing #-}---- | Map over the entries whose keys are missing from the other map.------ @--- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y--- @------ prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)------ but @mapMissing@ is somewhat faster.-mapMissing :: Applicative f => (k -> x -> y) -> WhenMissing f k x y-mapMissing f = WhenMissing-  { missingSubtree = \m -> pure $! mapWithKey f m-  , missingKey = \k x -> pure $! Just $! f k x }-{-# INLINE mapMissing #-}---- | 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.-traverseMaybeMissing :: Applicative f-                     => (k -> x -> f (Maybe y)) -> WhenMissing f k x y-traverseMaybeMissing f = WhenMissing-  { missingSubtree = traverseMaybeWithKey f-  , missingKey = \k x -> forceMaybe <$> f k x }-{-# INLINE traverseMaybeMissing #-}---- | Traverse over the entries whose keys are missing from the other map.-traverseMissing :: Applicative f-                     => (k -> x -> f y) -> WhenMissing f k x y-traverseMissing f = WhenMissing-  { missingSubtree = traverseWithKey f-  , missingKey = \k x -> (Just $!) <$> f k x }-{-# INLINE traverseMissing #-}--forceMaybe :: Maybe a -> Maybe a-forceMaybe Nothing = Nothing-forceMaybe m@(Just !_) = m-{-# INLINE forceMaybe #-}--{---------------------------------------------------------------------  MergeWithKey---------------------------------------------------------------------}---- | /O(n+m)/. An unsafe universal combining function.------ WARNING: This function can produce corrupt maps and its results--- may depend on the internal structures of its inputs. Users should--- prefer 'Data.Map.Merge.Strict.merge' or--- 'Data.Map.Merge.Strict.mergeA'.------ When 'mergeWithKey' is given three arguments, it is inlined to the call--- site. You should therefore use 'mergeWithKey' only to define custom--- combining functions. For example, you could define 'unionWithKey',--- 'differenceWithKey' and 'intersectionWithKey' as------ > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2--- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2--- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2------ When calling @'mergeWithKey' combine only1 only2@, a function combining two--- 'Map's is created, such that------ * if a key is present in both maps, it is passed with both corresponding---   values to the @combine@ function. Depending on the result, the key is either---   present in the result with specified value, or is left out;------ * a nonempty subtree present only in the first map is passed to @only1@ and---   the output is added to the result;------ * a nonempty subtree present only in the second map is passed to @only2@ and---   the output is added to the result.------ The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.--- The values can be modified arbitrarily. Most common variants of @only1@ and--- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or--- @'filterWithKey' f@ could be used for any @f@.--mergeWithKey :: Ord k-             => (k -> a -> b -> Maybe c)-             -> (Map k a -> Map k c)-             -> (Map k b -> Map k c)-             -> Map k a -> Map k b -> Map k c-mergeWithKey f g1 g2 = go-  where-    go Tip t2 = g2 t2-    go t1 Tip = g1 t1-    go (Bin _ kx x l1 r1) t2 =-      case found of-        Nothing -> case g1 (singleton kx x) of-                     Tip -> link2 l' r'-                     (Bin _ _ x' Tip Tip) -> link kx x' l' r'-                     _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"-        Just x2 -> case f kx x x2 of-                     Nothing -> link2 l' r'-                     Just x' -> link kx x' l' r'-      where-        (l2, found, r2) = splitLookup kx t2-        l' = go l1 l2-        r' = go r1 r2-{-# INLINE mergeWithKey #-}--{---------------------------------------------------------------------  Filter and partition---------------------------------------------------------------------}---- | /O(n)/. Map values and collect the 'Just' results.------ > let f x = if x == "a" then Just "new a" else Nothing--- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"--mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b-mapMaybe f = mapMaybeWithKey (\_ x -> f x)---- | /O(n)/. Map keys\/values and collect the 'Just' results.------ > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing--- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"--mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b-mapMaybeWithKey _ Tip = Tip-mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of-  Just y  -> y `seq` link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)-  Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r)---- | /O(n)/. Traverse keys\/values and collect the 'Just' results.------ @since 0.5.8--traverseMaybeWithKey :: Applicative f-                     => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)-traverseMaybeWithKey = go-  where-    go _ Tip = pure Tip-    go f (Bin _ kx x Tip Tip) = maybe Tip (\ !x' -> Bin 1 kx x' Tip Tip) <$> f kx x-    go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r)-      where-        combine !l' mx !r' = case mx of-          Nothing -> link2 l' r'-          Just !x' -> link kx x' l' r'---- | /O(n)/. Map values and separate the 'Left' and 'Right' results.------ > let f a = if a < "c" then Left a else Right a--- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])--- >--- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)-mapEither f m-  = mapEitherWithKey (\_ x -> f x) m---- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.------ > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])--- >--- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])--- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])--mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)-mapEitherWithKey f0 t0 = toPair $ go f0 t0-  where-    go _ Tip = (Tip :*: Tip)-    go f (Bin _ kx x l r) = case f kx x of-      Left y  -> y `seq` (link kx y l1 r1 :*: link2 l2 r2)-      Right z -> z `seq` (link2 l1 r1 :*: link kx z l2 r2)-     where-        (l1 :*: l2) = go f l-        (r1 :*: r2) = go f r--{---------------------------------------------------------------------  Mapping---------------------------------------------------------------------}--- | /O(n)/. Map a function over all values in the map.------ > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]--map :: (a -> b) -> Map k a -> Map k b-map f = go-  where-    go Tip = Tip-    go (Bin sx kx x l r) = let !x' = f x in Bin sx kx x' (go l) (go r)--- We use `go` to let `map` inline. This is important if `f` is a constant--- function.--#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 :: (k -> a -> b) -> Map k a -> Map k b-mapWithKey _ Tip = Tip-mapWithKey f (Bin sx kx x l r) =-  let x' = f kx x-  in x' `seq` Bin sx kx x' (mapWithKey f l) (mapWithKey f r)--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] mapWithKey #-}-{-# RULES-"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =-  mapWithKey (\k a -> f k $! g k a) xs-"mapWithKey/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 m == 'fromList' <$> 'traverse' (\(k, v) -> (\v' -> v' \`seq\` (k,v')) <$> f k v) ('toList' m)@--- That is, it behaves much like a regular 'traverse' except that the traversing--- function also has access to the key associated with a value and the values are--- forced before they are installed in the result map.------ > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])--- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing-traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)-traverseWithKey f = go-  where-    go Tip = pure Tip-    go (Bin 1 k v _ _) = (\ !v' -> Bin 1 k v' Tip Tip) <$> f k v-    go (Bin s k v l r) = liftA3 (\ l' !v' r' -> Bin s k v' l' r') (go l) (f k v) (go r)-{-# INLINE traverseWithKey #-}---- | /O(n)/. The function 'mapAccum' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a b = (a ++ b, b ++ "X")--- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])--mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccum f a m-  = mapAccumWithKey (\a' _ x' -> f a' x') a m---- | /O(n)/. The function 'mapAccumWithKey' threads an accumulating--- argument through the map in ascending order of keys.------ > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])--mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumWithKey f a t-  = mapAccumL f a t---- | /O(n)/. The function 'mapAccumL' threads an accumulating--- argument through the map in ascending order of keys.-mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumL _ a Tip               = (a,Tip)-mapAccumL f a (Bin sx kx x l r) =-  let (a1,l') = mapAccumL f a l-      (a2,x') = f a1 kx x-      (a3,r') = mapAccumL f a2 r-  in x' `seq` (a3,Bin sx kx x' l' r')---- | /O(n)/. The function 'mapAccumR' threads an accumulating--- argument through the map in descending order of keys.-mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)-mapAccumRWithKey _ a Tip = (a,Tip)-mapAccumRWithKey f a (Bin sx kx x l r) =-  let (a1,r') = mapAccumRWithKey f a r-      (a2,x') = f a1 kx x-      (a3,l') = mapAccumRWithKey f a2 l-  in x' `seq` (a3,Bin sx kx x' l' r')---- | /O(n*log n)/.--- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.------ The size of the result may be smaller if @f@ maps two or more distinct--- keys to the same new key.  In this case the associated values will be--- combined using @c@. The value at the greater of the two original keys--- is used as the first argument to @c@.------ > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"--- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"--mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a-mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []-#if __GLASGOW_HASKELL__-{-# INLINABLE mapKeysWith #-}-#endif--{---------------------------------------------------------------------  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.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]--- > fromSet undefined Data.Set.empty == empty--fromSet :: (k -> a) -> Set.Set k -> Map k a-fromSet _ Set.Tip = Tip-fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r)--{---------------------------------------------------------------------  Lists-  use [foldlStrict] to reduce demand on the control-stack---------------------------------------------------------------------}--- | /O(n*log n)/. Build a map from a list of key\/value pairs. See also 'fromAscList'.--- If the list contains more than one value for the same key, the last value--- for the key is retained.------ If the keys of the list are ordered, linear-time implementation is used,--- with the performance equal to 'fromDistinctAscList'.------ > fromList [] == empty--- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]--- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]---- For some reason, when 'singleton' is used in fromList or in--- create, it is not inlined, so we inline it manually.-fromList :: Ord k => [(k,a)] -> Map k a-fromList [] = Tip-fromList [(kx, x)] = x `seq` Bin 1 kx x Tip Tip-fromList ((kx0, x0) : xs0) | not_ordered kx0 xs0 = x0 `seq` fromList' (Bin 1 kx0 x0 Tip Tip) xs0-                           | otherwise = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0-  where-    not_ordered _ [] = False-    not_ordered kx ((ky,_) : _) = kx >= ky-    {-# INLINE not_ordered #-}--    fromList' t0 xs = Foldable.foldl' ins t0 xs-      where ins t (k,x) = insert k x t--    go !_ t [] = t-    go _ t [(kx, x)] = x `seq` insertMax kx x t-    go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs-                              | otherwise = case create s xss of-                                  (r, ys, []) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys-                                  (r, _,  ys) -> x `seq` fromList' (link kx x l r) ys--    -- The create is returning a triple (tree, xs, ys). Both xs and ys-    -- represent not yet processed elements and only one of them can be nonempty.-    -- If ys is nonempty, the keys in ys are not ordered with respect to tree-    -- and must be inserted using fromList'. Otherwise the keys have been-    -- ordered so far.-    create !_ [] = (Tip, [], [])-    create s xs@(xp : xss)-      | s == 1 = case xp of (kx, x) | not_ordered kx xss -> x `seq` (Bin 1 kx x Tip Tip, [], xss)-                                    | otherwise -> x `seq` (Bin 1 kx x Tip Tip, xss, [])-      | otherwise = case create (s `shiftR` 1) xs of-                      res@(_, [], _) -> res-                      (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs)-                      (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys)-                                               | otherwise -> case create (s `shiftR` 1) yss of-                                                   (r, zs, ws) -> y `seq` (link ky y l r, zs, ws)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromList #-}-#endif---- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.------ > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]--- > fromListWith (++) [] == empty--fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a-fromListWith f xs-  = fromListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromListWith #-}-#endif---- | /O(n*log n)/. Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.------ > let f k a1 a2 = (show k) ++ a1 ++ a2--- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "3ab"), (5, "5a5ba")]--- > fromListWithKey f [] == empty--fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromListWithKey f xs-  = Foldable.foldl' ins empty xs-  where-    ins t (k,x) = insertWithKey f k x t-#if __GLASGOW_HASKELL__-{-# INLINABLE fromListWithKey #-}-#endif--{---------------------------------------------------------------------  Building trees from ascending/descending lists can be done in linear time.--  Note that if [xs] is ascending then:-    fromAscList xs       == fromList xs-    fromAscListWith f xs == fromListWith f xs--  If [xs] is descending then:-    fromDescList xs       == fromList xs-    fromDescListWith f xs == fromListWith f xs---------------------------------------------------------------------}---- | /O(n)/. Build a map from an ascending list in linear time.--- /The precondition (input list is ascending) is not checked./------ > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]--- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]--- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True--- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False-fromAscList :: Eq k => [(k,a)] -> Map k a-fromAscList xs-  = fromAscListWithKey (\_ x _ -> x) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscList #-}-#endif---- | /O(n)/. Build a map from a descending list in linear time.--- /The precondition (input list is descending) is not checked./------ > fromDescList [(5,"a"), (3,"b")]          == fromList [(3, "b"), (5, "a")]--- > fromDescList [(5,"a"), (5,"b"), (3,"a")] == fromList [(3, "b"), (5, "b")]--- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True--- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False-fromDescList :: Eq k => [(k,a)] -> Map k a-fromDescList xs-  = fromDescListWithKey (\_ x _ -> x) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescList #-}-#endif---- | /O(n)/. Build a map from an ascending list in linear time with a combining function for equal keys.--- /The precondition (input list is ascending) is not checked./------ > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]--- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True--- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False--fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a-fromAscListWith f xs-  = fromAscListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscListWith #-}-#endif---- | /O(n)/. Build a map from a descending list in linear time with a combining function for equal keys.--- /The precondition (input list is descending) is not checked./------ > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")]--- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True--- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False--fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a-fromDescListWith f xs-  = fromDescListWithKey (\_ x y -> f x y) xs-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescListWith #-}-#endif---- | /O(n)/. Build a map from an ascending list in linear time with a--- combining function for equal keys.--- /The precondition (input list is ascending) is not checked./------ > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2--- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]--- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True--- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False--fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromAscListWithKey f xs-  = fromDistinctAscList (combineEq f xs)-  where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq _ xs'-    = case xs' of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,zz) (x@(kx,xx):xs')-    | kx==kz    = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'-    | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscListWithKey #-}-#endif---- | /O(n)/. Build a map from a descending list in linear time with a--- combining function for equal keys.--- /The precondition (input list is descending) is not checked./------ > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2--- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]--- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True--- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False--fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a-fromDescListWithKey f xs-  = fromDistinctDescList (combineEq f xs)-  where-  -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]-  combineEq _ xs'-    = case xs' of-        []     -> []-        [x]    -> [x]-        (x:xx) -> combineEq' x xx--  combineEq' z [] = [z]-  combineEq' z@(kz,zz) (x@(kx,xx):xs')-    | kx==kz    = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs'-    | otherwise = z:combineEq' x xs'-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescListWithKey #-}-#endif---- | /O(n)/. Build a map from an ascending list of distinct elements in linear time.--- /The precondition is not checked./------ > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]--- > valid (fromDistinctAscList [(3,"b"), (5,"a")])          == True--- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False---- For some reason, when 'singleton' is used in fromDistinctAscList or in--- create, it is not inlined, so we inline it manually.-fromDistinctAscList :: [(k,a)] -> Map k a-fromDistinctAscList [] = Tip-fromDistinctAscList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0-  where-    go !_ t [] = t-    go s l ((kx, x) : xs) =-      case create s xs of-        (r :*: ys) -> x `seq` let !t' = link kx x l r-                           in go (s `shiftL` 1) t' ys--    create !_ [] = (Tip :*: [])-    create s xs@(x' : xs')-      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs')-      | otherwise = case create (s `shiftR` 1) xs of-                      res@(_ :*: []) -> res-                      (l :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of-                        (r :*: zs) -> y `seq` (link ky y l r :*: zs)---- | /O(n)/. Build a map from a descending list of distinct elements in linear time.--- /The precondition is not checked./------ > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]--- > valid (fromDistinctDescList [(5,"a"), (3,"b")])          == True--- > valid (fromDistinctDescList [(5,"a"), (3,"b"), (3,"a")]) == False---- For some reason, when 'singleton' is used in fromDistinctDescList or in--- create, it is not inlined, so we inline it manually.-fromDistinctDescList :: [(k,a)] -> Map k a-fromDistinctDescList [] = Tip-fromDistinctDescList ((kx0, x0) : xs0) = x0 `seq` go (1::Int) (Bin 1 kx0 x0 Tip Tip) xs0-  where-    go !_ t [] = t-    go s r ((kx, x) : xs) =-      case create s xs of-        (l :*: ys) -> x `seq` let !t' = link kx x l r-                              in go (s `shiftL` 1) t' ys--    create !_ [] = (Tip :*: [])-    create s xs@(x' : xs')-      | s == 1 = case x' of (kx, x) -> x `seq` (Bin 1 kx x Tip Tip :*: xs')-      | otherwise = case create (s `shiftR` 1) xs of-                      res@(_ :*: []) -> res-                      (r :*: (ky, y):ys) -> case create (s `shiftR` 1) ys of-                        (l :*: zs) -> y `seq` (link ky y l r :*: zs)
− Data/Sequence.hs 
@@ -1,302 +0,0 @@-{-# LANGUAGE CPP #-}-#ifdef __HADDOCK_VERSION__-{-# OPTIONS_GHC -Wno-unused-imports #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.Sequence--- Copyright   :  (c) Ross Paterson 2005---                (c) Louis Wasserman 2009---                (c) Bertram Felgenhauer, David Feuer, Ross Paterson, and---                    Milan Straka 2014--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ = Finite sequences------ The @'Seq' a@ type represents a finite sequence of values of--- type @a@.------ Sequences generally behave very much like lists.------ * The class instances for sequences are all based very closely on those for--- lists.------ * Many functions in this module have the same names as functions in--- the "Prelude" or in "Data.List". In almost all cases, these functions--- behave analogously. For example, 'filter' filters a sequence in exactly the--- same way that @"Prelude".'Prelude.filter'@ filters a list. The only major--- exception is the 'lookup' function, which is based on the function by--- that name in "Data.IntMap" rather than the one in "Prelude".------ There are two major differences between sequences and lists:------ * Sequences support a wider variety of efficient operations than--- do lists. Notably, they offer------     * Constant-time access to both the front and the rear with---     '<|', '|>', 'viewl', 'viewr'. For recent GHC versions, this can---     be done more conveniently using the bidirectional patterns 'Empty',---     ':<|', and ':|>'. See the detailed explanation in the \"Pattern synonyms\"---     section.---     * Logarithmic-time concatenation with '><'---     * Logarithmic-time splitting with 'splitAt', 'take' and 'drop'---     * Logarithmic-time access to any element with---     'lookup', '!?', 'index', 'insertAt', 'deleteAt', 'adjust'', and 'update'------   Note that sequences are typically /slower/ than lists when using only---   operations for which they have the same big-\(O\) complexity: sequences---   make rather mediocre stacks!------ * Whereas lists can be either finite or infinite, sequences are--- always finite. As a result, a sequence is strict in its--- length. Ignoring efficiency, you can imagine that 'Seq' is defined------     @ data Seq a = Empty | a :<| !(Seq a) @------     This means that many operations on sequences are stricter than---     those on lists. For example,------     @ (1 : undefined) !! 0 = 1 @------     but------     @ (1 :<| undefined) ``index`` 0 = undefined @------ Sequences may also be compared to immutable--- [arrays](https://hackage.haskell.org/package/array)--- or [vectors](https://hackage.haskell.org/package/vector).--- Like these structures, sequences support fast indexing,--- although not as fast. But editing an immutable array or vector,--- or combining it with another, generally requires copying the--- entire structure; sequences generally avoid that, copying only--- the portion that has changed.------ == Detailed performance information------ An amortized running time is given for each operation, with /n/ referring--- to the length of the sequence and /i/ being the integral index used by--- some operations. These bounds hold even in a persistent (shared) setting.------ Despite sequences being structurally strict from a semantic standpoint,--- they are in fact implemented using laziness internally. As a result,--- many operations can be performed /incrementally/, producing their results--- as they are demanded. This greatly improves performance in some cases. These--- functions include------ * The 'Functor' methods 'fmap' and '<$', along with 'mapWithIndex'--- * The 'Applicative' methods '<*>', '*>', and '<*'--- * The zips: 'zipWith', 'zip', etc.--- * 'heads' and 'tails'--- * 'fromFunction', 'replicate', 'intersperse', and 'cycleTaking'--- * 'reverse'--- * 'chunksOf'------ Note that the 'Monad' method, '>>=', is not particularly lazy. It will--- take time proportional to the sum of the logarithms of the individual--- result sequences to produce anything whatsoever.------ Several functions take special advantage of sharing to produce--- results using much less time and memory than one might expect. These--- are documented individually for functions, but also include the--- methods '<$' and '*>', each of which take time and space proportional--- to the logarithm of the size of the result.------ == Warning------ The size of a 'Seq' must not exceed @maxBound::Int@. Violation--- of this condition is not detected and if the size limit is exceeded, the--- behaviour of the sequence is undefined. This is unlikely to occur in most--- applications, but some care may be required when using '><', '<*>', '*>', or--- '>>', particularly repeatedly and particularly in combination with--- 'replicate' or 'fromFunction'.------ == Implementation------ The implementation uses 2-3 finger trees annotated with sizes,--- as described in section 4.2 of------    * Ralf Hinze and Ross Paterson,---      [\"Finger trees: a simple general-purpose data structure\"]---      (http://staff.city.ac.uk/~ross/papers/FingerTree.html),---      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.------------------------------------------------------------------------------------module Data.Sequence (-    -- * Finite sequences-#if defined(DEFINE_PATTERN_SYNONYMS)-    Seq (Empty, (:<|), (:|>)),-    -- $patterns-#else-    Seq,-#endif-    -- * Construction-    empty,          -- :: Seq a-    singleton,      -- :: a -> Seq a-    (<|),           -- :: a -> Seq a -> Seq a-    (|>),           -- :: Seq a -> a -> Seq a-    (><),           -- :: Seq a -> Seq a -> Seq a-    fromList,       -- :: [a] -> Seq a-    fromFunction,   -- :: Int -> (Int -> a) -> Seq a-    fromArray,      -- :: Ix i => Array i a -> Seq a-    -- ** Repetition-    replicate,      -- :: Int -> a -> Seq a-    replicateA,     -- :: Applicative f => Int -> f a -> f (Seq a)-    replicateM,     -- :: Applicative m => Int -> m a -> m (Seq a)-    cycleTaking,    -- :: Int -> Seq a -> Seq a-    -- ** Iterative construction-    iterateN,       -- :: Int -> (a -> a) -> a -> Seq a-    unfoldr,        -- :: (b -> Maybe (a, b)) -> b -> Seq a-    unfoldl,        -- :: (b -> Maybe (b, a)) -> b -> Seq a-    -- * Deconstruction-    -- | Additional functions for deconstructing sequences are available-    -- via the 'Foldable' instance of 'Seq'.--    -- ** Queries-    null,           -- :: Seq a -> Bool-    length,         -- :: Seq a -> Int-    -- ** Views-    ViewL(..),-    viewl,          -- :: Seq a -> ViewL a-    ViewR(..),-    viewr,          -- :: Seq a -> ViewR a-    -- * Scans-    scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a-    scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a-    scanr,          -- :: (a -> b -> b) -> b -> Seq a -> Seq b-    scanr1,         -- :: (a -> a -> a) -> Seq a -> Seq a-    -- * Sublists-    tails,          -- :: Seq a -> Seq (Seq a)-    inits,          -- :: Seq a -> Seq (Seq a)-    chunksOf,       -- :: Int -> Seq a -> Seq (Seq a)-    -- ** Sequential searches-    takeWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a-    takeWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a-    dropWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a-    dropWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a-    spanl,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-    spanr,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-    breakl,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-    breakr,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-    partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-    filter,         -- :: (a -> Bool) -> Seq a -> Seq a-    -- * Sorting-    sort,           -- :: Ord a => Seq a -> Seq a-    sortBy,         -- :: (a -> a -> Ordering) -> Seq a -> Seq a-    sortOn,         -- :: Ord b => (a -> b) -> Seq a -> Seq a-    unstableSort,   -- :: Ord a => Seq a -> Seq a-    unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a-    unstableSortOn, -- :: Ord b => (a -> b) -> Seq a -> Seq a-    -- * Indexing-    lookup,         -- :: Int -> Seq a -> Maybe a-    (!?),           -- :: Seq a -> Int -> Maybe a-    index,          -- :: Seq a -> Int -> a-    adjust,         -- :: (a -> a) -> Int -> Seq a -> Seq a-    adjust',        -- :: (a -> a) -> Int -> Seq a -> Seq a-    update,         -- :: Int -> a -> Seq a -> Seq a-    take,           -- :: Int -> Seq a -> Seq a-    drop,           -- :: Int -> Seq a -> Seq a-    insertAt,       -- :: Int -> a -> Seq a -> Seq a-    deleteAt,       -- :: Int -> Seq a -> Seq a-    splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)-    -- ** Indexing with predicates-    -- | These functions perform sequential searches from the left-    -- or right ends of the sequence, returning indices of matching-    -- elements.-    elemIndexL,     -- :: Eq a => a -> Seq a -> Maybe Int-    elemIndicesL,   -- :: Eq a => a -> Seq a -> [Int]-    elemIndexR,     -- :: Eq a => a -> Seq a -> Maybe Int-    elemIndicesR,   -- :: Eq a => a -> Seq a -> [Int]-    findIndexL,     -- :: (a -> Bool) -> Seq a -> Maybe Int-    findIndicesL,   -- :: (a -> Bool) -> Seq a -> [Int]-    findIndexR,     -- :: (a -> Bool) -> Seq a -> Maybe Int-    findIndicesR,   -- :: (a -> Bool) -> Seq a -> [Int]-    -- * Folds-    -- | General folds are available via the 'Foldable' instance of 'Seq'.-    foldMapWithIndex, -- :: Monoid m => (Int -> a -> m) -> Seq a -> m-    foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b-    foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b-    -- * Transformations-    mapWithIndex,   -- :: (Int -> a -> b) -> Seq a -> Seq b-    traverseWithIndex, -- :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)-    reverse,        -- :: Seq a -> Seq a-    intersperse,    -- :: a -> Seq a -> Seq a-    -- ** Zips and unzip-    zip,            -- :: Seq a -> Seq b -> Seq (a, b)-    zipWith,        -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-    zip3,           -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)-    zipWith3,       -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-    zip4,           -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)-    zipWith4,       -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e-    unzip,          -- :: Seq (a, b) -> (Seq a, Seq b)-    unzipWith       -- :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)-    ) where--import Data.Sequence.Internal-import Data.Sequence.Internal.Sorting-import Prelude ()-#ifdef __HADDOCK_VERSION__-import Control.Monad (Monad (..))-import Control.Applicative (Applicative (..))-import Data.Functor (Functor (..))-#endif--{- $patterns--== Pattern synonyms--Much like lists can be constructed and matched using the-@:@ and @[]@ constructors, sequences can be constructed and-matched using the 'Empty', ':<|', and ':|>' pattern synonyms.--=== Note--These patterns are only available with GHC version 8.0 or later,-and version 8.2 works better with them. When writing for such recent-versions of GHC, the patterns can be used in place of 'empty',-'<|', '|>', 'viewl', and 'viewr'.--=== __Pattern synonym examples__--Import the patterns:--@-import Data.Sequence (Seq (..))-@--Look at the first three elements of a sequence--@-getFirst3 :: Seq a -> Maybe (a,a,a)-getFirst3 (x1 :<| x2 :<| x3 :<| _xs) = Just (x1,x2,x3)-getFirst3 _ = Nothing-@--@-\> getFirst3 ('fromList' [1,2,3,4]) = Just (1,2,3)-\> getFirst3 ('fromList' [1,2]) = Nothing-@--Move the last two elements from the end of the first list-onto the beginning of the second one.--@-shift2Right :: Seq a -> Seq a -> (Seq a, Seq a)-shift2Right Empty ys = (Empty, ys)-shift2Right (Empty :|> x) ys = (Empty, x :<| ys)-shift2Right (xs :|> x1 :|> x2) = (xs, x1 :<| x2 :<| ys)-@--@-\> shift2Right ('fromList' []) ('fromList' [10]) = ('fromList' [], 'fromList' [10])-\> shift2Right ('fromList' [9]) ('fromList' [10]) = ('fromList' [], 'fromList' [9,10])-\> shift2Right ('fromList' [8,9]) ('fromList' [10]) = ('fromList' [], 'fromList' [8,9,10])-\> shift2Right ('fromList' [7,8,9]) ('fromList' [10]) = ('fromList' [7], 'fromList' [8,9,10])-@--}
− Data/Sequence/Internal.hs 
@@ -1,4634 +0,0 @@-{-# LANGUAGE CPP #-}-#include "containers.h"-{-# LANGUAGE BangPatterns #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Trustworthy #-}-#endif-#ifdef DEFINE_PATTERN_SYNONYMS-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-}-#endif-{-# LANGUAGE PatternGuards #-}--{-# OPTIONS_HADDOCK not-home #-}---------------------------------------------------------------------------------- |--- Module      :  Data.Sequence.Internal--- Copyright   :  (c) Ross Paterson 2005---                (c) Louis Wasserman 2009---                (c) Bertram Felgenhauer, David Feuer, Ross Paterson, and---                    Milan Straka 2014--- 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------ General purpose finite sequences.--- Apart from being finite and having strict operations, sequences--- also differ from lists in supporting a wider variety of operations--- efficiently.------ An amortized running time is given for each operation, with \( n \) referring--- to the length of the sequence and \( i \) being the integral index used by--- some operations. These bounds hold even in a persistent (shared) setting.------ The implementation uses 2-3 finger trees annotated with sizes,--- as described in section 4.2 of------    * Ralf Hinze and Ross Paterson,---      \"Finger trees: a simple general-purpose data structure\",---      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.---      <http://staff.city.ac.uk/~ross/papers/FingerTree.html>------ /Note/: Many of these operations have the same names as similar--- operations on lists in the "Prelude". The ambiguity may be resolved--- using either qualification or the @hiding@ clause.------ /Warning/: The size of a 'Seq' must not exceed @maxBound::Int@.  Violation--- of this condition is not detected and if the size limit is exceeded, the--- behaviour of the sequence is undefined.  This is unlikely to occur in most--- applications, but some care may be required when using '><', '<*>', '*>', or--- '>>', particularly repeatedly and particularly in combination with--- 'replicate' or 'fromFunction'.------ @since 0.5.9--------------------------------------------------------------------------------module Data.Sequence.Internal (-    Elem(..), FingerTree(..), Node(..), Digit(..), Sized(..), MaybeForce,-#if defined(DEFINE_PATTERN_SYNONYMS)-    Seq (.., Empty, (:<|), (:|>)),-#else-    Seq (..),-#endif-    State(..),-    execState,-    foldDigit,-    foldNode,-    foldWithIndexDigit,-    foldWithIndexNode,--    -- * Construction-    empty,          -- :: Seq a-    singleton,      -- :: a -> Seq a-    (<|),           -- :: a -> Seq a -> Seq a-    (|>),           -- :: Seq a -> a -> Seq a-    (><),           -- :: Seq a -> Seq a -> Seq a-    fromList,       -- :: [a] -> Seq a-    fromFunction,   -- :: Int -> (Int -> a) -> Seq a-    fromArray,      -- :: Ix i => Array i a -> Seq a-    -- ** Repetition-    replicate,      -- :: Int -> a -> Seq a-    replicateA,     -- :: Applicative f => Int -> f a -> f (Seq a)-    replicateM,     -- :: Applicative m => Int -> m a -> m (Seq a)-    cycleTaking,    -- :: Int -> Seq a -> Seq a-    -- ** Iterative construction-    iterateN,       -- :: Int -> (a -> a) -> a -> Seq a-    unfoldr,        -- :: (b -> Maybe (a, b)) -> b -> Seq a-    unfoldl,        -- :: (b -> Maybe (b, a)) -> b -> Seq a-    -- * Deconstruction-    -- | Additional functions for deconstructing sequences are available-    -- via the 'Foldable' instance of 'Seq'.--    -- ** Queries-    null,           -- :: Seq a -> Bool-    length,         -- :: Seq a -> Int-    -- ** Views-    ViewL(..),-    viewl,          -- :: Seq a -> ViewL a-    ViewR(..),-    viewr,          -- :: Seq a -> ViewR a-    -- * Scans-    scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a-    scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a-    scanr,          -- :: (a -> b -> b) -> b -> Seq a -> Seq b-    scanr1,         -- :: (a -> a -> a) -> Seq a -> Seq a-    -- * Sublists-    tails,          -- :: Seq a -> Seq (Seq a)-    inits,          -- :: Seq a -> Seq (Seq a)-    chunksOf,       -- :: Int -> Seq a -> Seq (Seq a)-    -- ** Sequential searches-    takeWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a-    takeWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a-    dropWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a-    dropWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a-    spanl,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-    spanr,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-    breakl,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-    breakr,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-    partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-    filter,         -- :: (a -> Bool) -> Seq a -> Seq a-    -- * Indexing-    lookup,         -- :: Int -> Seq a -> Maybe a-    (!?),           -- :: Seq a -> Int -> Maybe a-    index,          -- :: Seq a -> Int -> a-    adjust,         -- :: (a -> a) -> Int -> Seq a -> Seq a-    adjust',        -- :: (a -> a) -> Int -> Seq a -> Seq a-    update,         -- :: Int -> a -> Seq a -> Seq a-    take,           -- :: Int -> Seq a -> Seq a-    drop,           -- :: Int -> Seq a -> Seq a-    insertAt,       -- :: Int -> a -> Seq a -> Seq a-    deleteAt,       -- :: Int -> Seq a -> Seq a-    splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)-    -- ** Indexing with predicates-    -- | These functions perform sequential searches from the left-    -- or right ends of the sequence, returning indices of matching-    -- elements.-    elemIndexL,     -- :: Eq a => a -> Seq a -> Maybe Int-    elemIndicesL,   -- :: Eq a => a -> Seq a -> [Int]-    elemIndexR,     -- :: Eq a => a -> Seq a -> Maybe Int-    elemIndicesR,   -- :: Eq a => a -> Seq a -> [Int]-    findIndexL,     -- :: (a -> Bool) -> Seq a -> Maybe Int-    findIndicesL,   -- :: (a -> Bool) -> Seq a -> [Int]-    findIndexR,     -- :: (a -> Bool) -> Seq a -> Maybe Int-    findIndicesR,   -- :: (a -> Bool) -> Seq a -> [Int]-    -- * Folds-    -- | General folds are available via the 'Foldable' instance of 'Seq'.-    foldMapWithIndex, -- :: Monoid m => (Int -> a -> m) -> Seq a -> m-    foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b-    foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b-    -- * Transformations-    mapWithIndex,   -- :: (Int -> a -> b) -> Seq a -> Seq b-    traverseWithIndex, -- :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)-    reverse,        -- :: Seq a -> Seq a-    intersperse,    -- :: a -> Seq a -> Seq a-    liftA2Seq,      -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-    -- ** Zips and unzips-    zip,            -- :: Seq a -> Seq b -> Seq (a, b)-    zipWith,        -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-    zip3,           -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)-    zipWith3,       -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-    zip4,           -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)-    zipWith4,       -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e-    unzip,          -- :: Seq (a, b) -> (Seq a, Seq b)-    unzipWith,      -- :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)-#ifdef TESTING-    deep,-    node2,-    node3,-#endif-    ) where--import Prelude hiding (-    Functor(..),-#if MIN_VERSION_base(4,11,0)-    (<>),-#endif-#if MIN_VERSION_base(4,8,0)-    Applicative, (<$>), foldMap, Monoid,-#endif-    null, length, lookup, take, drop, splitAt, foldl, foldl1, foldr, foldr1,-    scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,-    unzip, takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)-import qualified Data.List-import Control.Applicative (Applicative(..), (<$>), (<**>),  Alternative,-                            liftA2, liftA3)-import qualified Control.Applicative as Applicative-import Control.DeepSeq (NFData(rnf))-import Control.Monad (MonadPlus(..))-import Data.Monoid (Monoid(..))-import Data.Functor (Functor(..))-import Utils.Containers.Internal.State (State(..), execState)-import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr'), toList)--#if MIN_VERSION_base(4,9,0)-import qualified Data.Semigroup as Semigroup-import Data.Functor.Classes-#endif-import Data.Traversable-import Data.Typeable---- GHC specific stuff-#ifdef __GLASGOW_HASKELL__-import GHC.Exts (build)-import Text.Read (Lexeme(Ident), lexP, parens, prec,-    readPrec, readListPrec, readListPrecDefault)-import Data.Data-import Data.String (IsString(..))-#endif-#if __GLASGOW_HASKELL__-import GHC.Generics (Generic, Generic1)-#endif---- Array stuff, with GHC.Arr on GHC-import Data.Array (Ix, Array)-import qualified Data.Array-#ifdef __GLASGOW_HASKELL__-import qualified GHC.Arr-#endif--import Utils.Containers.Internal.Coercions ((.#), (.^#))--- Coercion on GHC 7.8+-#if __GLASGOW_HASKELL__ >= 708-import Data.Coerce-import qualified GHC.Exts-#else-#endif---- Identity functor on base 4.8 (GHC 7.10+)-#if MIN_VERSION_base(4,8,0)-import Data.Functor.Identity (Identity(..))-#endif--#if !MIN_VERSION_base(4,8,0)-import Data.Word (Word)-#endif--import Utils.Containers.Internal.StrictPair (StrictPair (..), toPair)-import Control.Monad.Zip (MonadZip (..))-import Control.Monad.Fix (MonadFix (..), fix)--default ()---- We define our own copy here, for Monoid only, even though this--- is now a Semigroup operator in base. The essential reason is that--- we have absolutely no use for semigroups in this module. Everything--- that needs to sum things up requires a Monoid constraint to deal--- with empty sequences. I'm not sure if there's a risk of walking--- through dictionaries to reach <> from Monoid, but I see no reason--- to risk it.-infixr 6 <>-(<>) :: Monoid m => m -> m -> m-(<>) = mappend-{-# INLINE (<>) #-}--infixr 5 `consTree`-infixl 5 `snocTree`-infixr 5 `appendTree0`--infixr 5 ><-infixr 5 <|, :<-infixl 5 |>, :>--#ifdef DEFINE_PATTERN_SYNONYMS-infixr 5 :<|-infixl 5 :|>--#if __GLASGOW_HASKELL__ >= 801-{-# COMPLETE (:<|), Empty #-}-{-# COMPLETE (:|>), Empty #-}-#endif---- | A bidirectional pattern synonym matching an empty sequence.------ @since 0.5.8-pattern Empty :: Seq a-pattern Empty = Seq EmptyT---- | A bidirectional pattern synonym viewing the front of a non-empty--- sequence.------ @since 0.5.8-pattern (:<|) :: a -> Seq a -> Seq a-pattern x :<| xs <- (viewl -> x :< xs)-  where-    x :<| xs = x <| xs---- | A bidirectional pattern synonym viewing the rear of a non-empty--- sequence.------ @since 0.5.8-pattern (:|>) :: Seq a -> a -> Seq a-pattern xs :|> x <- (viewr -> xs :> x)-  where-    xs :|> x = xs |> x-#endif--class Sized a where-    size :: a -> Int---- In much the same way that Sized lets us handle the--- sizes of elements and nodes uniformly, MaybeForce lets--- us handle their strictness (or lack thereof) uniformly.--- We can `mseq` something and not have to worry about--- whether it's an element or a node.-class MaybeForce a where-  maybeRwhnf :: a -> ()--mseq :: MaybeForce a => a -> b -> b-mseq a b = case maybeRwhnf a of () -> b-{-# INLINE mseq #-}--infixr 0 $!?-($!?) :: MaybeForce a => (a -> b) -> a -> b-f $!? a = case maybeRwhnf a of () -> f a-{-# INLINE ($!?) #-}--instance MaybeForce (Elem a) where-  maybeRwhnf _ = ()-  {-# INLINE maybeRwhnf #-}--instance MaybeForce (Node a) where-  maybeRwhnf !_ = ()-  {-# INLINE maybeRwhnf #-}---- A wrapper making mseq = seq-newtype ForceBox a = ForceBox a-instance MaybeForce (ForceBox a) where-  maybeRwhnf !_ = ()-instance Sized (ForceBox a) where-  size _ = 1---- | General-purpose finite sequences.-newtype Seq a = Seq (FingerTree (Elem a))--instance Functor Seq where-    fmap = fmapSeq-#ifdef __GLASGOW_HASKELL__-    x <$ s = replicate (length s) x-#endif--fmapSeq :: (a -> b) -> Seq a -> Seq b-fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)-#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] fmapSeq #-}-{-# RULES-"fmapSeq/fmapSeq" forall f g xs . fmapSeq f (fmapSeq g xs) = fmapSeq (f . g) xs- #-}-#endif-#if __GLASGOW_HASKELL__ >= 709--- Safe coercions were introduced in 7.8, but did not work well with RULES yet.-{-# RULES-"fmapSeq/coerce" fmapSeq coerce = coerce- #-}-#endif--getSeq :: Seq a -> FingerTree (Elem a)-getSeq (Seq xs) = xs--instance Foldable Seq where-    foldMap f = foldMap (f .# getElem) .# getSeq-    foldr f z = foldr (f .# getElem) z .# getSeq-    foldl f z = foldl (f .^# getElem) z .# getSeq--#if __GLASGOW_HASKELL__-    {-# INLINABLE foldMap #-}-    {-# INLINABLE foldr #-}-    {-# INLINABLE foldl #-}-#endif--    foldr' f z = foldr' (f .# getElem) z .# getSeq-    foldl' f z = foldl' (f .^# getElem) z .# getSeq--#if __GLASGOW_HASKELL__-    {-# INLINABLE foldr' #-}-    {-# INLINABLE foldl' #-}-#endif--    foldr1 f (Seq xs) = getElem (foldr1 f' xs)-      where f' (Elem x) (Elem y) = Elem (f x y)--    foldl1 f (Seq xs) = getElem (foldl1 f' xs)-      where f' (Elem x) (Elem y) = Elem (f x y)--#if MIN_VERSION_base(4,8,0)-    length = length-    {-# INLINE length #-}-    null   = null-    {-# INLINE null #-}-#endif--instance Traversable Seq where-#if __GLASGOW_HASKELL__-    {-# INLINABLE traverse #-}-#endif-    traverse _ (Seq EmptyT) = pure (Seq EmptyT)-    traverse f' (Seq (Single (Elem x'))) =-        (\x'' -> Seq (Single (Elem x''))) <$> f' x'-    traverse f' (Seq (Deep s' pr' m' sf')) =-        liftA3-            (\pr'' m'' sf'' -> Seq (Deep s' pr'' m'' sf''))-            (traverseDigitE f' pr')-            (traverseTree (traverseNodeE f') m')-            (traverseDigitE f' sf')-      where-        traverseTree-            :: Applicative f-            => (Node a -> f (Node b))-            -> FingerTree (Node a)-            -> f (FingerTree (Node b))-        traverseTree _ EmptyT = pure EmptyT-        traverseTree f (Single x) = Single <$> f x-        traverseTree f (Deep s pr m sf) =-            liftA3-                (Deep s)-                (traverseDigitN f pr)-                (traverseTree (traverseNodeN f) m)-                (traverseDigitN f sf)-        traverseDigitE-            :: Applicative f-            => (a -> f b) -> Digit (Elem a) -> f (Digit (Elem b))-        traverseDigitE f (One (Elem a)) =-            (\a' -> One (Elem a')) <$>-            f a-        traverseDigitE f (Two (Elem a) (Elem b)) =-            liftA2-                (\a' b' -> Two (Elem a') (Elem b'))-                (f a)-                (f b)-        traverseDigitE f (Three (Elem a) (Elem b) (Elem c)) =-            liftA3-                (\a' b' c' ->-                      Three (Elem a') (Elem b') (Elem c'))-                (f a)-                (f b)-                (f c)-        traverseDigitE f (Four (Elem a) (Elem b) (Elem c) (Elem d)) =-            liftA3-                (\a' b' c' d' -> Four (Elem a') (Elem b') (Elem c') (Elem d'))-                (f a)-                (f b)-                (f c) <*> -                (f d)-        traverseDigitN-            :: Applicative f-            => (Node a -> f (Node b)) -> Digit (Node a) -> f (Digit (Node b))-        traverseDigitN f t = traverse f t-        traverseNodeE-            :: Applicative f-            => (a -> f b) -> Node (Elem a) -> f (Node (Elem b))-        traverseNodeE f (Node2 s (Elem a) (Elem b)) =-            liftA2-                (\a' b' -> Node2 s (Elem a') (Elem b'))-                (f a)-                (f b)-        traverseNodeE f (Node3 s (Elem a) (Elem b) (Elem c)) =-            liftA3-                (\a' b' c' ->-                      Node3 s (Elem a') (Elem b') (Elem c'))-                (f a)-                (f b)-                (f c)-        traverseNodeN-            :: Applicative f-            => (Node a -> f (Node b)) -> Node (Node a) -> f (Node (Node b))-        traverseNodeN f t = traverse f t--instance NFData a => NFData (Seq a) where-    rnf (Seq xs) = rnf xs--instance Monad Seq where-    return = pure-    xs >>= f = foldl' add empty xs-      where add ys x = ys >< f x-    (>>) = (*>)---- | @since 0.5.11-instance MonadFix Seq where-    mfix = mfixSeq---- This is just like the instance for lists, but we can take advantage of--- constant-time length and logarithmic-time indexing to speed things up.--- Using fromFunction, we make this about as lazy as we can.-mfixSeq :: (a -> Seq a) -> Seq a-mfixSeq f = fromFunction (length (f err)) (\k -> fix (\xk -> f xk `index` k))-  where-    err = error "mfix for Data.Sequence.Seq applied to strict function"---- | @since 0.5.4-instance Applicative Seq where-    pure = singleton-    xs *> ys = cycleNTimes (length xs) ys-    (<*>) = apSeq-#if MIN_VERSION_base(4,10,0)-    liftA2 = liftA2Seq-#endif--apSeq :: Seq (a -> b) -> Seq a -> Seq b-apSeq fs xs@(Seq xsFT) = case viewl fs of-  EmptyL -> empty-  firstf :< fs' -> case viewr fs' of-    EmptyR -> fmap firstf xs-    Seq fs''FT :> lastf -> case rigidify xsFT of-         RigidEmpty -> empty-         RigidOne (Elem x) -> fmap ($x) fs-         RigidTwo (Elem x1) (Elem x2) ->-            Seq $ ap2FT firstf fs''FT lastf (x1, x2)-         RigidThree (Elem x1) (Elem x2) (Elem x3) ->-            Seq $ ap3FT firstf fs''FT lastf (x1, x2, x3)-         RigidFull r@(Rigid s pr _m sf) -> Seq $-               Deep (s * length fs)-                    (fmap (fmap firstf) (nodeToDigit pr))-                    (aptyMiddle (fmap firstf) (fmap lastf) fmap fs''FT r)-                    (fmap (fmap lastf) (nodeToDigit sf))-{-# NOINLINE [1] apSeq #-}--{-# RULES-"ap/fmap1" forall f xs ys . apSeq (fmapSeq f xs) ys = liftA2Seq f xs ys-"ap/fmap2" forall f gs xs . apSeq gs (fmapSeq f xs) =-                              liftA2Seq (\g x -> g (f x)) gs xs-"fmap/ap" forall f gs xs . fmapSeq f (gs `apSeq` xs) =-                             liftA2Seq (\g x -> f (g x)) gs xs-"fmap/liftA2" forall f g m n . fmapSeq f (liftA2Seq g m n) =-                       liftA2Seq (\x y -> f (g x y)) m n-"liftA2/fmap1" forall f g m n . liftA2Seq f (fmapSeq g m) n =-                       liftA2Seq (\x y -> f (g x) y) m n-"liftA2/fmap2" forall f g m n . liftA2Seq f m (fmapSeq g n) =-                       liftA2Seq (\x y -> f x (g y)) m n- #-}--ap2FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a) -> FingerTree (Elem b)-ap2FT firstf fs lastf (x,y) =-                 Deep (size fs * 2 + 4)-                      (Two (Elem $ firstf x) (Elem $ firstf y))-                      (mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) fs)-                      (Two (Elem $ lastf x) (Elem $ lastf y))--ap3FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a,a) -> FingerTree (Elem b)-ap3FT firstf fs lastf (x,y,z) = Deep (size fs * 3 + 6)-                        (Three (Elem $ firstf x) (Elem $ firstf y) (Elem $ firstf z))-                        (mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) fs)-                        (Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))--lift2FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b) -> FingerTree (Elem c)-lift2FT f firstx xs lastx (y1,y2) =-                 Deep (size xs * 2 + 4)-                      (Two (Elem $ f firstx y1) (Elem $ f firstx y2))-                      (mapMulFT 2 (\(Elem x) -> Node2 2 (Elem (f x y1)) (Elem (f x y2))) xs)-                      (Two (Elem $ f lastx y1) (Elem $ f lastx y2))--lift3FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b,b) -> FingerTree (Elem c)-lift3FT f firstx xs lastx (y1,y2,y3) =-                 Deep (size xs * 3 + 6)-                      (Three (Elem $ f firstx y1) (Elem $ f firstx y2) (Elem $ f firstx y3))-                      (mapMulFT 3 (\(Elem x) -> Node3 3 (Elem (f x y1)) (Elem (f x y2)) (Elem (f x y3))) xs)-                      (Three (Elem $ f lastx y1) (Elem $ f lastx y2) (Elem $ f lastx y3))--liftA2Seq :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-liftA2Seq f xs ys@(Seq ysFT) = case viewl xs of-  EmptyL -> empty-  firstx :< xs' -> case viewr xs' of-    EmptyR -> f firstx <$> ys-    Seq xs''FT :> lastx -> case rigidify ysFT of-      RigidEmpty -> empty-      RigidOne (Elem y) -> fmap (\x -> f x y) xs-      RigidTwo (Elem y1) (Elem y2) ->-        Seq $ lift2FT f firstx xs''FT lastx (y1, y2)-      RigidThree (Elem y1) (Elem y2) (Elem y3) ->-        Seq $ lift3FT f firstx xs''FT lastx (y1, y2, y3)-      RigidFull r@(Rigid s pr _m sf) -> Seq $-        Deep (s * length xs)-             (fmap (fmap (f firstx)) (nodeToDigit pr))-             (aptyMiddle (fmap (f firstx)) (fmap (f lastx)) (lift_elem f) xs''FT r)-             (fmap (fmap (f lastx)) (nodeToDigit sf))-  where-    lift_elem :: (a -> b -> c) -> a -> Elem b -> Elem c-#if __GLASGOW_HASKELL__ >= 708-    lift_elem = coerce-#else-    lift_elem f x (Elem y) = Elem (f x y)-#endif-{-# NOINLINE [1] liftA2Seq #-}---data Rigidified a = RigidEmpty-                  | RigidOne a-                  | RigidTwo a a-                  | RigidThree a a a-                  | RigidFull (Rigid a)-#ifdef TESTING-                  deriving Show-#endif---- | A finger tree whose top level has only Two and/or Three digits, and whose--- other levels have only One and Two digits. A Rigid tree is precisely what one--- gets by unzipping/inverting a 2-3 tree, so it is precisely what we need to--- turn a finger tree into in order to transform it into a 2-3 tree.-data Rigid a = Rigid {-# UNPACK #-} !Int !(Digit23 a) (Thin (Node a)) !(Digit23 a)-#ifdef TESTING-             deriving Show-#endif---- | A finger tree whose digits are all ones and twos-data Thin a = EmptyTh-            | SingleTh a-            | DeepTh {-# UNPACK #-} !Int !(Digit12 a) (Thin (Node a)) !(Digit12 a)-#ifdef TESTING-            deriving Show-#endif--data Digit12 a = One12 a | Two12 a a-#ifdef TESTING-        deriving Show-#endif---- | Sometimes, we want to emphasize that we are viewing a node as a top-level--- digit of a 'Rigid' tree.-type Digit23 a = Node a---- | 'aptyMiddle' does most of the hard work of computing @fs<*>xs@.  It--- produces the center part of a finger tree, with a prefix corresponding to--- the prefix of @xs@ and a suffix corresponding to the suffix of @xs@ omitted;--- the missing suffix and prefix are added by the caller.  For the recursive--- call, it squashes the prefix and the suffix into the center tree. Once it--- gets to the bottom, it turns the tree into a 2-3 tree, applies 'mapMulFT' to--- produce the main body, and glues all the pieces together.------ 'map23' itself is a bit horrifying because of the nested types involved. Its--- job is to map over the *elements* of a 2-3 tree, rather than the subtrees.--- If we used a higher-order nested type with MPTC, we could probably use a--- class, but as it is we have to build up 'map23' explicitly through the--- recursion.-aptyMiddle-  :: (b -> c)-     -> (b -> c)-     -> (a -> b -> c)-     -> FingerTree (Elem a)-     -> Rigid b-     -> FingerTree (Node c)---- Not at the bottom yet--aptyMiddle firstf-           lastf-           map23-           fs-           (Rigid s pr (DeepTh sm prm mm sfm) sf)-    = Deep (sm + s * (size fs + 1)) -- note: sm = s - size pr - size sf-           (fmap (fmap firstf) (digit12ToDigit prm))-           (aptyMiddle (fmap firstf)-                       (fmap lastf)-                       (fmap . map23)-                       fs-                       (Rigid s (squashL pr prm) mm (squashR sfm sf)))-           (fmap (fmap lastf) (digit12ToDigit sfm))---- At the bottom--aptyMiddle firstf-           lastf-           map23-           fs-           (Rigid s pr EmptyTh sf)-     = deep-            (One (fmap firstf sf))-            (mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)-            (One (fmap lastf pr))-   where converted = node2 pr sf--aptyMiddle firstf-           lastf-           map23-           fs-           (Rigid s pr (SingleTh q) sf)-     = deep-            (Two (fmap firstf q) (fmap firstf sf))-            (mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)-            (Two (fmap lastf pr) (fmap lastf q))-   where converted = node3 pr q sf--digit12ToDigit :: Digit12 a -> Digit a-digit12ToDigit (One12 a) = One a-digit12ToDigit (Two12 a b) = Two a b---- Squash the first argument down onto the left side of the second.-squashL :: Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)-squashL m (One12 n) = node2 m n-squashL m (Two12 n1 n2) = node3 m n1 n2---- Squash the second argument down onto the right side of the first-squashR :: Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)-squashR (One12 n) m = node2 n m-squashR (Two12 n1 n2) m = node3 n1 n2 m----- | /O(m*n)/ (incremental) Takes an /O(m)/ function and a finger tree of size--- /n/ and maps the function over the tree leaves. Unlike the usual 'fmap', the--- function is applied to the "leaves" of the 'FingerTree' (i.e., given a--- @FingerTree (Elem a)@, it applies the function to elements of type @Elem--- a@), replacing the leaves with subtrees of at least the same height, e.g.,--- @Node(Node(Elem y))@. The multiplier argument serves to make the annotations--- match up properly.-mapMulFT :: Int -> (a -> b) -> FingerTree a -> FingerTree b-mapMulFT _ _ EmptyT = EmptyT-mapMulFT _mul f (Single a) = Single (f a)-mapMulFT mul f (Deep s pr m sf) = Deep (mul * s) (fmap f pr) (mapMulFT mul (mapMulNode mul f) m) (fmap f sf)--mapMulNode :: Int -> (a -> b) -> Node a -> Node b-mapMulNode mul f (Node2 s a b)   = Node2 (mul * s) (f a) (f b)-mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c)---- | /O(log n)/ (incremental) Takes the extra flexibility out of a 'FingerTree'--- to make it a genuine 2-3 finger tree. The result of 'rigidify' will have--- only two and three digits at the top level and only one and two--- digits elsewhere. If the tree has fewer than four elements, 'rigidify'--- will simply extract them, and will not build a tree.-rigidify :: FingerTree (Elem a) -> Rigidified (Elem a)--- The patterns below just fix up the top level of the tree; 'rigidify'--- delegates the hard work to 'thin'.--rigidify EmptyT = RigidEmpty--rigidify (Single q) = RigidOne q---- The left digit is Two or Three-rigidify (Deep s (Two a b) m sf) = rigidifyRight s (node2 a b) m sf-rigidify (Deep s (Three a b c) m sf) = rigidifyRight s (node3 a b c) m sf---- The left digit is Four-rigidify (Deep s (Four a b c d) m sf) = rigidifyRight s (node2 a b) (node2 c d `consTree` m) sf---- The left digit is One-rigidify (Deep s (One a) m sf) = case viewLTree m of-   ConsLTree (Node2 _ b c) m' -> rigidifyRight s (node3 a b c) m' sf-   ConsLTree (Node3 _ b c d) m' -> rigidifyRight s (node2 a b) (node2 c d `consTree` m') sf-   EmptyLTree -> case sf of-     One b -> RigidTwo a b-     Two b c -> RigidThree a b c-     Three b c d -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c d)-     Four b c d e -> RigidFull $ Rigid s (node3 a b c) EmptyTh (node2 d e)---- | /O(log n)/ (incremental) Takes a tree whose left side has been rigidified--- and finishes the job.-rigidifyRight :: Int -> Digit23 (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> Rigidified (Elem a)---- The right digit is Two, Three, or Four-rigidifyRight s pr m (Two a b) = RigidFull $ Rigid s pr (thin m) (node2 a b)-rigidifyRight s pr m (Three a b c) = RigidFull $ Rigid s pr (thin m) (node3 a b c)-rigidifyRight s pr m (Four a b c d) = RigidFull $ Rigid s pr (thin $ m `snocTree` node2 a b) (node2 c d)---- The right digit is One-rigidifyRight s pr m (One e) = case viewRTree m of-    SnocRTree m' (Node2 _ a b) -> RigidFull $ Rigid s pr (thin m') (node3 a b e)-    SnocRTree m' (Node3 _ a b c) -> RigidFull $ Rigid s pr (thin $ m' `snocTree` node2 a b) (node2 c e)-    EmptyRTree -> case pr of-      Node2 _ a b -> RigidThree a b e-      Node3 _ a b c -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c e)---- | /O(log n)/ (incremental) Rejigger a finger tree so the digits are all ones--- and twos.-thin :: Sized a => FingerTree a -> Thin a--- Note that 'thin12' will produce a 'DeepTh' constructor immediately before--- recursively calling 'thin'.-thin EmptyT = EmptyTh-thin (Single a) = SingleTh a-thin (Deep s pr m sf) =-  case pr of-    One a -> thin12 s (One12 a) m sf-    Two a b -> thin12 s (Two12 a b) m sf-    Three a b c  -> thin12 s (One12 a) (node2 b c `consTree` m) sf-    Four a b c d -> thin12 s (Two12 a b) (node2 c d `consTree` m) sf--thin12 :: Sized a => Int -> Digit12 a -> FingerTree (Node a) -> Digit a -> Thin a-thin12 s pr m (One a) = DeepTh s pr (thin m) (One12 a)-thin12 s pr m (Two a b) = DeepTh s pr (thin m) (Two12 a b)-thin12 s pr m (Three a b c) = DeepTh s pr (thin $ m `snocTree` node2 a b) (One12 c)-thin12 s pr m (Four a b c d) = DeepTh s pr (thin $ m `snocTree` node2 a b) (Two12 c d)---- | \( O(n) \). Intersperse an element between the elements of a sequence.------ @--- intersperse a empty = empty--- intersperse a (singleton x) = singleton x--- intersperse a (fromList [x,y]) = fromList [x,a,y]--- intersperse a (fromList [x,y,z]) = fromList [x,a,y,a,z]--- @------ @since 0.5.8-intersperse :: a -> Seq a -> Seq a-intersperse y xs = case viewl xs of-  EmptyL -> empty-  p :< ps -> p <| (ps <**> (const y <| singleton id))--- We used to use------ intersperse y xs = drop 1 $ xs <**> (const y <| singleton id)------ but if length xs = ((maxBound :: Int) `quot` 2) + 1 then------ length (xs <**> (const y <| singleton id)) will wrap around to negative--- and the drop won't work. The new implementation can produce a result--- right up to maxBound :: Int--instance MonadPlus Seq where-    mzero = empty-    mplus = (><)---- | @since 0.5.4-instance Alternative Seq where-    empty = empty-    (<|>) = (><)--instance Eq a => Eq (Seq a) where-    xs == ys = length xs == length ys && toList xs == toList ys--instance Ord a => Ord (Seq a) where-    compare xs ys = compare (toList xs) (toList ys)--#ifdef TESTING-instance Show a => Show (Seq a) where-    showsPrec p (Seq x) = showsPrec p x-#else-instance Show a => Show (Seq a) where-    showsPrec p xs = showParen (p > 10) $-        showString "fromList " . shows (toList xs)-#endif--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Show1 Seq where-  liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $-        showString "fromList " . shwList (toList xs)---- | @since 0.5.9-instance Eq1 Seq where-    liftEq eq xs ys = length xs == length ys && liftEq eq (toList xs) (toList ys)---- | @since 0.5.9-instance Ord1 Seq where-    liftCompare cmp xs ys = liftCompare cmp (toList xs) (toList ys)-#endif--instance Read a => Read (Seq a) where-#ifdef __GLASGOW_HASKELL__-    readPrec = parens $ prec 10 $ do-        Ident "fromList" <- lexP-        xs <- readPrec-        return (fromList xs)--    readListPrec = readListPrecDefault-#else-    readsPrec p = readParen (p > 10) $ \ r -> do-        ("fromList",s) <- lex r-        (xs,t) <- reads s-        return (fromList xs,t)-#endif--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Read1 Seq where-  liftReadsPrec _rp readLst p = readParen (p > 10) $ \r -> do-    ("fromList",s) <- lex r-    (xs,t) <- readLst s-    pure (fromList xs, t)-#endif--instance Monoid (Seq a) where-    mempty = empty-    mappend = (><)--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.7-instance Semigroup.Semigroup (Seq a) where-    (<>)    = (><)-#endif--INSTANCE_TYPEABLE1(Seq)--#if __GLASGOW_HASKELL__-instance Data a => Data (Seq a) where-    gfoldl f z s    = case viewl s of-        EmptyL  -> z empty-        x :< xs -> z (<|) `f` x `f` xs--    gunfold k z c   = case constrIndex c of-        1 -> z empty-        2 -> k (k (z (<|)))-        _ -> error "gunfold"--    toConstr xs-      | null xs     = emptyConstr-      | otherwise   = consConstr--    dataTypeOf _    = seqDataType--    dataCast1 f     = gcast1 f--emptyConstr, consConstr :: Constr-emptyConstr = mkConstr seqDataType "empty" [] Prefix-consConstr  = mkConstr seqDataType "<|" [] Infix--seqDataType :: DataType-seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]-#endif---- Finger trees--data FingerTree a-    = EmptyT-    | Single a-    | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)-#ifdef TESTING-    deriving Show-#endif--#ifdef __GLASGOW_HASKELL__--- | @since 0.6.1-deriving instance Generic1 FingerTree---- | @since 0.6.1-deriving instance Generic (FingerTree a)-#endif--instance Sized a => Sized (FingerTree a) where-    {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}-    {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}-    size EmptyT             = 0-    size (Single x)         = size x-    size (Deep v _ _ _)     = v--instance Foldable FingerTree where-    foldMap _ EmptyT = mempty-    foldMap f' (Single x') = f' x'-    foldMap f' (Deep _ pr' m' sf') = -        foldMapDigit f' pr' <>-        foldMapTree (foldMapNode f') m' <>-        foldMapDigit f' sf'-      where-        foldMapTree :: Monoid m => (Node a -> m) -> FingerTree (Node a) -> m-        foldMapTree _ EmptyT = mempty-        foldMapTree f (Single x) = f x-        foldMapTree f (Deep _ pr m sf) = -            foldMapDigitN f pr <>-            foldMapTree (foldMapNodeN f) m <>-            foldMapDigitN f sf--        foldMapDigit :: Monoid m => (a -> m) -> Digit a -> m-        foldMapDigit f t = foldDigit (<>) f t--        foldMapDigitN :: Monoid m => (Node a -> m) -> Digit (Node a) -> m-        foldMapDigitN f t = foldDigit (<>) f t--        foldMapNode :: Monoid m => (a -> m) -> Node a -> m-        foldMapNode f t = foldNode (<>) f t--        foldMapNodeN :: Monoid m => (Node a -> m) -> Node (Node a) -> m-        foldMapNodeN f t = foldNode (<>) f t-#if __GLASGOW_HASKELL__-    {-# INLINABLE foldMap #-}-#endif--    foldr _ z' EmptyT = z'-    foldr f' z' (Single x') = x' `f'` z'-    foldr f' z' (Deep _ pr' m' sf') =-        foldrDigit f' (foldrTree (foldrNode f') (foldrDigit f' z' sf') m') pr'-      where-        foldrTree :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b-        foldrTree _ z EmptyT = z-        foldrTree f z (Single x) = x `f` z-        foldrTree f z (Deep _ pr m sf) =-            foldrDigitN f (foldrTree (foldrNodeN f) (foldrDigitN f z sf) m) pr--        foldrDigit :: (a -> b -> b) -> b -> Digit a -> b-        foldrDigit f z t = foldr f z t--        foldrDigitN :: (Node a -> b -> b) -> b -> Digit (Node a) -> b-        foldrDigitN f z t = foldr f z t--        foldrNode :: (a -> b -> b) -> Node a -> b -> b-        foldrNode f t z = foldr f z t--        foldrNodeN :: (Node a -> b -> b) -> Node (Node a) -> b -> b-        foldrNodeN f t z = foldr f z t-    {-# INLINE foldr #-}---    foldl _ z' EmptyT = z'-    foldl f' z' (Single x') = z' `f'` x'-    foldl f' z' (Deep _ pr' m' sf') =-        foldlDigit f' (foldlTree (foldlNode f') (foldlDigit f' z' pr') m') sf'-      where-        foldlTree :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b-        foldlTree _ z EmptyT = z-        foldlTree f z (Single x) = z `f` x-        foldlTree f z (Deep _ pr m sf) =-            foldlDigitN f (foldlTree (foldlNodeN f) (foldlDigitN f z pr) m) sf--        foldlDigit :: (b -> a -> b) -> b -> Digit a -> b-        foldlDigit f z t = foldl f z t--        foldlDigitN :: (b -> Node a -> b) -> b -> Digit (Node a) -> b-        foldlDigitN f z t = foldl f z t--        foldlNode :: (b -> a -> b) -> b -> Node a -> b-        foldlNode f z t = foldl f z t--        foldlNodeN :: (b -> Node a -> b) -> b -> Node (Node a) -> b-        foldlNodeN f z t = foldl f z t-    {-# INLINE foldl #-}--    foldr' _ z' EmptyT = z'-    foldr' f' z' (Single x') = f' x' z'-    foldr' f' z' (Deep _ pr' m' sf') =-        (foldrDigit' f' $! (foldrTree' (foldrNode' f') $! (foldrDigit' f' z') sf') m') pr'-      where-        foldrTree' :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b-        foldrTree' _ z EmptyT = z-        foldrTree' f z (Single x) = f x $! z-        foldrTree' f z (Deep _ pr m sf) =-            (foldr' f $! (foldrTree' (foldrNodeN' f) $! (foldr' f $! z) sf) m) pr--        foldrDigit' :: (a -> b -> b) -> b -> Digit a -> b-        foldrDigit' f z t = foldr' f z t--        foldrNode' :: (a -> b -> b) -> Node a -> b -> b-        foldrNode' f t z = foldr' f z t--        foldrNodeN' :: (Node a -> b -> b) -> Node (Node a) -> b -> b-        foldrNodeN' f t z = foldr' f z t-    {-# INLINE foldr' #-}--    foldl' _ z' EmptyT = z'-    foldl' f' z' (Single x') = f' z' x'-    foldl' f' z' (Deep _ pr' m' sf') =-        (foldlDigit' f' $!-         (foldlTree' (foldlNode' f') $! (foldlDigit' f' z') pr') m')-            sf'-      where-        foldlTree' :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b-        foldlTree' _ z EmptyT = z-        foldlTree' f z (Single xs) = f z xs-        foldlTree' f z (Deep _ pr m sf) =-            (foldl' f $! (foldlTree' (foldl' f) $! foldl' f z pr) m) sf--        foldlDigit' :: (b -> a -> b) -> b -> Digit a -> b-        foldlDigit' f z t = foldl' f z t--        foldlNode' :: (b -> a -> b) -> b -> Node a -> b-        foldlNode' f z t = foldl' f z t-    {-# INLINE foldl' #-}--    foldr1 _ EmptyT = error "foldr1: empty sequence"-    foldr1 _ (Single x) = x-    foldr1 f (Deep _ pr m sf) =-        foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr--    foldl1 _ EmptyT = error "foldl1: empty sequence"-    foldl1 _ (Single x) = x-    foldl1 f (Deep _ pr m sf) =-        foldl f (foldl (foldl f) (foldl1 f pr) m) sf--instance Functor FingerTree where-    fmap _ EmptyT = EmptyT-    fmap f (Single x) = Single (f x)-    fmap f (Deep v pr m sf) =-        Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)--instance Traversable FingerTree where-    traverse _ EmptyT = pure EmptyT-    traverse f (Single x) = Single <$> f x-    traverse f (Deep v pr m sf) =-        liftA3 (Deep v) (traverse f pr) (traverse (traverse f) m)-            (traverse f sf)--instance NFData a => NFData (FingerTree a) where-    rnf EmptyT = ()-    rnf (Single x) = rnf x-    rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m--{-# INLINE deep #-}-deep            :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a-deep pr m sf    =  Deep (size pr + size m + size sf) pr m sf--{-# INLINE pullL #-}-pullL :: Int -> FingerTree (Node a) -> Digit a -> FingerTree a-pullL s m sf = case viewLTree m of-    EmptyLTree          -> digitToTree' s sf-    ConsLTree pr m'     -> Deep s (nodeToDigit pr) m' sf--{-# INLINE pullR #-}-pullR :: Int -> Digit a -> FingerTree (Node a) -> FingerTree a-pullR s pr m = case viewRTree m of-    EmptyRTree          -> digitToTree' s pr-    SnocRTree m' sf     -> Deep s pr m' (nodeToDigit sf)---- Digits--data Digit a-    = One a-    | Two a a-    | Three a a a-    | Four a a a a-#ifdef TESTING-    deriving Show-#endif--#ifdef __GLASGOW_HASKELL__--- | @since 0.6.1-deriving instance Generic1 Digit---- | @since 0.6.1-deriving instance Generic (Digit a)-#endif--foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b-foldDigit _     f (One a) = f a-foldDigit (<+>) f (Two a b) = f a <+> f b-foldDigit (<+>) f (Three a b c) = f a <+> f b <+> f c-foldDigit (<+>) f (Four a b c d) = f a <+> f b <+> f c <+> f d-{-# INLINE foldDigit #-}--instance Foldable Digit where-    foldMap = foldDigit mappend--    foldr f z (One a) = a `f` z-    foldr f z (Two a b) = a `f` (b `f` z)-    foldr f z (Three a b c) = a `f` (b `f` (c `f` z))-    foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))-    {-# INLINE foldr #-}--    foldl f z (One a) = z `f` a-    foldl f z (Two a b) = (z `f` a) `f` b-    foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c-    foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d-    {-# INLINE foldl #-}--    foldr' f z (One a) = f a z-    foldr' f z (Two a b) = f a $! f b z-    foldr' f z (Three a b c) = f a $! f b $! f c z-    foldr' f z (Four a b c d) = f a $! f b $! f c $! f d z-    {-# INLINE foldr' #-}--    foldl' f z (One a) = f z a-    foldl' f z (Two a b) = (f $! f z a) b-    foldl' f z (Three a b c) = (f $! (f $! f z a) b) c-    foldl' f z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d-    {-# INLINE foldl' #-}--    foldr1 _ (One a) = a-    foldr1 f (Two a b) = a `f` b-    foldr1 f (Three a b c) = a `f` (b `f` c)-    foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))--    foldl1 _ (One a) = a-    foldl1 f (Two a b) = a `f` b-    foldl1 f (Three a b c) = (a `f` b) `f` c-    foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d--instance Functor Digit where-    {-# INLINE fmap #-}-    fmap f (One a) = One (f a)-    fmap f (Two a b) = Two (f a) (f b)-    fmap f (Three a b c) = Three (f a) (f b) (f c)-    fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)--instance Traversable Digit where-    {-# INLINE traverse #-}-    traverse f (One a) = One <$> f a-    traverse f (Two a b) = liftA2 Two (f a) (f b)-    traverse f (Three a b c) = liftA3 Three (f a) (f b) (f c)-    traverse f (Four a b c d) = liftA3 Four (f a) (f b) (f c) <*> f d--instance NFData a => NFData (Digit a) where-    rnf (One a) = rnf a-    rnf (Two a b) = rnf a `seq` rnf b-    rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c-    rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d--instance Sized a => Sized (Digit a) where-    {-# INLINE size #-}-    size = foldl1 (+) . fmap size--{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}-digitToTree     :: Sized a => Digit a -> FingerTree a-digitToTree (One a) = Single a-digitToTree (Two a b) = deep (One a) EmptyT (One b)-digitToTree (Three a b c) = deep (Two a b) EmptyT (One c)-digitToTree (Four a b c d) = deep (Two a b) EmptyT (Two c d)---- | Given the size of a digit and the digit itself, efficiently converts--- it to a FingerTree.-digitToTree' :: Int -> Digit a -> FingerTree a-digitToTree' n (Four a b c d) = Deep n (Two a b) EmptyT (Two c d)-digitToTree' n (Three a b c) = Deep n (Two a b) EmptyT (One c)-digitToTree' n (Two a b) = Deep n (One a) EmptyT (One b)-digitToTree' !_n (One a) = Single a---- Nodes--data Node a-    = Node2 {-# UNPACK #-} !Int a a-    | Node3 {-# UNPACK #-} !Int a a a-#ifdef TESTING-    deriving Show-#endif--#ifdef __GLASGOW_HASKELL__--- | @since 0.6.1-deriving instance Generic1 Node---- | @since 0.6.1-deriving instance Generic (Node a)-#endif--foldNode :: (b -> b -> b) -> (a -> b) -> Node a -> b-foldNode (<+>) f (Node2 _ a b) = f a <+> f b-foldNode (<+>) f (Node3 _ a b c) = f a <+> f b <+> f c-{-# INLINE foldNode #-}--instance Foldable Node where-    foldMap = foldNode mappend--    foldr f z (Node2 _ a b) = a `f` (b `f` z)-    foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))-    {-# INLINE foldr #-}--    foldl f z (Node2 _ a b) = (z `f` a) `f` b-    foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c-    {-# INLINE foldl #-}--    foldr' f z (Node2 _ a b) = f a $! f b z-    foldr' f z (Node3 _ a b c) = f a $! f b $! f c z-    {-# INLINE foldr' #-}--    foldl' f z (Node2 _ a b) = (f $! f z a) b-    foldl' f z (Node3 _ a b c) = (f $! (f $! f z a) b) c-    {-# INLINE foldl' #-}--instance Functor Node where-    {-# INLINE fmap #-}-    fmap f (Node2 v a b) = Node2 v (f a) (f b)-    fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)--instance Traversable Node where-    {-# INLINE traverse #-}-    traverse f (Node2 v a b) = liftA2 (Node2 v) (f a) (f b)-    traverse f (Node3 v a b c) = liftA3 (Node3 v) (f a) (f b) (f c)--instance NFData a => NFData (Node a) where-    rnf (Node2 _ a b) = rnf a `seq` rnf b-    rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c--instance Sized (Node a) where-    size (Node2 v _ _)      = v-    size (Node3 v _ _ _)    = v--{-# INLINE node2 #-}-node2           :: Sized a => a -> a -> Node a-node2 a b       =  Node2 (size a + size b) a b--{-# INLINE node3 #-}-node3           :: Sized a => a -> a -> a -> Node a-node3 a b c     =  Node3 (size a + size b + size c) a b c--nodeToDigit :: Node a -> Digit a-nodeToDigit (Node2 _ a b) = Two a b-nodeToDigit (Node3 _ a b c) = Three a b c---- Elements--newtype Elem a  =  Elem { getElem :: a }-#ifdef TESTING-    deriving Show-#endif--#ifdef __GLASGOW_HASKELL__--- | @since 0.6.1-deriving instance Generic1 Elem---- | @since 0.6.1-deriving instance Generic (Elem a)-#endif--instance Sized (Elem a) where-    size _ = 1--instance Functor Elem where-#if __GLASGOW_HASKELL__ >= 708--- This cuts the time for <*> by around a fifth.-    fmap = coerce-#else-    fmap f (Elem x) = Elem (f x)-#endif--instance Foldable Elem where-    foldr f z (Elem x) = f x z-#if __GLASGOW_HASKELL__ >= 708-    foldMap = coerce-    foldl = coerce-    foldl' = coerce-#else-    foldMap f (Elem x) = f x-    foldl f z (Elem x) = f z x-    foldl' f z (Elem x) = f z x-#endif--instance Traversable Elem where-    traverse f (Elem x) = Elem <$> f x--instance NFData a => NFData (Elem a) where-    rnf (Elem x) = rnf x------------------------------------------------------------ Applicative construction---------------------------------------------------------#if !MIN_VERSION_base(4,8,0)-newtype Identity a = Identity {runIdentity :: a}--instance Functor Identity where-    fmap f (Identity x) = Identity (f x)--instance Applicative Identity where-    pure = Identity-    Identity f <*> Identity x = Identity (f x)-#endif---- | 'applicativeTree' takes an Applicative-wrapped construction of a--- piece of a FingerTree, assumed to always have the same size (which--- is put in the second argument), and replicates it as many times as--- specified.  This is a generalization of 'replicateA', which itself--- is a generalization of many Data.Sequence methods.-{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}-{-# SPECIALIZE applicativeTree :: Int -> Int -> Identity a -> Identity (FingerTree a) #-}--- Special note: the Identity specialization automatically does node sharing,--- reducing memory usage of the resulting tree to /O(log n)/.-applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)-applicativeTree n !mSize m = case n of-    0 -> pure EmptyT-    1 -> fmap Single m-    2 -> deepA one emptyTree one-    3 -> deepA two emptyTree one-    4 -> deepA two emptyTree two-    5 -> deepA three emptyTree two-    6 -> deepA three emptyTree three-    _ -> case n `quotRem` 3 of-           (q,0) -> deepA three (applicativeTree (q - 2) mSize' n3) three-           (q,1) -> deepA two (applicativeTree (q - 1) mSize' n3) two-           (q,_) -> deepA three (applicativeTree (q - 1) mSize' n3) two-      where !mSize' = 3 * mSize-            n3 = liftA3 (Node3 mSize') m m m-  where-    one = fmap One m-    two = liftA2 Two m m-    three = liftA3 Three m m m-    deepA = liftA3 (Deep (n * mSize))-    emptyTree = pure EmptyT----------------------------------------------------------------------------- Construction----------------------------------------------------------------------------- | \( O(1) \). The empty sequence.-empty           :: Seq a-empty           =  Seq EmptyT---- | \( O(1) \). A singleton sequence.-singleton       :: a -> Seq a-singleton x     =  Seq (Single (Elem x))---- | \( O(\log n) \). @replicate n x@ is a sequence consisting of @n@ copies of @x@.-replicate       :: Int -> a -> Seq a-replicate n x-  | n >= 0      = runIdentity (replicateA n (Identity x))-  | otherwise   = error "replicate takes a nonnegative integer argument"---- | 'replicateA' is an 'Applicative' version of 'replicate', and makes--- \( O(\log n) \) calls to 'liftA2' and 'pure'.------ > replicateA n x = sequenceA (replicate n x)-replicateA :: Applicative f => Int -> f a -> f (Seq a)-replicateA n x-  | n >= 0      = Seq <$> applicativeTree n 1 (Elem <$> x)-  | otherwise   = error "replicateA takes a nonnegative integer argument"-{-# SPECIALIZE replicateA :: Int -> State a b -> State a (Seq b) #-}---- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.------ > replicateM n x = sequence (replicate n x)------ For @base >= 4.8.0@ and @containers >= 0.5.11@, 'replicateM'--- is a synonym for 'replicateA'.-#if MIN_VERSION_base(4,8,0)-replicateM :: Applicative m => Int -> m a -> m (Seq a)-replicateM = replicateA-#else-replicateM :: Monad m => Int -> m a -> m (Seq a)-replicateM n x-  | n >= 0      = Applicative.unwrapMonad (replicateA n (Applicative.WrapMonad x))-  | otherwise   = error "replicateM takes a nonnegative integer argument"-#endif---- | /O(/log/ k)/. @'cycleTaking' k xs@ forms a sequence of length @k@ by--- repeatedly concatenating @xs@ with itself. @xs@ may only be empty if--- @k@ is 0.------ prop> cycleTaking k = fromList . take k . cycle . toList---- If you wish to concatenate a non-empty sequence @xs@ with itself precisely--- @k@ times, you can use @cycleTaking (k * length xs)@ or just--- @replicate k () *> xs@.------ @since 0.5.8-cycleTaking :: Int -> Seq a -> Seq a-cycleTaking n !_xs | n <= 0 = empty-cycleTaking _n xs  | null xs = error "cycleTaking cannot take a positive number of elements from an empty cycle."-cycleTaking n xs = cycleNTimes reps xs >< take final xs-  where-    (reps, final) = n `quotRem` length xs---- \( O(\log(kn)) \). @'cycleNTimes' k xs@ concatenates @k@ copies of @xs@. This--- operation uses time and additional space logarithmic in the size of its--- result.-cycleNTimes :: Int -> Seq a -> Seq a-cycleNTimes n !xs-  | n <= 0    = empty-  | n == 1    = xs-cycleNTimes n (Seq xsFT) = case rigidify xsFT of-             RigidEmpty -> empty-             RigidOne (Elem x) -> replicate n x-             RigidTwo x1 x2 -> Seq $-               Deep (n*2) pair-                    (runIdentity $ applicativeTree (n-2) 2 (Identity (node2 x1 x2)))-                    pair-               where pair = Two x1 x2-             RigidThree x1 x2 x3 -> Seq $-               Deep (n*3) triple-                    (runIdentity $ applicativeTree (n-2) 3 (Identity (node3 x1 x2 x3)))-                    triple-               where triple = Three x1 x2 x3-             RigidFull r@(Rigid s pr _m sf) -> Seq $-                   Deep (n*s)-                        (nodeToDigit pr)-                        (cycleNMiddle (n-2) r)-                        (nodeToDigit sf)--cycleNMiddle-  :: Int-     -> Rigid c-     -> FingerTree (Node c)---- Not at the bottom yet--cycleNMiddle !n-           (Rigid s pr (DeepTh sm prm mm sfm) sf)-    = Deep (sm + s * (n + 1)) -- note: sm = s - size pr - size sf-           (digit12ToDigit prm)-           (cycleNMiddle n-                       (Rigid s (squashL pr prm) mm (squashR sfm sf)))-           (digit12ToDigit sfm)---- At the bottom--cycleNMiddle n-           (Rigid s pr EmptyTh sf)-     = deep-            (One sf)-            (runIdentity $ applicativeTree n s (Identity converted))-            (One pr)-   where converted = node2 pr sf--cycleNMiddle n-           (Rigid s pr (SingleTh q) sf)-     = deep-            (Two q sf)-            (runIdentity $ applicativeTree n s (Identity converted))-            (Two pr q)-   where converted = node3 pr q sf----- | \( O(1) \). Add an element to the left end of a sequence.--- Mnemonic: a triangle with the single element at the pointy end.-(<|)            :: a -> Seq a -> Seq a-x <| Seq xs     =  Seq (Elem x `consTree` xs)--{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}-consTree        :: Sized a => a -> FingerTree a -> FingerTree a-consTree a EmptyT       = Single a-consTree a (Single b)   = deep (One a) EmptyT (One b)--- As described in the paper, we force the middle of a tree--- *before* consing onto it; this preserves the amortized--- bounds but prevents repeated consing from building up--- gigantic suspensions.-consTree a (Deep s (Four b c d e) m sf) = m `seq`-    Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf-consTree a (Deep s (Three b c d) m sf) =-    Deep (size a + s) (Four a b c d) m sf-consTree a (Deep s (Two b c) m sf) =-    Deep (size a + s) (Three a b c) m sf-consTree a (Deep s (One b) m sf) =-    Deep (size a + s) (Two a b) m sf--cons' :: a -> Seq a -> Seq a-cons' x (Seq xs) = Seq (Elem x `consTree'` xs)--snoc' :: Seq a -> a -> Seq a-snoc' (Seq xs) x = Seq (xs `snocTree'` Elem x)--{-# SPECIALIZE consTree' :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE consTree' :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}-consTree'        :: Sized a => a -> FingerTree a -> FingerTree a-consTree' a EmptyT       = Single a-consTree' a (Single b)   = deep (One a) EmptyT (One b)--- As described in the paper, we force the middle of a tree--- *before* consing onto it; this preserves the amortized--- bounds but prevents repeated consing from building up--- gigantic suspensions.-consTree' a (Deep s (Four b c d e) m sf) =-    Deep (size a + s) (Two a b) m' sf-  where !m' = abc `consTree'` m-        !abc = node3 c d e-consTree' a (Deep s (Three b c d) m sf) =-    Deep (size a + s) (Four a b c d) m sf-consTree' a (Deep s (Two b c) m sf) =-    Deep (size a + s) (Three a b c) m sf-consTree' a (Deep s (One b) m sf) =-    Deep (size a + s) (Two a b) m sf---- | \( O(1) \). Add an element to the right end of a sequence.--- Mnemonic: a triangle with the single element at the pointy end.-(|>)            :: Seq a -> a -> Seq a-Seq xs |> x     =  Seq (xs `snocTree` Elem x)--{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}-{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}-snocTree        :: Sized a => FingerTree a -> a -> FingerTree a-snocTree EmptyT a       =  Single a-snocTree (Single a) b   =  deep (One a) EmptyT (One b)--- See note on `seq` in `consTree`.-snocTree (Deep s pr m (Four a b c d)) e = m `seq`-    Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)-snocTree (Deep s pr m (Three a b c)) d =-    Deep (s + size d) pr m (Four a b c d)-snocTree (Deep s pr m (Two a b)) c =-    Deep (s + size c) pr m (Three a b c)-snocTree (Deep s pr m (One a)) b =-    Deep (s + size b) pr m (Two a b)--{-# SPECIALIZE snocTree' :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}-{-# SPECIALIZE snocTree' :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}-snocTree'        :: Sized a => FingerTree a -> a -> FingerTree a-snocTree' EmptyT a       =  Single a-snocTree' (Single a) b   =  deep (One a) EmptyT (One b)--- See note on `seq` in `consTree`.-snocTree' (Deep s pr m (Four a b c d)) e =-    Deep (s + size e) pr m' (Two d e)-  where !m' = m `snocTree'` abc-        !abc = node3 a b c-snocTree' (Deep s pr m (Three a b c)) d =-    Deep (s + size d) pr m (Four a b c d)-snocTree' (Deep s pr m (Two a b)) c =-    Deep (s + size c) pr m (Three a b c)-snocTree' (Deep s pr m (One a)) b =-    Deep (s + size b) pr m (Two a b)---- | \( O(\log(\min(n_1,n_2))) \). Concatenate two sequences.-(><)            :: Seq a -> Seq a -> Seq a-Seq xs >< Seq ys = Seq (appendTree0 xs ys)---- The appendTree/addDigits gunk below is machine generated--appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)-appendTree0 EmptyT xs =-    xs-appendTree0 xs EmptyT =-    xs-appendTree0 (Single x) xs =-    x `consTree` xs-appendTree0 xs (Single x) =-    xs `snocTree` x-appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =-    Deep (s1 + s2) pr1 m sf2-  where !m = addDigits0 m1 sf1 pr2 m2--addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))-addDigits0 m1 (One a) (One b) m2 =-    appendTree1 m1 (node2 a b) m2-addDigits0 m1 (One a) (Two b c) m2 =-    appendTree1 m1 (node3 a b c) m2-addDigits0 m1 (One a) (Three b c d) m2 =-    appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (One a) (Four b c d e) m2 =-    appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Two a b) (One c) m2 =-    appendTree1 m1 (node3 a b c) m2-addDigits0 m1 (Two a b) (Two c d) m2 =-    appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (Two a b) (Three c d e) m2 =-    appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Two a b) (Four c d e f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Three a b c) (One d) m2 =-    appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (Three a b c) (Two d e) m2 =-    appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Three a b c) (Three d e f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Three a b c) (Four d e f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits0 m1 (Four a b c d) (One e) m2 =-    appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Four a b c d) (Two e f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Four a b c d) (Three e f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits0 m1 (Four a b c d) (Four e f g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2--appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)-appendTree1 EmptyT !a xs =-    a `consTree` xs-appendTree1 xs !a EmptyT =-    xs `snocTree` a-appendTree1 (Single x) !a xs =-    x `consTree` a `consTree` xs-appendTree1 xs !a (Single x) =-    xs `snocTree` a `snocTree` x-appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =-    Deep (s1 + size a + s2) pr1 m sf2-  where !m = addDigits1 m1 sf1 a pr2 m2--addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))-addDigits1 m1 (One a) b (One c) m2 =-    appendTree1 m1 (node3 a b c) m2-addDigits1 m1 (One a) b (Two c d) m2 =-    appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits1 m1 (One a) b (Three c d e) m2 =-    appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (One a) b (Four c d e f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Two a b) c (One d) m2 =-    appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits1 m1 (Two a b) c (Two d e) m2 =-    appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (Two a b) c (Three d e f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Two a b) c (Four d e f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Three a b c) d (One e) m2 =-    appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (Three a b c) d (Two e f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Three a b c) d (Three e f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Three a b c) d (Four e f g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits1 m1 (Four a b c d) e (One f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Four a b c d) e (Two f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Four a b c d) e (Three f g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2--appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)-appendTree2 EmptyT !a !b xs =-    a `consTree` b `consTree` xs-appendTree2 xs !a !b EmptyT =-    xs `snocTree` a `snocTree` b-appendTree2 (Single x) a b xs =-    x `consTree` a `consTree` b `consTree` xs-appendTree2 xs a b (Single x) =-    xs `snocTree` a `snocTree` b `snocTree` x-appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =-    Deep (s1 + size a + size b + s2) pr1 m sf2-  where !m = addDigits2 m1 sf1 a b pr2 m2--addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))-addDigits2 m1 (One a) b c (One d) m2 =-    appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits2 m1 (One a) b c (Two d e) m2 =-    appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits2 m1 (One a) b c (Three d e f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (One a) b c (Four d e f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Two a b) c d (One e) m2 =-    appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits2 m1 (Two a b) c d (Two e f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (Two a b) c d (Three e f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Two a b) c d (Four e f g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Three a b c) d e (One f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (Three a b c) d e (Two f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Three a b c) d e (Three f g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits2 m1 (Four a b c d) e f (One g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Four a b c d) e f (Two g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =-    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2--appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)-appendTree3 EmptyT !a !b !c xs =-    a `consTree` b `consTree` c `consTree` xs-appendTree3 xs !a !b !c EmptyT =-    xs `snocTree` a `snocTree` b `snocTree` c-appendTree3 (Single x) a b c xs =-    x `consTree` a `consTree` b `consTree` c `consTree` xs-appendTree3 xs a b c (Single x) =-    xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x-appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =-    Deep (s1 + size a + size b + size c + s2) pr1 m sf2-  where !m = addDigits3 m1 sf1 a b c pr2 m2--addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))-addDigits3 m1 (One a) !b !c !d (One e) m2 =-    appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits3 m1 (One a) b c d (Two e f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits3 m1 (One a) b c d (Three e f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (One a) b c d (Four e f g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Two a b) !c !d !e (One f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits3 m1 (Two a b) c d e (Two f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (Two a b) c d e (Three f g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Three a b c) !d !e !f (One g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (Three a b c) d e f (Two g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =-    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits3 m1 (Four a b c d) !e !f !g (One h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =-    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =-    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2--appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)-appendTree4 EmptyT !a !b !c !d xs =-    a `consTree` b `consTree` c `consTree` d `consTree` xs-appendTree4 xs !a !b !c !d EmptyT =-    xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d-appendTree4 (Single x) a b c d xs =-    x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs-appendTree4 xs a b c d (Single x) =-    xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x-appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =-    Deep (s1 + size a + size b + size c + size d + s2) pr1 m sf2-  where !m = addDigits4 m1 sf1 a b c d pr2 m2--addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))-addDigits4 m1 (One a) !b !c !d !e (One f) m2 =-    appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits4 m1 (One a) b c d e (Two f g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits4 m1 (One a) b c d e (Three f g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (One a) b c d e (Four f g h i) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Two a b) !c !d !e !f (One g) m2 =-    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits4 m1 (Two a b) c d e f (Two g h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =-    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Three a b c) !d !e !f !g (One h) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =-    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =-    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2-addDigits4 m1 (Four a b c d) !e !f !g !h (One i) m2 =-    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Four a b c d) !e !f !g !h (Two i j) m2 =-    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Four a b c d) !e !f !g !h (Three i j k) m2 =-    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2-addDigits4 m1 (Four a b c d) !e !f !g !h (Four i j k l) m2 =-    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2---- | Builds a sequence from a seed value.  Takes time linear in the--- number of generated elements.  /WARNING:/ If the number of generated--- elements is infinite, this method will not terminate.-unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a-unfoldr f = unfoldr' empty-  -- uses tail recursion rather than, for instance, the List implementation.-  where unfoldr' !as b = maybe as (\ (a, b') -> unfoldr' (as `snoc'` a) b') (f b)---- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' ('fmap' swap . f) x)@.-unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a-unfoldl f = unfoldl' empty-  where unfoldl' !as b = maybe as (\ (b', a) -> unfoldl' (a `cons'` as) b') (f b)---- | \( O(n) \).  Constructs a sequence by repeated application of a function--- to a seed value.------ > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))-iterateN :: Int -> (a -> a) -> a -> Seq a-iterateN n f x-  | n >= 0      = replicateA n (State (\ y -> (f y, y))) `execState` x-  | otherwise   = error "iterateN takes a nonnegative integer argument"----------------------------------------------------------------------------- Deconstruction----------------------------------------------------------------------------- | \( O(1) \). Is this the empty sequence?-null            :: Seq a -> Bool-null (Seq EmptyT) = True-null _            =  False---- | \( O(1) \). The number of elements in the sequence.-length          :: Seq a -> Int-length (Seq xs) =  size xs---- Views--data ViewLTree a = ConsLTree a (FingerTree a) | EmptyLTree-data ViewRTree a = SnocRTree (FingerTree a) a | EmptyRTree---- | View of the left end of a sequence.-data ViewL a-    = EmptyL        -- ^ empty sequence-    | a :< Seq a    -- ^ leftmost element and the rest of the sequence-    deriving (Eq, Ord, Show, Read)--#ifdef __GLASGOW_HASKELL__-deriving instance Data a => Data (ViewL a)---- | @since 0.5.8-deriving instance Generic1 ViewL---- | @since 0.5.8-deriving instance Generic (ViewL a)-#endif--INSTANCE_TYPEABLE1(ViewL)--instance Functor ViewL where-    {-# INLINE fmap #-}-    fmap _ EmptyL       = EmptyL-    fmap f (x :< xs)    = f x :< fmap f xs--instance Foldable ViewL where-    foldr _ z EmptyL = z-    foldr f z (x :< xs) = f x (foldr f z xs)--    foldl _ z EmptyL = z-    foldl f z (x :< xs) = foldl f (f z x) xs--    foldl1 _ EmptyL = error "foldl1: empty view"-    foldl1 f (x :< xs) = foldl f x xs--#if MIN_VERSION_base(4,8,0)-    null EmptyL = True-    null (_ :< _) = False--    length EmptyL = 0-    length (_ :< xs) = 1 + length xs-#endif--instance Traversable ViewL where-    traverse _ EmptyL       = pure EmptyL-    traverse f (x :< xs)    = liftA2 (:<) (f x) (traverse f xs)---- | \( O(1) \). Analyse the left end of a sequence.-viewl           ::  Seq a -> ViewL a-viewl (Seq xs)  =  case viewLTree xs of-    EmptyLTree -> EmptyL-    ConsLTree (Elem x) xs' -> x :< Seq xs'--{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> ViewLTree (Elem a) #-}-{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> ViewLTree (Node a) #-}-viewLTree       :: Sized a => FingerTree a -> ViewLTree a-viewLTree EmptyT                = EmptyLTree-viewLTree (Single a)            = ConsLTree a EmptyT-viewLTree (Deep s (One a) m sf) = ConsLTree a (pullL (s - size a) m sf)-viewLTree (Deep s (Two a b) m sf) =-    ConsLTree a (Deep (s - size a) (One b) m sf)-viewLTree (Deep s (Three a b c) m sf) =-    ConsLTree a (Deep (s - size a) (Two b c) m sf)-viewLTree (Deep s (Four a b c d) m sf) =-    ConsLTree a (Deep (s - size a) (Three b c d) m sf)---- | View of the right end of a sequence.-data ViewR a-    = EmptyR        -- ^ empty sequence-    | Seq a :> a    -- ^ the sequence minus the rightmost element,-            -- and the rightmost element-    deriving (Eq, Ord, Show, Read)--#ifdef __GLASGOW_HASKELL__-deriving instance Data a => Data (ViewR a)---- | @since 0.5.8-deriving instance Generic1 ViewR---- | @since 0.5.8-deriving instance Generic (ViewR a)-#endif--INSTANCE_TYPEABLE1(ViewR)--instance Functor ViewR where-    {-# INLINE fmap #-}-    fmap _ EmptyR       = EmptyR-    fmap f (xs :> x)    = fmap f xs :> f x--instance Foldable ViewR where-    foldMap _ EmptyR = mempty-    foldMap f (xs :> x) = foldMap f xs <> f x--    foldr _ z EmptyR = z-    foldr f z (xs :> x) = foldr f (f x z) xs--    foldl _ z EmptyR = z-    foldl f z (xs :> x) = foldl f z xs `f` x--    foldr1 _ EmptyR = error "foldr1: empty view"-    foldr1 f (xs :> x) = foldr f x xs-#if MIN_VERSION_base(4,8,0)-    null EmptyR = True-    null (_ :> _) = False--    length EmptyR = 0-    length (xs :> _) = length xs + 1-#endif--instance Traversable ViewR where-    traverse _ EmptyR       = pure EmptyR-    traverse f (xs :> x)    = liftA2 (:>) (traverse f xs) (f x)---- | \( O(1) \). Analyse the right end of a sequence.-viewr           ::  Seq a -> ViewR a-viewr (Seq xs)  =  case viewRTree xs of-    EmptyRTree -> EmptyR-    SnocRTree xs' (Elem x) -> Seq xs' :> x--{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> ViewRTree (Elem a) #-}-{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> ViewRTree (Node a) #-}-viewRTree       :: Sized a => FingerTree a -> ViewRTree a-viewRTree EmptyT                = EmptyRTree-viewRTree (Single z)            = SnocRTree EmptyT z-viewRTree (Deep s pr m (One z)) = SnocRTree (pullR (s - size z) pr m) z-viewRTree (Deep s pr m (Two y z)) =-    SnocRTree (Deep (s - size z) pr m (One y)) z-viewRTree (Deep s pr m (Three x y z)) =-    SnocRTree (Deep (s - size z) pr m (Two x y)) z-viewRTree (Deep s pr m (Four w x y z)) =-    SnocRTree (Deep (s - size z) pr m (Three w x y)) z----------------------------------------------------------------------------- Scans------ These are not particularly complex applications of the Traversable--- functor, though making the correspondence with Data.List exact--- requires the use of (<|) and (|>).------ Note that save for the single (<|) or (|>), we maintain the original--- structure of the Seq, not having to do any restructuring of our own.------ wasserman.louis@gmail.com, 5/23/09----------------------------------------------------------------------------- | 'scanl' is similar to 'foldl', but returns a sequence of reduced--- values from the left:------ > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]-scanl :: (a -> b -> a) -> a -> Seq b -> Seq a-scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)---- | 'scanl1' is a variant of 'scanl' that has no starting value argument:------ > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]-scanl1 :: (a -> a -> a) -> Seq a -> Seq a-scanl1 f xs = case viewl xs of-    EmptyL          -> error "scanl1 takes a nonempty sequence as an argument"-    x :< xs'        -> scanl f x xs'---- | 'scanr' is the right-to-left dual of 'scanl'.-scanr :: (a -> b -> b) -> b -> Seq a -> Seq b-scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0---- | 'scanr1' is a variant of 'scanr' that has no starting value argument.-scanr1 :: (a -> a -> a) -> Seq a -> Seq a-scanr1 f xs = case viewr xs of-    EmptyR          -> error "scanr1 takes a nonempty sequence as an argument"-    xs' :> x        -> scanr f x xs'---- Indexing---- | \( O(\log(\min(i,n-i))) \). The element at the specified position,--- counting from 0.  The argument should thus be a non-negative--- integer less than the size of the sequence.--- If the position is out of range, 'index' fails with an error.------ prop> xs `index` i = toList xs !! i------ Caution: 'index' necessarily delays retrieving the requested--- element until the result is forced. It can therefore lead to a space--- leak if the result is stored, unforced, in another structure. To retrieve--- an element immediately without forcing it, use 'lookup' or '(!?)'.-index           :: Seq a -> Int -> a-index (Seq xs) i-  -- See note on unsigned arithmetic in splitAt-  | fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of-                Place _ (Elem x) -> x-  | otherwise   = -      error $ "index out of bounds in call to: Data.Sequence.index " ++ show i---- | \( O(\log(\min(i,n-i))) \). The element at the specified position,--- counting from 0. If the specified position is negative or at--- least the length of the sequence, 'lookup' returns 'Nothing'.------ prop> 0 <= i < length xs ==> lookup i xs == Just (toList xs !! i)--- prop> i < 0 || i >= length xs ==> lookup i xs = Nothing------ Unlike 'index', this can be used to retrieve an element without--- forcing it. For example, to insert the fifth element of a sequence--- @xs@ into a 'Data.Map.Lazy.Map' @m@ at key @k@, you could use------ @--- case lookup 5 xs of---   Nothing -> m---   Just x -> 'Data.Map.Lazy.insert' k x m--- @------ @since 0.5.8-lookup            :: Int -> Seq a -> Maybe a-lookup i (Seq xs)-  -- Note: we perform the lookup *before* applying the Just constructor-  -- to ensure that we don't hold a reference to the whole sequence in-  -- a thunk. If we applied the Just constructor around the case, the-  -- actual lookup wouldn't be performed unless and until the value was-  -- forced.-  | fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of-                Place _ (Elem x) -> Just x-  | otherwise = Nothing---- | \( O(\log(\min(i,n-i))) \). A flipped, infix version of `lookup`.------ @since 0.5.8-(!?) ::           Seq a -> Int -> Maybe a-(!?) = flip lookup--data Place a = Place {-# UNPACK #-} !Int a-#ifdef TESTING-    deriving Show-#endif--{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}-{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}-lookupTree :: Sized a => Int -> FingerTree a -> Place a-lookupTree !_ EmptyT = error "lookupTree of empty tree"-lookupTree i (Single x) = Place i x-lookupTree i (Deep _ pr m sf)-  | i < spr     =  lookupDigit i pr-  | i < spm     =  case lookupTree (i - spr) m of-                   Place i' xs -> lookupNode i' xs-  | otherwise   =  lookupDigit (i - spm) sf-  where-    spr     = size pr-    spm     = spr + size m--{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}-{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}-lookupNode :: Sized a => Int -> Node a -> Place a-lookupNode i (Node2 _ a b)-  | i < sa      = Place i a-  | otherwise   = Place (i - sa) b-  where-    sa      = size a-lookupNode i (Node3 _ a b c)-  | i < sa      = Place i a-  | i < sab     = Place (i - sa) b-  | otherwise   = Place (i - sab) c-  where-    sa      = size a-    sab     = sa + size b--{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}-{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}-lookupDigit :: Sized a => Int -> Digit a -> Place a-lookupDigit i (One a) = Place i a-lookupDigit i (Two a b)-  | i < sa      = Place i a-  | otherwise   = Place (i - sa) b-  where-    sa      = size a-lookupDigit i (Three a b c)-  | i < sa      = Place i a-  | i < sab     = Place (i - sa) b-  | otherwise   = Place (i - sab) c-  where-    sa      = size a-    sab     = sa + size b-lookupDigit i (Four a b c d)-  | i < sa      = Place i a-  | i < sab     = Place (i - sa) b-  | i < sabc    = Place (i - sab) c-  | otherwise   = Place (i - sabc) d-  where-    sa      = size a-    sab     = sa + size b-    sabc    = sab + size c---- | \( O(\log(\min(i,n-i))) \). Replace the element at the specified position.--- If the position is out of range, the original sequence is returned.-update          :: Int -> a -> Seq a -> Seq a-update i x (Seq xs)-  -- See note on unsigned arithmetic in splitAt-  | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq (updateTree (Elem x) i xs)-  | otherwise   = Seq xs---- It seems a shame to copy the implementation of the top layer of--- `adjust` instead of just using `update i x = adjust (const x) i`.--- With the latter implementation, updating the same position many--- times could lead to silly thunks building up around that position.--- The thunks will each look like @const v a@, where @v@ is the new--- value and @a@ the old.-updateTree      :: Elem a -> Int -> FingerTree (Elem a) -> FingerTree (Elem a)-updateTree _ !_ EmptyT = EmptyT -- Unreachable-updateTree v _i (Single _) = Single v-updateTree v i (Deep s pr m sf)-  | i < spr     = Deep s (updateDigit v i pr) m sf-  | i < spm     = let !m' = adjustTree (updateNode v) (i - spr) m-                  in Deep s pr m' sf-  | otherwise   = Deep s pr m (updateDigit v (i - spm) sf)-  where-    spr     = size pr-    spm     = spr + size m--updateNode      :: Elem a -> Int -> Node (Elem a) -> Node (Elem a)-updateNode v i (Node2 s a b)-  | i < sa      = Node2 s v b-  | otherwise   = Node2 s a v-  where-    sa      = size a-updateNode v i (Node3 s a b c)-  | i < sa      = Node3 s v b c-  | i < sab     = Node3 s a v c-  | otherwise   = Node3 s a b v-  where-    sa      = size a-    sab     = sa + size b--updateDigit     :: Elem a -> Int -> Digit (Elem a) -> Digit (Elem a)-updateDigit v !_i (One _) = One v-updateDigit v i (Two a b)-  | i < sa      = Two v b-  | otherwise   = Two a v-  where-    sa      = size a-updateDigit v i (Three a b c)-  | i < sa      = Three v b c-  | i < sab     = Three a v c-  | otherwise   = Three a b v-  where-    sa      = size a-    sab     = sa + size b-updateDigit v i (Four a b c d)-  | i < sa      = Four v b c d-  | i < sab     = Four a v c d-  | i < sabc    = Four a b v d-  | otherwise   = Four a b c v-  where-    sa      = size a-    sab     = sa + size b-    sabc    = sab + size c---- | \( O(\log(\min(i,n-i))) \). Update the element at the specified position.  If--- the position is out of range, the original sequence is returned.  'adjust'--- can lead to poor performance and even memory leaks, because it does not--- force the new value before installing it in the sequence. 'adjust'' should--- usually be preferred.------ @since 0.5.8-adjust          :: (a -> a) -> Int -> Seq a -> Seq a-adjust f i (Seq xs)-  -- See note on unsigned arithmetic in splitAt-  | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq (adjustTree (`seq` fmap f) i xs)-  | otherwise   = Seq xs---- | \( O(\log(\min(i,n-i))) \). Update the element at the specified position.--- If the position is out of range, the original sequence is returned.--- The new value is forced before it is installed in the sequence.------ @--- adjust' f i xs =---  case xs !? i of---    Nothing -> xs---    Just x -> let !x' = f x---              in update i x' xs--- @------ @since 0.5.8-adjust'          :: forall a . (a -> a) -> Int -> Seq a -> Seq a-#if __GLASGOW_HASKELL__ >= 708-adjust' f i xs-  -- See note on unsigned arithmetic in splitAt-  | fromIntegral i < (fromIntegral (length xs) :: Word) =-      coerce $ adjustTree (\ !_k (ForceBox a) -> ForceBox (f a)) i (coerce xs)-  | otherwise   = xs-#else--- This is inefficient, but fixing it would take a lot of fuss and bother--- for little immediate gain. We can deal with that when we have another--- Haskell implementation to worry about.-adjust' f i xs =-  case xs !? i of-    Nothing -> xs-    Just x -> let !x' = f x-              in update i x' xs-#endif--{-# SPECIALIZE adjustTree :: (Int -> ForceBox a -> ForceBox a) -> Int -> FingerTree (ForceBox a) -> FingerTree (ForceBox a) #-}-{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}-adjustTree      :: (Sized a, MaybeForce a) => (Int -> a -> a) ->-             Int -> FingerTree a -> FingerTree a-adjustTree _ !_ EmptyT = EmptyT -- Unreachable-adjustTree f i (Single x) = Single $!? f i x-adjustTree f i (Deep s pr m sf)-  | i < spr     = Deep s (adjustDigit f i pr) m sf-  | i < spm     = let !m' = adjustTree (adjustNode f) (i - spr) m-                  in Deep s pr m' sf-  | otherwise   = Deep s pr m (adjustDigit f (i - spm) sf)-  where-    spr     = size pr-    spm     = spr + size m--{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}-{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}-adjustNode      :: (Sized a, MaybeForce a) => (Int -> a -> a) -> Int -> Node a -> Node a-adjustNode f i (Node2 s a b)-  | i < sa      = let fia = f i a in fia `mseq` Node2 s fia b-  | otherwise   = let fisab = f (i - sa) b in fisab `mseq` Node2 s a fisab-  where-    sa      = size a-adjustNode f i (Node3 s a b c)-  | i < sa      = let fia = f i a in fia `mseq` Node3 s fia b c-  | i < sab     = let fisab = f (i - sa) b in fisab `mseq` Node3 s a fisab c-  | otherwise   = let fisabc = f (i - sab) c in fisabc `mseq` Node3 s a b fisabc-  where-    sa      = size a-    sab     = sa + size b--{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}-{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}-adjustDigit     :: (Sized a, MaybeForce a) => (Int -> a -> a) -> Int -> Digit a -> Digit a-adjustDigit f !i (One a) = One $!? f i a-adjustDigit f i (Two a b)-  | i < sa      = let fia = f i a in fia `mseq` Two fia b-  | otherwise   = let fisab = f (i - sa) b in fisab `mseq` Two a fisab-  where-    sa      = size a-adjustDigit f i (Three a b c)-  | i < sa      = let fia = f i a in fia `mseq` Three fia b c-  | i < sab     = let fisab = f (i - sa) b in fisab `mseq` Three a fisab c-  | otherwise   = let fisabc = f (i - sab) c in fisabc `mseq` Three a b fisabc-  where-    sa      = size a-    sab     = sa + size b-adjustDigit f i (Four a b c d)-  | i < sa      = let fia = f i a in fia `mseq` Four fia b c d-  | i < sab     = let fisab = f (i - sa) b in fisab `mseq` Four a fisab c d-  | i < sabc    = let fisabc = f (i - sab) c in fisabc `mseq` Four a b fisabc d-  | otherwise   = let fisabcd = f (i - sabc) d in fisabcd `mseq` Four a b c fisabcd-  where-    sa      = size a-    sab     = sa + size b-    sabc    = sab + size c---- | \( O(\log(\min(i,n-i))) \). @'insertAt' i x xs@ inserts @x@ into @xs@--- at the index @i@, shifting the rest of the sequence over.------ @--- insertAt 2 x (fromList [a,b,c,d]) = fromList [a,b,x,c,d]--- insertAt 4 x (fromList [a,b,c,d]) = insertAt 10 x (fromList [a,b,c,d])---                                   = fromList [a,b,c,d,x]--- @------ prop> insertAt i x xs = take i xs >< singleton x >< drop i xs------ @since 0.5.8-insertAt :: Int -> a -> Seq a -> Seq a-insertAt i a s@(Seq xs)-  | fromIntegral i < (fromIntegral (size xs) :: Word)-      = Seq (insTree (`seq` InsTwo (Elem a)) i xs)-  | i <= 0 = a <| s-  | otherwise = s |> a--data Ins a = InsOne a | InsTwo a a--{-# SPECIALIZE insTree :: (Int -> Elem a -> Ins (Elem a)) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}-{-# SPECIALIZE insTree :: (Int -> Node a -> Ins (Node a)) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}-insTree      :: Sized a => (Int -> a -> Ins a) ->-             Int -> FingerTree a -> FingerTree a-insTree _ !_ EmptyT = EmptyT -- Unreachable-insTree f i (Single x) = case f i x of-  InsOne x' -> Single x'-  InsTwo m n -> deep (One m) EmptyT (One n)-insTree f i (Deep s pr m sf)-  | i < spr     = case insLeftDigit f i pr of-     InsLeftDig pr' -> Deep (s + 1) pr' m sf-     InsDigNode pr' n -> m `seq` Deep (s + 1) pr' (n `consTree` m) sf-  | i < spm     = let !m' = insTree (insNode f) (i - spr) m-                  in Deep (s + 1) pr m' sf-  | otherwise   = case insRightDigit f (i - spm) sf of-     InsRightDig sf' -> Deep (s + 1) pr m sf'-     InsNodeDig n sf' -> m `seq` Deep (s + 1) pr (m `snocTree` n) sf'-  where-    spr     = size pr-    spm     = spr + size m--{-# SPECIALIZE insNode :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Node (Elem a) -> Ins (Node (Elem a)) #-}-{-# SPECIALIZE insNode :: (Int -> Node a -> Ins (Node a)) -> Int -> Node (Node a) -> Ins (Node (Node a)) #-}-insNode :: Sized a => (Int -> a -> Ins a) -> Int -> Node a -> Ins (Node a)-insNode f i (Node2 s a b)-  | i < sa = case f i a of-      InsOne n -> InsOne $ Node2 (s + 1) n b-      InsTwo m n -> InsOne $ Node3 (s + 1) m n b-  | otherwise = case f (i - sa) b of-      InsOne n -> InsOne $ Node2 (s + 1) a n-      InsTwo m n -> InsOne $ Node3 (s + 1) a m n-  where sa = size a-insNode f i (Node3 s a b c)-  | i < sa = case f i a of-      InsOne n -> InsOne $ Node3 (s + 1) n b c-      InsTwo m n -> InsTwo (Node2 (sa + 1) m n) (Node2 (s - sa) b c)-  | i < sab = case f (i - sa) b of-      InsOne n -> InsOne $ Node3 (s + 1) a n c-      InsTwo m n -> InsTwo am nc-        where !am = node2 a m-              !nc = node2 n c-  | otherwise = case f (i - sab) c of-      InsOne n -> InsOne $ Node3 (s + 1) a b n-      InsTwo m n -> InsTwo (Node2 sab a b) (Node2 (s - sab + 1) m n)-  where sa = size a-        sab = sa + size b--data InsDigNode a = InsLeftDig !(Digit a) | InsDigNode !(Digit a) !(Node a)-{-# SPECIALIZE insLeftDigit :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Digit (Elem a) -> InsDigNode (Elem a) #-}-{-# SPECIALIZE insLeftDigit :: (Int -> Node a -> Ins (Node a)) -> Int -> Digit (Node a) -> InsDigNode (Node a) #-}-insLeftDigit :: Sized a => (Int -> a -> Ins a) -> Int -> Digit a -> InsDigNode a-insLeftDigit f !i (One a) = case f i a of-  InsOne a' -> InsLeftDig $ One a'-  InsTwo a1 a2 -> InsLeftDig $ Two a1 a2-insLeftDigit f i (Two a b)-  | i < sa = case f i a of-     InsOne a' -> InsLeftDig $ Two a' b-     InsTwo a1 a2 -> InsLeftDig $ Three a1 a2 b-  | otherwise = case f (i - sa) b of-     InsOne b' -> InsLeftDig $ Two a b'-     InsTwo b1 b2 -> InsLeftDig $ Three a b1 b2-  where sa = size a-insLeftDigit f i (Three a b c)-  | i < sa = case f i a of-     InsOne a' -> InsLeftDig $ Three a' b c-     InsTwo a1 a2 -> InsLeftDig $ Four a1 a2 b c-  | i < sab = case f (i - sa) b of-     InsOne b' -> InsLeftDig $ Three a b' c-     InsTwo b1 b2 -> InsLeftDig $ Four a b1 b2 c-  | otherwise = case f (i - sab) c of-     InsOne c' -> InsLeftDig $ Three a b c'-     InsTwo c1 c2 -> InsLeftDig $ Four a b c1 c2-  where sa = size a-        sab = sa + size b-insLeftDigit f i (Four a b c d)-  | i < sa = case f i a of-     InsOne a' -> InsLeftDig $ Four a' b c d-     InsTwo a1 a2 -> InsDigNode (Two a1 a2) (node3 b c d)-  | i < sab = case f (i - sa) b of-     InsOne b' -> InsLeftDig $ Four a b' c d-     InsTwo b1 b2 -> InsDigNode (Two a b1) (node3 b2 c d)-  | i < sabc = case f (i - sab) c of-     InsOne c' -> InsLeftDig $ Four a b c' d-     InsTwo c1 c2 -> InsDigNode (Two a b) (node3 c1 c2 d)-  | otherwise = case f (i - sabc) d of-     InsOne d' -> InsLeftDig $ Four a b c d'-     InsTwo d1 d2 -> InsDigNode (Two a b) (node3 c d1 d2)-  where sa = size a-        sab = sa + size b-        sabc = sab + size c--data InsNodeDig a = InsRightDig !(Digit a) | InsNodeDig !(Node a) !(Digit a)-{-# SPECIALIZE insRightDigit :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Digit (Elem a) -> InsNodeDig (Elem a) #-}-{-# SPECIALIZE insRightDigit :: (Int -> Node a -> Ins (Node a)) -> Int -> Digit (Node a) -> InsNodeDig (Node a) #-}-insRightDigit :: Sized a => (Int -> a -> Ins a) -> Int -> Digit a -> InsNodeDig a-insRightDigit f !i (One a) = case f i a of-  InsOne a' -> InsRightDig $ One a'-  InsTwo a1 a2 -> InsRightDig $ Two a1 a2-insRightDigit f i (Two a b)-  | i < sa = case f i a of-     InsOne a' -> InsRightDig $ Two a' b-     InsTwo a1 a2 -> InsRightDig $ Three a1 a2 b-  | otherwise = case f (i - sa) b of-     InsOne b' -> InsRightDig $ Two a b'-     InsTwo b1 b2 -> InsRightDig $ Three a b1 b2-  where sa = size a-insRightDigit f i (Three a b c)-  | i < sa = case f i a of-     InsOne a' -> InsRightDig $ Three a' b c-     InsTwo a1 a2 -> InsRightDig $ Four a1 a2 b c-  | i < sab = case f (i - sa) b of-     InsOne b' -> InsRightDig $ Three a b' c-     InsTwo b1 b2 -> InsRightDig $ Four a b1 b2 c-  | otherwise = case f (i - sab) c of-     InsOne c' -> InsRightDig $ Three a b c'-     InsTwo c1 c2 -> InsRightDig $ Four a b c1 c2-  where sa = size a-        sab = sa + size b-insRightDigit f i (Four a b c d)-  | i < sa = case f i a of-     InsOne a' -> InsRightDig $ Four a' b c d-     InsTwo a1 a2 -> InsNodeDig (node3 a1 a2 b) (Two c d)-  | i < sab = case f (i - sa) b of-     InsOne b' -> InsRightDig $ Four a b' c d-     InsTwo b1 b2 -> InsNodeDig (node3 a b1 b2) (Two c d)-  | i < sabc = case f (i - sab) c of-     InsOne c' -> InsRightDig $ Four a b c' d-     InsTwo c1 c2 -> InsNodeDig (node3 a b c1) (Two c2 d)-  | otherwise = case f (i - sabc) d of-     InsOne d' -> InsRightDig $ Four a b c d'-     InsTwo d1 d2 -> InsNodeDig (node3 a b c) (Two d1 d2)-  where sa = size a-        sab = sa + size b-        sabc = sab + size c---- | \( O(\log(\min(i,n-i))) \). Delete the element of a sequence at a given--- index. Return the original sequence if the index is out of range.------ @--- deleteAt 2 [a,b,c,d] = [a,b,d]--- deleteAt 4 [a,b,c,d] = deleteAt (-1) [a,b,c,d] = [a,b,c,d]--- @------ @since 0.5.8-deleteAt :: Int -> Seq a -> Seq a-deleteAt i (Seq xs)-  | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq $ delTreeE i xs-  | otherwise = Seq xs--delTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)-delTreeE !_i EmptyT = EmptyT -- Unreachable-delTreeE _i Single{} = EmptyT-delTreeE i (Deep s pr m sf)-  | i < spr = delLeftDigitE i s pr m sf-  | i < spm = case delTree delNodeE (i - spr) m of-     FullTree m' -> Deep (s - 1) pr m' sf-     DefectTree e -> delRebuildMiddle (s - 1) pr e sf-  | otherwise = delRightDigitE (i - spm) s pr m sf-  where spr = size pr-        spm = spr + size m--delNodeE :: Int -> Node (Elem a) -> Del (Elem a)-delNodeE i (Node3 _ a b c) = case i of-  0 -> Full $ Node2 2 b c-  1 -> Full $ Node2 2 a c-  _ -> Full $ Node2 2 a b-delNodeE i (Node2 _ a b) = case i of-  0 -> Defect b-  _ -> Defect a---delLeftDigitE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a)-delLeftDigitE !_i s One{} m sf = pullL (s - 1) m sf-delLeftDigitE i s (Two a b) m sf-  | i == 0 = Deep (s - 1) (One b) m sf-  | otherwise = Deep (s - 1) (One a) m sf-delLeftDigitE i s (Three a b c) m sf-  | i == 0 = Deep (s - 1) (Two b c) m sf-  | i == 1 = Deep (s - 1) (Two a c) m sf-  | otherwise = Deep (s - 1) (Two a b) m sf-delLeftDigitE i s (Four a b c d) m sf-  | i == 0 = Deep (s - 1) (Three b c d) m sf-  | i == 1 = Deep (s - 1) (Three a c d) m sf-  | i == 2 = Deep (s - 1) (Three a b d) m sf-  | otherwise = Deep (s - 1) (Three a b c) m sf--delRightDigitE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a)-delRightDigitE !_i s pr m One{} = pullR (s - 1) pr m-delRightDigitE i s pr m (Two a b)-  | i == 0 = Deep (s - 1) pr m (One b)-  | otherwise = Deep (s - 1) pr m (One a)-delRightDigitE i s pr m (Three a b c)-  | i == 0 = Deep (s - 1) pr m (Two b c)-  | i == 1 = Deep (s - 1) pr m (Two a c)-  | otherwise = deep pr m (Two a b)-delRightDigitE i s pr m (Four a b c d)-  | i == 0 = Deep (s - 1) pr m (Three b c d)-  | i == 1 = Deep (s - 1) pr m (Three a c d)-  | i == 2 = Deep (s - 1) pr m (Three a b d)-  | otherwise = Deep (s - 1) pr m (Three a b c)--data DelTree a = FullTree !(FingerTree (Node a)) | DefectTree a--{-# SPECIALIZE delTree :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> FingerTree (Node (Elem a)) -> DelTree (Elem a) #-}-{-# SPECIALIZE delTree :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> FingerTree (Node (Node a)) -> DelTree (Node a) #-}-delTree :: Sized a => (Int -> Node a -> Del a) -> Int -> FingerTree (Node a) -> DelTree a-delTree _f !_i EmptyT = FullTree EmptyT -- Unreachable-delTree f i (Single a) = case f i a of-  Full a' -> FullTree (Single a')-  Defect e -> DefectTree e-delTree f i (Deep s pr m sf)-  | i < spr = case delDigit f i pr of-     FullDig pr' -> FullTree $ Deep (s - 1) pr' m sf-     DefectDig e -> case viewLTree m of-                      EmptyLTree -> FullTree $ delRebuildRightDigit (s - 1) e sf-                      ConsLTree n m' -> FullTree $ delRebuildLeftSide (s - 1) e n m' sf-  | i < spm = case delTree (delNode f) (i - spr) m of-     FullTree m' -> FullTree (Deep (s - 1) pr m' sf)-     DefectTree e -> FullTree $ delRebuildMiddle (s - 1) pr e sf-  | otherwise = case delDigit f (i - spm) sf of-     FullDig sf' -> FullTree $ Deep (s - 1) pr m sf'-     DefectDig e -> case viewRTree m of-                      EmptyRTree -> FullTree $ delRebuildLeftDigit (s - 1) pr e-                      SnocRTree m' n -> FullTree $ delRebuildRightSide (s - 1) pr m' n e-  where spr = size pr-        spm = spr + size m--data Del a = Full !(Node a) | Defect a--{-# SPECIALIZE delNode :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> Node (Node (Elem a)) -> Del (Node (Elem a)) #-}-{-# SPECIALIZE delNode :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> Node (Node (Node a)) -> Del (Node (Node a)) #-}-delNode :: Sized a => (Int -> Node a -> Del a) -> Int -> Node (Node a) -> Del (Node a)-delNode f i (Node3 s a b c)-  | i < sa = case f i a of-     Full a' -> Full $ Node3 (s - 1) a' b c-     Defect e -> let !se = size e in case b of-       Node3 sxyz x y z -> Full $ Node3 (s - 1) (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c-         where !sx = size x-       Node2 sxy x y -> Full $ Node2 (s - 1) (Node3 (sxy + se) e x y) c-  | i < sab = case f (i - sa) b of-     Full b' -> Full $ Node3 (s - 1) a b' c-     Defect e -> let !se = size e in case a of-       Node3 sxyz x y z -> Full $ Node3 (s - 1) (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c-         where !sz = size z-       Node2 sxy x y -> Full $ Node2 (s - 1) (Node3 (sxy + se) x y e) c-  | otherwise = case f (i - sab) c of-     Full c' -> Full $ Node3 (s - 1) a b c'-     Defect e -> let !se = size e in case b of-       Node3 sxyz x y z -> Full $ Node3 (s - 1) a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)-         where !sz = size z-       Node2 sxy x y -> Full $ Node2 (s - 1) a (Node3 (sxy + se) x y e)-  where sa = size a-        sab = sa + size b-delNode f i (Node2 s a b)-  | i < sa = case f i a of-     Full a' -> Full $ Node2 (s - 1) a' b-     Defect e -> let !se = size e in case b of-       Node3 sxyz x y z -> Full $ Node2 (s - 1) (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z)-        where !sx = size x-       Node2 _ x y -> Defect $ Node3 (s - 1) e x y-  | otherwise = case f (i - sa) b of-     Full b' -> Full $ Node2 (s - 1) a b'-     Defect e -> let !se = size e in case a of-       Node3 sxyz x y z -> Full $ Node2 (s - 1) (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)-         where !sz = size z-       Node2 _ x y -> Defect $ Node3 (s - 1) x y e-  where sa = size a--{-# SPECIALIZE delRebuildRightDigit :: Int -> Elem a -> Digit (Node (Elem a)) -> FingerTree (Node (Elem a)) #-}-{-# SPECIALIZE delRebuildRightDigit :: Int -> Node a -> Digit (Node (Node a)) -> FingerTree (Node (Node a)) #-}-delRebuildRightDigit :: Sized a => Int -> a -> Digit (Node a) -> FingerTree (Node a)-delRebuildRightDigit s p (One a) = let !sp = size p in case a of-  Node3 sxyz x y z -> Deep s (One (Node2 (sp + sx) p x)) EmptyT (One (Node2 (sxyz - sx) y z))-    where !sx = size x-  Node2 sxy x y -> Single (Node3 (sp + sxy) p x y)-delRebuildRightDigit s p (Two a b) = let !sp = size p in case a of-  Node3 sxyz x y z -> Deep s (Two (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z)) EmptyT (One b)-    where !sx = size x-  Node2 sxy x y -> Deep s (One (Node3 (sp + sxy) p x y)) EmptyT (One b)-delRebuildRightDigit s p (Three a b c) = let !sp = size p in case a of-  Node3 sxyz x y z -> Deep s (Two (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z)) EmptyT (Two b c)-    where !sx = size x-  Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) EmptyT (One c)-delRebuildRightDigit s p (Four a b c d) = let !sp = size p in case a of-  Node3 sxyz x y z -> Deep s (Three (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b) EmptyT (Two c d)-    where !sx = size x-  Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) EmptyT (Two c d)--{-# SPECIALIZE delRebuildLeftDigit :: Int -> Digit (Node (Elem a)) -> Elem a -> FingerTree (Node (Elem a)) #-}-{-# SPECIALIZE delRebuildLeftDigit :: Int -> Digit (Node (Node a)) -> Node a -> FingerTree (Node (Node a)) #-}-delRebuildLeftDigit :: Sized a => Int -> Digit (Node a) -> a -> FingerTree (Node a)-delRebuildLeftDigit s (One a) p = let !sp = size p in case a of-  Node3 sxyz x y z -> Deep s (One (Node2 (sxyz - sz) x y)) EmptyT (One (Node2 (sz + sp) z p))-    where !sz = size z-  Node2 sxy x y -> Single (Node3 (sxy + sp) x y p)-delRebuildLeftDigit s (Two a b) p = let !sp = size p in case b of-  Node3 sxyz x y z -> Deep s (Two a (Node2 (sxyz - sz) x y)) EmptyT (One (Node2 (sz + sp) z p))-    where !sz = size z-  Node2 sxy x y -> Deep s (One a) EmptyT (One (Node3 (sxy + sp) x y p))-delRebuildLeftDigit s (Three a b c) p = let !sp = size p in case c of-  Node3 sxyz x y z -> Deep s (Two a b) EmptyT (Two (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))-    where !sz = size z-  Node2 sxy x y -> Deep s (Two a b) EmptyT (One (Node3 (sxy + sp) x y p))-delRebuildLeftDigit s (Four a b c d) p = let !sp = size p in case d of-  Node3 sxyz x y z -> Deep s (Three a b c) EmptyT (Two (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))-    where !sz = size z-  Node2 sxy x y -> Deep s (Two a b) EmptyT (Two c (Node3 (sxy + sp) x y p))--delRebuildLeftSide :: Sized a-                   => Int -> a -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)-                   -> FingerTree (Node a)-delRebuildLeftSide s p (Node2 _ a b) m sf = let !sp = size p in case a of-  Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) m sf-  Node3 sxyz x y z -> Deep s (Three (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b) m sf-    where !sx = size x-delRebuildLeftSide s p (Node3 _ a b c) m sf = let !sp = size p in case a of-  Node2 sxy x y -> Deep s (Three (Node3 (sp + sxy) p x y) b c) m sf-  Node3 sxyz x y z -> Deep s (Four (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b c) m sf-    where !sx = size x--delRebuildRightSide :: Sized a-                    => Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a) -> a-                    -> FingerTree (Node a)-delRebuildRightSide s pr m (Node2 _ a b) p = let !sp = size p in case b of-  Node2 sxy x y -> Deep s pr m (Two a (Node3 (sxy + sp) x y p))-  Node3 sxyz x y z -> Deep s pr m (Three a (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))-    where !sz = size z-delRebuildRightSide s pr m (Node3 _ a b c) p = let !sp = size p in case c of-  Node2 sxy x y -> Deep s pr m (Three a b (Node3 (sxy + sp) x y p))-  Node3 sxyz x y z -> Deep s pr m (Four a b (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))-    where !sz = size z--delRebuildMiddle :: Sized a-                 => Int -> Digit a -> a -> Digit a-                 -> FingerTree a-delRebuildMiddle s (One a) e sf = Deep s (Two a e) EmptyT sf-delRebuildMiddle s (Two a b) e sf = Deep s (Three a b e) EmptyT sf-delRebuildMiddle s (Three a b c) e sf = Deep s (Four a b c e) EmptyT sf-delRebuildMiddle s (Four a b c d) e sf = Deep s (Two a b) (Single (node3 c d e)) sf--data DelDig a = FullDig !(Digit (Node a)) | DefectDig a--{-# SPECIALIZE delDigit :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> Digit (Node (Elem a)) -> DelDig (Elem a) #-}-{-# SPECIALIZE delDigit :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> Digit (Node (Node a)) -> DelDig (Node a) #-}-delDigit :: Sized a => (Int -> Node a -> Del a) -> Int -> Digit (Node a) -> DelDig a-delDigit f !i (One a) = case f i a of-  Full a' -> FullDig $ One a'-  Defect e -> DefectDig e-delDigit f i (Two a b)-  | i < sa = case f i a of-     Full a' -> FullDig $ Two a' b-     Defect e -> let !se = size e in case b of-       Node3 sxyz x y z -> FullDig $ Two (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z)-         where !sx = size x-       Node2 sxy x y -> FullDig $ One (Node3 (se + sxy) e x y)-  | otherwise = case f (i - sa) b of-     Full b' -> FullDig $ Two a b'-     Defect e -> let !se = size e in case a of-       Node3 sxyz x y z -> FullDig $ Two (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)-         where !sz = size z-       Node2 sxy x y -> FullDig $ One (Node3 (sxy + se) x y e)-  where sa = size a-delDigit f i (Three a b c)-  | i < sa = case f i a of-     Full a' -> FullDig $ Three a' b c-     Defect e -> let !se = size e in case b of-       Node3 sxyz x y z -> FullDig $ Three (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c-         where !sx = size x-       Node2 sxy x y -> FullDig $ Two (Node3 (se + sxy) e x y) c-  | i < sab = case f (i - sa) b of-     Full b' -> FullDig $ Three a b' c-     Defect e -> let !se = size e in case a of-       Node3 sxyz x y z -> FullDig $ Three (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c-         where !sz = size z-       Node2 sxy x y -> FullDig $ Two (Node3 (sxy + se) x y e) c-  | otherwise = case f (i - sab) c of-     Full c' -> FullDig $ Three a b c'-     Defect e -> let !se = size e in case b of-       Node3 sxyz x y z -> FullDig $ Three a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)-         where !sz = size z-       Node2 sxy x y -> FullDig $ Two a (Node3 (sxy + se) x y e)-  where sa = size a-        sab = sa + size b-delDigit f i (Four a b c d)-  | i < sa = case f i a of-     Full a' -> FullDig $ Four a' b c d-     Defect e -> let !se = size e in case b of-       Node3 sxyz x y z -> FullDig $ Four (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c d-         where !sx = size x-       Node2 sxy x y -> FullDig $ Three (Node3 (se + sxy) e x y) c d-  | i < sab = case f (i - sa) b of-     Full b' -> FullDig $ Four a b' c d-     Defect e -> let !se = size e in case a of-       Node3 sxyz x y z -> FullDig $ Four (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c d-         where !sz = size z-       Node2 sxy x y -> FullDig $ Three (Node3 (sxy + se) x y e) c d-  | i < sabc = case f (i - sab) c of-     Full c' -> FullDig $ Four a b c' d-     Defect e -> let !se = size e in case b of-       Node3 sxyz x y z -> FullDig $ Four a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) d-         where !sz = size z-       Node2 sxy x y -> FullDig $ Three a (Node3 (sxy + se) x y e) d-  | otherwise = case f (i - sabc) d of-     Full d' -> FullDig $ Four a b c d'-     Defect e -> let !se = size e in case c of-       Node3 sxyz x y z -> FullDig $ Four a b (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)-         where !sz = size z-       Node2 sxy x y -> FullDig $ Three a b (Node3 (sxy + se) x y e)-  where sa = size a-        sab = sa + size b-        sabc = sab + size c----- | A generalization of 'fmap', 'mapWithIndex' takes a mapping--- function that also depends on the element's index, and applies it to every--- element in the sequence.-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b-mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)) 0 xs'- where-  {-# SPECIALIZE mapWithIndexTree :: (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> FingerTree b #-}-  {-# SPECIALIZE mapWithIndexTree :: (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> FingerTree b #-}-  mapWithIndexTree :: Sized a => (Int -> a -> b) -> Int -> FingerTree a -> FingerTree b-  mapWithIndexTree _ !_s EmptyT = EmptyT-  mapWithIndexTree f s (Single xs) = Single $ f s xs-  mapWithIndexTree f s (Deep n pr m sf) =-          Deep n-               (mapWithIndexDigit f s pr)-               (mapWithIndexTree (mapWithIndexNode f) sPspr m)-               (mapWithIndexDigit f sPsprm sf)-    where-      !sPspr = s + size pr-      !sPsprm = sPspr + size m--  {-# SPECIALIZE mapWithIndexDigit :: (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> Digit b #-}-  {-# SPECIALIZE mapWithIndexDigit :: (Int -> Node y -> b) -> Int -> Digit (Node y) -> Digit b #-}-  mapWithIndexDigit :: Sized a => (Int -> a -> b) -> Int -> Digit a -> Digit b-  mapWithIndexDigit f !s (One a) = One (f s a)-  mapWithIndexDigit f s (Two a b) = Two (f s a) (f sPsa b)-    where-      !sPsa = s + size a-  mapWithIndexDigit f s (Three a b c) =-                                      Three (f s a) (f sPsa b) (f sPsab c)-    where-      !sPsa = s + size a-      !sPsab = sPsa + size b-  mapWithIndexDigit f s (Four a b c d) =-                          Four (f s a) (f sPsa b) (f sPsab c) (f sPsabc d)-    where-      !sPsa = s + size a-      !sPsab = sPsa + size b-      !sPsabc = sPsab + size c--  {-# SPECIALIZE mapWithIndexNode :: (Int -> Elem y -> b) -> Int -> Node (Elem y) -> Node b #-}-  {-# SPECIALIZE mapWithIndexNode :: (Int -> Node y -> b) -> Int -> Node (Node y) -> Node b #-}-  mapWithIndexNode :: Sized a => (Int -> a -> b) -> Int -> Node a -> Node b-  mapWithIndexNode f s (Node2 ns a b) = Node2 ns (f s a) (f sPsa b)-    where-      !sPsa = s + size a-  mapWithIndexNode f s (Node3 ns a b c) =-                                     Node3 ns (f s a) (f sPsa b) (f sPsab c)-    where-      !sPsa = s + size a-      !sPsab = sPsa + size b--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] mapWithIndex #-}-{-# RULES-"mapWithIndex/mapWithIndex" forall f g xs . mapWithIndex f (mapWithIndex g xs) =-  mapWithIndex (\k a -> f k (g k a)) xs-"mapWithIndex/fmapSeq" forall f g xs . mapWithIndex f (fmapSeq g xs) =-  mapWithIndex (\k a -> f k (g a)) xs-"fmapSeq/mapWithIndex" forall f g xs . fmapSeq f (mapWithIndex g xs) =-  mapWithIndex (\k a -> f (g k a)) xs- #-}-#endif--{-# INLINE foldWithIndexDigit #-}-foldWithIndexDigit :: Sized a => (b -> b -> b) -> (Int -> a -> b) -> Int -> Digit a -> b-foldWithIndexDigit _ f !s (One a) = f s a-foldWithIndexDigit (<+>) f s (Two a b) = f s a <+> f sPsa b-  where-    !sPsa = s + size a-foldWithIndexDigit (<+>) f s (Three a b c) = f s a <+> f sPsa b <+> f sPsab c-  where-    !sPsa = s + size a-    !sPsab = sPsa + size b-foldWithIndexDigit (<+>) f s (Four a b c d) =-    f s a <+> f sPsa b <+> f sPsab c <+> f sPsabc d-  where-    !sPsa = s + size a-    !sPsab = sPsa + size b-    !sPsabc = sPsab + size c--{-# INLINE foldWithIndexNode #-}-foldWithIndexNode :: Sized a => (m -> m -> m) -> (Int -> a -> m) -> Int -> Node a -> m-foldWithIndexNode (<+>) f !s (Node2 _ a b) = f s a <+> f sPsa b-  where-    !sPsa = s + size a-foldWithIndexNode (<+>) f s (Node3 _ a b c) = f s a <+> f sPsa b <+> f sPsab c-  where-    !sPsa = s + size a-    !sPsab = sPsa + size b---- A generalization of 'foldMap', 'foldMapWithIndex' takes a folding--- function that also depends on the element's index, and applies it to every--- element in the sequence.------ @since 0.5.8-foldMapWithIndex :: Monoid m => (Int -> a -> m) -> Seq a -> m-foldMapWithIndex f' (Seq xs') = foldMapWithIndexTreeE (lift_elem f') 0 xs'- where-  lift_elem :: (Int -> a -> m) -> (Int -> Elem a -> m)-#if __GLASGOW_HASKELL__ >= 708-  lift_elem g = coerce g-#else-  lift_elem g = \s (Elem a) -> g s a-#endif-  {-# INLINE lift_elem #-}--- We have to specialize these functions by hand, unfortunately, because--- GHC does not specialize until *all* instances are determined.--- Although the Sized instance is known at compile time, the Monoid--- instance generally is not.-  foldMapWithIndexTreeE :: Monoid m => (Int -> Elem a -> m) -> Int -> FingerTree (Elem a) -> m-  foldMapWithIndexTreeE _ !_s EmptyT = mempty-  foldMapWithIndexTreeE f s (Single xs) = f s xs-  foldMapWithIndexTreeE f s (Deep _ pr m sf) =-               foldMapWithIndexDigitE f s pr <>-               foldMapWithIndexTreeN (foldMapWithIndexNodeE f) sPspr m <>-               foldMapWithIndexDigitE f sPsprm sf-    where-      !sPspr = s + size pr-      !sPsprm = sPspr + size m--  foldMapWithIndexTreeN :: Monoid m => (Int -> Node a -> m) -> Int -> FingerTree (Node a) -> m-  foldMapWithIndexTreeN _ !_s EmptyT = mempty-  foldMapWithIndexTreeN f s (Single xs) = f s xs-  foldMapWithIndexTreeN f s (Deep _ pr m sf) =-               foldMapWithIndexDigitN f s pr <>-               foldMapWithIndexTreeN (foldMapWithIndexNodeN f) sPspr m <>-               foldMapWithIndexDigitN f sPsprm sf-    where-      !sPspr = s + size pr-      !sPsprm = sPspr + size m--  foldMapWithIndexDigitE :: Monoid m => (Int -> Elem a -> m) -> Int -> Digit (Elem a) -> m-  foldMapWithIndexDigitE f i t = foldWithIndexDigit (<>) f i t--  foldMapWithIndexDigitN :: Monoid m => (Int -> Node a -> m) -> Int -> Digit (Node a) -> m-  foldMapWithIndexDigitN f i t = foldWithIndexDigit (<>) f i t--  foldMapWithIndexNodeE :: Monoid m => (Int -> Elem a -> m) -> Int -> Node (Elem a) -> m-  foldMapWithIndexNodeE f i t = foldWithIndexNode (<>) f i t--  foldMapWithIndexNodeN :: Monoid m => (Int -> Node a -> m) -> Int -> Node (Node a) -> m-  foldMapWithIndexNodeN f i t = foldWithIndexNode (<>) f i t--#if __GLASGOW_HASKELL__-{-# INLINABLE foldMapWithIndex #-}-#endif---- | 'traverseWithIndex' is a version of 'traverse' that also offers--- access to the index of each element.------ @since 0.5.8-traverseWithIndex :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)-traverseWithIndex f' (Seq xs') = Seq <$> traverseWithIndexTreeE (\s (Elem a) -> Elem <$> f' s a) 0 xs'- where--- We have to specialize these functions by hand, unfortunately, because--- GHC does not specialize until *all* instances are determined.--- Although the Sized instance is known at compile time, the Applicative--- instance generally is not.-  traverseWithIndexTreeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> FingerTree (Elem a) -> f (FingerTree b)-  traverseWithIndexTreeE _ !_s EmptyT = pure EmptyT-  traverseWithIndexTreeE f s (Single xs) = Single <$> f s xs-  traverseWithIndexTreeE f s (Deep n pr m sf) =-          liftA3 (Deep n)-               (traverseWithIndexDigitE f s pr)-               (traverseWithIndexTreeN (traverseWithIndexNodeE f) sPspr m)-               (traverseWithIndexDigitE f sPsprm sf)-    where-      !sPspr = s + size pr-      !sPsprm = sPspr + size m--  traverseWithIndexTreeN :: Applicative f => (Int -> Node a -> f b) -> Int -> FingerTree (Node a) -> f (FingerTree b)-  traverseWithIndexTreeN _ !_s EmptyT = pure EmptyT-  traverseWithIndexTreeN f s (Single xs) = Single <$> f s xs-  traverseWithIndexTreeN f s (Deep n pr m sf) =-          liftA3 (Deep n)-               (traverseWithIndexDigitN f s pr)-               (traverseWithIndexTreeN (traverseWithIndexNodeN f) sPspr m)-               (traverseWithIndexDigitN f sPsprm sf)-    where-      !sPspr = s + size pr-      !sPsprm = sPspr + size m--  traverseWithIndexDigitE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Digit (Elem a) -> f (Digit b)-  traverseWithIndexDigitE f i t = traverseWithIndexDigit f i t--  traverseWithIndexDigitN :: Applicative f => (Int -> Node a -> f b) -> Int -> Digit (Node a) -> f (Digit b)-  traverseWithIndexDigitN f i t = traverseWithIndexDigit f i t--  {-# INLINE traverseWithIndexDigit #-}-  traverseWithIndexDigit :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Digit a -> f (Digit b)-  traverseWithIndexDigit f !s (One a) = One <$> f s a-  traverseWithIndexDigit f s (Two a b) = liftA2 Two (f s a) (f sPsa b)-    where-      !sPsa = s + size a-  traverseWithIndexDigit f s (Three a b c) =-                                      liftA3 Three (f s a) (f sPsa b) (f sPsab c)-    where-      !sPsa = s + size a-      !sPsab = sPsa + size b-  traverseWithIndexDigit f s (Four a b c d) =-                          liftA3 Four (f s a) (f sPsa b) (f sPsab c) <*> f sPsabc d-    where-      !sPsa = s + size a-      !sPsab = sPsa + size b-      !sPsabc = sPsab + size c--  traverseWithIndexNodeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Node (Elem a) -> f (Node b)-  traverseWithIndexNodeE f i t = traverseWithIndexNode f i t--  traverseWithIndexNodeN :: Applicative f => (Int -> Node a -> f b) -> Int -> Node (Node a) -> f (Node b)-  traverseWithIndexNodeN f i t = traverseWithIndexNode f i t--  {-# INLINE traverseWithIndexNode #-}-  traverseWithIndexNode :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Node a -> f (Node b)-  traverseWithIndexNode f !s (Node2 ns a b) = liftA2 (Node2 ns) (f s a) (f sPsa b)-    where-      !sPsa = s + size a-  traverseWithIndexNode f s (Node3 ns a b c) =-                           liftA3 (Node3 ns) (f s a) (f sPsa b) (f sPsab c)-    where-      !sPsa = s + size a-      !sPsab = sPsa + size b---{-# NOINLINE [1] traverseWithIndex #-}-#ifdef __GLASGOW_HASKELL__-{-# RULES-"travWithIndex/mapWithIndex" forall f g xs . traverseWithIndex f (mapWithIndex g xs) =-  traverseWithIndex (\k a -> f k (g k a)) xs-"travWithIndex/fmapSeq" forall f g xs . traverseWithIndex f (fmapSeq g xs) =-  traverseWithIndex (\k a -> f k (g a)) xs- #-}-#endif-{--It might be nice to be able to rewrite--traverseWithIndex f (fromFunction i g)-to-replicateAWithIndex i (\k -> f k (g k))-and-traverse f (fromFunction i g)-to-replicateAWithIndex i (f . g)--but we don't have replicateAWithIndex as yet.--We might wish for a rule like-"fmapSeq/travWithIndex" forall f g xs . fmapSeq f <$> traverseWithIndex g xs =-  traverseWithIndex (\k a -> f <$> g k a) xs-Unfortunately, this rule could screw up the inliner's treatment of-fmap in general, and it also relies on the arbitrary Functor being-valid.--}----- | \( O(n) \). Convert a given sequence length and a function representing that--- sequence into a sequence.------ @since 0.5.6.2-fromFunction :: Int -> (Int -> a) -> Seq a-fromFunction len f | len < 0 = error "Data.Sequence.fromFunction called with negative len"-                   | len == 0 = empty-                   | otherwise = Seq $ create (lift_elem f) 1 0 len-  where-    create :: (Int -> a) -> Int -> Int -> Int -> FingerTree a-    create b{-tree_builder-} !s{-tree_size-} !i{-start_index-} trees = case trees of-       1 -> Single $ b i-       2 -> Deep (2*s) (One (b i)) EmptyT (One (b (i+s)))-       3 -> Deep (3*s) (createTwo i) EmptyT (One (b (i+2*s)))-       4 -> Deep (4*s) (createTwo i) EmptyT (createTwo (i+2*s))-       5 -> Deep (5*s) (createThree i) EmptyT (createTwo (i+3*s))-       6 -> Deep (6*s) (createThree i) EmptyT (createThree (i+3*s))-       _ -> case trees `quotRem` 3 of-           (trees', 1) -> Deep (trees*s) (createTwo i)-                              (create mb (3*s) (i+2*s) (trees'-1))-                              (createTwo (i+(2+3*(trees'-1))*s))-           (trees', 2) -> Deep (trees*s) (createThree i)-                              (create mb (3*s) (i+3*s) (trees'-1))-                              (createTwo (i+(3+3*(trees'-1))*s))-           (trees', _) -> Deep (trees*s) (createThree i)-                              (create mb (3*s) (i+3*s) (trees'-2))-                              (createThree (i+(3+3*(trees'-2))*s))-      where-        createTwo j = Two (b j) (b (j + s))-        {-# INLINE createTwo #-}-        createThree j = Three (b j) (b (j + s)) (b (j + 2*s))-        {-# INLINE createThree #-}-        mb j = Node3 (3*s) (b j) (b (j + s)) (b (j + 2*s))-        {-# INLINE mb #-}--    lift_elem :: (Int -> a) -> (Int -> Elem a)-#if __GLASGOW_HASKELL__ >= 708-    lift_elem g = coerce g-#else-    lift_elem g = Elem . g-#endif-    {-# INLINE lift_elem #-}---- | \( O(n) \). Create a sequence consisting of the elements of an 'Array'.--- Note that the resulting sequence elements may be evaluated lazily (as on GHC),--- so you must force the entire structure to be sure that the original array--- can be garbage-collected.------ @since 0.5.6.2-fromArray :: Ix i => Array i a -> Seq a-#ifdef __GLASGOW_HASKELL__-fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a)- where-  -- The following definition uses (Ix i) constraing, which is needed for the-  -- other fromArray definition.-  _ = Data.Array.rangeSize (Data.Array.bounds a)-#else-fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a)-#endif---- Splitting---- | \( O(\log(\min(i,n-i))) \). The first @i@ elements of a sequence.--- If @i@ is negative, @'take' i s@ yields the empty sequence.--- If the sequence contains fewer than @i@ elements, the whole sequence--- is returned.-take :: Int -> Seq a -> Seq a-take i xs@(Seq t)-    -- See note on unsigned arithmetic in splitAt-  | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =-      Seq (takeTreeE i t)-  | i <= 0 = empty-  | otherwise = xs--takeTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)-takeTreeE !_i EmptyT = EmptyT-takeTreeE i t@(Single _)-   | i <= 0 = EmptyT-   | otherwise = t-takeTreeE i (Deep s pr m sf)-  | i < spr     = takePrefixE i pr-  | i < spm     = case takeTreeN im m of-            ml :*: xs -> takeMiddleE (im - size ml) spr pr ml xs-  | otherwise   = takeSuffixE (i - spm) s pr m sf-  where-    spr     = size pr-    spm     = spr + size m-    im      = i - spr--takeTreeN :: Int -> FingerTree (Node a) -> StrictPair (FingerTree (Node a)) (Node a)-takeTreeN !_i EmptyT = error "takeTreeN of empty tree"-takeTreeN _i (Single x) = EmptyT :*: x-takeTreeN i (Deep s pr m sf)-  | i < spr     = takePrefixN i pr-  | i < spm     = case takeTreeN im m of-            ml :*: xs -> takeMiddleN (im - size ml) spr pr ml xs-  | otherwise   = takeSuffixN (i - spm) s pr m sf  where-    spr     = size pr-    spm     = spr + size m-    im      = i - spr--takeMiddleN :: Int -> Int-             -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a)-             -> StrictPair (FingerTree (Node a)) (Node a)-takeMiddleN i spr pr ml (Node2 _ a b)-  | i < sa      = pullR sprml pr ml :*: a-  | otherwise   = Deep sprmla pr ml (One a) :*: b-  where-    sa      = size a-    sprml   = spr + size ml-    sprmla  = sa + sprml-takeMiddleN i spr pr ml (Node3 _ a b c)-  | i < sa      = pullR sprml pr ml :*: a-  | i < sab     = Deep sprmla pr ml (One a) :*: b-  | otherwise   = Deep sprmlab pr ml (Two a b) :*: c-  where-    sa      = size a-    sab     = sa + size b-    sprml   = spr + size ml-    sprmla  = sa + sprml-    sprmlab = sprmla + size b--takeMiddleE :: Int -> Int-             -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Node (Elem a)-             -> FingerTree (Elem a)-takeMiddleE i spr pr ml (Node2 _ a _)-  | i < 1       = pullR sprml pr ml-  | otherwise   = Deep sprmla pr ml (One a)-  where-    sprml   = spr + size ml-    sprmla  = 1 + sprml-takeMiddleE i spr pr ml (Node3 _ a b _)-  | i < 1       = pullR sprml pr ml-  | i < 2       = Deep sprmla pr ml (One a)-  | otherwise   = Deep sprmlab pr ml (Two a b)-  where-    sprml   = spr + size ml-    sprmla  = 1 + sprml-    sprmlab = sprmla + 1--takePrefixE :: Int -> Digit (Elem a) -> FingerTree (Elem a)-takePrefixE !_i (One _) = EmptyT-takePrefixE i (Two a _)-  | i < 1       = EmptyT-  | otherwise   = Single a-takePrefixE i (Three a b _)-  | i < 1       = EmptyT-  | i < 2       = Single a-  | otherwise   = Deep 2 (One a) EmptyT (One b)-takePrefixE i (Four a b c _)-  | i < 1       = EmptyT-  | i < 2       = Single a-  | i < 3       = Deep 2 (One a) EmptyT (One b)-  | otherwise   = Deep 3 (Two a b) EmptyT (One c)--takePrefixN :: Int -> Digit (Node a)-                    -> StrictPair (FingerTree (Node a)) (Node a)-takePrefixN !_i (One a) = EmptyT :*: a-takePrefixN i (Two a b)-  | i < sa      = EmptyT :*: a-  | otherwise   = Single a :*: b-  where-    sa      = size a-takePrefixN i (Three a b c)-  | i < sa      = EmptyT :*: a-  | i < sab     = Single a :*: b-  | otherwise   = Deep sab (One a) EmptyT (One b) :*: c-  where-    sa      = size a-    sab     = sa + size b-takePrefixN i (Four a b c d)-  | i < sa      = EmptyT :*: a-  | i < sab     = Single a :*: b-  | i < sabc    = Deep sab (One a) EmptyT (One b) :*: c-  | otherwise   = Deep sabc (Two a b) EmptyT (One c) :*: d-  where-    sa      = size a-    sab     = sa + size b-    sabc    = sab + size c--takeSuffixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->-   FingerTree (Elem a)-takeSuffixE !_i !s pr m (One _) = pullR (s - 1) pr m-takeSuffixE i s pr m (Two a _)-  | i < 1      = pullR (s - 2) pr m-  | otherwise  = Deep (s - 1) pr m (One a)-takeSuffixE i s pr m (Three a b _)-  | i < 1      = pullR (s - 3) pr m-  | i < 2      = Deep (s - 2) pr m (One a)-  | otherwise  = Deep (s - 1) pr m (Two a b)-takeSuffixE i s pr m (Four a b c _)-  | i < 1      = pullR (s - 4) pr m-  | i < 2      = Deep (s - 3) pr m (One a)-  | i < 3      = Deep (s - 2) pr m (Two a b)-  | otherwise  = Deep (s - 1) pr m (Three a b c)--takeSuffixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->-   StrictPair (FingerTree (Node a)) (Node a)-takeSuffixN !_i !s pr m (One a) = pullR (s - size a) pr m :*: a-takeSuffixN i s pr m (Two a b)-  | i < sa      = pullR (s - sa - size b) pr m :*: a-  | otherwise   = Deep (s - size b) pr m (One a) :*: b-  where-    sa      = size a-takeSuffixN i s pr m (Three a b c)-  | i < sa      = pullR (s - sab - size c) pr m :*: a-  | i < sab     = Deep (s - size b - size c) pr m (One a) :*: b-  | otherwise   = Deep (s - size c) pr m (Two a b) :*: c-  where-    sa      = size a-    sab     = sa + size b-takeSuffixN i s pr m (Four a b c d)-  | i < sa      = pullR (s - sa - sbcd) pr m :*: a-  | i < sab     = Deep (s - sbcd) pr m (One a) :*: b-  | i < sabc    = Deep (s - scd) pr m (Two a b) :*: c-  | otherwise   = Deep (s - sd) pr m (Three a b c) :*: d-  where-    sa      = size a-    sab     = sa + size b-    sabc    = sab + size c-    sd      = size d-    scd     = size c + sd-    sbcd    = size b + scd---- | \( O(\log(\min(i,n-i))) \). Elements of a sequence after the first @i@.--- If @i@ is negative, @'drop' i s@ yields the whole sequence.--- If the sequence contains fewer than @i@ elements, the empty sequence--- is returned.-drop            :: Int -> Seq a -> Seq a-drop i xs@(Seq t)-    -- See note on unsigned arithmetic in splitAt-  | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =-      Seq (takeTreeER (length xs - i) t)-  | i <= 0 = xs-  | otherwise = empty---- We implement `drop` using a "take from the rear" strategy.  There's no--- particular technical reason for this; it just lets us reuse the arithmetic--- from `take` (which itself reuses the arithmetic from `splitAt`) instead of--- figuring it out from scratch and ending up with lots of off-by-one errors.-takeTreeER :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)-takeTreeER !_i EmptyT = EmptyT-takeTreeER i t@(Single _)-   | i <= 0 = EmptyT-   | otherwise = t-takeTreeER i (Deep s pr m sf)-  | i < ssf     = takeSuffixER i sf-  | i < ssm     = case takeTreeNR im m of-            xs :*: mr -> takeMiddleER (im - size mr) ssf xs mr sf-  | otherwise   = takePrefixER (i - ssm) s pr m sf-  where-    ssf     = size sf-    ssm     = ssf + size m-    im      = i - ssf--takeTreeNR :: Int -> FingerTree (Node a) -> StrictPair (Node a) (FingerTree (Node a))-takeTreeNR !_i EmptyT = error "takeTreeNR of empty tree"-takeTreeNR _i (Single x) = x :*: EmptyT-takeTreeNR i (Deep s pr m sf)-  | i < ssf     = takeSuffixNR i sf-  | i < ssm     = case takeTreeNR im m of-            xs :*: mr -> takeMiddleNR (im - size mr) ssf xs mr sf-  | otherwise   = takePrefixNR (i - ssm) s pr m sf  where-    ssf     = size sf-    ssm     = ssf + size m-    im      = i - ssf--takeMiddleNR :: Int -> Int-             -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)-             -> StrictPair (Node a) (FingerTree (Node a))-takeMiddleNR i ssf (Node2 _ a b) mr sf-  | i < sb      = b :*: pullL ssfmr mr sf-  | otherwise   = a :*: Deep ssfmrb (One b) mr sf-  where-    sb      = size b-    ssfmr   = ssf + size mr-    ssfmrb  = sb + ssfmr-takeMiddleNR i ssf (Node3 _ a b c) mr sf-  | i < sc      = c :*: pullL ssfmr mr sf-  | i < sbc     = b :*: Deep ssfmrc (One c) mr sf-  | otherwise   = a :*: Deep ssfmrbc (Two b c) mr sf-  where-    sc      = size c-    sbc     = sc + size b-    ssfmr   = ssf + size mr-    ssfmrc  = sc + ssfmr-    ssfmrbc = ssfmrc + size b--takeMiddleER :: Int -> Int-             -> Node (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a)-             -> FingerTree (Elem a)-takeMiddleER i ssf (Node2 _ _ b) mr sf-  | i < 1       = pullL ssfmr mr sf-  | otherwise   = Deep ssfmrb (One b) mr sf-  where-    ssfmr   = ssf + size mr-    ssfmrb  = 1 + ssfmr-takeMiddleER i ssf (Node3 _ _ b c) mr sf-  | i < 1       = pullL ssfmr mr sf-  | i < 2       = Deep ssfmrc (One c) mr sf-  | otherwise   = Deep ssfmrbc (Two b c) mr sf-  where-    ssfmr   = ssf + size mr-    ssfmrc  = 1 + ssfmr-    ssfmrbc = ssfmr + 2--takeSuffixER :: Int -> Digit (Elem a) -> FingerTree (Elem a)-takeSuffixER !_i (One _) = EmptyT-takeSuffixER i (Two _ b)-  | i < 1       = EmptyT-  | otherwise   = Single b-takeSuffixER i (Three _ b c)-  | i < 1       = EmptyT-  | i < 2       = Single c-  | otherwise   = Deep 2 (One b) EmptyT (One c)-takeSuffixER i (Four _ b c d)-  | i < 1       = EmptyT-  | i < 2       = Single d-  | i < 3       = Deep 2 (One c) EmptyT (One d)-  | otherwise   = Deep 3 (Two b c) EmptyT (One d)--takeSuffixNR :: Int -> Digit (Node a)-                    -> StrictPair (Node a) (FingerTree (Node a))-takeSuffixNR !_i (One a) = a :*: EmptyT-takeSuffixNR i (Two a b)-  | i < sb      = b :*: EmptyT-  | otherwise   = a :*: Single b-  where-    sb      = size b-takeSuffixNR i (Three a b c)-  | i < sc      = c :*: EmptyT-  | i < sbc     = b :*: Single c-  | otherwise   = a :*: Deep sbc (One b) EmptyT (One c)-  where-    sc      = size c-    sbc     = sc + size b-takeSuffixNR i (Four a b c d)-  | i < sd      = d :*: EmptyT-  | i < scd     = c :*: Single d-  | i < sbcd    = b :*: Deep scd (One c) EmptyT (One d)-  | otherwise   = a :*: Deep sbcd (Two b c) EmptyT (One d)-  where-    sd      = size d-    scd     = sd + size c-    sbcd    = scd + size b--takePrefixER :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->-   FingerTree (Elem a)-takePrefixER !_i !s (One _) m sf = pullL (s - 1) m sf-takePrefixER i s (Two _ b) m sf-  | i < 1      = pullL (s - 2) m sf-  | otherwise  = Deep (s - 1) (One b) m sf-takePrefixER i s (Three _ b c) m sf-  | i < 1      = pullL (s - 3) m sf-  | i < 2      = Deep (s - 2) (One c) m sf-  | otherwise  = Deep (s - 1) (Two b c) m sf-takePrefixER i s (Four _ b c d) m sf-  | i < 1      = pullL (s - 4) m sf-  | i < 2      = Deep (s - 3) (One d) m sf-  | i < 3      = Deep (s - 2) (Two c d) m sf-  | otherwise  = Deep (s - 1) (Three b c d) m sf--takePrefixNR :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->-   StrictPair (Node a) (FingerTree (Node a))-takePrefixNR !_i !s (One a) m sf = a :*: pullL (s - size a) m sf-takePrefixNR i s (Two a b) m sf-  | i < sb      = b :*: pullL (s - sb - size a) m sf-  | otherwise   = a :*: Deep (s - size a) (One b) m sf-  where-    sb      = size b-takePrefixNR i s (Three a b c) m sf-  | i < sc      = c :*: pullL (s - sbc - size a) m sf-  | i < sbc     = b :*: Deep (s - size b - size a) (One c) m sf-  | otherwise   = a :*: Deep (s - size a) (Two b c) m sf-  where-    sc      = size c-    sbc     = sc + size b-takePrefixNR i s (Four a b c d) m sf-  | i < sd      = d :*: pullL (s - sd - sabc) m sf-  | i < scd     = c :*: Deep (s - sabc) (One d) m sf-  | i < sbcd    = b :*: Deep (s - sab) (Two c d) m sf-  | otherwise   = a :*: Deep (s - sa) (Three b c d) m sf-  where-    sa      = size a-    sab     = sa + size b-    sabc    = sab + size c-    sd      = size d-    scd     = size c + sd-    sbcd    = size b + scd---- | \( O(\log(\min(i,n-i))) \). Split a sequence at a given position.--- @'splitAt' i s = ('take' i s, 'drop' i s)@.-splitAt                  :: Int -> Seq a -> (Seq a, Seq a)-splitAt i xs@(Seq t)-  -- We use an unsigned comparison to make the common case-  -- faster. This only works because our representation of-  -- sizes as (signed) Ints gives us a free high bit to play-  -- with. Note also that there's no sharing to lose in the-  -- case that the length is 0.-  | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =-      case splitTreeE i t of-        l :*: r -> (Seq l, Seq r)-  | i <= 0 = (empty, xs)-  | otherwise = (xs, empty)---- | \( O(\log(\min(i,n-i))) \) A version of 'splitAt' that does not attempt to--- enhance sharing when the split point is less than or equal to 0, and that--- gives completely wrong answers when the split point is at least the length--- of the sequence, unless the sequence is a singleton. This is used to--- implement zipWith and chunksOf, which are extremely sensitive to the cost of--- splitting very short sequences. There is just enough of a speed increase to--- make this worth the trouble.-uncheckedSplitAt :: Int -> Seq a -> (Seq a, Seq a)-uncheckedSplitAt i (Seq xs) = case splitTreeE i xs of-  l :*: r -> (Seq l, Seq r)--data Split a = Split !(FingerTree (Node a)) !(Node a) !(FingerTree (Node a))-#ifdef TESTING-    deriving Show-#endif--splitTreeE :: Int -> FingerTree (Elem a) -> StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))-splitTreeE !_i EmptyT = EmptyT :*: EmptyT-splitTreeE i t@(Single _)-   | i <= 0 = EmptyT :*: t-   | otherwise = t :*: EmptyT-splitTreeE i (Deep s pr m sf)-  | i < spr     = splitPrefixE i s pr m sf-  | i < spm     = case splitTreeN im m of-            Split ml xs mr -> splitMiddleE (im - size ml) s spr pr ml xs mr sf-  | otherwise   = splitSuffixE (i - spm) s pr m sf-  where-    spr     = size pr-    spm     = spr + size m-    im      = i - spr--splitTreeN :: Int -> FingerTree (Node a) -> Split a-splitTreeN !_i EmptyT = error "splitTreeN of empty tree"-splitTreeN _i (Single x) = Split EmptyT x EmptyT-splitTreeN i (Deep s pr m sf)-  | i < spr     = splitPrefixN i s pr m sf-  | i < spm     = case splitTreeN im m of-            Split ml xs mr -> splitMiddleN (im - size ml) s spr pr ml xs mr sf-  | otherwise   = splitSuffixN (i - spm) s pr m sf  where-    spr     = size pr-    spm     = spr + size m-    im      = i - spr--splitMiddleN :: Int -> Int -> Int-             -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)-             -> Split a-splitMiddleN i s spr pr ml (Node2 _ a b) mr sf-  | i < sa      = Split (pullR sprml pr ml) a (Deep (s - sprmla) (One b) mr sf)-  | otherwise   = Split (Deep sprmla pr ml (One a)) b (pullL (s - sprmla - size b) mr sf)-  where-    sa      = size a-    sprml   = spr + size ml-    sprmla  = sa + sprml-splitMiddleN i s spr pr ml (Node3 _ a b c) mr sf-  | i < sa      = Split (pullR sprml pr ml) a (Deep (s - sprmla) (Two b c) mr sf)-  | i < sab     = Split (Deep sprmla pr ml (One a)) b (Deep (s - sprmlab) (One c) mr sf)-  | otherwise   = Split (Deep sprmlab pr ml (Two a b)) c (pullL (s - sprmlab - size c) mr sf)-  where-    sa      = size a-    sab     = sa + size b-    sprml   = spr + size ml-    sprmla  = sa + sprml-    sprmlab = sprmla + size b--splitMiddleE :: Int -> Int -> Int-             -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Node (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a)-             -> StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))-splitMiddleE i s spr pr ml (Node2 _ a b) mr sf-  | i < 1       = pullR sprml pr ml :*: Deep (s - sprml) (Two a b) mr sf-  | otherwise   = Deep sprmla pr ml (One a) :*: Deep (s - sprmla) (One b) mr sf-  where-    sprml   = spr + size ml-    sprmla  = 1 + sprml-splitMiddleE i s spr pr ml (Node3 _ a b c) mr sf = case i of-  0 -> pullR sprml pr ml :*: Deep (s - sprml) (Three a b c) mr sf-  1 -> Deep sprmla pr ml (One a) :*: Deep (s - sprmla) (Two b c) mr sf-  _ -> Deep sprmlab pr ml (Two a b) :*: Deep (s - sprmlab) (One c) mr sf-  where-    sprml   = spr + size ml-    sprmla  = 1 + sprml-    sprmlab = sprmla + 1--splitPrefixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->-                    StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))-splitPrefixE !_i !s (One a) m sf = EmptyT :*: Deep s (One a) m sf-splitPrefixE i s (Two a b) m sf = case i of-  0 -> EmptyT :*: Deep s (Two a b) m sf-  _ -> Single a :*: Deep (s - 1) (One b) m sf-splitPrefixE i s (Three a b c) m sf = case i of-  0 -> EmptyT :*: Deep s (Three a b c) m sf-  1 -> Single a :*: Deep (s - 1) (Two b c) m sf-  _ -> Deep 2 (One a) EmptyT (One b) :*: Deep (s - 2) (One c) m sf-splitPrefixE i s (Four a b c d) m sf = case i of-  0 -> EmptyT :*: Deep s (Four a b c d) m sf-  1 -> Single a :*: Deep (s - 1) (Three b c d) m sf-  2 -> Deep 2 (One a) EmptyT (One b) :*: Deep (s - 2) (Two c d) m sf-  _ -> Deep 3 (Two a b) EmptyT (One c) :*: Deep (s - 3) (One d) m sf--splitPrefixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->-                    Split a-splitPrefixN !_i !s (One a) m sf = Split EmptyT a (pullL (s - size a) m sf)-splitPrefixN i s (Two a b) m sf-  | i < sa      = Split EmptyT a (Deep (s - sa) (One b) m sf)-  | otherwise   = Split (Single a) b (pullL (s - sa - size b) m sf)-  where-    sa      = size a-splitPrefixN i s (Three a b c) m sf-  | i < sa      = Split EmptyT a (Deep (s - sa) (Two b c) m sf)-  | i < sab     = Split (Single a) b (Deep (s - sab) (One c) m sf)-  | otherwise   = Split (Deep sab (One a) EmptyT (One b)) c (pullL (s - sab - size c) m sf)-  where-    sa      = size a-    sab     = sa + size b-splitPrefixN i s (Four a b c d) m sf-  | i < sa      = Split EmptyT a $ Deep (s - sa) (Three b c d) m sf-  | i < sab     = Split (Single a) b $ Deep (s - sab) (Two c d) m sf-  | i < sabc    = Split (Deep sab (One a) EmptyT (One b)) c $ Deep (s - sabc) (One d) m sf-  | otherwise   = Split (Deep sabc (Two a b) EmptyT (One c)) d $ pullL (s - sabc - size d) m sf-  where-    sa      = size a-    sab     = sa + size b-    sabc    = sab + size c--splitSuffixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->-   StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))-splitSuffixE !_i !s pr m (One a) = pullR (s - 1) pr m :*: Single a-splitSuffixE i s pr m (Two a b) = case i of-  0 -> pullR (s - 2) pr m :*: Deep 2 (One a) EmptyT (One b)-  _ -> Deep (s - 1) pr m (One a) :*: Single b-splitSuffixE i s pr m (Three a b c) = case i of-  0 -> pullR (s - 3) pr m :*: Deep 3 (Two a b) EmptyT (One c)-  1 -> Deep (s - 2) pr m (One a) :*: Deep 2 (One b) EmptyT (One c)-  _ -> Deep (s - 1) pr m (Two a b) :*: Single c-splitSuffixE i s pr m (Four a b c d) = case i of-  0 -> pullR (s - 4) pr m :*: Deep 4 (Two a b) EmptyT (Two c d)-  1 -> Deep (s - 3) pr m (One a) :*: Deep 3 (Two b c) EmptyT (One d)-  2 -> Deep (s - 2) pr m (Two a b) :*: Deep 2 (One c) EmptyT (One d)-  _ -> Deep (s - 1) pr m (Three a b c) :*: Single d--splitSuffixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->-   Split a-splitSuffixN !_i !s pr m (One a) = Split (pullR (s - size a) pr m) a EmptyT-splitSuffixN i s pr m (Two a b)-  | i < sa      = Split (pullR (s - sa - size b) pr m) a (Single b)-  | otherwise   = Split (Deep (s - size b) pr m (One a)) b EmptyT-  where-    sa      = size a-splitSuffixN i s pr m (Three a b c)-  | i < sa      = Split (pullR (s - sab - size c) pr m) a (deep (One b) EmptyT (One c))-  | i < sab     = Split (Deep (s - size b - size c) pr m (One a)) b (Single c)-  | otherwise   = Split (Deep (s - size c) pr m (Two a b)) c EmptyT-  where-    sa      = size a-    sab     = sa + size b-splitSuffixN i s pr m (Four a b c d)-  | i < sa      = Split (pullR (s - sa - sbcd) pr m) a (Deep sbcd (Two b c) EmptyT (One d))-  | i < sab     = Split (Deep (s - sbcd) pr m (One a)) b (Deep scd (One c) EmptyT (One d))-  | i < sabc    = Split (Deep (s - scd) pr m (Two a b)) c (Single d)-  | otherwise   = Split (Deep (s - sd) pr m (Three a b c)) d EmptyT-  where-    sa      = size a-    sab     = sa + size b-    sabc    = sab + size c-    sd      = size d-    scd     = size c + sd-    sbcd    = size b + scd---- | \(O \Bigl(\bigl(\frac{n}{c}\bigr) \log c\Bigr)\). @chunksOf c xs@ splits @xs@ into chunks of size @c>0@.--- If @c@ does not divide the length of @xs@ evenly, then the last element--- of the result will be short.------ Side note: the given performance bound is missing some messy terms that only--- really affect edge cases. Performance degrades smoothly from \( O(1) \) (for--- \( c = n \)) to \( O(n) \) (for \( c = 1 \)). The true bound is more like--- \( O \Bigl( \bigl(\frac{n}{c} - 1\bigr) (\log (c + 1)) + 1 \Bigr) \)------ @since 0.5.8-chunksOf :: Int -> Seq a -> Seq (Seq a)-chunksOf n xs | n <= 0 =-  if null xs-    then empty-    else error "chunksOf: A non-empty sequence can only be broken up into positively-sized chunks."-chunksOf 1 s = fmap singleton s-chunksOf n s = splitMap (uncheckedSplitAt . (*n)) const most (replicate numReps ())-                 >< if null end then empty else singleton end-  where-    (numReps, endLength) = length s `quotRem` n-    (most, end) = splitAt (length s - endLength) s---- | \( O(n) \).  Returns a sequence of all suffixes of this sequence,--- longest first.  For example,------ > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]------ Evaluating the \( i \)th suffix takes \( O(\log(\min(i, n-i))) \), but evaluating--- every suffix in the sequence takes \( O(n) \) due to sharing.-tails                   :: Seq a -> Seq (Seq a)-tails (Seq xs)          = Seq (tailsTree (Elem . Seq) xs) |> empty---- | \( O(n) \).  Returns a sequence of all prefixes of this sequence,--- shortest first.  For example,------ > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]------ Evaluating the \( i \)th prefix takes \( O(\log(\min(i, n-i))) \), but evaluating--- every prefix in the sequence takes \( O(n) \) due to sharing.-inits                   :: Seq a -> Seq (Seq a)-inits (Seq xs)          = empty <| Seq (initsTree (Elem . Seq) xs)---- This implementation of tails (and, analogously, inits) has the--- following algorithmic advantages:---      Evaluating each tail in the sequence takes linear total time,---      which is better than we could say for---              @fromList [drop n xs | n <- [0..length xs]]@.---      Evaluating any individual tail takes logarithmic time, which is---      better than we can say for either---              @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.------ Moreover, if we actually look at every tail in the sequence, the--- following benchmarks demonstrate that this implementation is modestly--- faster than any of the above:------ Times (ms)---               min      mean    +/-sd    median    max--- Seq.tails:   21.986   24.961   10.169   22.417   86.485--- scanr:       85.392   87.942    2.488   87.425  100.217--- iterateN:       29.952   31.245    1.574   30.412   37.268------ The algorithm for tails (and, analogously, inits) is as follows:------ A Node in the FingerTree of tails is constructed by evaluating the--- corresponding tail of the FingerTree of Nodes, considering the first--- Node in this tail, and constructing a Node in which each tail of this--- Node is made to be the prefix of the remaining tree.  This ends up--- working quite elegantly, as the remainder of the tail of the FingerTree--- of Nodes becomes the middle of a new tail, the suffix of the Node is--- the prefix, and the suffix of the original tree is retained.------ In particular, evaluating the /i/th tail involves making as--- many partial evaluations as the Node depth of the /i/th element.--- In addition, when we evaluate the /i/th tail, and we also evaluate--- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,--- each of those /m/ evaluations are shared between the computation of--- the /i/th and /j/th tails.------ wasserman.louis@gmail.com, 7/16/09--tailsDigit :: Digit a -> Digit (Digit a)-tailsDigit (One a) = One (One a)-tailsDigit (Two a b) = Two (Two a b) (One b)-tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)-tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)--initsDigit :: Digit a -> Digit (Digit a)-initsDigit (One a) = One (One a)-initsDigit (Two a b) = Two (One a) (Two a b)-initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)-initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)--tailsNode :: Node a -> Node (Digit a)-tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)-tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)--initsNode :: Node a -> Node (Digit a)-initsNode (Node2 s a b) = Node2 s (One a) (Two a b)-initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)--{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}-{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}--- | Given a function to apply to tails of a tree, applies that function--- to every tail of the specified tree.-tailsTree :: Sized a => (FingerTree a -> b) -> FingerTree a -> FingerTree b-tailsTree _ EmptyT = EmptyT-tailsTree f (Single x) = Single (f (Single x))-tailsTree f (Deep n pr m sf) =-    Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))-        (tailsTree f' m)-        (fmap (f . digitToTree) (tailsDigit sf))-  where-    f' ms = let ConsLTree node m' = viewLTree ms in-        fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)--{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}-{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}--- | Given a function to apply to inits of a tree, applies that function--- to every init of the specified tree.-initsTree :: Sized a => (FingerTree a -> b) -> FingerTree a -> FingerTree b-initsTree _ EmptyT = EmptyT-initsTree f (Single x) = Single (f (Single x))-initsTree f (Deep n pr m sf) =-    Deep n (fmap (f . digitToTree) (initsDigit pr))-        (initsTree f' m)-        (fmap (f . deep pr m) (initsDigit sf))-  where-    f' ms =  let SnocRTree m' node = viewRTree ms in-             fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)--{-# INLINE foldlWithIndex #-}--- | 'foldlWithIndex' is a version of 'foldl' that also provides access--- to the index of each element.-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldlWithIndex f z xs = foldl (\ g x !i -> f (g (i - 1)) i x) (const z) xs (length xs - 1)--{-# INLINE foldrWithIndex #-}--- | 'foldrWithIndex' is a version of 'foldr' that also provides access--- to the index of each element.-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldrWithIndex f z xs = foldr (\ x g !i -> f i x (g (i+1))) (const z) xs 0--{-# INLINE listToMaybe' #-}--- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.-listToMaybe' :: [a] -> Maybe a-listToMaybe' = foldr (\ x _ -> Just x) Nothing---- | \( O(i) \) where \( i \) is the prefix length. 'takeWhileL', applied--- to a predicate @p@ and a sequence @xs@, returns the longest prefix--- (possibly empty) of @xs@ of elements that satisfy @p@.-takeWhileL :: (a -> Bool) -> Seq a -> Seq a-takeWhileL p = fst . spanl p---- | \( O(i) \) where \( i \) is the suffix length.  'takeWhileR', applied--- to a predicate @p@ and a sequence @xs@, returns the longest suffix--- (possibly empty) of @xs@ of elements that satisfy @p@.------ @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.-takeWhileR :: (a -> Bool) -> Seq a -> Seq a-takeWhileR p = fst . spanr p---- | \( O(i) \) where \( i \) is the prefix length.  @'dropWhileL' p xs@ returns--- the suffix remaining after @'takeWhileL' p xs@.-dropWhileL :: (a -> Bool) -> Seq a -> Seq a-dropWhileL p = snd . spanl p---- | \( O(i) \) where \( i \) is the suffix length.  @'dropWhileR' p xs@ returns--- the prefix remaining after @'takeWhileR' p xs@.------ @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.-dropWhileR :: (a -> Bool) -> Seq a -> Seq a-dropWhileR p = snd . spanr p---- | \( O(i) \) where \( i \) is the prefix length.  'spanl', applied to--- a predicate @p@ and a sequence @xs@, returns a pair whose first--- element is the longest prefix (possibly empty) of @xs@ of elements that--- satisfy @p@ and the second element is the remainder of the sequence.-spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-spanl p = breakl (not . p)---- | \( O(i) \) where \( i \) is the suffix length.  'spanr', applied to a--- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element--- is the longest /suffix/ (possibly empty) of @xs@ of elements that--- satisfy @p@ and the second element is the remainder of the sequence.-spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-spanr p = breakr (not . p)--{-# INLINE breakl #-}--- | \( O(i) \) where \( i \) is the breakpoint index.  'breakl', applied to a--- predicate @p@ and a sequence @xs@, returns a pair whose first element--- is the longest prefix (possibly empty) of @xs@ of elements that--- /do not satisfy/ @p@ and the second element is the remainder of--- the sequence.------ @'breakl' p@ is equivalent to @'spanl' (not . p)@.-breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)--{-# INLINE breakr #-}--- | @'breakr' p@ is equivalent to @'spanr' (not . p)@.-breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)-  where flipPair (x, y) = (y, x)---- | \( O(n) \).  The 'partition' function takes a predicate @p@ and a--- sequence @xs@ and returns sequences of those elements which do and--- do not satisfy the predicate.-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-partition p = toPair . foldl' part (empty :*: empty)-  where-    part (xs :*: ys) x-      | p x         = (xs `snoc'` x) :*: ys-      | otherwise   = xs :*: (ys `snoc'` x)---- | \( O(n) \).  The 'filter' function takes a predicate @p@ and a sequence--- @xs@ and returns a sequence of those elements which satisfy the--- predicate.-filter :: (a -> Bool) -> Seq a -> Seq a-filter p = foldl' (\ xs x -> if p x then xs `snoc'` x else xs) empty---- Indexing sequences---- | 'elemIndexL' finds the leftmost index of the specified element,--- if it is present, and otherwise 'Nothing'.-elemIndexL :: Eq a => a -> Seq a -> Maybe Int-elemIndexL x = findIndexL (x ==)---- | 'elemIndexR' finds the rightmost index of the specified element,--- if it is present, and otherwise 'Nothing'.-elemIndexR :: Eq a => a -> Seq a -> Maybe Int-elemIndexR x = findIndexR (x ==)---- | 'elemIndicesL' finds the indices of the specified element, from--- left to right (i.e. in ascending order).-elemIndicesL :: Eq a => a -> Seq a -> [Int]-elemIndicesL x = findIndicesL (x ==)---- | 'elemIndicesR' finds the indices of the specified element, from--- right to left (i.e. in descending order).-elemIndicesR :: Eq a => a -> Seq a -> [Int]-elemIndicesR x = findIndicesR (x ==)---- | @'findIndexL' p xs@ finds the index of the leftmost element that--- satisfies @p@, if any exist.-findIndexL :: (a -> Bool) -> Seq a -> Maybe Int-findIndexL p = listToMaybe' . findIndicesL p---- | @'findIndexR' p xs@ finds the index of the rightmost element that--- satisfies @p@, if any exist.-findIndexR :: (a -> Bool) -> Seq a -> Maybe Int-findIndexR p = listToMaybe' . findIndicesR p--{-# INLINE findIndicesL #-}--- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,--- in ascending order.-findIndicesL :: (a -> Bool) -> Seq a -> [Int]-#if __GLASGOW_HASKELL__-findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in-                foldrWithIndex g n xs)-#else-findIndicesL p xs = foldrWithIndex g [] xs-  where g i x is = if p x then i:is else is-#endif--{-# INLINE findIndicesR #-}--- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,--- in descending order.-findIndicesR :: (a -> Bool) -> Seq a -> [Int]-#if __GLASGOW_HASKELL__-findIndicesR p xs = build (\ c n ->-    let g z i x = if p x then c i z else z in foldlWithIndex g n xs)-#else-findIndicesR p xs = foldlWithIndex g [] xs-  where g is i x = if p x then i:is else is-#endif----------------------------------------------------------------------------- Lists----------------------------------------------------------------------------- The implementation below is based on an idea by Ross Paterson and--- implemented by Lennart Spitzner. It avoids the rebuilding the original--- (|>)-based implementation suffered from. It also avoids the excessive pair--- allocations Paterson's implementation suffered from.------ David Feuer suggested building in nine-element chunks, which reduces--- intermediate conses from around (1/2)*n to around (1/8)*n with a concomitant--- improvement in benchmark constant factors. In fact, it should be even--- better to work in chunks of 27 `Elem`s and chunks of three `Node`s, rather--- than nine of each, but it seems hard to avoid a code explosion with--- such large chunks.------ Paterson's code can be seen, for example, in--- https://github.com/haskell/containers/blob/74034b3244fa4817c7bef1202e639b887a975d9e/Data/Sequence.hs#L3532------ Given a list------ [1..302]------ the original code forms Three 1 2 3 | [node3 4 5 6, node3 7 8 9, node3 10 11--- 12, ...] | Two 301 302------ Then it recurses on the middle list. The middle lists become successively--- shorter as their elements become successively deeper nodes.------ The original implementation of the list shortener, getNodes, included the--- recursive step----     getNodes s x1 (x2:x3:x4:xs) = (Node3 s x1 x2 x3:ns, d)---            where (ns, d) = getNodes s x4 xs---- This allocates a cons and a lazy pair at each 3-element step. It relies on--- the Haskell implementation using Wadler's technique, described in "Fixing--- some space leaks with a garbage collector"--- http://homepages.inf.ed.ac.uk/wadler/papers/leak/leak.ps.gz, to repeatedly--- simplify the `d` thunk. Although GHC uses this GC trick, heap profiling at--- least appears to indicate that the pair constructors and conses build up--- with this implementation.------ Spitzner's implementation uses a similar approach, but replaces the middle--- list, in each level, with a customized stream type that finishes off with--- the final digit in that level and (since it works in nines) in the one--- above. To work around the nested tree structure, the overall computation is--- structured using continuation-passing style, with a function that, at the--- bottom of the tree, deals with a stream that terminates in a nested-pair--- representation of the entire right side of the tree. Perhaps someone will--- eventually find a less mind-bending way to accomplish this.---- | \( O(n) \). Create a sequence from a finite list of elements.--- There is a function 'toList' in the opposite direction for all--- instances of the 'Foldable' class, including 'Seq'.-fromList        :: [a] -> Seq a--- Note: we can avoid map_elem if we wish by scattering--- Elem applications throughout mkTreeE and getNodesE, but--- it gets a bit hard to read.-fromList = Seq . mkTree . map_elem-  where-#ifdef __GLASGOW_HASKELL__-    mkTree :: forall a' . [Elem a'] -> FingerTree (Elem a')-#else-    mkTree :: [Elem a] -> FingerTree (Elem a)-#endif-    mkTree [] = EmptyT-    mkTree [x1] = Single x1-    mkTree [x1, x2] = Deep 2 (One x1) EmptyT (One x2)-    mkTree [x1, x2, x3] = Deep 3 (Two x1 x2) EmptyT (One x3)-    mkTree [x1, x2, x3, x4] = Deep 4 (Two x1 x2) EmptyT (Two x3 x4)-    mkTree [x1, x2, x3, x4, x5] = Deep 5 (Three x1 x2 x3) EmptyT (Two x4 x5)-    mkTree [x1, x2, x3, x4, x5, x6] =-      Deep 6 (Three x1 x2 x3) EmptyT (Three x4 x5 x6)-    mkTree [x1, x2, x3, x4, x5, x6, x7] =-      Deep 7 (Two x1 x2) (Single (Node3 3 x3 x4 x5)) (Two x6 x7)-    mkTree [x1, x2, x3, x4, x5, x6, x7, x8] =-      Deep 8 (Three x1 x2 x3) (Single (Node3 3 x4 x5 x6)) (Two x7 x8)-    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9] =-      Deep 9 (Three x1 x2 x3) (Single (Node3 3 x4 x5 x6)) (Three x7 x8 x9)-    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, y0, y1] =-      Deep 10 (Two x1 x2)-              (Deep 6 (One (Node3 3 x3 x4 x5)) EmptyT (One (Node3 3 x6 x7 x8)))-              (Two y0 y1)-    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1] =-      Deep 11 (Three x1 x2 x3)-              (Deep 6 (One (Node3 3 x4 x5 x6)) EmptyT (One (Node3 3 x7 x8 x9)))-              (Two y0 y1)-    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2] =-      Deep 12 (Three x1 x2 x3)-              (Deep 6 (One (Node3 3 x4 x5 x6)) EmptyT (One (Node3 3 x7 x8 x9)))-              (Three y0 y1 y2)-    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, y0, y1, y2, y3, y4] =-      Deep 13 (Two x1 x2)-              (Deep 9 (Two (Node3 3 x3 x4 x5) (Node3 3 x6 x7 x8)) EmptyT (One (Node3 3 y0 y1 y2)))-              (Two y3 y4)-    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2, y3, y4] =-      Deep 14 (Three x1 x2 x3)-              (Deep 9 (Two (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9)) EmptyT (One (Node3 3 y0 y1 y2)))-              (Two y3 y4)-    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2, y3, y4, y5] =-      Deep 15 (Three x1 x2 x3)-              (Deep 9 (Two (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9)) EmptyT (One (Node3 3 y0 y1 y2)))-              (Three y3 y4 y5)-    mkTree (x1:x2:x3:x4:x5:x6:x7:x8:x9:y0:y1:y2:y3:y4:y5:y6:xs) =-        mkTreeC cont 9 (getNodes 3 (Node3 3 y3 y4 y5) y6 xs)-      where-        d2 = Three x1 x2 x3-        d1 = Three (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9) (Node3 3 y0 y1 y2)-#ifdef __GLASGOW_HASKELL__-        cont :: (Digit (Node (Elem a')), Digit (Elem a')) -> FingerTree (Node (Node (Elem a'))) -> FingerTree (Elem a')-#endif-        cont (!r1, !r2) !sub =-          let !sub1 = Deep (9 + size r1 + size sub) d1 sub r1-          in Deep (3 + size r2 + size sub1) d2 sub1 r2--    getNodes :: forall a . Int-             -> Node a-             -> a-             -> [a]-             -> ListFinal (Node (Node a)) (Digit (Node a), Digit a)-    getNodes !_ n1 x1 [] = LFinal (One n1, One x1)-    getNodes _ n1 x1 [x2] = LFinal (One n1, Two x1 x2)-    getNodes _ n1 x1 [x2, x3] = LFinal (One n1, Three x1 x2 x3)-    getNodes s n1 x1 [x2, x3, x4] = LFinal (Two n1 (Node3 s x1 x2 x3), One x4)-    getNodes s n1 x1 [x2, x3, x4, x5] = LFinal (Two n1 (Node3 s x1 x2 x3), Two x4 x5)-    getNodes s n1 x1 [x2, x3, x4, x5, x6] = LFinal (Two n1 (Node3 s x1 x2 x3), Three x4 x5 x6)-    getNodes s n1 x1 [x2, x3, x4, x5, x6, x7] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), One x7)-    getNodes s n1 x1 [x2, x3, x4, x5, x6, x7, x8] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), Two x7 x8)-    getNodes s n1 x1 [x2, x3, x4, x5, x6, x7, x8, x9] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), Three x7 x8 x9)-    getNodes s n1 x1 (x2:x3:x4:x5:x6:x7:x8:x9:x10:xs) = LCons n10 (getNodes s (Node3 s x7 x8 x9) x10 xs)-      where !n2 = Node3 s x1 x2 x3-            !n3 = Node3 s x4 x5 x6-            !n10 = Node3 (3*s) n1 n2 n3--    mkTreeC ::-#ifdef __GLASGOW_HASKELL__-               forall a b c .-#endif-               (b -> FingerTree (Node a) -> c)-            -> Int-            -> ListFinal (Node a) b-            -> c-    mkTreeC cont !_ (LFinal b) =-      cont b EmptyT-    mkTreeC cont _ (LCons x1 (LFinal b)) =-      cont b (Single x1)-    mkTreeC cont s (LCons x1 (LCons x2 (LFinal b))) =-      cont b (Deep (2*s) (One x1) EmptyT (One x2))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LFinal b)))) =-      cont b (Deep (3*s) (Two x1 x2) EmptyT (One x3))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LFinal b))))) =-      cont b (Deep (4*s) (Two x1 x2) EmptyT (Two x3 x4))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LFinal b)))))) =-      cont b (Deep (5*s) (Three x1 x2 x3) EmptyT (Two x4 x5))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LFinal b))))))) =-      cont b (Deep (6*s) (Three x1 x2 x3) EmptyT (Three x4 x5 x6))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LFinal b)))))))) =-      cont b (Deep (7*s) (Two x1 x2) (Single (Node3 (3*s) x3 x4 x5)) (Two x6 x7))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LFinal b))))))))) =-      cont b (Deep (8*s) (Three x1 x2 x3) (Single (Node3 (3*s) x4 x5 x6)) (Two x7 x8))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LFinal b)))))))))) =-      cont b (Deep (9*s) (Three x1 x2 x3) (Single (Node3 (3*s) x4 x5 x6)) (Three x7 x8 x9))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons y0 (LCons y1 (LFinal b))))))))))) =-      cont b (Deep (10*s) (Two x1 x2) (Deep (6*s) (One (Node3 (3*s) x3 x4 x5)) EmptyT (One (Node3 (3*s) x6 x7 x8))) (Two y0 y1))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LFinal b)))))))))))) =-      cont b (Deep (11*s) (Three x1 x2 x3) (Deep (6*s) (One (Node3 (3*s) x4 x5 x6)) EmptyT (One (Node3 (3*s) x7 x8 x9))) (Two y0 y1))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LFinal b))))))))))))) =-      cont b (Deep (12*s) (Three x1 x2 x3) (Deep (6*s) (One (Node3 (3*s) x4 x5 x6)) EmptyT (One (Node3 (3*s) x7 x8 x9))) (Three y0 y1 y2))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LFinal b)))))))))))))) =-      cont b (Deep (13*s) (Two x1 x2) (Deep (9*s) (Two (Node3 (3*s) x3 x4 x5) (Node3 (3*s) x6 x7 x8)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Two y3 y4))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LFinal b))))))))))))))) =-      cont b (Deep (14*s) (Three x1 x2 x3) (Deep (9*s) (Two (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Two y3 y4))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LFinal b)))))))))))))))) =-      cont b (Deep (15*s) (Three x1 x2 x3) (Deep (9*s) (Two (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Three y3 y4 y5))-    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LCons y6 xs)))))))))))))))) =-      mkTreeC cont2 (9*s) (getNodesC (3*s) (Node3 (3*s) y3 y4 y5) y6 xs)-      where-#ifdef __GLASGOW_HASKELL__-        cont2 :: (b, Digit (Node (Node a)), Digit (Node a)) -> FingerTree (Node (Node (Node a))) -> c-#endif-        cont2 (b, r1, r2) !sub =-          let d2 = Three x1 x2 x3-              d1 = Three (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9) (Node3 (3*s) y0 y1 y2)-              !sub1 = Deep (9*s + size r1 + size sub) d1 sub r1-          in cont b $! Deep (3*s + size r2 + size sub1) d2 sub1 r2--    getNodesC :: Int-              -> Node a-              -> a-              -> ListFinal a b-              -> ListFinal (Node (Node a)) (b, Digit (Node a), Digit a)-    getNodesC !_ n1 x1 (LFinal b) = LFinal $ (b, One n1, One x1)-    getNodesC _  n1  x1 (LCons x2 (LFinal b)) = LFinal $ (b, One n1, Two x1 x2)-    getNodesC _  n1  x1 (LCons x2 (LCons x3 (LFinal b))) = LFinal $ (b, One n1, Three x1 x2 x3)-    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LFinal b)))) =-      let !n2 = Node3 s x1 x2 x3-      in LFinal $ (b, Two n1 n2, One x4)-    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LFinal b))))) =-      let !n2 = Node3 s x1 x2 x3-      in LFinal $ (b, Two n1 n2, Two x4 x5)-    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LFinal b)))))) =-      let !n2 = Node3 s x1 x2 x3-      in LFinal $ (b, Two n1 n2, Three x4 x5 x6)-    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LFinal b))))))) =-      let !n2 = Node3 s x1 x2 x3-          !n3 = Node3 s x4 x5 x6-      in LFinal $ (b, Three n1 n2 n3, One x7)-    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LFinal b)))))))) =-      let !n2 = Node3 s x1 x2 x3-          !n3 = Node3 s x4 x5 x6-      in LFinal $ (b, Three n1 n2 n3, Two x7 x8)-    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LFinal b))))))))) =-      let !n2 = Node3 s x1 x2 x3-          !n3 = Node3 s x4 x5 x6-      in LFinal $ (b, Three n1 n2 n3, Three x7 x8 x9)-    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons x10 xs))))))))) =-        LCons n10 $ getNodesC s (Node3 s x7 x8 x9) x10 xs-      where !n2 = Node3 s x1 x2 x3-            !n3 = Node3 s x4 x5 x6-            !n10 = Node3 (3*s) n1 n2 n3--    map_elem :: [a] -> [Elem a]-#if __GLASGOW_HASKELL__ >= 708-    map_elem xs = coerce xs-#else-    map_elem xs = Data.List.map Elem xs-#endif-    {-# INLINE map_elem #-}---- essentially: Free ((,) a) b.-data ListFinal a cont = LFinal !cont | LCons !a (ListFinal a cont)--#if __GLASGOW_HASKELL__ >= 708-instance GHC.Exts.IsList (Seq a) where-    type Item (Seq a) = a-    fromList = fromList-    fromListN = fromList2-    toList = toList-#endif--#ifdef __GLASGOW_HASKELL__--- | @since 0.5.7-instance a ~ Char => IsString (Seq a) where-    fromString = fromList-#endif----------------------------------------------------------------------------- Reverse----------------------------------------------------------------------------- | \( O(n) \). The reverse of a sequence.-reverse :: Seq a -> Seq a-reverse (Seq xs) = Seq (fmapReverseTree id xs)--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] reverse #-}---- | \( O(n) \). Reverse a sequence while mapping over it. This is not--- currently exported, but is used in rewrite rules.-fmapReverse :: (a -> b) -> Seq a -> Seq b-fmapReverse f (Seq xs) = Seq (fmapReverseTree (lift_elem f) xs)-  where-    lift_elem :: (a -> b) -> (Elem a -> Elem b)-#if __GLASGOW_HASKELL__ >= 708-    lift_elem = coerce-#else-    lift_elem g (Elem a) = Elem (g a)-#endif---- If we're mapping over a sequence, we can reverse it at the same time--- at no extra charge.-{-# RULES-"fmapSeq/reverse" forall f xs . fmapSeq f (reverse xs) = fmapReverse f xs-"reverse/fmapSeq" forall f xs . reverse (fmapSeq f xs) = fmapReverse f xs- #-}-#endif--fmapReverseTree :: (a -> b) -> FingerTree a -> FingerTree b-fmapReverseTree _ EmptyT = EmptyT-fmapReverseTree f (Single x) = Single (f x)-fmapReverseTree f (Deep s pr m sf) =-    Deep s (reverseDigit f sf)-        (fmapReverseTree (reverseNode f) m)-        (reverseDigit f pr)--{-# INLINE reverseDigit #-}-reverseDigit :: (a -> b) -> Digit a -> Digit b-reverseDigit f (One a) = One (f a)-reverseDigit f (Two a b) = Two (f b) (f a)-reverseDigit f (Three a b c) = Three (f c) (f b) (f a)-reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)--reverseNode :: (a -> b) -> Node a -> Node b-reverseNode f (Node2 s a b) = Node2 s (f b) (f a)-reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)----------------------------------------------------------------------------- Mapping with a splittable value----------------------------------------------------------------------------- For zipping, it is useful to build a result by--- traversing a sequence while splitting up something else.  For zipping, we--- traverse the first sequence while splitting up the second.------ What makes all this crazy code a good idea:------ Suppose we zip together two sequences of the same length:------ zs = zip xs ys------ We want to get reasonably fast indexing into zs immediately, rather than--- needing to construct the entire thing first, as the previous implementation--- required. The first aspect is that we build the result "outside-in" or--- "top-down", rather than left to right. That gives us access to both ends--- quickly. But that's not enough, by itself, to give immediate access to the--- center of zs. For that, we need to be able to skip over larger segments of--- zs, delaying their construction until we actually need them. The way we do--- this is to traverse xs, while splitting up ys according to the structure of--- xs. If we have a Deep _ pr m sf, we split ys into three pieces, and hand off--- one piece to the prefix, one to the middle, and one to the suffix of the--- result. The key point is that we don't need to actually do anything further--- with those pieces until we actually need them; the computations to split--- them up further and zip them with their matching pieces can be delayed until--- they're actually needed. We do the same thing for Digits (splitting into--- between one and four pieces) and Nodes (splitting into two or three). The--- ultimate result is that we can index into, or split at, any location in zs--- in polylogarithmic time *immediately*, while still being able to force all--- the thunks in O(n) time.------ Benchmark info, and alternatives:------ The old zipping code used mapAccumL to traverse the first sequence while--- cutting down the second sequence one piece at a time.------ An alternative way to express that basic idea is to convert both sequences--- to lists, zip the lists, and then convert the result back to a sequence.--- I'll call this the "listy" implementation.------ I benchmarked two operations: Each started by zipping two sequences--- constructed with replicate and/or fromList. The first would then immediately--- index into the result. The second would apply deepseq to force the entire--- result.  The new implementation worked much better than either of the others--- on the immediate indexing test, as expected. It also worked better than the--- old implementation for all the deepseq tests. For short sequences, the listy--- implementation outperformed all the others on the deepseq test. However, the--- splitting implementation caught up and surpassed it once the sequences grew--- long enough. It seems likely that by avoiding rebuilding, it interacts--- better with the cache hierarchy.------ David Feuer, with some guidance from Carter Schonwald, December 2014---- | \( O(n) \). Constructs a new sequence with the same structure as an existing--- sequence using a user-supplied mapping function along with a splittable--- value and a way to split it. The value is split up lazily according to the--- structure of the sequence, so one piece of the value is distributed to each--- element of the sequence. The caller should provide a splitter function that--- takes a number, @n@, and a splittable value, breaks off a chunk of size @n@--- from the value, and returns that chunk and the remainder as a pair. The--- following examples will hopefully make the usage clear:------ > zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c--- > zipWith f s1 s2 = splitMap splitAt (\b a -> f a (b `index` 0)) s2' s1'--- >   where--- >     minLen = min (length s1) (length s2)--- >     s1' = take minLen s1--- >     s2' = take minLen s2------ > mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b--- > mapWithIndex f = splitMap (\n i -> (i, n+i)) f 0-#ifdef __GLASGOW_HASKELL__--- We use ScopedTypeVariables to improve performance and make--- performance less sensitive to minor changes.---- We INLINE this so GHC can see that the function passed in is--- strict in its Int argument.-{-# INLINE splitMap #-}-splitMap :: forall s a' b' . (Int -> s -> (s,s)) -> (s -> a' -> b') -> s -> Seq a' -> Seq b'-splitMap splt f0 s0 (Seq xs0) = Seq $ splitMapTreeE (\s' (Elem a) -> Elem (f0 s' a)) s0 xs0-  where-    {-# INLINE splitMapTreeE #-}-    splitMapTreeE :: (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b-    splitMapTreeE  _ _ EmptyT = EmptyT-    splitMapTreeE  f s (Single xs) = Single $ f s xs-    splitMapTreeE  f s (Deep n pr m sf) = Deep n (splitMapDigit f prs pr) (splitMapTreeN (\eta1 eta2 -> splitMapNode f eta1 eta2) ms m) (splitMapDigit f sfs sf)-          where-            !spr = size pr-            !sm = n - spr - size sf-            (prs, r) = splt spr s-            (ms, sfs) = splt sm r--    splitMapTreeN :: (s -> Node a -> b) -> s -> FingerTree (Node a) -> FingerTree b-    splitMapTreeN _ _ EmptyT = EmptyT-    splitMapTreeN f s (Single xs) = Single $ f s xs-    splitMapTreeN f s (Deep n pr m sf) = Deep n (splitMapDigit f prs pr) (splitMapTreeN (\eta1 eta2 -> splitMapNode f eta1 eta2) ms m) (splitMapDigit f sfs sf)-          where-            (prs, r) = splt (size pr) s-            (ms, sfs) = splt (size m) r--    {-# INLINE splitMapDigit #-}-    splitMapDigit :: Sized a => (s -> a -> b) -> s -> Digit a -> Digit b-    splitMapDigit f s (One a) = One (f s a)-    splitMapDigit f s (Two a b) = Two (f first a) (f second b)-      where-        (first, second) = splt (size a) s-    splitMapDigit f s (Three a b c) = Three (f first a) (f second b) (f third c)-      where-        (first, r) = splt (size a) s-        (second, third) = splt (size b) r-    splitMapDigit f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)-      where-        (first, s') = splt (size a) s-        (middle, fourth) = splt (size b + size c) s'-        (second, third) = splt (size b) middle--    {-# INLINE splitMapNode #-}-    splitMapNode :: Sized a => (s -> a -> b) -> s -> Node a -> Node b-    splitMapNode f s (Node2 ns a b) = Node2 ns (f first a) (f second b)-      where-        (first, second) = splt (size a) s-    splitMapNode f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)-      where-        (first, r) = splt (size a) s-        (second, third) = splt (size b) r--#else--- Implementation without ScopedTypeVariables--somewhat slower,--- and much more sensitive to minor changes in various places.--{-# INLINE splitMap #-}-splitMap :: (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Seq a -> Seq b-splitMap splt' f0 s0 (Seq xs0) = Seq $ splitMapTreeE splt' (\s' (Elem a) -> Elem (f0 s' a)) s0 xs0--{-# INLINE splitMapTreeE #-}-splitMapTreeE :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b-splitMapTreeE _    _ _ EmptyT = EmptyT-splitMapTreeE _    f s (Single xs) = Single $ f s xs-splitMapTreeE splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTreeN splt (\eta1 eta2 -> splitMapNode splt f eta1 eta2) ms m) (splitMapDigit splt f sfs sf)-      where-        !spr = size pr-        sm = n - spr - size sf-        (prs, r) = splt spr s-        (ms, sfs) = splt sm r--splitMapTreeN :: (Int -> s -> (s,s)) -> (s -> Node a -> b) -> s -> FingerTree (Node a) -> FingerTree b-splitMapTreeN _    _ _ EmptyT = EmptyT-splitMapTreeN _    f s (Single xs) = Single $ f s xs-splitMapTreeN splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTreeN splt (\eta1 eta2 -> splitMapNode splt f eta1 eta2) ms m) (splitMapDigit splt f sfs sf)-      where-        (prs, r) = splt (size pr) s-        (ms, sfs) = splt (size m) r--{-# INLINE splitMapDigit #-}-splitMapDigit :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Digit a -> Digit b-splitMapDigit _    f s (One a) = One (f s a)-splitMapDigit splt f s (Two a b) = Two (f first a) (f second b)-  where-    (first, second) = splt (size a) s-splitMapDigit splt f s (Three a b c) = Three (f first a) (f second b) (f third c)-  where-    (first, r) = splt (size a) s-    (second, third) = splt (size b) r-splitMapDigit splt f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)-  where-    (first, s') = splt (size a) s-    (middle, fourth) = splt (size b + size c) s'-    (second, third) = splt (size b) middle--{-# INLINE splitMapNode #-}-splitMapNode :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Node a -> Node b-splitMapNode splt f s (Node2 ns a b) = Node2 ns (f first a) (f second b)-  where-    (first, second) = splt (size a) s-splitMapNode splt f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)-  where-    (first, r) = splt (size a) s-    (second, third) = splt (size b) r-#endif----------------------------------------------------------------------------- Zipping----------------------------------------------------------------------------- We use a custom definition of munzip to avoid retaining--- memory longer than necessary. Using the default definition, if--- we write------ let (xs,ys) = munzip zs--- in xs `deepseq` (... ys ...)------ then ys will retain the entire zs sequence until ys itself is fully forced.--- This implementation uses the selector thunk optimization to prevent that.--- Unfortunately, that optimization is fragile, so we can't actually guarantee--- anything.---- | @ 'mzipWith' = 'zipWith' @------ @ 'munzip' = 'unzip' @-instance MonadZip Seq where-  mzipWith = zipWith-  munzip = unzip---- | Unzip a sequence of pairs.------ @--- unzip ps = ps ``seq`` ('fmap' 'fst' ps) ('fmap' 'snd' ps)--- @------ Example:------ @--- unzip $ fromList [(1,"a"), (2,"b"), (3,"c")] =---   (fromList [1,2,3], fromList ["a", "b", "c"])--- @------ See the note about efficiency at 'unzipWith'.------ @since 0.5.11-unzip :: Seq (a, b) -> (Seq a, Seq b)-unzip xs = unzipWith id xs---- | \( O(n) \). Unzip a sequence using a function to divide elements.------ @ unzipWith f xs == 'unzip' ('fmap' f xs) @------ Efficiency note:------ @unzipWith@ produces its two results in lockstep. If you calculate--- @ unzipWith f xs @ and fully force /either/ of the results, then the--- entire structure of the /other/ one will be built as well. This--- behavior allows the garbage collector to collect each calculated--- pair component as soon as it dies, without having to wait for its mate--- to die. If you do not need this behavior, you may be better off simply--- calculating the sequence of pairs and using 'fmap' to extract each--- component sequence.------ @since 0.5.11-unzipWith :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)-unzipWith f = unzipWith' (\x ->-  let-    {-# NOINLINE fx #-}-    fx = f x-    (y,z) = fx-  in (y,z))--- Why do we lazify `f`? Because we don't want the strictness to depend--- on exactly how the sequence is balanced. For example, what do we want--- from------ unzip [(1,2), undefined, (5,6)]?------ The argument could be represented as------ Seq $ Deep 3 (One (Elem (1,2))) EmptyT (Two undefined (Elem (5,6)))------ or as------ Seq $ Deep 3 (Two (Elem (1,2)) undefined) EmptyT (One (Elem (5,6)))------ We don't want the tree balance to determine whether we get------ ([1, undefined, undefined], [2, undefined, undefined])------ or------ ([undefined, undefined, 5], [undefined, undefined, 6])------ so we pretty much have to be completely lazy in the elements.--#ifdef __GLASGOW_HASKELL__-{-# NOINLINE [1] unzipWith #-}---- We don't need a special rule for unzip:------ unzip (fmap f xs) = unzipWith id f xs,------ which rewrites to unzipWith (id . f) xs------ It's true that if GHC doesn't know the arity of `f` then--- it won't reduce further, but that doesn't seem like too--- big a deal here.-{-# RULES-"unzipWith/fmapSeq" forall f g xs. unzipWith f (fmapSeq g xs) =-                                     unzipWith (f . g) xs- #-}-#endif--class UnzipWith f where-  unzipWith' :: (x -> (a, b)) -> f x -> (f a, f b)---- This instance is only used at the very top of the tree;--- the rest of the elements are handled by unzipWithNodeElem-instance UnzipWith Elem where-#if __GLASGOW_HASKELL__ >= 708-  unzipWith' = coerce-#else-  unzipWith' f (Elem a) = case f a of (x, y) -> (Elem x, Elem y)-#endif---- We're very lazy here for the sake of efficiency. We want to be able to--- reach any element of either result in logarithmic time. If we pattern--- match strictly, we'll end up building entire 2-3 trees at once, which--- would take linear time.------ However, we're not *entirely* lazy! We are careful to build pieces--- of each sequence as the corresponding pieces of the *other* sequence--- are demanded. This allows the garbage collector to get rid of each--- *component* of each result pair as soon as it is dead.------ Note that this instance is used only for *internal* nodes. Nodes--- containing elements are handled by 'unzipWithNodeElem'-instance UnzipWith Node where-  unzipWith' f (Node2 s x y) =-    ( Node2 s x1 y1-    , Node2 s x2 y2)-    where-      {-# NOINLINE fx #-}-      {-# NOINLINE fy #-}-      fx = strictifyPair (f x)-      fy = strictifyPair (f y)-      (x1, x2) = fx-      (y1, y2) = fy-  unzipWith' f (Node3 s x y z) =-    ( Node3 s x1 y1 z1-    , Node3 s x2 y2 z2)-    where-      {-# NOINLINE fx #-}-      {-# NOINLINE fy #-}-      {-# NOINLINE fz #-}-      fx = strictifyPair (f x)-      fy = strictifyPair (f y)-      fz = strictifyPair (f z)-      (x1, x2) = fx-      (y1, y2) = fy-      (z1, z2) = fz---- Force both elements of a pair-strictifyPair :: (a, b) -> (a, b)-strictifyPair (!x, !y) = (x, y)---- We're strict here for the sake of efficiency. The Node instance--- is lazy, so we don't particularly need to add an extra thunk on top--- of each node.-instance UnzipWith Digit where-  unzipWith' f (One x)-    | (x1, x2) <- f x-    = (One x1, One x2)-  unzipWith' f (Two x y)-    | (x1, x2) <- f x-    , (y1, y2) <- f y-    = ( Two x1 y1-      , Two x2 y2)-  unzipWith' f (Three x y z)-    | (x1, x2) <- f x-    , (y1, y2) <- f y-    , (z1, z2) <- f z-    = ( Three x1 y1 z1-      , Three x2 y2 z2)-  unzipWith' f (Four x y z w)-    | (x1, x2) <- f x-    , (y1, y2) <- f y-    , (z1, z2) <- f z-    , (w1, w2) <- f w-    = ( Four x1 y1 z1 w1-      , Four x2 y2 z2 w2)--instance UnzipWith FingerTree where-  unzipWith' _ EmptyT = (EmptyT, EmptyT)-  unzipWith' f (Single x)-    | (x1, x2) <- f x-    = (Single x1, Single x2)-  unzipWith' f (Deep s pr m sf)-    | (!pr1, !pr2) <- unzipWith' f pr-    , (!sf1, !sf2) <- unzipWith' f sf-    = (Deep s pr1 m1 sf1, Deep s pr2 m2 sf2)-    where-      {-# NOINLINE m1m2 #-}-      m1m2 = strictifyPair $ unzipWith' (unzipWith' f) m-      (m1, m2) = m1m2--instance UnzipWith Seq where-  unzipWith' _ (Seq EmptyT) = (empty, empty)-  unzipWith' f (Seq (Single (Elem x)))-    | (x1, x2) <- f x-    = (singleton x1, singleton x2)-  unzipWith' f (Seq (Deep s pr m sf))-    | (!pr1, !pr2) <- unzipWith' (unzipWith' f) pr-    , (!sf1, !sf2) <- unzipWith' (unzipWith' f) sf-    = (Seq (Deep s pr1 m1 sf1), Seq (Deep s pr2 m2 sf2))-    where-      {-# NOINLINE m1m2 #-}-      m1m2 = strictifyPair $ unzipWith' (unzipWithNodeElem f) m-      (m1, m2) = m1m2---- Here we need to be lazy in the children (because they're--- Elems), but we can afford to be strict in the results--- of `f` because it's sure to return a pair immediately--- (unzipWith lazifies the function it's passed).-unzipWithNodeElem :: (x -> (a, b))-       -> Node (Elem x) -> (Node (Elem a), Node (Elem b))-unzipWithNodeElem f (Node2 s (Elem x) (Elem y))-  | (x1, x2) <- f x-  , (y1, y2) <- f y-  = ( Node2 s (Elem x1) (Elem y1)-    , Node2 s (Elem x2) (Elem y2))-unzipWithNodeElem f (Node3 s (Elem x) (Elem y) (Elem z))-  | (x1, x2) <- f x-  , (y1, y2) <- f y-  , (z1, z2) <- f z-  = ( Node3 s (Elem x1) (Elem y1) (Elem z1)-    , Node3 s (Elem x2) (Elem y2) (Elem z2))---- | \( O(\min(n_1,n_2)) \).  'zip' takes two sequences and returns a sequence--- of corresponding pairs.  If one input is short, excess elements are--- discarded from the right end of the longer sequence.-zip :: Seq a -> Seq b -> Seq (a, b)-zip = zipWith (,)---- | \( O(\min(n_1,n_2)) \).  'zipWith' generalizes 'zip' by zipping with the--- function given as the first argument, instead of a tupling function.--- For example, @zipWith (+)@ is applied to two sequences to take the--- sequence of corresponding sums.-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith f s1 s2 = zipWith' f s1' s2'-  where-    minLen = min (length s1) (length s2)-    s1' = take minLen s1-    s2' = take minLen s2---- | A version of zipWith that assumes the sequences have the same length.-zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith' f s1 s2 = splitMap uncheckedSplitAt goLeaf s2 s1-  where-    goLeaf (Seq (Single (Elem b))) a = f a b-    goLeaf _ _ = error "Data.Sequence.zipWith'.goLeaf internal error: not a singleton"---- | \( O(\min(n_1,n_2,n_3)) \).  'zip3' takes three sequences and returns a--- sequence of triples, analogous to 'zip'.-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zip3 = zipWith3 (,,)---- | \( O(\min(n_1,n_2,n_3)) \).  'zipWith3' takes a function which combines--- three elements, as well as three sequences and returns a sequence of--- their point-wise combinations, analogous to 'zipWith'.-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-zipWith3 f s1 s2 s3 = zipWith' ($) (zipWith' f s1' s2') s3'-  where-    minLen = minimum [length s1, length s2, length s3]-    s1' = take minLen s1-    s2' = take minLen s2-    s3' = take minLen s3--zipWith3' :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-zipWith3' f s1 s2 s3 = zipWith' ($) (zipWith' f s1 s2) s3---- | \( O(\min(n_1,n_2,n_3,n_4)) \).  'zip4' takes four sequences and returns a--- sequence of quadruples, analogous to 'zip'.-zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)-zip4 = zipWith4 (,,,)---- | \( O(\min(n_1,n_2,n_3,n_4)) \).  'zipWith4' takes a function which combines--- four elements, as well as four sequences and returns a sequence of--- their point-wise combinations, analogous to 'zipWith'.-zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e-zipWith4 f s1 s2 s3 s4 = zipWith' ($) (zipWith3' f s1' s2' s3') s4'-  where-    minLen = minimum [length s1, length s2, length s3, length s4]-    s1' = take minLen s1-    s2' = take minLen s2-    s3' = take minLen s3-    s4' = take minLen s4---- | fromList2, given a list and its length, constructs a completely--- balanced Seq whose elements are that list using the replicateA--- generalization.-fromList2 :: Int -> [a] -> Seq a-fromList2 n = execState (replicateA n (State ht))-  where-    ht (x:xs) = (xs, x)-    ht []     = error "fromList2: short list"
− Data/Sequence/Internal/Sorting.hs 
@@ -1,437 +0,0 @@-{-# LANGUAGE BangPatterns #-}--{-# OPTIONS_HADDOCK not-home #-}---- |------ = 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 module provides the various sorting implementations for--- "Data.Sequence". Further notes are available in the file sorting.md--- (in this directory).--module Data.Sequence.Internal.Sorting-  (-   -- * Sort Functions-   sort-  ,sortBy-  ,sortOn-  ,unstableSort-  ,unstableSortBy-  ,unstableSortOn-  ,-   -- * Heaps-   -- $heaps-   Queue(..)-  ,QList(..)-  ,IndexedQueue(..)-  ,IQList(..)-  ,TaggedQueue(..)-  ,TQList(..)-  ,IndexedTaggedQueue(..)-  ,ITQList(..)-  ,-   -- * Merges-   -- $merges-   mergeQ-  ,mergeIQ-  ,mergeTQ-  ,mergeITQ-  ,-   -- * popMin-   -- $popMin-   popMinQ-  ,popMinIQ-  ,popMinTQ-  ,popMinITQ-  ,-   -- * Building-   -- $building-   buildQ-  ,buildIQ-  ,buildTQ-  ,buildITQ-  ,-   -- * Special folds-   -- $folds-   foldToMaybeTree-  ,foldToMaybeWithIndexTree)-  where--import Data.Sequence.Internal-       (Elem(..), Seq(..), Node(..), Digit(..), Sized(..), FingerTree(..),-        replicateA, foldDigit, foldNode, foldWithIndexDigit,-        foldWithIndexNode)-import Utils.Containers.Internal.State (State(..), execState)--- | \( O(n \log n) \).  'sort' sorts the specified 'Seq' by the natural--- ordering of its elements.  The sort is stable.  If stability is not--- required, 'unstableSort' can be slightly faster.------ @since 0.3.0-sort :: Ord a => Seq a -> Seq a-sort = sortBy compare---- | \( O(n \log n) \).  'sortBy' sorts the specified 'Seq' according to the--- specified comparator.  The sort is stable.  If stability is not required,--- 'unstableSortBy' can be slightly faster.------ @since 0.3.0-sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a-sortBy cmp (Seq xs) =-    maybe-        (Seq EmptyT)-        (execState (replicateA (size xs) (State (popMinIQ cmp))))-        (buildIQ cmp (\s (Elem x) -> IQ s x IQNil) 0 xs)---- | \( O(n \log n) \). 'sortOn' sorts the specified 'Seq' by comparing--- the results of a key function applied to each element. @'sortOn' f@ is--- equivalent to @'sortBy' ('compare' ``Data.Function.on`` f)@, but has the--- performance advantage of only evaluating @f@ once for each element in the--- input list. This is called the decorate-sort-undecorate paradigm, or--- Schwartzian transform.------ An example of using 'sortOn' might be to sort a 'Seq' of strings--- according to their length:------ > sortOn length (fromList ["alligator", "monkey", "zebra"]) == fromList ["zebra", "monkey", "alligator"]------ If, instead, 'sortBy' had been used, 'length' would be evaluated on--- every comparison, giving \( O(n \log n) \) evaluations, rather than--- \( O(n) \).------ If @f@ is very cheap (for example a record selector, or 'fst'),--- @'sortBy' ('compare' ``Data.Function.on`` f)@ will be faster than--- @'sortOn' f@.------ @since 0.5.11-sortOn :: Ord b => (a -> b) -> Seq a -> Seq a-sortOn f (Seq xs) =-    maybe-       (Seq EmptyT)-       (execState (replicateA (size xs) (State (popMinITQ compare))))-       (buildITQ compare (\s (Elem x) -> ITQ s (f x) x ITQNil) 0 xs)---- | \( O(n \log n) \).  'unstableSort' sorts the specified 'Seq' by--- the natural ordering of its elements, but the sort is not stable.--- This algorithm is frequently faster and uses less memory than 'sort'.---- Notes on the implementation and choice of heap are available in--- the file sorting.md (in this directory).------ @since 0.3.0-unstableSort :: Ord a => Seq a -> Seq a-unstableSort = unstableSortBy compare---- | \( O(n \log n) \).  A generalization of 'unstableSort', 'unstableSortBy'--- takes an arbitrary comparator and sorts the specified sequence.--- The sort is not stable.  This algorithm is frequently faster and--- uses less memory than 'sortBy'.------ @since 0.3.0-unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a-unstableSortBy cmp (Seq xs) =-    maybe-        (Seq EmptyT)-        (execState (replicateA (size xs) (State (popMinQ cmp))))-        (buildQ cmp (\(Elem x) -> Q x Nil) xs)---- | \( O(n \log n) \). 'unstableSortOn' sorts the specified 'Seq' by--- comparing the results of a key function applied to each element.--- @'unstableSortOn' f@ is equivalent to @'unstableSortBy' ('compare' ``Data.Function.on`` f)@,--- but has the performance advantage of only evaluating @f@ once for each--- element in the input list. This is called the--- decorate-sort-undecorate paradigm, or Schwartzian transform.------ An example of using 'unstableSortOn' might be to sort a 'Seq' of strings--- according to their length:------ > unstableSortOn length (fromList ["alligator", "monkey", "zebra"]) == fromList ["zebra", "monkey", "alligator"]------ If, instead, 'unstableSortBy' had been used, 'length' would be evaluated on--- every comparison, giving \( O(n \log n) \) evaluations, rather than--- \( O(n) \).------ If @f@ is very cheap (for example a record selector, or 'fst'),--- @'unstableSortBy' ('compare' ``Data.Function.on`` f)@ will be faster than--- @'unstableSortOn' f@.------ @since 0.5.11-unstableSortOn :: Ord b => (a -> b) -> Seq a -> Seq a-unstableSortOn f (Seq xs) =-    maybe-       (Seq EmptyT)-       (execState (replicateA (size xs) (State (popMinTQ compare))))-       (buildTQ compare (\(Elem x) -> TQ (f x) x TQNil) xs)----------------------------------------------------------------------------- $heaps------ The following are definitions for various specialized pairing heaps.------ All of the heaps are defined to be non-empty, which speeds up the--- merge functions.----------------------------------------------------------------------------- | A simple pairing heap.-data Queue e = Q !e (QList e)-data QList e-    = Nil-    | QCons {-# UNPACK #-} !(Queue e)-            (QList e)---- | A pairing heap tagged with the original position of elements,--- to allow for stable sorting.-data IndexedQueue e =-    IQ {-# UNPACK #-} !Int !e (IQList e)-data IQList e-    = IQNil-    | IQCons {-# UNPACK #-} !(IndexedQueue e)-             (IQList e)---- | A pairing heap tagged with some key for sorting elements, for use--- in 'unstableSortOn'.-data TaggedQueue a b =-    TQ !a b (TQList a b)-data TQList a b-    = TQNil-    | TQCons {-# UNPACK #-} !(TaggedQueue a b)-             (TQList a b)---- | A pairing heap tagged with both a key and the original position--- of its elements, for use in 'sortOn'.-data IndexedTaggedQueue e a =-    ITQ {-# UNPACK #-} !Int !e a (ITQList e a)-data ITQList e a-    = ITQNil-    | ITQCons {-# UNPACK #-} !(IndexedTaggedQueue e a)-              (ITQList e a)--infixr 8 `ITQCons`, `TQCons`, `QCons`, `IQCons`----------------------------------------------------------------------------- $merges------ The following are definitions for "merge" for each of the heaps--- above. Each takes a comparison function which is used to order the--- elements.----------------------------------------------------------------------------- | 'mergeQ' merges two 'Queue's.-mergeQ :: (a -> a -> Ordering) -> Queue a -> Queue a -> Queue a-mergeQ cmp q1@(Q x1 ts1) q2@(Q x2 ts2)-  | cmp x1 x2 == GT = Q x2 (q1 `QCons` ts2)-  | otherwise       = Q x1 (q2 `QCons` ts1)---- | 'mergeTQ' merges two 'TaggedQueue's, based on the tag value.-mergeTQ :: (a -> a -> Ordering)-        -> TaggedQueue a b-        -> TaggedQueue a b-        -> TaggedQueue a b-mergeTQ cmp q1@(TQ x1 y1 ts1) q2@(TQ x2 y2 ts2)-  | cmp x1 x2 == GT = TQ x2 y2 (q1 `TQCons` ts2)-  | otherwise       = TQ x1 y1 (q2 `TQCons` ts1)---- | 'mergeIQ' merges two 'IndexedQueue's, taking into account the--- original position of the elements.-mergeIQ :: (a -> a -> Ordering)-        -> IndexedQueue a-        -> IndexedQueue a-        -> IndexedQueue a-mergeIQ cmp q1@(IQ i1 x1 ts1) q2@(IQ i2 x2 ts2) =-    case cmp x1 x2 of-        LT -> IQ i1 x1 (q2 `IQCons` ts1)-        EQ | i1 <= i2 -> IQ i1 x1 (q2 `IQCons` ts1)-        _ -> IQ i2 x2 (q1 `IQCons` ts2)---- | 'mergeITQ' merges two 'IndexedTaggedQueue's, based on the tag--- value, taking into account the original position of the elements.-mergeITQ-    :: (a -> a -> Ordering)-    -> IndexedTaggedQueue a b-    -> IndexedTaggedQueue a b-    -> IndexedTaggedQueue a b-mergeITQ cmp q1@(ITQ i1 x1 y1 ts1) q2@(ITQ i2 x2 y2 ts2) =-    case cmp x1 x2 of-        LT -> ITQ i1 x1 y1 (q2 `ITQCons` ts1)-        EQ | i1 <= i2 -> ITQ i1 x1 y1 (q2 `ITQCons` ts1)-        _ -> ITQ i2 x2 y2 (q1 `ITQCons` ts2)----------------------------------------------------------------------------- $popMin------ The following are definitions for @popMin@, a function which--- constructs a stateful action which pops the smallest element from the--- queue, where "smallest" is according to the supplied comparison--- function.------ All of the functions fail on an empty queue.------ Each of these functions is structured something like this:------ @popMinQ cmp (Q x ts) = (mergeQs ts, x)@------ The reason the call to @mergeQs@ is lazy is that it will be bottom--- for the last element in the queue, preventing us from evaluating the--- fully sorted sequence.----------------------------------------------------------------------------- | Pop the smallest element from the queue, using the supplied--- comparator.-popMinQ :: (e -> e -> Ordering) -> Queue e -> (Queue e, e)-popMinQ cmp (Q x xs) = (mergeQs xs, x)-  where-    mergeQs (t `QCons` Nil) = t-    mergeQs (t1 `QCons` t2 `QCons` Nil) = t1 <+> t2-    mergeQs (t1 `QCons` t2 `QCons` ts) = (t1 <+> t2) <+> mergeQs ts-    mergeQs Nil = error "popMinQ: tried to pop from empty queue"-    (<+>) = mergeQ cmp---- | Pop the smallest element from the queue, using the supplied--- comparator, deferring to the item's original position when the--- comparator returns 'EQ'.-popMinIQ :: (e -> e -> Ordering) -> IndexedQueue e -> (IndexedQueue e, e)-popMinIQ cmp (IQ _ x xs) = (mergeQs xs, x)-  where-    mergeQs (t `IQCons` IQNil) = t-    mergeQs (t1 `IQCons` t2 `IQCons` IQNil) = t1 <+> t2-    mergeQs (t1 `IQCons` t2 `IQCons` ts) = (t1 <+> t2) <+> mergeQs ts-    mergeQs IQNil = error "popMinQ: tried to pop from empty queue"-    (<+>) = mergeIQ cmp---- | Pop the smallest element from the queue, using the supplied--- comparator on the tag.-popMinTQ :: (a -> a -> Ordering) -> TaggedQueue a b -> (TaggedQueue a b, b)-popMinTQ cmp (TQ _ x xs) = (mergeQs xs, x)-  where-    mergeQs (t `TQCons` TQNil) = t-    mergeQs (t1 `TQCons` t2 `TQCons` TQNil) = t1 <+> t2-    mergeQs (t1 `TQCons` t2 `TQCons` ts) = (t1 <+> t2) <+> mergeQs ts-    mergeQs TQNil = error "popMinQ: tried to pop from empty queue"-    (<+>) = mergeTQ cmp---- | Pop the smallest element from the queue, using the supplied--- comparator on the tag, deferring to the item's original position--- when the comparator returns 'EQ'.-popMinITQ :: (e -> e -> Ordering)-          -> IndexedTaggedQueue e b-          -> (IndexedTaggedQueue e b, b)-popMinITQ cmp (ITQ _ _ x xs) = (mergeQs xs, x)-  where-    mergeQs (t `ITQCons` ITQNil) = t-    mergeQs (t1 `ITQCons` t2 `ITQCons` ITQNil) = t1 <+> t2-    mergeQs (t1 `ITQCons` t2 `ITQCons` ts) = (t1 <+> t2) <+> mergeQs ts-    mergeQs ITQNil = error "popMinQ: tried to pop from empty queue"-    (<+>) = mergeITQ cmp----------------------------------------------------------------------------- $building------ The following are definitions for functions to build queues, given a--- comparison function.---------------------------------------------------------------------------buildQ :: (b -> b -> Ordering) -> (a -> Queue b) -> FingerTree a -> Maybe (Queue b)-buildQ cmp = foldToMaybeTree (mergeQ cmp)--buildIQ-    :: (b -> b -> Ordering)-    -> (Int -> Elem y -> IndexedQueue b)-    -> Int-    -> FingerTree (Elem y)-    -> Maybe (IndexedQueue b)-buildIQ cmp = foldToMaybeWithIndexTree (mergeIQ cmp)--buildTQ-    :: (b -> b -> Ordering)-    -> (a -> TaggedQueue b c)-    -> FingerTree a-    -> Maybe (TaggedQueue b c)-buildTQ cmp = foldToMaybeTree (mergeTQ cmp)--buildITQ-    :: (b -> b -> Ordering)-    -> (Int -> Elem y -> IndexedTaggedQueue b c)-    -> Int-    -> FingerTree (Elem y)-    -> Maybe (IndexedTaggedQueue b c)-buildITQ cmp = foldToMaybeWithIndexTree (mergeITQ cmp)----------------------------------------------------------------------------- $folds------ A big part of what makes the heaps fast is that they're non empty,--- so the merge function can avoid an extra case match. To take--- advantage of this, though, we need specialized versions of 'foldMap'--- and 'Data.Sequence.foldMapWithIndex', which can alternate between--- calling the faster semigroup-like merge when folding over non empty--- structures (like 'Node' and 'Digit'), and the--- 'Data.Semirgroup.Option'-like mappend, when folding over structures--- which can be empty (like 'FingerTree').----------------------------------------------------------------------------- | A 'foldMap'-like function, specialized to the--- 'Data.Semigroup.Option' monoid, which takes advantage of the--- internal structure of 'Seq' to avoid wrapping in 'Maybe' at certain--- points.-foldToMaybeTree :: (b -> b -> b) -> (a -> b) -> FingerTree a -> Maybe b-foldToMaybeTree _ _ EmptyT = Nothing-foldToMaybeTree _ f (Single xs) = Just (f xs)-foldToMaybeTree (<+>) f (Deep _ pr m sf) =-    Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) m')-  where-    pr' = foldDigit (<+>) f pr-    sf' = foldDigit (<+>) f sf-    m' = foldToMaybeTree (<+>) (foldNode (<+>) f) m-{-# INLINE foldToMaybeTree #-}---- | A 'foldMapWithIndex'-like function, specialized to the--- 'Data.Semigroup.Option' monoid, which takes advantage of the--- internal structure of 'Seq' to avoid wrapping in 'Maybe' at certain--- points.-foldToMaybeWithIndexTree :: (b -> b -> b)-                         -> (Int -> Elem y -> b)-                         -> Int-                         -> FingerTree (Elem y)-                         -> Maybe b-foldToMaybeWithIndexTree = foldToMaybeWithIndexTree'-  where-    {-# SPECIALISE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> Maybe b #-}-    {-# SPECIALISE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> Maybe b #-}-    foldToMaybeWithIndexTree'-        :: Sized a-        => (b -> b -> b) -> (Int -> a -> b) -> Int -> FingerTree a -> Maybe b-    foldToMaybeWithIndexTree' _ _ !_s EmptyT = Nothing-    foldToMaybeWithIndexTree' _ f s (Single xs) = Just (f s xs)-    foldToMaybeWithIndexTree' (<+>) f s (Deep _ pr m sf) =-        Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) m')-      where-        pr' = digit (<+>) f s pr-        sf' = digit (<+>) f sPsprm sf-        m' = foldToMaybeWithIndexTree' (<+>) (node (<+>) f) sPspr m-        !sPspr = s + size pr-        !sPsprm = sPspr + size m-    {-# SPECIALISE digit :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> b #-}-    {-# SPECIALISE digit :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Digit (Node y) -> b #-}-    digit-        :: Sized a-        => (b -> b -> b) -> (Int -> a -> b) -> Int -> Digit a -> b-    digit = foldWithIndexDigit-    {-# SPECIALISE node :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Node (Elem y) -> b #-}-    {-# SPECIALISE node :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Node (Node y) -> b #-}-    node-        :: Sized a-        => (b -> b -> b) -> (Int -> a -> b) -> Int -> Node a -> b-    node = foldWithIndexNode-{-# INLINE foldToMaybeWithIndexTree #-}
− Data/Set.hs 
@@ -1,179 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.Set--- Copyright   :  (c) Daan Leijen 2002--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable--------- = Finite Sets------ The @'Set' e@ type represents a set of elements of type @e@. Most operations--- require that @e@ be an instance of the 'Ord' class. A 'Set' is strict in its--- elements.------ For a walkthrough of the most commonly used functions see the--- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>.------ Note that the implementation is generally /left-biased/. Functions that take--- two sets as arguments and combine them, such as `union` and `intersection`,--- prefer the entries in the first argument to those in the second. Of course,--- this bias can only be observed when equality is an equivalence relation--- instead of structural equality.------ These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.------ >  import Data.Set (Set)--- >  import qualified Data.Set as Set--------- == Warning------ The size of the set must not exceed @maxBound::Int@. Violation of--- this condition is not detected and if the size limit is exceeded, its--- behaviour is undefined.--------- == Implementation------ The implementation of 'Set' is based on /size balanced/ binary trees (or--- trees of /bounded balance/) as described by:------    * Stephen Adams, \"/Efficient sets: a balancing act/\",---      Journal of Functional Programming 3(4):553-562, October 1993,---      <http://www.swiss.ai.mit.edu/~adams/BB/>.---    * J. Nievergelt and E.M. Reingold,---      \"/Binary search trees of bounded balance/\",---      SIAM journal of computing 2(1), March 1973.------  Bounds for 'union', 'intersection', and 'difference' are as given---  by------    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.-----------------------------------------------------------------------------------module Data.Set (-            -- * Set type-#if !defined(TESTING)-              Set          -- instance Eq,Ord,Show,Read,Data,Typeable-#else-              Set(..)-#endif--            -- * Construction-            , empty-            , singleton-            , fromList-            , fromAscList-            , fromDescList-            , fromDistinctAscList-            , fromDistinctDescList-            , powerSet--            -- * Insertion-            , insert--            -- * Deletion-            , delete--            -- * Query-            , member-            , notMember-            , lookupLT-            , lookupGT-            , lookupLE-            , lookupGE-            , S.null-            , size-            , isSubsetOf-            , isProperSubsetOf-            , disjoint--            -- * Combine-            , union-            , unions-            , difference-            , (\\)-            , intersection-            , cartesianProduct-            , disjointUnion--            -- * Filter-            , S.filter-            , takeWhileAntitone-            , dropWhileAntitone-            , spanAntitone-            , partition-            , split-            , splitMember-            , splitRoot--            -- * Indexed-            , lookupIndex-            , findIndex-            , elemAt-            , deleteAt-            , S.take-            , S.drop-            , S.splitAt--            -- * Map-            , S.map-            , mapMonotonic--            -- * Folds-            , S.foldr-            , S.foldl-            -- ** Strict folds-            , foldr'-            , foldl'-            -- ** Legacy folds-            , fold--            -- * Min\/Max-            , lookupMin-            , lookupMax-            , findMin-            , findMax-            , deleteMin-            , deleteMax-            , deleteFindMin-            , deleteFindMax-            , maxView-            , minView--            -- * Conversion--            -- ** List-            , elems-            , toList-            , toAscList-            , toDescList--            -- * Debugging-            , showTree-            , showTreeWith-            , valid--#if defined(TESTING)-            -- Internals (for testing)-            , bin-            , balanced-            , link-            , merge-#endif-            ) where--import Data.Set.Internal as S
− Data/Set/Internal.hs 
@@ -1,1889 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}-#endif--{-# OPTIONS_HADDOCK not-home #-}--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.Set.Internal--- Copyright   :  (c) Daan Leijen 2002--- License     :  BSD-style--- Maintainer  :  libraries@haskell.org--- Portability :  portable------ = WARNING------ This module is considered __internal__.------ The Package Versioning Policy __does not apply__.------ 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 sets.------ These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.------ >  import Data.Set (Set)--- >  import qualified Data.Set as Set------ The implementation of 'Set' is based on /size balanced/ binary trees (or--- trees of /bounded balance/) as described by:------    * Stephen Adams, \"/Efficient sets: a balancing act/\",---      Journal of Functional Programming 3(4):553-562, October 1993,---      <http://www.swiss.ai.mit.edu/~adams/BB/>.---    * J. Nievergelt and E.M. Reingold,---      \"/Binary search trees of bounded balance/\",---      SIAM journal of computing 2(1), March 1973.------  Bounds for 'union', 'intersection', and 'difference' are as given---  by------    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,---      \"/Just Join for Parallel Ordered Sets/\",---      <https://arxiv.org/abs/1602.02120v3>.------ Note that the implementation is /left-biased/ -- the elements of a--- first argument are always preferred to the second, for example in--- 'union' or 'insert'.  Of course, left-biasing can only be observed--- when equality is an equivalence relation instead of structural--- equality.------ /Warning/: The size of the set must not exceed @maxBound::Int@. Violation of--- this condition is not detected and if the size limit is exceeded, the--- behavior of the set is completely undefined.------ @since 0.5.9---------------------------------------------------------------------------------- [Note: Using INLINABLE]--- ~~~~~~~~~~~~~~~~~~~~~~~--- It is crucial to the performance that the functions specialize on the Ord--- type when possible. GHC 7.0 and higher does this by itself when it sees th--- unfolding of a function -- that is why all public functions are marked--- INLINABLE (that exposes the unfolding).----- [Note: Using INLINE]--- ~~~~~~~~~~~~~~~~~~~~--- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.--- We mark the functions that just navigate down the tree (lookup, insert,--- delete and similar). That navigation code gets inlined and thus specialized--- when possible. There is a price to pay -- code growth. The code INLINED is--- therefore only the tree navigation, all the real work (rebalancing) is not--- INLINED by using a NOINLINE.------ All methods marked INLINE have to be nonrecursive -- a 'go' function doing--- the real work is provided.----- [Note: Type of local 'go' function]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- If the local 'go' function uses an Ord class, it sometimes heap-allocates--- the Ord dictionary when the 'go' function does not have explicit type.--- In that case we give 'go' explicit type. But this slightly decrease--- performance, as the resulting 'go' function can float out to top level.----- [Note: Local 'go' functions and capturing]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- As opposed to IntSet, when 'go' function captures an argument, increased--- heap-allocation can occur: sometimes in a polymorphic function, the 'go'--- floats out of its enclosing function and then it heap-allocates the--- dictionary and the argument. Maybe it floats out too late and strictness--- analyzer cannot see that these could be passed on stack.---- [Note: Order of constructors]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The order of constructors of Set matters when considering performance.--- Currently in GHC 7.0, when type has 2 constructors, a forward conditional--- jump is made when successfully matching second constructor. Successful match--- of first constructor results in the forward jump not taken.--- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip--- improves the benchmark by up to 10% on x86.--module Data.Set.Internal (-            -- * Set type-              Set(..)       -- instance Eq,Ord,Show,Read,Data,Typeable-            , Size--            -- * Operators-            , (\\)--            -- * Query-            , null-            , size-            , member-            , notMember-            , lookupLT-            , lookupGT-            , lookupLE-            , lookupGE-            , isSubsetOf-            , isProperSubsetOf-            , disjoint--            -- * Construction-            , empty-            , singleton-            , insert-            , delete-            , powerSet--            -- * Combine-            , union-            , unions-            , difference-            , intersection-            , cartesianProduct-            , disjointUnion--            -- * Filter-            , filter-            , takeWhileAntitone-            , dropWhileAntitone-            , spanAntitone-            , partition-            , split-            , splitMember-            , splitRoot--            -- * Indexed-            , lookupIndex-            , findIndex-            , elemAt-            , deleteAt-            , take-            , drop-            , splitAt--            -- * Map-            , map-            , mapMonotonic--            -- * Folds-            , foldr-            , foldl-            -- ** Strict folds-            , foldr'-            , foldl'-            -- ** Legacy folds-            , fold--            -- * Min\/Max-            , lookupMin-            , lookupMax-            , findMin-            , findMax-            , deleteMin-            , deleteMax-            , deleteFindMin-            , deleteFindMax-            , maxView-            , minView--            -- * Conversion--            -- ** List-            , elems-            , toList-            , fromList--            -- ** Ordered list-            , toAscList-            , toDescList-            , fromAscList-            , fromDistinctAscList-            , fromDescList-            , fromDistinctDescList--            -- * Debugging-            , showTree-            , showTreeWith-            , valid--            -- Internals (for testing)-            , bin-            , balanced-            , link-            , merge-            ) where--import Prelude hiding (filter,foldl,foldr,null,map,take,drop,splitAt)-import qualified Data.List as List-import Data.Bits (shiftL, shiftR)-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(..))-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotentMonoid)-import Data.Functor.Classes-#endif-import qualified Data.Foldable as Foldable-#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable (foldMap))-#endif-import Data.Typeable-import Control.DeepSeq (NFData(rnf))--import Utils.Containers.Internal.StrictPair-import Utils.Containers.Internal.PtrEquality--#if __GLASGOW_HASKELL__-import GHC.Exts ( build, lazy )-#if __GLASGOW_HASKELL__ >= 708-import qualified GHC.Exts as GHCExts-#endif-import Text.Read ( readPrec, Read (..), Lexeme (..), parens, prec-                 , lexP, readListPrecDefault )-import Data.Data-#endif---{---------------------------------------------------------------------  Operators---------------------------------------------------------------------}-infixl 9 \\ ------ | /O(m*log(n\/m+1)), m <= n/. See 'difference'.-(\\) :: Ord a => Set a -> Set a -> Set a-m1 \\ m2 = difference m1 m2-#if __GLASGOW_HASKELL__-{-# INLINABLE (\\) #-}-#endif--{---------------------------------------------------------------------  Sets are size balanced trees---------------------------------------------------------------------}--- | A set of values @a@.---- See Note: Order of constructors-data Set a    = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)-              | Tip--type Size     = Int--#if __GLASGOW_HASKELL__ >= 708-type role Set nominal-#endif--instance Ord a => Monoid (Set a) where-    mempty  = empty-    mconcat = unions-#if !(MIN_VERSION_base(4,9,0))-    mappend = union-#else-    mappend = (<>)---- | @since 0.5.7-instance Ord a => Semigroup (Set a) where-    (<>)    = union-    stimes  = stimesIdempotentMonoid-#endif---instance Foldable.Foldable Set where-    fold = go-      where go Tip = mempty-            go (Bin 1 k _ _) = k-            go (Bin _ k l r) = go l `mappend` (k `mappend` go r)-    {-# INLINABLE fold #-}-    foldr = foldr-    {-# INLINE foldr #-}-    foldl = foldl-    {-# INLINE foldl #-}-    foldMap f t = go t-      where go Tip = mempty-            go (Bin 1 k _ _) = f k-            go (Bin _ k l r) = go l `mappend` (f k `mappend` go r)-    {-# INLINE foldMap #-}-    foldl' = foldl'-    {-# INLINE foldl' #-}-    foldr' = foldr'-    {-# INLINE foldr' #-}-#if MIN_VERSION_base(4,8,0)-    length = size-    {-# INLINE length #-}-    null   = null-    {-# INLINE null #-}-    toList = toList-    {-# INLINE toList #-}-    elem = go-      where go !_ Tip = False-            go x (Bin _ y l r) = x == y || go x l || go x r-    {-# INLINABLE elem #-}-    minimum = findMin-    {-# INLINE minimum #-}-    maximum = findMax-    {-# INLINE maximum #-}-    sum = foldl' (+) 0-    {-# INLINABLE sum #-}-    product = foldl' (*) 1-    {-# INLINABLE product #-}-#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 a, Ord a) => Data (Set a) where-  gfoldl f z set = z fromList `f` (toList set)-  toConstr _     = fromListConstr-  gunfold k z c  = case constrIndex c of-    1 -> k (z fromList)-    _ -> error "gunfold"-  dataTypeOf _   = setDataType-  dataCast1 f    = gcast1 f--fromListConstr :: Constr-fromListConstr = mkConstr setDataType "fromList" [] Prefix--setDataType :: DataType-setDataType = mkDataType "Data.Set.Internal.Set" [fromListConstr]--#endif--{---------------------------------------------------------------------  Query---------------------------------------------------------------------}--- | /O(1)/. Is this the empty set?-null :: Set a -> Bool-null Tip      = True-null (Bin {}) = False-{-# INLINE null #-}---- | /O(1)/. The number of elements in the set.-size :: Set a -> Int-size Tip = 0-size (Bin sz _ _ _) = sz-{-# INLINE size #-}---- | /O(log n)/. Is the element in the set?-member :: Ord a => a -> Set a -> Bool-member = go-  where-    go !_ Tip = False-    go x (Bin _ y l r) = case compare x y of-      LT -> go x l-      GT -> go x r-      EQ -> True-#if __GLASGOW_HASKELL__-{-# INLINABLE member #-}-#else-{-# INLINE member #-}-#endif---- | /O(log n)/. Is the element not in the set?-notMember :: Ord a => a -> Set a -> Bool-notMember a t = not $ member a t-#if __GLASGOW_HASKELL__-{-# INLINABLE notMember #-}-#else-{-# INLINE notMember #-}-#endif---- | /O(log n)/. Find largest element smaller than the given one.------ > lookupLT 3 (fromList [3, 5]) == Nothing--- > lookupLT 5 (fromList [3, 5]) == Just 3-lookupLT :: Ord a => a -> Set a -> Maybe a-lookupLT = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing x (Bin _ y l r) | x <= y = goNothing x l-                              | otherwise = goJust x y r--    goJust !_ best Tip = Just best-    goJust x best (Bin _ y l r) | x <= y = goJust x best l-                                | otherwise = goJust x y r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupLT #-}-#else-{-# INLINE lookupLT #-}-#endif---- | /O(log n)/. Find smallest element greater than the given one.------ > lookupGT 4 (fromList [3, 5]) == Just 5--- > lookupGT 5 (fromList [3, 5]) == Nothing-lookupGT :: Ord a => a -> Set a -> Maybe a-lookupGT = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing x (Bin _ y l r) | x < y = goJust x y l-                              | otherwise = goNothing x r--    goJust !_ best Tip = Just best-    goJust x best (Bin _ y l r) | x < y = goJust x y l-                                | otherwise = goJust x best r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupGT #-}-#else-{-# INLINE lookupGT #-}-#endif---- | /O(log n)/. Find largest element smaller or equal to the given one.------ > lookupLE 2 (fromList [3, 5]) == Nothing--- > lookupLE 4 (fromList [3, 5]) == Just 3--- > lookupLE 5 (fromList [3, 5]) == Just 5-lookupLE :: Ord a => a -> Set a -> Maybe a-lookupLE = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing x (Bin _ y l r) = case compare x y of LT -> goNothing x l-                                                    EQ -> Just y-                                                    GT -> goJust x y r--    goJust !_ best Tip = Just best-    goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x best l-                                                      EQ -> Just y-                                                      GT -> goJust x y r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupLE #-}-#else-{-# INLINE lookupLE #-}-#endif---- | /O(log n)/. Find smallest element greater or equal to the given one.------ > lookupGE 3 (fromList [3, 5]) == Just 3--- > lookupGE 4 (fromList [3, 5]) == Just 5--- > lookupGE 6 (fromList [3, 5]) == Nothing-lookupGE :: Ord a => a -> Set a -> Maybe a-lookupGE = goNothing-  where-    goNothing !_ Tip = Nothing-    goNothing x (Bin _ y l r) = case compare x y of LT -> goJust x y l-                                                    EQ -> Just y-                                                    GT -> goNothing x r--    goJust !_ best Tip = Just best-    goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x y l-                                                      EQ -> Just y-                                                      GT -> goJust x best r-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupGE #-}-#else-{-# INLINE lookupGE #-}-#endif--{---------------------------------------------------------------------  Construction---------------------------------------------------------------------}--- | /O(1)/. The empty set.-empty  :: Set a-empty = Tip-{-# INLINE empty #-}---- | /O(1)/. Create a singleton set.-singleton :: a -> Set a-singleton x = Bin 1 x Tip Tip-{-# INLINE singleton #-}--{---------------------------------------------------------------------  Insertion, Deletion---------------------------------------------------------------------}--- | /O(log n)/. Insert an element in a set.--- If the set already contains an element equal to the given value,--- it is replaced with the new value.---- See Note: Type of local 'go' function--- See Note: Avoiding worker/wrapper (in Data.Map.Internal)-insert :: Ord a => a -> Set a -> Set a-insert x0 = go x0 x0-  where-    go :: Ord a => a -> a -> Set a -> Set a-    go orig !_ Tip = singleton (lazy orig)-    go orig !x t@(Bin sz y l r) = case compare x y of-        LT | l' `ptrEq` l -> t-           | otherwise -> balanceL y l' r-           where !l' = go orig x l-        GT | r' `ptrEq` r -> t-           | otherwise -> balanceR y l r'-           where !r' = go orig x r-        EQ | lazy orig `seq` (orig `ptrEq` y) -> t-           | otherwise -> Bin sz (lazy orig) l r-#if __GLASGOW_HASKELL__-{-# INLINABLE insert #-}-#else-{-# INLINE insert #-}-#endif--#ifndef __GLASGOW_HASKELL__-lazy :: a -> a-lazy a = a-#endif---- Insert an element to the set only if it is not in the set.--- Used by `union`.---- See Note: Type of local 'go' function--- See Note: Avoiding worker/wrapper (in Data.Map.Internal)-insertR :: Ord a => a -> Set a -> Set a-insertR x0 = go x0 x0-  where-    go :: Ord a => a -> a -> Set a -> Set a-    go orig !_ Tip = singleton (lazy orig)-    go orig !x t@(Bin _ y l r) = case compare x y of-        LT | l' `ptrEq` l -> t-           | otherwise -> balanceL y l' r-           where !l' = go orig x l-        GT | r' `ptrEq` r -> t-           | otherwise -> balanceR y l r'-           where !r' = go orig x r-        EQ -> t-#if __GLASGOW_HASKELL__-{-# INLINABLE insertR #-}-#else-{-# INLINE insertR #-}-#endif---- | /O(log n)/. Delete an element from a set.---- See Note: Type of local 'go' function-delete :: Ord a => a -> Set a -> Set a-delete = go-  where-    go :: Ord a => a -> Set a -> Set a-    go !_ Tip = Tip-    go x t@(Bin _ y l r) = case compare x y of-        LT | l' `ptrEq` l -> t-           | otherwise -> balanceR y l' r-           where !l' = go x l-        GT | r' `ptrEq` r -> t-           | otherwise -> balanceL y l r'-           where !r' = go x r-        EQ -> glue l r-#if __GLASGOW_HASKELL__-{-# INLINABLE delete #-}-#else-{-# INLINE delete #-}-#endif--{---------------------------------------------------------------------  Subset---------------------------------------------------------------------}--- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).-isProperSubsetOf :: Ord a => Set a -> Set a -> Bool-isProperSubsetOf s1 s2-    = (size s1 < size s2) && (isSubsetOf s1 s2)-#if __GLASGOW_HASKELL__-{-# INLINABLE isProperSubsetOf #-}-#endif----- | /O(n+m)/. Is this a subset?--- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.-isSubsetOf :: Ord a => Set a -> Set a -> Bool-isSubsetOf t1 t2-  = (size t1 <= size t2) && (isSubsetOfX t1 t2)-#if __GLASGOW_HASKELL__-{-# INLINABLE isSubsetOf #-}-#endif--isSubsetOfX :: Ord a => Set a -> Set a -> Bool-isSubsetOfX Tip _ = True-isSubsetOfX _ Tip = False-isSubsetOfX (Bin _ x l r) t-  = found && isSubsetOfX l lt && isSubsetOfX r gt-  where-    (lt,found,gt) = splitMember x t-#if __GLASGOW_HASKELL__-{-# INLINABLE isSubsetOfX #-}-#endif--{---------------------------------------------------------------------  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 :: Ord a => Set a -> Set a -> Bool-disjoint Tip _ = True-disjoint _ Tip = True-disjoint (Bin _ x l r) t-  -- Analogous implementation to `subsetOfX`-  = not found && disjoint l lt && disjoint r gt-  where-    (lt,found,gt) = splitMember x t--{---------------------------------------------------------------------  Minimal, Maximal---------------------------------------------------------------------}---- We perform call-pattern specialization manually on lookupMin--- and lookupMax. Otherwise, GHC doesn't seem to do it, which is--- unfortunate if, for example, someone uses findMin or findMax.--lookupMinSure :: a -> Set a -> a-lookupMinSure x Tip = x-lookupMinSure _ (Bin _ x l _) = lookupMinSure x l---- | /O(log n)/. The minimal element of a set.------ @since 0.5.9--lookupMin :: Set a -> Maybe a-lookupMin Tip = Nothing-lookupMin (Bin _ x l _) = Just $! lookupMinSure x l---- | /O(log n)/. The minimal element of a set.-findMin :: Set a -> a-findMin t-  | Just r <- lookupMin t = r-  | otherwise = error "Set.findMin: empty set has no minimal element"--lookupMaxSure :: a -> Set a -> a-lookupMaxSure x Tip = x-lookupMaxSure _ (Bin _ x _ r) = lookupMaxSure x r---- | /O(log n)/. The maximal element of a set.------ @since 0.5.9--lookupMax :: Set a -> Maybe a-lookupMax Tip = Nothing-lookupMax (Bin _ x _ r) = Just $! lookupMaxSure x r---- | /O(log n)/. The maximal element of a set.-findMax :: Set a -> a-findMax t-  | Just r <- lookupMax t = r-  | otherwise = error "Set.findMax: empty set has no maximal element"---- | /O(log n)/. Delete the minimal element. Returns an empty set if the set is empty.-deleteMin :: Set a -> Set a-deleteMin (Bin _ _ Tip r) = r-deleteMin (Bin _ x l r)   = balanceR x (deleteMin l) r-deleteMin Tip             = Tip---- | /O(log n)/. Delete the maximal element. Returns an empty set if the set is empty.-deleteMax :: Set a -> Set a-deleteMax (Bin _ _ l Tip) = l-deleteMax (Bin _ x l r)   = balanceL x l (deleteMax r)-deleteMax Tip             = Tip--{---------------------------------------------------------------------  Union.---------------------------------------------------------------------}--- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).-unions :: (Foldable f, Ord a) => f (Set a) -> Set a-unions = Foldable.foldl' union empty-#if __GLASGOW_HASKELL__-{-# INLINABLE unions #-}-#endif---- | /O(m*log(n\/m + 1)), m <= n/. The union of two sets, preferring the first set when--- equal elements are encountered.-union :: Ord a => Set a -> Set a -> Set a-union t1 Tip  = t1-union t1 (Bin 1 x _ _) = insertR x t1-union (Bin 1 x _ _) t2 = insert x t2-union Tip t2  = t2-union t1@(Bin _ x l1 r1) t2 = case splitS x t2 of-  (l2 :*: r2)-    | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1-    | otherwise -> link x l1l2 r1r2-    where !l1l2 = union l1 l2-          !r1r2 = union r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE union #-}-#endif--{---------------------------------------------------------------------  Difference---------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. Difference of two sets.-difference :: Ord a => Set a -> Set a -> Set a-difference Tip _   = Tip-difference t1 Tip  = t1-difference t1 (Bin _ x l2 r2) = case split x t1 of-   (l1, r1)-     | size l1l2 + size r1r2 == size t1 -> t1-     | otherwise -> merge l1l2 r1r2-     where !l1l2 = difference l1 l2-           !r1r2 = difference r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE difference #-}-#endif--{---------------------------------------------------------------------  Intersection---------------------------------------------------------------------}--- | /O(m*log(n\/m + 1)), m <= n/. The intersection of two sets.--- Elements of the result come from the first set, so for example------ > import qualified Data.Set as S--- > data AB = A | B deriving Show--- > instance Ord AB where compare _ _ = EQ--- > instance Eq AB where _ == _ = True--- > main = print (S.singleton A `S.intersection` S.singleton B,--- >               S.singleton B `S.intersection` S.singleton A)------ prints @(fromList [A],fromList [B])@.-intersection :: Ord a => Set a -> Set a -> Set a-intersection Tip _ = Tip-intersection _ Tip = Tip-intersection t1@(Bin _ x l1 r1) t2-  | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1-        then t1-        else link x l1l2 r1r2-  | otherwise = merge l1l2 r1r2-  where-    !(l2, b, r2) = splitMember x t2-    !l1l2 = intersection l1 l2-    !r1r2 = intersection r1 r2-#if __GLASGOW_HASKELL__-{-# INLINABLE intersection #-}-#endif--{---------------------------------------------------------------------  Filter and partition---------------------------------------------------------------------}--- | /O(n)/. Filter all elements that satisfy the predicate.-filter :: (a -> Bool) -> Set a -> Set a-filter _ Tip = Tip-filter p t@(Bin _ x l r)-    | p x = if l `ptrEq` l' && r `ptrEq` r'-            then t-            else link x l' r'-    | otherwise = merge l' r'-    where-      !l' = filter p l-      !r' = filter p r---- | /O(n)/. Partition the set into two sets, one with all elements that satisfy--- the predicate and one with all elements that don't satisfy the predicate.--- See also 'split'.-partition :: (a -> Bool) -> Set a -> (Set a,Set a)-partition p0 t0 = toPair $ go p0 t0-  where-    go _ Tip = (Tip :*: Tip)-    go p t@(Bin _ x l r) = case (go p l, go p r) of-      ((l1 :*: l2), (r1 :*: r2))-        | p x       -> (if l1 `ptrEq` l && r1 `ptrEq` r-                        then t-                        else link x l1 r1) :*: merge l2 r2-        | otherwise -> merge l1 r1 :*:-                       (if l2 `ptrEq` l && r2 `ptrEq` r-                        then t-                        else link x l2 r2)--{-----------------------------------------------------------------------  Map-----------------------------------------------------------------------}---- | /O(n*log n)/.--- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.------ It's worth noting that the size of the result may be smaller if,--- for some @(x,y)@, @x \/= y && f x == f y@--map :: Ord b => (a->b) -> Set a -> Set b-map f = fromList . List.map f . toList-#if __GLASGOW_HASKELL__-{-# INLINABLE map #-}-#endif---- | /O(n)/. The------ @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.--- /The precondition is not checked./--- Semi-formally, we have:------ > and [x < y ==> f x < f y | x <- ls, y <- ls]--- >                     ==> mapMonotonic f s == map f s--- >     where ls = toList s--mapMonotonic :: (a->b) -> Set a -> Set b-mapMonotonic _ Tip = Tip-mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)--{---------------------------------------------------------------------  Fold---------------------------------------------------------------------}--- | /O(n)/. Fold the elements in the set using the given right-associative--- binary operator. This function is an equivalent of 'foldr' and is present--- for compatibility only.------ /Please note that fold will be deprecated in the future and removed./-fold :: (a -> b -> b) -> b -> Set a -> b-fold = foldr-{-# INLINE fold #-}---- | /O(n)/. Fold the elements in the set using the given right-associative--- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.------ For example,------ > toAscList set = foldr (:) [] set-foldr :: (a -> b -> b) -> b -> Set a -> b-foldr f z = go z-  where-    go z' Tip           = z'-    go z' (Bin _ x l r) = go (f x (go z' r)) l-{-# INLINE foldr #-}---- | /O(n)/. A strict version of 'foldr'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldr' :: (a -> b -> b) -> b -> Set a -> b-foldr' f z = go z-  where-    go !z' Tip           = z'-    go z' (Bin _ x l r) = go (f x (go z' r)) l-{-# INLINE foldr' #-}---- | /O(n)/. Fold the elements in the set using the given left-associative--- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.------ For example,------ > toDescList set = foldl (flip (:)) [] set-foldl :: (a -> b -> a) -> a -> Set b -> a-foldl f z = go z-  where-    go z' Tip           = z'-    go z' (Bin _ x l r) = go (f (go z' l) x) r-{-# INLINE foldl #-}---- | /O(n)/. A strict version of 'foldl'. Each application of the operator is--- evaluated before using the result in the next application. This--- function is strict in the starting value.-foldl' :: (a -> b -> a) -> a -> Set b -> a-foldl' f z = go z-  where-    go !z' Tip           = z'-    go z' (Bin _ x l r) = go (f (go z' l) x) r-{-# INLINE foldl' #-}--{---------------------------------------------------------------------  List variations---------------------------------------------------------------------}--- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order.--- Subject to list fusion.-elems :: Set a -> [a]-elems = toAscList--{---------------------------------------------------------------------  Lists---------------------------------------------------------------------}-#if __GLASGOW_HASKELL__ >= 708--- | @since 0.5.6.2-instance (Ord a) => GHCExts.IsList (Set a) where-  type Item (Set a) = a-  fromList = fromList-  toList   = toList-#endif---- | /O(n)/. Convert the set to a list of elements. Subject to list fusion.-toList :: Set a -> [a]-toList = toAscList---- | /O(n)/. Convert the set to an ascending list of elements. Subject to list fusion.-toAscList :: Set a -> [a]-toAscList = foldr (:) []---- | /O(n)/. Convert the set to a descending list of elements. Subject to list--- fusion.-toDescList :: Set a -> [a]-toDescList = foldl (flip (:)) []---- List fusion for the list generating functions.-#if __GLASGOW_HASKELL__--- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.--- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.-foldrFB :: (a -> b -> b) -> b -> Set a -> b-foldrFB = foldr-{-# INLINE[0] foldrFB #-}-foldlFB :: (a -> b -> a) -> a -> Set b -> a-foldlFB = foldl-{-# INLINE[0] foldlFB #-}---- Inline elems and toList, so that we need to fuse only toAscList.-{-# INLINE elems #-}-{-# INLINE toList #-}---- The fusion is enabled up to phase 2 included. If it does not succeed,--- convert in phase 1 the expanded to{Asc,Desc}List calls back to--- to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were used in--- a list fusion, otherwise it would go away in phase 1), and let compiler do--- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it--- before phase 0, otherwise the fusion rules would not fire at all.-{-# NOINLINE[0] toAscList #-}-{-# NOINLINE[0] toDescList #-}-{-# RULES "Set.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-}-{-# RULES "Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-}-{-# RULES "Set.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}-{-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}-#endif---- | /O(n*log n)/. Create a set from a list of elements.------ If the elements are ordered, a linear-time implementation is used,--- with the performance equal to 'fromDistinctAscList'.---- For some reason, when 'singleton' is used in fromList or in--- create, it is not inlined, so we inline it manually.-fromList :: Ord a => [a] -> Set a-fromList [] = Tip-fromList [x] = Bin 1 x Tip Tip-fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0-                    | otherwise = go (1::Int) (Bin 1 x0 Tip Tip) xs0-  where-    not_ordered _ [] = False-    not_ordered x (y : _) = x >= y-    {-# INLINE not_ordered #-}--    fromList' t0 xs = Foldable.foldl' ins t0 xs-      where ins t x = insert x t--    go !_ t [] = t-    go _ t [x] = insertMax x t-    go s l xs@(x : xss) | not_ordered x xss = fromList' l xs-                        | otherwise = case create s xss of-                            (r, ys, []) -> go (s `shiftL` 1) (link x l r) ys-                            (r, _,  ys) -> fromList' (link x l r) ys--    -- The create is returning a triple (tree, xs, ys). Both xs and ys-    -- represent not yet processed elements and only one of them can be nonempty.-    -- If ys is nonempty, the keys in ys are not ordered with respect to tree-    -- and must be inserted using fromList'. Otherwise the keys have been-    -- ordered so far.-    create !_ [] = (Tip, [], [])-    create s xs@(x : xss)-      | s == 1 = if not_ordered x xss then (Bin 1 x Tip Tip, [], xss)-                                      else (Bin 1 x Tip Tip, xss, [])-      | otherwise = case create (s `shiftR` 1) xs of-                      res@(_, [], _) -> res-                      (l, [y], zs) -> (insertMax y l, [], zs)-                      (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys)-                                         | otherwise -> case create (s `shiftR` 1) yss of-                                                   (r, zs, ws) -> (link y l r, zs, ws)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromList #-}-#endif--{---------------------------------------------------------------------  Building trees from ascending/descending lists can be done in linear time.--  Note that if [xs] is ascending that:-    fromAscList xs == fromList xs---------------------------------------------------------------------}--- | /O(n)/. Build a set from an ascending list in linear time.--- /The precondition (input list is ascending) is not checked./-fromAscList :: Eq a => [a] -> Set a-fromAscList xs = fromDistinctAscList (combineEq xs)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromAscList #-}-#endif---- | /O(n)/. Build a set from a descending list in linear time.--- /The precondition (input list is descending) is not checked./------ @since 0.5.8-fromDescList :: Eq a => [a] -> Set a-fromDescList xs = fromDistinctDescList (combineEq xs)-#if __GLASGOW_HASKELL__-{-# INLINABLE fromDescList #-}-#endif---- [combineEq xs] combines equal elements with [const] in an ordered list [xs]------ TODO: combineEq allocates an intermediate list. It *should* be better to--- make fromAscListBy and fromDescListBy the fundamental operations, and to--- implement the rest using those.-combineEq :: Eq a => [a] -> [a]-combineEq [] = []-combineEq (x : xs) = combineEq' x xs-  where-    combineEq' z [] = [z]-    combineEq' z (y:ys)-      | z == y = combineEq' z ys-      | otherwise = z : combineEq' y ys---- | /O(n)/. Build a set from an ascending list of distinct elements in linear time.--- /The precondition (input list is strictly ascending) is not checked./---- For some reason, when 'singleton' is used in fromDistinctAscList or in--- create, it is not inlined, so we inline it manually.-fromDistinctAscList :: [a] -> Set a-fromDistinctAscList [] = Tip-fromDistinctAscList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0-  where-    go !_ t [] = t-    go s l (x : xs) = case create s xs of-                        (r :*: ys) -> let !t' = link x l r-                                      in go (s `shiftL` 1) t' ys--    create !_ [] = (Tip :*: [])-    create s xs@(x : xs')-      | s == 1 = (Bin 1 x Tip Tip :*: xs')-      | otherwise = case create (s `shiftR` 1) xs of-                      res@(_ :*: []) -> res-                      (l :*: (y:ys)) -> case create (s `shiftR` 1) ys of-                        (r :*: zs) -> (link y l r :*: zs)---- | /O(n)/. Build a set from a descending list of distinct elements in linear time.--- /The precondition (input list is strictly descending) is not checked./---- For some reason, when 'singleton' is used in fromDistinctDescList or in--- create, it is not inlined, so we inline it manually.------ @since 0.5.8-fromDistinctDescList :: [a] -> Set a-fromDistinctDescList [] = Tip-fromDistinctDescList (x0 : xs0) = go (1::Int) (Bin 1 x0 Tip Tip) xs0-  where-    go !_ t [] = t-    go s r (x : xs) = case create s xs of-                        (l :*: ys) -> let !t' = link x l r-                                      in go (s `shiftL` 1) t' ys--    create !_ [] = (Tip :*: [])-    create s xs@(x : xs')-      | s == 1 = (Bin 1 x Tip Tip :*: xs')-      | otherwise = case create (s `shiftR` 1) xs of-                      res@(_ :*: []) -> res-                      (r :*: (y:ys)) -> case create (s `shiftR` 1) ys of-                        (l :*: zs) -> (link y l r :*: zs)--{---------------------------------------------------------------------  Eq converts the set to a list. In a lazy setting, this-  actually seems one of the faster methods to compare two trees-  and it is certainly the simplest :-)---------------------------------------------------------------------}-instance Eq a => Eq (Set a) where-  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)--{---------------------------------------------------------------------  Ord---------------------------------------------------------------------}--instance Ord a => Ord (Set a) where-    compare s1 s2 = compare (toAscList s1) (toAscList s2)--{---------------------------------------------------------------------  Show---------------------------------------------------------------------}-instance Show a => Show (Set a) where-  showsPrec p xs = showParen (p > 10) $-    showString "fromList " . shows (toList xs)--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Eq1 Set where-    liftEq eq m n =-        size m == size n && liftEq eq (toList m) (toList n)---- | @since 0.5.9-instance Ord1 Set where-    liftCompare cmp m n =-        liftCompare cmp (toList m) (toList n)---- | @since 0.5.9-instance Show1 Set where-    liftShowsPrec sp sl d m =-        showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)-#endif--{---------------------------------------------------------------------  Read---------------------------------------------------------------------}-instance (Read a, Ord a) => Read (Set a) where-#ifdef __GLASGOW_HASKELL__-  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/Data---------------------------------------------------------------------}--INSTANCE_TYPEABLE1(Set)--{---------------------------------------------------------------------  NFData---------------------------------------------------------------------}--instance NFData a => NFData (Set a) where-    rnf Tip           = ()-    rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r--{---------------------------------------------------------------------  Split---------------------------------------------------------------------}--- | /O(log n)/. The expression (@'split' x set@) is a pair @(set1,set2)@--- where @set1@ comprises the elements of @set@ less than @x@ and @set2@--- comprises the elements of @set@ greater than @x@.-split :: Ord a => a -> Set a -> (Set a,Set a)-split x t = toPair $ splitS x t-{-# INLINABLE split #-}--splitS :: Ord a => a -> Set a -> StrictPair (Set a) (Set a)-splitS _ Tip = (Tip :*: Tip)-splitS x (Bin _ y l r)-      = case compare x y of-          LT -> let (lt :*: gt) = splitS x l in (lt :*: link y gt r)-          GT -> let (lt :*: gt) = splitS x r in (link y l lt :*: gt)-          EQ -> (l :*: r)-{-# INLINABLE splitS #-}---- | /O(log n)/. Performs a 'split' but also returns whether the pivot--- element was found in the original set.-splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)-splitMember _ Tip = (Tip, False, Tip)-splitMember x (Bin _ y l r)-   = case compare x y of-       LT -> let (lt, found, gt) = splitMember x l-                 !gt' = link y gt r-             in (lt, found, gt')-       GT -> let (lt, found, gt) = splitMember x r-                 !lt' = link y l lt-             in (lt', found, gt)-       EQ -> (l, True, r)-#if __GLASGOW_HASKELL__-{-# INLINABLE splitMember #-}-#endif--{---------------------------------------------------------------------  Indexing---------------------------------------------------------------------}---- | /O(log n)/. Return the /index/ of an element, which is its zero-based--- index in the sorted sequence of elements. The index is a number from /0/ up--- to, but not including, the 'size' of the set. Calls 'error' when the element--- is not a 'member' of the set.------ > findIndex 2 (fromList [5,3])    Error: element is not in the set--- > findIndex 3 (fromList [5,3]) == 0--- > findIndex 5 (fromList [5,3]) == 1--- > findIndex 6 (fromList [5,3])    Error: element is not in the set------ @since 0.5.4---- See Note: Type of local 'go' function-findIndex :: Ord a => a -> Set a -> Int-findIndex = go 0-  where-    go :: Ord a => Int -> a -> Set a -> Int-    go !_ !_ Tip  = error "Set.findIndex: element is not in the set"-    go idx x (Bin _ kx l r) = case compare x kx of-      LT -> go idx x l-      GT -> go (idx + size l + 1) x r-      EQ -> idx + size l-#if __GLASGOW_HASKELL__-{-# INLINABLE findIndex #-}-#endif---- | /O(log n)/. Lookup the /index/ of an element, which is its zero-based index in--- the sorted sequence of elements. The index is a number from /0/ up to, but not--- including, the 'size' of the set.------ > isJust   (lookupIndex 2 (fromList [5,3])) == False--- > fromJust (lookupIndex 3 (fromList [5,3])) == 0--- > fromJust (lookupIndex 5 (fromList [5,3])) == 1--- > isJust   (lookupIndex 6 (fromList [5,3])) == False------ @since 0.5.4---- See Note: Type of local 'go' function-lookupIndex :: Ord a => a -> Set a -> Maybe Int-lookupIndex = go 0-  where-    go :: Ord a => Int -> a -> Set a -> Maybe Int-    go !_ !_ Tip  = Nothing-    go idx x (Bin _ kx l r) = case compare x kx of-      LT -> go idx x l-      GT -> go (idx + size l + 1) x r-      EQ -> Just $! idx + size l-#if __GLASGOW_HASKELL__-{-# INLINABLE lookupIndex #-}-#endif---- | /O(log n)/. Retrieve an element by its /index/, i.e. by its zero-based--- index in the sorted sequence of elements. If the /index/ is out of range (less--- than zero, greater or equal to 'size' of the set), 'error' is called.------ > elemAt 0 (fromList [5,3]) == 3--- > elemAt 1 (fromList [5,3]) == 5--- > elemAt 2 (fromList [5,3])    Error: index out of range------ @since 0.5.4--elemAt :: Int -> Set a -> a-elemAt !_ Tip = error "Set.elemAt: index out of range"-elemAt i (Bin _ x l r)-  = case compare i sizeL of-      LT -> elemAt i l-      GT -> elemAt (i-sizeL-1) r-      EQ -> x-  where-    sizeL = size l---- | /O(log n)/. Delete the element at /index/, i.e. by its zero-based index in--- the sorted sequence of elements. If the /index/ is out of range (less than zero,--- greater or equal to 'size' of the set), 'error' is called.------ > deleteAt 0    (fromList [5,3]) == singleton 5--- > deleteAt 1    (fromList [5,3]) == singleton 3--- > deleteAt 2    (fromList [5,3])    Error: index out of range--- > deleteAt (-1) (fromList [5,3])    Error: index out of range------ @since 0.5.4--deleteAt :: Int -> Set a -> Set a-deleteAt !i t =-  case t of-    Tip -> error "Set.deleteAt: index out of range"-    Bin _ x l r -> case compare i sizeL of-      LT -> balanceR x (deleteAt i l) r-      GT -> balanceL x l (deleteAt (i-sizeL-1) r)-      EQ -> glue l r-      where-        sizeL = size l---- | Take a given number of elements in order, beginning--- with the smallest ones.------ @--- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'--- @------ @since 0.5.8-take :: Int -> Set a -> Set a-take i m | i >= size m = m-take i0 m0 = go i0 m0-  where-    go i !_ | i <= 0 = Tip-    go !_ Tip = Tip-    go i (Bin _ x l r) =-      case compare i sizeL of-        LT -> go i l-        GT -> link x l (go (i - sizeL - 1) r)-        EQ -> l-      where sizeL = size l---- | Drop a given number of elements in order, beginning--- with the smallest ones.------ @--- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'--- @------ @since 0.5.8-drop :: Int -> Set a -> Set a-drop i m | i >= size m = Tip-drop i0 m0 = go i0 m0-  where-    go i m | i <= 0 = m-    go !_ Tip = Tip-    go i (Bin _ x l r) =-      case compare i sizeL of-        LT -> link x (go i l) r-        GT -> go (i - sizeL - 1) r-        EQ -> insertMin x r-      where sizeL = size l---- | /O(log n)/. Split a set at a particular index.------ @--- splitAt !n !xs = ('take' n xs, 'drop' n xs)--- @-splitAt :: Int -> Set a -> (Set a, Set a)-splitAt i0 m0-  | i0 >= size m0 = (m0, Tip)-  | otherwise = toPair $ go i0 m0-  where-    go i m | i <= 0 = Tip :*: m-    go !_ Tip = Tip :*: Tip-    go i (Bin _ x l r)-      = case compare i sizeL of-          LT -> case go i l of-                  ll :*: lr -> ll :*: link x lr r-          GT -> case go (i - sizeL - 1) r of-                  rl :*: rr -> link x l rl :*: rr-          EQ -> l :*: insertMin x r-      where sizeL = size l---- | /O(log n)/. Take while a predicate on the elements holds.--- The user is responsible for ensuring that for all elements @j@ and @k@ in the set,--- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.------ @--- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'--- takeWhileAntitone p = 'filter' p--- @------ @since 0.5.8--takeWhileAntitone :: (a -> Bool) -> Set a -> Set a-takeWhileAntitone _ Tip = Tip-takeWhileAntitone p (Bin _ x l r)-  | p x = link x l (takeWhileAntitone p r)-  | otherwise = takeWhileAntitone p l---- | /O(log n)/. Drop while a predicate on the elements holds.--- The user is responsible for ensuring that for all elements @j@ and @k@ in the set,--- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.------ @--- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'--- dropWhileAntitone p = 'filter' (not . p)--- @------ @since 0.5.8--dropWhileAntitone :: (a -> Bool) -> Set a -> Set a-dropWhileAntitone _ Tip = Tip-dropWhileAntitone p (Bin _ x l r)-  | p x = dropWhileAntitone p r-  | otherwise = link x (dropWhileAntitone p l) r---- | /O(log n)/. Divide a set at the point where a predicate on the elements stops holding.--- The user is responsible for ensuring that for all elements @j@ and @k@ in the set,--- @j \< k ==\> p j \>= p k@.------ @--- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)--- spanAntitone p xs = partition p xs--- @------ Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set--- at some /unspecified/ point where the predicate switches from holding to not--- holding (where the predicate is seen to hold before the first element and to fail--- after the last element).------ @since 0.5.8--spanAntitone :: (a -> Bool) -> Set a -> (Set a, Set a)-spanAntitone p0 m = toPair (go p0 m)-  where-    go _ Tip = Tip :*: Tip-    go p (Bin _ x l r)-      | p x = let u :*: v = go p r in link x l u :*: v-      | otherwise = let u :*: v = go p l in u :*: link x v r---{---------------------------------------------------------------------  Utility functions that maintain the balance properties of the tree.-  All constructors assume that all values in [l] < [x] and all values-  in [r] > [x], and that [l] and [r] are valid trees.--  In order of sophistication:-    [Bin sz x l r]    The type constructor.-    [bin x l r]       Maintains the correct size, assumes that both [l]-                      and [r] are balanced with respect to each other.-    [balance x l r]   Restores the balance and size.-                      Assumes that the original tree was balanced and-                      that [l] or [r] has changed by at most one element.-    [link x l r]      Restores balance and size.--  Furthermore, we can construct a new tree from two trees. Both operations-  assume that all values in [l] < all values in [r] and that [l] and [r]-  are valid:-    [glue l r]        Glues [l] and [r] together. Assumes that [l] and-                      [r] are already balanced with respect to each other.-    [merge l r]       Merges two trees and restores balance.---------------------------------------------------------------------}--{---------------------------------------------------------------------  Link---------------------------------------------------------------------}-link :: a -> Set a -> Set a -> Set a-link x Tip r  = insertMin x r-link x l Tip  = insertMax x l-link x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)-  | delta*sizeL < sizeR  = balanceL z (link x l lz) rz-  | delta*sizeR < sizeL  = balanceR y ly (link x ry r)-  | otherwise            = bin x l r----- insertMin and insertMax don't perform potentially expensive comparisons.-insertMax,insertMin :: a -> Set a -> Set a-insertMax x t-  = case t of-      Tip -> singleton x-      Bin _ y l r-          -> balanceR y l (insertMax x r)--insertMin x t-  = case t of-      Tip -> singleton x-      Bin _ y l r-          -> balanceL y (insertMin x l) r--{---------------------------------------------------------------------  [merge l r]: merges two trees.---------------------------------------------------------------------}-merge :: Set a -> Set a -> Set a-merge Tip r   = r-merge l Tip   = l-merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)-  | delta*sizeL < sizeR = balanceL y (merge l ly) ry-  | delta*sizeR < sizeL = balanceR x lx (merge rx r)-  | otherwise           = glue l r--{---------------------------------------------------------------------  [glue l r]: glues two trees together.-  Assumes that [l] and [r] are already balanced with respect to each other.---------------------------------------------------------------------}-glue :: Set a -> Set a -> Set a-glue Tip r = r-glue l Tip = l-glue l@(Bin sl xl ll lr) r@(Bin sr xr rl rr)-  | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in balanceR m l' r-  | otherwise = let !(m :*: r') = minViewSure xr rl rr in balanceL m l r'---- | /O(log n)/. Delete and find the minimal element.------ > deleteFindMin set = (findMin set, deleteMin set)--deleteFindMin :: Set a -> (a,Set a)-deleteFindMin t-  | Just r <- minView t = r-  | otherwise = (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)---- | /O(log n)/. Delete and find the maximal element.------ > deleteFindMax set = (findMax set, deleteMax set)-deleteFindMax :: Set a -> (a,Set a)-deleteFindMax t-  | Just r <- maxView t = r-  | otherwise = (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)--minViewSure :: a -> Set a -> Set a -> StrictPair a (Set a)-minViewSure = go-  where-    go x Tip r = x :*: r-    go x (Bin _ xl ll lr) r =-      case go xl ll lr of-        xm :*: l' -> xm :*: balanceR x l' r---- | /O(log n)/. Retrieves the minimal key of the set, and the set--- stripped of that element, or 'Nothing' if passed an empty set.-minView :: Set a -> Maybe (a, Set a)-minView Tip = Nothing-minView (Bin _ x l r) = Just $! toPair $ minViewSure x l r--maxViewSure :: a -> Set a -> Set a -> StrictPair a (Set a)-maxViewSure = go-  where-    go x l Tip = x :*: l-    go x l (Bin _ xr rl rr) =-      case go xr rl rr of-        xm :*: r' -> xm :*: balanceL x l r'---- | /O(log n)/. Retrieves the maximal key of the set, and the set--- stripped of that element, or 'Nothing' if passed an empty set.-maxView :: Set a -> Maybe (a, Set a)-maxView Tip = Nothing-maxView (Bin _ x l r) = Just $! toPair $ maxViewSure x l r--{---------------------------------------------------------------------  [balance x l r] balances two trees with value x.-  The sizes of the trees should balance after decreasing the-  size of one of them. (a rotation).--  [delta] is the maximal relative difference between the sizes of-          two trees, it corresponds with the [w] in Adams' paper.-  [ratio] is the ratio between an outer and inner sibling of the-          heavier subtree in an unbalanced setting. It determines-          whether a double or single rotation should be performed-          to restore balance. It is correspondes with the inverse-          of $\alpha$ in Adam's article.--  Note that according to the Adam's paper:-  - [delta] should be larger than 4.646 with a [ratio] of 2.-  - [delta] should be larger than 3.745 with a [ratio] of 1.534.--  But the Adam's paper is errorneous:-  - it can be proved that for delta=2 and delta>=5 there does-    not exist any ratio that would work-  - delta=4.5 and ratio=2 does not work--  That leaves two reasonable variants, delta=3 and delta=4,-  both with ratio=2.--  - A lower [delta] leads to a more 'perfectly' balanced tree.-  - A higher [delta] performs less rebalancing.--  In the benchmarks, delta=3 is faster on insert operations,-  and delta=4 has slightly better deletes. As the insert speedup-  is larger, we currently use delta=3.----------------------------------------------------------------------}-delta,ratio :: Int-delta = 3-ratio = 2---- The balance function is equivalent to the following:------   balance :: a -> Set a -> Set a -> Set a---   balance x l r---     | sizeL + sizeR <= 1   = Bin sizeX x l r---     | sizeR > delta*sizeL  = rotateL x l r---     | sizeL > delta*sizeR  = rotateR x l r---     | otherwise            = Bin sizeX x l r---     where---       sizeL = size l---       sizeR = size r---       sizeX = sizeL + sizeR + 1------   rotateL :: a -> Set a -> Set a -> Set a---   rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r---                                 | otherwise               = doubleL x l r---   rotateR :: a -> Set a -> Set a -> Set a---   rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r---                                 | otherwise               = doubleR x l r------   singleL, singleR :: a -> Set a -> Set a -> Set a---   singleL x1 t1 (Bin _ x2 t2 t3)  = bin x2 (bin x1 t1 t2) t3---   singleR x1 (Bin _ x2 t1 t2) t3  = bin x2 t1 (bin x1 t2 t3)------   doubleL, doubleR :: a -> Set a -> Set a -> Set a---   doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)---   doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)------ It is only written in such a way that every node is pattern-matched only once.------ Only balanceL and balanceR are needed at the moment, so balance is not here anymore.--- In case it is needed, it can be found in Data.Map.---- Functions balanceL and balanceR are specialised versions of balance.--- balanceL only checks whether the left subtree is too big,--- balanceR only checks whether the right subtree is too big.---- balanceL is called when left subtree might have been inserted to or when--- right subtree might have been deleted from.-balanceL :: a -> Set a -> Set a -> Set a-balanceL x l r = case r of-  Tip -> case l of-           Tip -> Bin 1 x Tip Tip-           (Bin _ _ Tip Tip) -> Bin 2 x l Tip-           (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)-           (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)-           (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))-             | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)-             | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)--  (Bin rs _ _ _) -> case l of-           Tip -> Bin (1+rs) x Tip r--           (Bin ls lx ll lr)-              | ls > delta*rs  -> case (ll, lr) of-                   (Bin lls _ _ _, Bin lrs lrx lrl lrr)-                     | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)-                     | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)-                   (_, _) -> error "Failure in Data.Map.balanceL"-              | otherwise -> Bin (1+ls+rs) x l r-{-# NOINLINE balanceL #-}---- balanceR is called when right subtree might have been inserted to or when--- left subtree might have been deleted from.-balanceR :: a -> Set a -> Set a -> Set a-balanceR x l r = case l of-  Tip -> case r of-           Tip -> Bin 1 x Tip Tip-           (Bin _ _ Tip Tip) -> Bin 2 x Tip r-           (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr-           (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)-           (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))-             | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr-             | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)--  (Bin ls _ _ _) -> case r of-           Tip -> Bin (1+ls) x l Tip--           (Bin rs rx rl rr)-              | rs > delta*ls  -> case (rl, rr) of-                   (Bin rls rlx rll rlr, Bin rrs _ _ _)-                     | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr-                     | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)-                   (_, _) -> error "Failure in Data.Map.balanceR"-              | otherwise -> Bin (1+ls+rs) x l r-{-# NOINLINE balanceR #-}--{---------------------------------------------------------------------  The bin constructor maintains the size of the tree---------------------------------------------------------------------}-bin :: a -> Set a -> Set a -> Set a-bin x l r-  = Bin (size l + size r + 1) x l r-{-# INLINE bin #-}---{---------------------------------------------------------------------  Utilities---------------------------------------------------------------------}---- | /O(1)/.  Decompose a set into pieces based on the structure of the underlying--- tree.  This function is useful for consuming a set in parallel.------ No guarantee is made as to the sizes of the pieces; an internal, but--- deterministic process determines this.  However, it is guaranteed that the pieces--- returned will be in ascending order (all elements in the first subset less than all--- elements in the second, and so on).------ Examples:------ > splitRoot (fromList [1..6]) ==--- >   [fromList [1,2,3],fromList [4],fromList [5,6]]------ > splitRoot empty == []------  Note that the current implementation does not return more than three subsets,---  but you should not depend on this behaviour because it can change in the---  future without notice.------ @since 0.5.4-splitRoot :: Set a -> [Set a]-splitRoot orig =-  case orig of-    Tip           -> []-    Bin _ v l r -> [l, singleton v, r]-{-# INLINE splitRoot #-}----- | Calculate the power set of a set: the set of all its subsets.------ @--- t ``member`` powerSet s == t ``isSubsetOf`` s--- @------ Example:------ @--- powerSet (fromList [1,2,3]) =---   fromList [[], [1], [2], [3], [1,2], [1,3], [2,3], [1,2,3]]--- @------ @since 0.5.11-powerSet :: Set a -> Set (Set a)-powerSet xs0 = insertMin empty (foldr' step Tip xs0) where-  step x pxs = insertMin (singleton x) (insertMin x `mapMonotonic` pxs) `glue` pxs---- | Calculate the Cartesian product of two sets.------ @--- cartesianProduct xs ys = fromList $ liftA2 (,) (toList xs) (toList ys)--- @------ Example:------ @--- cartesianProduct (fromList [1,2]) (fromList ['a','b']) =---   fromList [(1,'a'), (1,'b'), (2,'a'), (2,'b')]--- @------ @since 0.5.11-cartesianProduct :: Set a -> Set b -> Set (a, b)-cartesianProduct as bs =-  getMergeSet $ foldMap (\a -> MergeSet $ mapMonotonic ((,) a) bs) as---- A version of Set with peculiar Semigroup and Monoid instances.--- The result of xs <> ys will only be a valid set if the greatest--- element of xs is strictly less than the least element of ys.--- This is used to define cartesianProduct.-newtype MergeSet a = MergeSet { getMergeSet :: Set a }--#if (MIN_VERSION_base(4,9,0))-instance Semigroup (MergeSet a) where-  MergeSet xs <> MergeSet ys = MergeSet (merge xs ys)-#endif--instance Monoid (MergeSet a) where-  mempty = MergeSet empty--#if (MIN_VERSION_base(4,9,0))-  mappend = (<>)-#else-  mappend (MergeSet xs) (MergeSet ys) = MergeSet (merge xs ys)-#endif---- | Calculate the disjoint union of two sets.------ @ disjointUnion xs ys = map Left xs ``union`` map Right ys @------ Example:------ @--- disjointUnion (fromList [1,2]) (fromList ["hi", "bye"]) =---   fromList [Left 1, Left 2, Right "hi", Right "bye"]--- @------ @since 0.5.11-disjointUnion :: Set a -> Set b -> Set (Either a b)-disjointUnion as bs = merge (mapMonotonic Left as) (mapMonotonic Right bs)--{---------------------------------------------------------------------  Debugging---------------------------------------------------------------------}--- | /O(n)/. Show the tree that implements the set. The tree is shown--- in a compressed, hanging format.-showTree :: Show a => Set a -> String-showTree s-  = showTreeWith True False s---{- | /O(n)/. The expression (@showTreeWith hang wide map@) shows- the tree that implements the set. If @hang@ is- @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If- @wide@ is 'True', an extra wide version is shown.--> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]-> 4-> +--2-> |  +--1-> |  +--3-> +--5->-> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]-> 4-> |-> +--2-> |  |-> |  +--1-> |  |-> |  +--3-> |-> +--5->-> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]-> +--5-> |-> 4-> |-> |  +--3-> |  |-> +--2->    |->    +--1---}-showTreeWith :: Show a => Bool -> Bool -> Set a -> String-showTreeWith hang wide t-  | hang      = (showsTreeHang wide [] t) ""-  | otherwise = (showsTree wide [] [] t) ""--showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS-showsTree wide lbars rbars t-  = case t of-      Tip -> showsBars lbars . showString "|\n"-      Bin _ x Tip Tip-          -> showsBars lbars . shows x . showString "\n"-      Bin _ x l r-          -> showsTree wide (withBar rbars) (withEmpty rbars) r .-             showWide wide rbars .-             showsBars lbars . shows x . showString "\n" .-             showWide wide lbars .-             showsTree wide (withEmpty lbars) (withBar lbars) l--showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS-showsTreeHang wide bars t-  = case t of-      Tip -> showsBars bars . showString "|\n"-      Bin _ x Tip Tip-          -> showsBars bars . shows x . showString "\n"-      Bin _ x l r-          -> showsBars bars . shows x . showString "\n" .-             showWide wide bars .-             showsTreeHang wide (withBar bars) l .-             showWide wide bars .-             showsTreeHang wide (withEmpty bars) r--showWide :: Bool -> [String] -> String -> String-showWide wide bars-  | wide      = showString (concat (reverse bars)) . showString "|\n"-  | otherwise = id--showsBars :: [String] -> ShowS-showsBars bars-  = case bars of-      [] -> id-      _  -> showString (concat (reverse (tail bars))) . showString node--node :: String-node           = "+--"--withBar, withEmpty :: [String] -> [String]-withBar bars   = "|  ":bars-withEmpty bars = "   ":bars--{---------------------------------------------------------------------  Assertions---------------------------------------------------------------------}--- | /O(n)/. Test if the internal set structure is valid.-valid :: Ord a => Set a -> Bool-valid t-  = balanced t && ordered t && validsize t--ordered :: Ord a => Set a -> Bool-ordered t-  = bounded (const True) (const True) t-  where-    bounded lo hi t'-      = case t' of-          Tip         -> True-          Bin _ x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r--balanced :: Set a -> Bool-balanced t-  = case t of-      Tip         -> True-      Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&-                     balanced l && balanced r--validsize :: Set a -> Bool-validsize t-  = (realsize t == Just (size t))-  where-    realsize t'-      = case t' of-          Tip          -> Just 0-          Bin sz _ l r -> case (realsize l,realsize r) of-                            (Just n,Just m)  | n+m+1 == sz  -> Just sz-                            _                -> Nothing
− Data/Tree.hs 
@@ -1,417 +0,0 @@-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE Trustworthy #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Data.Tree--- Copyright   :  (c) The University of Glasgow 2002--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Portability :  portable------ = Multi-way Trees and Forests------ The @'Tree' a@ type represents a lazy, possibly infinite, multi-way tree--- (also known as a /rose tree/).------ The @'Forest' a@ type represents a forest of @'Tree' a@s.-----------------------------------------------------------------------------------module Data.Tree(--    -- * Trees and Forests-      Tree(..)-    , Forest--    -- * Construction-    , unfoldTree-    , unfoldForest-    , unfoldTreeM-    , unfoldForestM-    , unfoldTreeM_BF-    , unfoldForestM_BF--    -- * Elimination-    , foldTree-    , flatten-    , levels--    -- * Ascii Drawings-    , drawTree-    , drawForest--    ) where--#if MIN_VERSION_base(4,8,0)-import Data.Foldable (toList)-import Control.Applicative (Applicative(..), liftA2)-#else-import Control.Applicative (Applicative(..), liftA2, (<$>))-import Data.Foldable (Foldable(foldMap), toList)-import Data.Monoid (Monoid(..))-import Data.Traversable (Traversable(traverse))-#endif--import Control.Monad (liftM)-import Control.Monad.Fix (MonadFix (..), fix)-import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList,-            ViewL(..), ViewR(..), viewl, viewr)-import Data.Typeable-import Control.DeepSeq (NFData(rnf))--#ifdef __GLASGOW_HASKELL__-import Data.Data (Data)-import GHC.Generics (Generic, Generic1)-#endif--import Control.Monad.Zip (MonadZip (..))--#if MIN_VERSION_base(4,8,0)-import Data.Coerce-#endif--#if MIN_VERSION_base(4,9,0)-import Data.Functor.Classes-import Data.Semigroup (Semigroup (..))-#endif--#if !MIN_VERSION_base(4,8,0)-import Data.Functor ((<$))-#endif---- | Non-empty, possibly infinite, multi-way trees; also known as /rose trees/.-data Tree a = Node {-        rootLabel :: a,         -- ^ label value-        subForest :: Forest a   -- ^ zero or more child trees-    }-#ifdef __GLASGOW_HASKELL__-  deriving ( Eq-           , Read-           , Show-           , Data-           , Generic  -- ^ @since 0.5.8-           , Generic1 -- ^ @since 0.5.8-           )-#else-  deriving (Eq, Read, Show)-#endif--type Forest a = [Tree a]--#if MIN_VERSION_base(4,9,0)--- | @since 0.5.9-instance Eq1 Tree where-  liftEq eq = leq-    where-      leq (Node a fr) (Node a' fr') = eq a a' && liftEq leq fr fr'---- | @since 0.5.9-instance Ord1 Tree where-  liftCompare cmp = lcomp-    where-      lcomp (Node a fr) (Node a' fr') = cmp a a' <> liftCompare lcomp fr fr'---- | @since 0.5.9-instance Show1 Tree where-  liftShowsPrec shw shwl p (Node a fr) = showParen (p > 10) $-        showString "Node {rootLabel = " . shw 0 a . showString ", " .-          showString "subForest = " . liftShowList shw shwl fr .-          showString "}"---- | @since 0.5.9-instance Read1 Tree where-  liftReadsPrec rd rdl p = readParen (p > 10) $-    \s -> do-      ("Node", s1) <- lex s-      ("{", s2) <- lex s1-      ("rootLabel", s3) <- lex s2-      ("=", s4) <- lex s3-      (a, s5) <- rd 0 s4-      (",", s6) <- lex s5-      ("subForest", s7) <- lex s6-      ("=", s8) <- lex s7-      (fr, s9) <- liftReadList rd rdl s8-      ("}", s10) <- lex s9-      pure (Node a fr, s10)-#endif--INSTANCE_TYPEABLE1(Tree)--instance Functor Tree where-    fmap = fmapTree-    x <$ Node _ ts = Node x (map (x <$) ts)--fmapTree :: (a -> b) -> Tree a -> Tree b-fmapTree f (Node x ts) = Node (f x) (map (fmapTree f) ts)-#if MIN_VERSION_base(4,8,0)--- Safe coercions were introduced in 4.7.0, but I am not sure if they played--- well enough with RULES to do what we want.-{-# NOINLINE [1] fmapTree #-}-{-# RULES-"fmapTree/coerce" fmapTree coerce = coerce- #-}-#endif--instance Applicative Tree where-    pure x = Node x []-    Node f tfs <*> tx@(Node x txs) =-        Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs)-#if MIN_VERSION_base(4,10,0)-    liftA2 f (Node x txs) ty@(Node y tys) =-        Node (f x y) (map (f x <$>) tys ++ map (\tx -> liftA2 f tx ty) txs)-#endif-    Node x txs <* ty@(Node _ tys) =-        Node x (map (x <$) tys ++ map (<* ty) txs)-    Node _ txs *> ty@(Node y tys) =-        Node y (tys ++ map (*> ty) txs)--instance Monad Tree where-    return = pure-    Node x ts >>= f = case f x of-        Node x' ts' -> Node x' (ts' ++ map (>>= f) ts)---- | @since 0.5.11-instance MonadFix Tree where-  mfix = mfixTree--mfixTree :: (a -> Tree a) -> Tree a-mfixTree f-  | Node a children <- fix (f . rootLabel)-  = Node a (zipWith (\i _ -> mfixTree ((!! i) . subForest . f))-                    [0..] children)--instance Traversable Tree where-    traverse f (Node x ts) = liftA2 Node (f x) (traverse (traverse f) ts)--instance Foldable Tree where-    foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts--#if MIN_VERSION_base(4,8,0)-    null _ = False-    {-# INLINE null #-}-    toList = flatten-    {-# INLINE toList #-}-#endif--instance NFData a => NFData (Tree a) where-    rnf (Node x ts) = rnf x `seq` rnf ts--instance MonadZip Tree where-  mzipWith f (Node a as) (Node b bs)-    = Node (f a b) (mzipWith (mzipWith f) as bs)--  munzip (Node (a, b) ts) = (Node a as, Node b bs)-    where (as, bs) = munzip (map munzip ts)---- | 2-dimensional ASCII drawing of a tree.------ ==== __Examples__------ > putStr $ drawTree $ fmap show (Node 1 [Node 2 [], Node 3 []])------ @--- 1--- |--- +- 2--- |--- `- 3--- @----drawTree :: Tree String -> String-drawTree  = unlines . draw---- | 2-dimensional ASCII drawing of a forest.------ ==== __Examples__------ > putStr $ drawForest $ map (fmap show) [(Node 1 [Node 2 [], Node 3 []]), (Node 10 [Node 20 []])]------ @--- 1--- |--- +- 2--- |--- `- 3------ 10--- |--- `- 20--- @----drawForest :: Forest String -> String-drawForest  = unlines . map drawTree--draw :: Tree String -> [String]-draw (Node x ts0) = lines x ++ drawSubTrees ts0-  where-    drawSubTrees [] = []-    drawSubTrees [t] =-        "|" : shift "`- " "   " (draw t)-    drawSubTrees (t:ts) =-        "|" : shift "+- " "|  " (draw t) ++ drawSubTrees ts--    shift first other = zipWith (++) (first : repeat other)---- | Returns the elements of a tree in pre-order.------ @------   a---  / \\    => [a,b,c]--- b   c--- @------ ==== __Examples__------ > flatten (Node 1 [Node 2 [], Node 3 []]) == [1,2,3]-flatten :: Tree a -> [a]-flatten t = squish t []-  where squish (Node x ts) xs = x:Prelude.foldr squish xs ts---- | Returns the list of nodes at each level of the tree.------ @------   a---  / \\    => [[a], [b,c]]--- b   c--- @------ ==== __Examples__------ > levels (Node 1 [Node 2 [], Node 3 []]) == [[1],[2,3]]----levels :: Tree a -> [[a]]-levels t =-    map (map rootLabel) $-        takeWhile (not . null) $-        iterate (concatMap subForest) [t]---- | Fold a tree into a "summary" value in depth-first order.------ For each node in the tree, apply @f@ to the @rootLabel@ and the result--- of applying @f@ to each @subForent@.------ This is also known as the catamorphism on trees.------ ==== __Examples__------ Sum the values in a tree:------ > foldTree (\x xs -> sum (x:xs)) (Node 1 [Node 2 [], Node 3 []]) == 6------ Find the maximum value in the tree:------ > foldTree (\x xs -> maximum (x:xs)) (Node 1 [Node 2 [], Node 3 []]) == 3--------- @since 0.5.8-foldTree :: (a -> [b] -> b) -> Tree a -> b-foldTree f = go where-    go (Node x ts) = f x (map go ts)---- | Build a (possibly infinite) tree from a seed value in breadth-first order.------ @unfoldTree f b@ constructs a tree by starting with the tree--- @Node { rootLabel=b, subForest=[] }@ and repeatedly applying @f@ to each--- 'rootLabel' value in the tree's leaves to generate its 'subForest'.------ For a monadic version see 'unfoldTreeM_BF'.------ ==== __Examples__------ Construct the tree of @Integer@s where each node has two children:--- @left = 2*x@ and @right = 2*x + 1@, where @x@ is the 'rootLabel' of the node.--- Stop when the values exceed 7.------ > let buildNode x = if 2*x + 1 > 7 then (x, []) else (x, [2*x, 2*x+1])--- > putStr $ drawTree $ fmap show $ unfoldTree buildNode 1------ @------ 1--- |--- +- 2--- |  |--- |  +- 4--- |  |--- |  `- 5--- |--- `- 3---    |---    +- 6---    |---    `- 7--- @----unfoldTree :: (b -> (a, [b])) -> b -> Tree a-unfoldTree f b = let (a, bs) = f b in Node a (unfoldForest f bs)---- | Build a (possibly infinite) forest from a list of seed values in--- breadth-first order.------ @unfoldForest f seeds@ invokes 'unfoldTree' on each seed value.------ For a monadic version see 'unfoldForestM_BF'.----unfoldForest :: (b -> (a, [b])) -> [b] -> Forest a-unfoldForest f = map (unfoldTree f)---- | Monadic tree builder, in depth-first order.-unfoldTreeM :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)-unfoldTreeM f b = do-    (a, bs) <- f b-    ts <- unfoldForestM f bs-    return (Node a ts)---- | Monadic forest builder, in depth-first order-unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a)-unfoldForestM f = Prelude.mapM (unfoldTreeM f)---- | Monadic tree builder, in breadth-first order.------ See 'unfoldTree' for more info.------ Implemented using an algorithm adapted from /Breadth-First Numbering: Lessons--- from a Small Exercise in Algorithm Design/, by Chris Okasaki, /ICFP'00/.-unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)-unfoldTreeM_BF f b = liftM getElement $ unfoldForestQ f (singleton b)-  where-    getElement xs = case viewl xs of-        x :< _ -> x-        EmptyL -> error "unfoldTreeM_BF"---- | Monadic forest builder, in breadth-first order------ See 'unfoldForest' for more info.------ Implemented using an algorithm adapted from /Breadth-First Numbering: Lessons--- from a Small Exercise in Algorithm Design/, by Chris Okasaki, /ICFP'00/.-unfoldForestM_BF :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a)-unfoldForestM_BF f = liftM toList . unfoldForestQ f . fromList---- Takes a sequence (queue) of seeds and produces a sequence (reversed queue) of--- trees of the same length.-unfoldForestQ :: Monad m => (b -> m (a, [b])) -> Seq b -> m (Seq (Tree a))-unfoldForestQ f aQ = case viewl aQ of-    EmptyL -> return empty-    a :< aQ' -> do-        (b, as) <- f a-        tQ <- unfoldForestQ f (Prelude.foldl (|>) aQ' as)-        let (tQ', ts) = splitOnto [] as tQ-        return (Node b ts <| tQ')-  where-    splitOnto :: [a'] -> [b'] -> Seq a' -> (Seq a', [a'])-    splitOnto as [] q = (q, as)-    splitOnto as (_:bs) q = case viewr q of-        q' :> a -> splitOnto (a:as) bs q'-        EmptyR -> error "unfoldForestQ"
− Utils/Containers/Internal/BitQueue.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Utils.Containers.Internal.BitQueue--- Copyright   :  (c) David Feuer 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------ An extremely light-weight, fast, and limited representation of a string of--- up to (2*WORDSIZE - 2) bits. In fact, there are two representations,--- misleadingly named bit queue builder and bit queue. The builder supports--- only `emptyQB`, creating an empty builder, and `snocQB`, enqueueing a bit.--- The bit queue builder is then turned into a bit queue using `buildQ`, after--- which bits can be removed one by one using `unconsQ`. If the size limit is--- exceeded, further operations will silently produce nonsense.--------------------------------------------------------------------------------module Utils.Containers.Internal.BitQueue-    ( BitQueue-    , BitQueueB-    , emptyQB-    , snocQB-    , buildQ-    , unconsQ-    , toListQ-    ) where--#if !MIN_VERSION_base(4,8,0)-import Data.Word (Word)-#endif-import Utils.Containers.Internal.BitUtil (shiftLL, shiftRL, wordSize)-import Data.Bits ((.|.), (.&.), testBit)-#if MIN_VERSION_base(4,8,0)-import Data.Bits (countTrailingZeros)-#else-import Data.Bits (popCount)-#endif--#if !MIN_VERSION_base(4,8,0)-countTrailingZeros :: Word -> Int-countTrailingZeros x = popCount ((x .&. (-x)) - 1)-{-# INLINE countTrailingZeros #-}-#endif---- A bit queue builder. We represent a double word using two words--- because we don't currently have access to proper double words.-data BitQueueB = BQB {-# UNPACK #-} !Word-                     {-# UNPACK #-} !Word--newtype BitQueue = BQ BitQueueB deriving Show---- Intended for debugging.-instance Show BitQueueB where-  show (BQB hi lo) = "BQ"++-    show (map (testBit hi) [(wordSize - 1),(wordSize - 2)..0]-            ++ map (testBit lo) [(wordSize - 1),(wordSize - 2)..0])---- | Create an empty bit queue builder. This is represented as a single guard--- bit in the most significant position.-emptyQB :: BitQueueB-emptyQB = BQB (1 `shiftLL` (wordSize - 1)) 0-{-# INLINE emptyQB #-}---- Shift the double word to the right by one bit.-shiftQBR1 :: BitQueueB -> BitQueueB-shiftQBR1 (BQB hi lo) = BQB hi' lo' where-  lo' = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))-  hi' = hi `shiftRL` 1-{-# INLINE shiftQBR1 #-}---- | Enqueue a bit. This works by shifting the queue right one bit,--- then setting the most significant bit as requested.-{-# INLINE snocQB #-}-snocQB :: BitQueueB -> Bool -> BitQueueB-snocQB bq b = case shiftQBR1 bq of-  BQB hi lo -> BQB (hi .|. (fromIntegral (fromEnum b) `shiftLL` (wordSize - 1))) lo---- | Convert a bit queue builder to a bit queue. This shifts in a new--- guard bit on the left, and shifts right until the old guard bit falls--- off.-{-# INLINE buildQ #-}-buildQ :: BitQueueB -> BitQueue-buildQ (BQB hi 0) = BQ (BQB 0 lo') where-  zeros = countTrailingZeros hi-  lo' = ((hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))) `shiftRL` zeros-buildQ (BQB hi lo) = BQ (BQB hi' lo') where-  zeros = countTrailingZeros lo-  lo1 = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))-  hi1 = (hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))-  lo' = (lo1 `shiftRL` zeros) .|. (hi1 `shiftLL` (wordSize - zeros))-  hi' = hi1 `shiftRL` zeros---- Test if the queue is empty, which occurs when theres--- nothing left but a guard bit in the least significant--- place.-nullQ :: BitQueue -> Bool-nullQ (BQ (BQB 0 1)) = True-nullQ _ = False-{-# INLINE nullQ #-}---- | Dequeue an element, or discover the queue is empty.-unconsQ :: BitQueue -> Maybe (Bool, BitQueue)-unconsQ q | nullQ q = Nothing-unconsQ (BQ bq@(BQB _ lo)) = Just (hd, BQ tl)-  where-    !hd = (lo .&. 1) /= 0-    !tl = shiftQBR1 bq-{-# INLINE unconsQ #-}---- | Convert a bit queue to a list of bits by unconsing.--- This is used to test that the queue functions properly.-toListQ :: BitQueue -> [Bool]-toListQ bq = case unconsQ bq of-      Nothing -> []-      Just (hd, tl) -> hd : toListQ tl
− Utils/Containers/Internal/BitUtil.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__-{-# LANGUAGE MagicHash #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif--#include "containers.h"---------------------------------------------------------------------------------- |--- Module      :  Utils.Containers.Internal.BitUtil--- Copyright   :  (c) Clark Gaebel 2012---                (c) Johan Tibel 2012--- 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.--module Utils.Containers.Internal.BitUtil-    ( bitcount-    , highestBitMask-    , shiftLL-    , shiftRL-    , wordSize-    ) where--import Data.Bits ((.|.), xor)-import Data.Bits (popCount, unsafeShiftL, unsafeShiftR)-#if MIN_VERSION_base(4,7,0)-import Data.Bits (finiteBitSize)-#else-import Data.Bits (bitSize)-#endif--#if !MIN_VERSION_base (4,8,0)-import Data.Word (Word)-#endif--{-----------------------------------------------------------------------  [bitcount] as posted by David F. Place to haskell-cafe on April 11, 2006,-  based on the code on-  http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan,-  where the following source is given:-    Published in 1988, the C Programming Language 2nd Ed. (by Brian W.-    Kernighan and Dennis M. Ritchie) mentions this in exercise 2-9. On April-    19, 2006 Don Knuth pointed out to me that this method "was first published-    by Peter Wegner in CACM 3 (1960), 322. (Also discovered independently by-    Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)"-----------------------------------------------------------------------}--bitcount :: Int -> Word -> Int-bitcount a x = a + popCount x-{-# INLINE bitcount #-}---- The highestBitMask implementation is based on--- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2--- which has been put in the public domain.---- | Return a word where only the highest bit is set.-highestBitMask :: Word -> Word-highestBitMask x1 = let x2 = x1 .|. x1 `shiftRL` 1-                        x3 = x2 .|. x2 `shiftRL` 2-                        x4 = x3 .|. x3 `shiftRL` 4-                        x5 = x4 .|. x4 `shiftRL` 8-                        x6 = x5 .|. x5 `shiftRL` 16-#if !(defined(__GLASGOW_HASKELL__) && WORD_SIZE_IN_BITS==32)-                        x7 = x6 .|. x6 `shiftRL` 32-                     in x7 `xor` (x7 `shiftRL` 1)-#else-                     in x6 `xor` (x6 `shiftRL` 1)-#endif-{-# INLINE highestBitMask #-}---- Right and left logical shifts.-shiftRL, shiftLL :: Word -> Int -> Word-shiftRL = unsafeShiftR-shiftLL = unsafeShiftL--{-# INLINE wordSize #-}-wordSize :: Int-#if MIN_VERSION_base(4,7,0)-wordSize = finiteBitSize (0 :: Word)-#else-wordSize = bitSize (0 :: Word)-#endif
− Utils/Containers/Internal/Coercions.hs 
@@ -1,44 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}--#include "containers.h"--module Utils.Containers.Internal.Coercions where--#if __GLASGOW_HASKELL__ >= 708-import Data.Coerce-#endif--infixl 8 .#-#if __GLASGOW_HASKELL__ >= 708-(.#) :: Coercible b a => (b -> c) -> (a -> b) -> a -> c-(.#) f _ = coerce f-#else-(.#) :: (b -> c) -> (a -> b) -> a -> c-(.#) = (.)-#endif-{-# INLINE (.#) #-}--infix 9 .^#---- | Coerce the second argument of a function. Conceptually,--- can be thought of as:------ @---   (f .^# g) x y = f x (g y)--- @------ However it is most useful when coercing the arguments to--- 'foldl':------ @---   foldl f b . fmap g = foldl (f .^# g) b--- @-#if __GLASGOW_HASKELL__ >= 708-(.^#) :: Coercible c b => (a -> c -> d) -> (b -> c) -> (a -> b -> d)-(.^#) f _ = coerce f-#else-(.^#) :: (a -> c -> d) -> (b -> c) -> (a -> b -> d)-(f .^# g) x y = f x (g y)-#endif-{-# INLINE (.^#) #-}
− Utils/Containers/Internal/PtrEquality.hs 
@@ -1,51 +0,0 @@-{-# LANGUAGE CPP #-}-#ifdef __GLASGOW_HASKELL__-{-# LANGUAGE MagicHash #-}-#endif--{-# OPTIONS_HADDOCK hide #-}---- | Really unsafe pointer equality-module Utils.Containers.Internal.PtrEquality (ptrEq, hetPtrEq) where--#ifdef __GLASGOW_HASKELL__-import GHC.Exts ( reallyUnsafePtrEquality# )-import Unsafe.Coerce ( unsafeCoerce )-#if __GLASGOW_HASKELL__ < 707-import GHC.Exts ( (==#) )-#else-import GHC.Exts ( isTrue# )-#endif-#endif---- | Checks if two pointers are equal. Yes means yes;--- no means maybe. The values should be forced to at least--- WHNF before comparison to get moderately reliable results.-ptrEq :: a -> a -> Bool---- | Checks if two pointers are equal, without requiring--- them to have the same type. The values should be forced--- to at least WHNF before comparison to get moderately--- reliable results.-hetPtrEq :: a -> b -> Bool--#ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ < 707-ptrEq x y = reallyUnsafePtrEquality# x y ==# 1#-hetPtrEq x y = unsafeCoerce reallyUnsafePtrEquality# x y ==# 1#-#else-ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)-hetPtrEq x y = isTrue# (unsafeCoerce reallyUnsafePtrEquality# x y)-#endif--#else--- Not GHC-ptrEq _ _ = False-hetPtrEq _ _ = False-#endif--{-# INLINE ptrEq #-}-{-# INLINE hetPtrEq #-}--infix 4 `ptrEq`-infix 4 `hetPtrEq`
− Utils/Containers/Internal/State.hs 
@@ -1,35 +0,0 @@-{-# LANGUAGE CPP #-}-#include "containers.h"-{-# OPTIONS_HADDOCK hide #-}---- | A clone of Control.Monad.State.Strict.-module Utils.Containers.Internal.State where--import Prelude hiding (-#if MIN_VERSION_base(4,8,0)-    Applicative-#endif-    )--import Control.Monad (ap)-import Control.Applicative (Applicative(..), liftA)--newtype State s a = State {runState :: s -> (s, a)}--instance Functor (State s) where-    fmap = liftA--instance Monad (State s) where-    {-# INLINE return #-}-    {-# INLINE (>>=) #-}-    return = pure-    m >>= k = State $ \ s -> case runState m s of-        (s', x) -> runState (k x) s'--instance Applicative (State s) where-    {-# INLINE pure #-}-    pure x = State $ \ s -> (s, x)-    (<*>) = ap--execState :: State s a -> s -> a-execState m x = snd (runState m x)
− Utils/Containers/Internal/StrictMaybe.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE CPP #-}--#include "containers.h"--{-# OPTIONS_HADDOCK hide #-}--- | Strict 'Maybe'--module Utils.Containers.Internal.StrictMaybe (MaybeS (..), maybeS, toMaybe, toMaybeS) where--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable (..))-import Data.Monoid (Monoid (..))-#endif--data MaybeS a = NothingS | JustS !a--instance Foldable MaybeS where-  foldMap _ NothingS = mempty-  foldMap f (JustS a) = f a--maybeS :: r -> (a -> r) -> MaybeS a -> r-maybeS n _ NothingS = n-maybeS _ j (JustS a) = j a--toMaybe :: MaybeS a -> Maybe a-toMaybe NothingS = Nothing-toMaybe (JustS a) = Just a--toMaybeS :: Maybe a -> MaybeS a-toMaybeS Nothing = NothingS-toMaybeS (Just a) = JustS a
− Utils/Containers/Internal/StrictPair.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif--#include "containers.h"---- | A strict pair--module Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where---- | The same as a regular Haskell pair, but------ @--- (x :*: _|_) = (_|_ :*: y) = _|_--- @-data StrictPair a b = !a :*: !b--infixr 1 :*:---- | Convert a strict pair to a standard pair.-toPair :: StrictPair a b -> (a, b)-toPair (x :*: y) = (x, y)-{-# INLINE toPair #-}
− Utils/Containers/Internal/TypeError.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE DataKinds, FlexibleInstances, FlexibleContexts, UndecidableInstances,-     KindSignatures, TypeFamilies, CPP #-}--#if !defined(TESTING)-# if __GLASGOW_HASKELL__ >= 710-{-# LANGUAGE Safe #-}-# else-{-# LANGUAGE Trustworthy #-}-#endif-#endif---- | Unsatisfiable constraints for functions being removed.--module Utils.Containers.Internal.TypeError where-import GHC.TypeLits---- | The constraint @Whoops s@ is unsatisfiable for every 'Symbol' @s@.--- Under GHC 8.0 and above, trying to use a function with a @Whoops s@--- constraint will lead to a pretty type error explaining how to fix--- the problem. Under earlier GHC versions, it will produce an extremely--- ugly type error within which the desired message is buried.------ ==== Example------ @--- oldFunction :: Whoops "oldFunction is gone now. Use newFunction."---             => Int -> IntMap a -> IntMap a--- @-class Whoops (a :: Symbol)--#if __GLASGOW_HASKELL__ >= 800-instance TypeError ('Text a) => Whoops a-#endif---- Why don't we just use------ type Whoops a = TypeError ('Text a) ?------ When GHC sees the type signature of oldFunction, it will see that it--- has an unsatisfiable constraint and reject it out of hand.------ It seems possible to hack around that with a type family:------ type family Whoops a where---   Whoops a = TypeError ('Text a)------ but I don't really trust that to work reliably. What we actually--- do is pretty much guaranteed to work. Despite the fact that there--- is a totally polymorphic instance in scope, GHC will refrain from--- reducing the constraint because it knows someone could (theoretically)--- define an overlapping instance of Whoops. It doesn't commit to--- the polymorphic one until it has to, at the call site.
− benchmarks/IntMap.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Main where--import Control.DeepSeq (rnf)-import Control.Exception (evaluate)-import Criterion.Main (bench, defaultMain, whnf)-import Data.List (foldl')-import qualified Data.IntMap as M-import qualified Data.IntMap.Strict as MS-import Data.Maybe (fromMaybe)-import Prelude hiding (lookup)--main = do-    let m = M.fromAscList elems :: M.IntMap Int-    evaluate $ rnf [m]-    defaultMain-        [ bench "lookup" $ whnf (lookup keys) m-        , bench "insert" $ whnf (ins elems) M.empty-        , bench "insertWith empty" $ whnf (insWith elems) M.empty-        , bench "insertWith update" $ whnf (insWith elems) m-        , bench "insertWith' empty" $ whnf (insWith' elems) M.empty-        , bench "insertWith' update" $ whnf (insWith' elems) m-        , bench "insertWithKey empty" $ whnf (insWithKey elems) M.empty-        , bench "insertWithKey update" $ whnf (insWithKey elems) m-        , bench "insertWithKey' empty" $ whnf (insWithKey' elems) M.empty-        , bench "insertWithKey' update" $ whnf (insWithKey' elems) m-        , bench "insertLookupWithKey empty" $ whnf (insLookupWithKey elems) M.empty-        , bench "insertLookupWithKey update" $ whnf (insLookupWithKey elems) m-        , bench "map" $ whnf (M.map (+ 1)) m-        , bench "mapWithKey" $ whnf (M.mapWithKey (+)) m-        , bench "foldlWithKey" $ whnf (ins elems) m-        , bench "foldlWithKey'" $ whnf (M.foldlWithKey' sum 0) m-        , bench "foldrWithKey" $ whnf (M.foldrWithKey consPair []) m-        , bench "delete" $ whnf (del keys) m-        , bench "update" $ whnf (upd keys) m-        , bench "updateLookupWithKey" $ whnf (upd' keys) m-        , bench "alter"  $ whnf (alt keys) m-        , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m-        , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m-        , bench "fromList" $ whnf M.fromList elems-        , bench "fromAscList" $ whnf M.fromAscList elems-        , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems-        , bench "minView" $ whnf (maybe 0 (\((k,v), m) -> k+v+M.size m) . M.minViewWithKey)-                    (M.fromList $ zip [1..10] [1..10])-        ]-  where-    elems = zip keys values-    keys = [1..2^12]-    values = [1..2^12]-    sum k v1 v2 = k + v1 + v2-    consPair k v xs = (k, v) : xs--add3 :: Int -> Int -> Int -> Int-add3 x y z = x + y + z-{-# INLINE add3 #-}--lookup :: [Int] -> M.IntMap Int -> Int-lookup xs m = foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 xs--ins :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int-ins xs m = foldl' (\m (k, v) -> M.insert k v m) m xs--insWith :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int-insWith xs m = foldl' (\m (k, v) -> M.insertWith (+) k v m) m xs--insWithKey :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int-insWithKey xs m = foldl' (\m (k, v) -> M.insertWithKey add3 k v m) m xs--insWith' :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int-insWith' xs m = foldl' (\m (k, v) -> MS.insertWith (+) k v m) m xs--insWithKey' :: [(Int, Int)] -> M.IntMap Int -> M.IntMap Int-insWithKey' xs m = foldl' (\m (k, v) -> MS.insertWithKey add3 k v m) m xs--data PairS a b = PS !a !b--insLookupWithKey :: [(Int, Int)] -> M.IntMap Int -> (Int, M.IntMap Int)-insLookupWithKey xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)-  where-    f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey add3 k v m-                        in PS (fromMaybe 0 n' + n) m'--del :: [Int] -> M.IntMap Int -> M.IntMap Int-del xs m = foldl' (\m k -> M.delete k m) m xs--upd :: [Int] -> M.IntMap Int -> M.IntMap Int-upd xs m = foldl' (\m k -> M.update Just k m) m xs--upd' :: [Int] -> M.IntMap Int -> M.IntMap Int-upd' xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> Just a) k m) m xs--alt :: [Int] -> M.IntMap Int -> M.IntMap Int-alt xs m = foldl' (\m k -> M.alter id k m) m xs--maybeDel :: Int -> Maybe Int-maybeDel n | n `mod` 3 == 0 = Nothing-           | otherwise      = Just n
− benchmarks/IntSet.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Main where--import Control.DeepSeq (rnf)-import Control.Exception (evaluate)-import Criterion.Main (bench, defaultMain, whnf)-import Data.List (foldl')-import qualified Data.IntSet as S--main = do-    let s = S.fromAscList elems :: S.IntSet-        s_even = S.fromAscList elems_even :: S.IntSet-        s_odd = S.fromAscList elems_odd :: S.IntSet-    evaluate $ rnf [s, s_even, s_odd]-    defaultMain-        [ bench "member" $ whnf (member elems) s-        , bench "insert" $ whnf (ins elems) S.empty-        , bench "map" $ whnf (S.map (+ 1)) s-        , bench "filter" $ whnf (S.filter ((== 0) . (`mod` 2))) s-        , bench "partition" $ whnf (S.partition ((== 0) . (`mod` 2))) s-        , bench "fold" $ whnf (S.fold (:) []) s-        , bench "delete" $ whnf (del elems) s-        , bench "findMin" $ whnf S.findMin s-        , bench "findMax" $ whnf S.findMax s-        , bench "deleteMin" $ whnf S.deleteMin s-        , bench "deleteMax" $ whnf S.deleteMax s-        , bench "unions" $ whnf S.unions [s_even, s_odd]-        , bench "union" $ whnf (S.union s_even) s_odd-        , bench "difference" $ whnf (S.difference s) s_even-        , bench "intersection" $ whnf (S.intersection s) s_even-        , bench "fromList" $ whnf S.fromList elems-        , bench "fromAscList" $ whnf S.fromAscList elems-        , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems-        , bench "disjoint:false" $ whnf (S.disjoint s) s_even-        , bench "disjoint:true" $ whnf (S.disjoint s_odd) s_even-        , bench "null.intersection:false" $ whnf (S.null. S.intersection s) s_even-        , bench "null.intersection:true" $ whnf (S.null. S.intersection s_odd) s_even-        ]-  where-    elems = [1..2^12]-    elems_even = [2,4..2^12]-    elems_odd = [1,3..2^12]--member :: [Int] -> S.IntSet -> Int-member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs--ins :: [Int] -> S.IntSet -> S.IntSet-ins xs s0 = foldl' (\s a -> S.insert a s) s0 xs--del :: [Int] -> S.IntSet -> S.IntSet-del xs s0 = foldl' (\s k -> S.delete k s) s0 xs
− benchmarks/LookupGE/IntMap.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Main where--import Control.DeepSeq (rnf)-import Control.Exception (evaluate)-import Criterion.Main (bench, defaultMain, nf)-import Data.List (foldl')-import qualified Data.IntMap as M-import qualified LookupGE_IntMap as M-import Data.Maybe (fromMaybe)-import Prelude hiding (lookup)--main :: IO ()-main = do-    evaluate $ rnf [m_even, m_odd, m_large]-    defaultMain [b f | b <- benches, f <- funs1]-  where-    m_even = M.fromAscList elems_even :: M.IntMap Int-    m_odd  = M.fromAscList elems_odd :: M.IntMap Int-    m_large = M.fromAscList elems_large :: M.IntMap Int-    bound = 2^12-    elems_even  = zip evens evens-    elems_odd   = zip odds odds-    elems_large = zip large large-    evens = [2,4..bound]-    odds  = [1,3..bound]-    large = [1,100..50*bound]-    benches =-          [ \(n,fun) -> bench (n++" present")  $ nf (fge fun evens) m_even-          , \(n,fun) -> bench (n++" absent")   $ nf (fge fun evens) m_odd-          , \(n,fun) -> bench (n++" far")      $ nf (fge fun odds)  m_large-          , \(n,fun) -> bench (n++" !present") $ nf (fge2 fun evens) m_even-          , \(n,fun) -> bench (n++" !absent")  $ nf (fge2 fun evens) m_odd-          , \(n,fun) -> bench (n++" !far")     $ nf (fge2 fun odds)  m_large-          ]-    funs1 = [ ("GE split", M.lookupGE1)-            , ("GE Craig", M.lookupGE2)-            , ("GE Twan", M.lookupGE3)-            , ("GE Milan", M.lookupGE4) ]--fge :: (Int -> M.IntMap Int -> Maybe (Int,Int)) -> [Int] -> M.IntMap Int -> (Int,Int)-fge fun xs m = foldl' (\n k -> fromMaybe n (fun k m)) (0,0) xs---- forcing values inside tuples!-fge2 :: (Int -> M.IntMap Int -> Maybe (Int,Int)) -> [Int] -> M.IntMap Int -> (Int,Int)-fge2 fun xs m = foldl' (\n@(!_, !_) k -> fromMaybe n (fun k m)) (0,0) xs-
− benchmarks/LookupGE/LookupGE_IntMap.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE CPP #-}-module LookupGE_IntMap where--import Prelude hiding (null)-import Data.IntMap.Internal--lookupGE1 :: Key -> IntMap a -> Maybe (Key,a)-lookupGE1 k m =-    case splitLookup k m of-        (_,Just v,_)  -> Just (k,v)-        (_,Nothing,r) -> findMinMaybe r--lookupGE2 :: Key -> IntMap a -> Maybe (Key,a)-lookupGE2 k t = case t of-    Bin _ m l r | m < 0 -> if k >= 0-      then go l-      else case go r of-        Nothing -> Just $ findMin l-        justx -> justx-    _ -> go t-  where-    go (Bin p m l r)-      | nomatch k p m = if k < p-        then Just $ findMin l-        else Nothing-      | zero k m = case go l of-        Nothing -> Just $ findMin r-        justx -> justx-      | otherwise = go r-    go (Tip ky y)-      | k > ky = Nothing-      | otherwise = Just (ky, y)-    go Nil = Nothing--lookupGE3 :: Key -> IntMap a -> Maybe (Key,a)-lookupGE3 k t = k `seq` case t of-    Bin _ m l r | m < 0 -> if k >= 0-      then go Nothing l-      else go (Just (findMin l)) r-    _ -> go Nothing t-  where-    go def (Bin p m l r)-      | nomatch k p m = if k < p then Just $ findMin l else def-      | zero k m  = go (Just $ findMin r) l-      | otherwise = go def r-    go def (Tip ky y)-      | k > ky    = def-      | otherwise = Just (ky, y)-    go def Nil  = def--lookupGE4 :: Key -> IntMap a -> Maybe (Key,a)-lookupGE4 k t = k `seq` 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 fMin l else fMin def-      | zero k m  = go r l-      | otherwise = go def r-    go def (Tip ky y)-      | k > ky    = fMin def-      | otherwise = Just (ky, y)-    go def Nil  = fMin def--    fMin :: IntMap a -> Maybe (Key, a)-    fMin Nil = Nothing-    fMin (Tip ky y) = Just (ky, y)-    fMin (Bin _ _ l _) = fMin l------------------------------------------------------------------------------------ Utilities------------------------------------------------------------------------------------ | /O(log n)/. The minimal key of the map.-findMinMaybe :: IntMap a -> Maybe (Key, a)-findMinMaybe m-  | null m = Nothing-  | otherwise = Just (findMin m)--#ifdef TESTING----------------------------------------------------------------------------------- Properties:----------------------------------------------------------------------------------prop_lookupGE12 :: Int -> [Int] -> Bool-prop_lookupGE12 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE2 x m--prop_lookupGE13 :: Int -> [Int] -> Bool-prop_lookupGE13 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE3 x m--prop_lookupGE14 :: Int -> [Int] -> Bool-prop_lookupGE14 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE4 x m-#endif
− benchmarks/LookupGE/LookupGE_Map.hs 
@@ -1,75 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}-module LookupGE_Map where--import Data.Map.Internal--lookupGE1 :: Ord k => k -> Map k a -> Maybe (k,a)-lookupGE1 k m =-    case splitLookup k m of-        (_,Just v,_)  -> Just (k,v)-        (_,Nothing,r) -> findMinMaybe r-{-# INLINABLE lookupGE1 #-}--lookupGE2 :: Ord k => k -> Map k a -> Maybe (k,a)-lookupGE2 = go-  where-    go !_ Tip = Nothing-    go !k (Bin _ kx x l r) =-        case compare k kx of-            LT -> case go k l of-                    Nothing -> Just (kx,x)-                    ret -> ret-            GT -> go k r-            EQ -> Just (kx,x)-{-# INLINABLE lookupGE2 #-}--lookupGE3 :: Ord k => k -> Map k a -> Maybe (k,a)-lookupGE3 = go Nothing-  where-    go def !_ Tip = def-    go def !k (Bin _ kx x l r) =-        case compare k kx of-            LT -> go (Just (kx,x)) k l-            GT -> go def k r-            EQ -> Just (kx,x)-{-# INLINABLE lookupGE3 #-}--lookupGE4 :: Ord k => k -> Map k a -> Maybe (k,a)-lookupGE4 k = k `seq` goNothing-  where-    goNothing Tip = Nothing-    goNothing (Bin _ kx x l r) = case compare k kx of-                                   LT -> goJust kx x l-                                   EQ -> Just (kx, x)-                                   GT -> goNothing r--    goJust ky y Tip = Just (ky, y)-    goJust ky y (Bin _ kx x l r) = case compare k kx of-                                     LT -> goJust kx x l-                                     EQ -> Just (kx, x)-                                     GT -> goJust ky y r-{-# INLINABLE lookupGE4 #-}------------------------------------------------------------------------------------ Utilities----------------------------------------------------------------------------------findMinMaybe :: Map k a -> Maybe (k,a)-findMinMaybe (Bin _ kx x Tip _)  = Just (kx,x)-findMinMaybe (Bin _ _  _ l _)    = findMinMaybe l-findMinMaybe Tip                 = Nothing--#ifdef TESTING----------------------------------------------------------------------------------- Properties:----------------------------------------------------------------------------------prop_lookupGE12 :: Int -> [Int] -> Bool-prop_lookupGE12 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE2 x m--prop_lookupGE13 :: Int -> [Int] -> Bool-prop_lookupGE13 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE3 x m--prop_lookupGE14 :: Int -> [Int] -> Bool-prop_lookupGE14 x xs = case fromList $ zip xs xs of m -> lookupGE1 x m == lookupGE4 x m-#endif
− benchmarks/LookupGE/Makefile 
@@ -1,3 +0,0 @@-TOP = ..--include ../Makefile
− benchmarks/LookupGE/Map.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE BangPatterns #-}-module Main where--import Control.DeepSeq (rnf)-import Control.Exception (evaluate)-import Criterion.Main (defaultMain, bench, nf)-import Data.List (foldl')-import qualified Data.Map as M-import qualified LookupGE_Map as M-import Data.Maybe (fromMaybe)-import Prelude hiding (lookup)--main :: IO ()-main = do-    evaluate $ rnf [m_even, m_odd, m_large]-    defaultMain [b f | b <- benches, f <- funs1]-  where-    m_even = M.fromAscList elems_even :: M.Map Int Int-    m_odd  = M.fromAscList elems_odd :: M.Map Int Int-    m_large = M.fromAscList elems_large :: M.Map Int Int-    bound = 2^10-    elems_even  = zip evens evens-    elems_odd   = zip odds odds-    elems_large = zip large large-    evens = [2,4..bound]-    odds  = [1,3..bound]-    large = [1,100..50*bound]-    benches =-          [ \(n,fun) -> bench (n++" present")  $ nf (fge fun evens) m_even-          , \(n,fun) -> bench (n++" absent")   $ nf (fge fun evens) m_odd-          , \(n,fun) -> bench (n++" far")      $ nf (fge fun odds)  m_large-          , \(n,fun) -> bench (n++" !present") $ nf (fge2 fun evens) m_even-          , \(n,fun) -> bench (n++" !absent")  $ nf (fge2 fun evens) m_odd-          , \(n,fun) -> bench (n++" !far")     $ nf (fge2 fun odds)  m_large-          ]-    funs1 = [ ("GE split", M.lookupGE1)-            , ("GE caseof", M.lookupGE2)-            , ("GE Twan", M.lookupGE3)-            , ("GE Milan", M.lookupGE4) ]--fge :: (Int -> M.Map Int Int -> Maybe (Int,Int)) -> [Int] -> M.Map Int Int -> (Int,Int)-fge fun xs m = foldl' (\n k -> fromMaybe n (fun k m)) (0,0) xs---- forcing values inside tuples!-fge2 :: (Int -> M.Map Int Int -> Maybe (Int,Int)) -> [Int] -> M.Map Int Int -> (Int,Int)-fge2 fun xs m = foldl' (\n@(!_, !_) k -> fromMaybe n (fun k m)) (0,0) xs
− benchmarks/Makefile 
@@ -1,18 +0,0 @@-all:--bench-%: %.hs force-	ghc -O2 -DTESTING $< -I$(TOP)../include -i$(TOP).. -o $@ -outputdir tmp -rtsopts--.PRECIOUS: bench-%--bench-%.csv: bench-%-	./bench-$* "$(BENCHMARK)" -v1 --csv bench-$*.csv--.PHONY: force clean veryclean-force:--clean:-	rm -rf tmp $(patsubst %.hs, bench-%, $(wildcard *.hs))--veryclean: clean-	rm -rf *.csv
− benchmarks/Map.hs 
@@ -1,197 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-module Main where--import Control.Applicative (Const(Const, getConst), pure)-import Control.DeepSeq (rnf)-import Control.Exception (evaluate)-import Criterion.Main (bench, defaultMain, whnf, nf)-import Data.Functor.Identity (Identity(..))-import Data.List (foldl')-import qualified Data.Map as M-import qualified Data.Map.Strict as MS-import Data.Map (alterF)-import Data.Maybe (fromMaybe)-import Data.Functor ((<$))-#if __GLASGOW_HASKELL__ >= 708-import Data.Coerce-#endif-import Prelude hiding (lookup)--main = do-    let m = M.fromAscList elems :: M.Map Int Int-        m_even = M.fromAscList elems_even :: M.Map Int Int-        m_odd = M.fromAscList elems_odd :: M.Map Int Int-    evaluate $ rnf [m, m_even, m_odd]-    defaultMain-        [ bench "lookup absent" $ whnf (lookup evens) m_odd-        , bench "lookup present" $ whnf (lookup evens) m_even-        , bench "map" $ whnf (M.map (+ 1)) m-        , bench "map really" $ nf (M.map (+ 2)) m-        , bench "<$" $ whnf ((1 :: Int) <$) m-        , bench "<$ really" $ nf ((2 :: Int) <$) m-        , bench "alterF lookup absent" $ whnf (atLookup evens) m_odd-        , bench "alterF lookup present" $ whnf (atLookup evens) m_even-        , bench "alterF no rules lookup absent" $ whnf (atLookupNoRules evens) m_odd-        , bench "alterF no rules lookup present" $ whnf (atLookupNoRules evens) m_even-        , bench "insert absent" $ whnf (ins elems_even) m_odd-        , bench "insert present" $ whnf (ins elems_even) m_even-        , bench "alterF insert absent" $ whnf (atIns elems_even) m_odd-        , bench "alterF insert present" $ whnf (atIns elems_even) m_even-        , bench "alterF no rules insert absent" $ whnf (atInsNoRules elems_even) m_odd-        , bench "alterF no rules insert present" $ whnf (atInsNoRules elems_even) m_even-        , bench "delete absent" $ whnf (del evens) m_odd-        , bench "delete present" $ whnf (del evens) m-        , bench "alterF delete absent" $ whnf (atDel evens) m_odd-        , bench "alterF delete present" $ whnf (atDel evens) m-        , bench "alterF no rules delete absent" $ whnf (atDelNoRules evens) m_odd-        , bench "alterF no rules delete present" $ whnf (atDelNoRules evens) m-        , bench "alter absent"  $ whnf (alt id evens) m_odd-        , bench "alter insert"  $ whnf (alt (const (Just 1)) evens) m_odd-        , bench "alter update"  $ whnf (alt id evens) m_even-        , bench "alter delete"  $ whnf (alt (const Nothing) evens) m-        , bench "alterF alter absent" $ whnf (atAlt id evens) m_odd-        , bench "alterF alter insert" $ whnf (atAlt (const (Just 1)) evens) m_odd-        , bench "alterF alter update" $ whnf (atAlt id evens) m_even-        , bench "alterF alter delete" $ whnf (atAlt (const Nothing) evens) m-        , bench "alterF no rules alter absent" $ whnf (atAltNoRules id evens) m_odd-        , bench "alterF no rules alter insert" $ whnf (atAltNoRules (const (Just 1)) evens) m_odd-        , bench "alterF no rules alter update" $ whnf (atAltNoRules id evens) m_even-        , bench "alterF no rules alter delete" $ whnf (atAltNoRules (const Nothing) evens) m-        , bench "insertWith absent" $ whnf (insWith elems_even) m_odd-        , bench "insertWith present" $ whnf (insWith elems_even) m_even-        , bench "insertWith' absent" $ whnf (insWith' elems_even) m_odd-        , bench "insertWith' present" $ whnf (insWith' elems_even) m_even-        , bench "insertWithKey absent" $ whnf (insWithKey elems_even) m_odd-        , bench "insertWithKey present" $ whnf (insWithKey elems_even) m_even-        , bench "insertWithKey' absent" $ whnf (insWithKey' elems_even) m_odd-        , bench "insertWithKey' present" $ whnf (insWithKey' elems_even) m_even-        , bench "insertLookupWithKey absent" $ whnf (insLookupWithKey elems_even) m_odd-        , bench "insertLookupWithKey present" $ whnf (insLookupWithKey elems_even) m_even-        , bench "insertLookupWithKey' absent" $ whnf (insLookupWithKey' elems_even) m_odd-        , bench "insertLookupWithKey' present" $ whnf (insLookupWithKey' elems_even) m_even-        , bench "mapWithKey" $ whnf (M.mapWithKey (+)) m-        , bench "foldlWithKey" $ whnf (ins elems) m---         , bench "foldlWithKey'" $ whnf (M.foldlWithKey' sum 0) m-        , bench "foldrWithKey" $ whnf (M.foldrWithKey consPair []) m-        , bench "update absent" $ whnf (upd Just evens) m_odd-        , bench "update present" $ whnf (upd Just evens) m_even-        , bench "update delete" $ whnf (upd (const Nothing) evens) m-        , bench "updateLookupWithKey absent" $ whnf (upd' Just evens) m_odd-        , bench "updateLookupWithKey present" $ whnf (upd' Just evens) m_even-        , bench "updateLookupWithKey delete" $ whnf (upd' (const Nothing) evens) m-        , bench "mapMaybe" $ whnf (M.mapMaybe maybeDel) m-        , bench "mapMaybeWithKey" $ whnf (M.mapMaybeWithKey (const maybeDel)) m-        , bench "lookupIndex" $ whnf (lookupIndex keys) m-        , bench "union" $ whnf (M.union m_even) m_odd-        , bench "difference" $ whnf (M.difference m) m_even-        , bench "intersection" $ whnf (M.intersection m) m_even-        , bench "split" $ whnf (M.split (bound `div` 2)) m-        , bench "fromList" $ whnf M.fromList elems-        , bench "fromList-desc" $ whnf M.fromList (reverse elems)-        , bench "fromAscList" $ whnf M.fromAscList elems-        , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems-        , bench "minView" $ whnf (\m' -> case M.minViewWithKey m' of {Nothing -> 0; Just ((k,v),m'') -> k+v+M.size m''}) (M.fromAscList $ zip [1..10::Int] [100..110::Int])-        ]-  where-    bound = 2^12-    elems = zip keys values-    elems_even = zip evens evens-    elems_odd = zip odds odds-    keys = [1..bound]-    evens = [2,4..bound]-    odds = [1,3..bound]-    values = [1..bound]-    sum k v1 v2 = k + v1 + v2-    consPair k v xs = (k, v) : xs--add3 :: Int -> Int -> Int -> Int-add3 x y z = x + y + z-{-# INLINE add3 #-}--lookup :: [Int] -> M.Map Int Int -> Int-lookup xs m = foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 xs--atLookup :: [Int] -> M.Map Int Int -> Int-atLookup xs m = foldl' (\n k -> fromMaybe n (getConst (alterF Const k m))) 0 xs--newtype Consty a b = Consty { getConsty :: a }-instance Functor (Consty a) where-  fmap _ (Consty a) = Consty a--atLookupNoRules :: [Int] -> M.Map Int Int -> Int-atLookupNoRules xs m = foldl' (\n k -> fromMaybe n (getConsty (alterF Consty k m))) 0 xs--lookupIndex :: [Int] -> M.Map Int Int -> Int-lookupIndex xs m = foldl' (\n k -> fromMaybe n (M.lookupIndex k m)) 0 xs--ins :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int-ins xs m = foldl' (\m (k, v) -> M.insert k v m) m xs--atIns :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int-atIns xs m = foldl' (\m (k, v) -> runIdentity (alterF (\_ -> Identity (Just v)) k m)) m xs--newtype Ident a = Ident { runIdent :: a }-instance Functor Ident where-#if __GLASGOW_HASKELL__ >= 708-  fmap = coerce-#else-  fmap f (Ident a) = Ident (f a)-#endif--atInsNoRules :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int-atInsNoRules xs m = foldl' (\m (k, v) -> runIdent (alterF (\_ -> Ident (Just v)) k m)) m xs--insWith :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int-insWith xs m = foldl' (\m (k, v) -> M.insertWith (+) k v m) m xs--insWithKey :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int-insWithKey xs m = foldl' (\m (k, v) -> M.insertWithKey add3 k v m) m xs--insWith' :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int-insWith' xs m = foldl' (\m (k, v) -> MS.insertWith (+) k v m) m xs--insWithKey' :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int-insWithKey' xs m = foldl' (\m (k, v) -> MS.insertWithKey add3 k v m) m xs--data PairS a b = PS !a !b--insLookupWithKey :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int)-insLookupWithKey xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)-  where-    f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey add3 k v m-                        in PS (fromMaybe 0 n' + n) m'--insLookupWithKey' :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int)-insLookupWithKey' xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)-  where-    f (PS n m) (k, v) = let !(n', m') = MS.insertLookupWithKey add3 k v m-                        in PS (fromMaybe 0 n' + n) m'--del :: [Int] -> M.Map Int Int -> M.Map Int Int-del xs m = foldl' (\m k -> M.delete k m) m xs--atDel :: [Int] -> M.Map Int Int -> M.Map Int Int-atDel xs m = foldl' (\m k -> runIdentity (alterF (\_ -> Identity Nothing) k m)) m xs--atDelNoRules :: [Int] -> M.Map Int Int -> M.Map Int Int-atDelNoRules xs m = foldl' (\m k -> runIdent (alterF (\_ -> Ident Nothing) k m)) m xs--upd :: (Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int-upd f xs m = foldl' (\m k -> M.update f k m) m xs--upd' :: (Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int-upd' f xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> f a) k m) m xs--alt :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int-alt f xs m = foldl' (\m k -> M.alter f k m) m xs--atAlt :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int-atAlt f xs m = foldl' (\m k -> runIdentity (alterF (Identity . f) k m)) m xs--atAltNoRules :: (Maybe Int -> Maybe Int) -> [Int] -> M.Map Int Int -> M.Map Int Int-atAltNoRules f xs m = foldl' (\m k -> runIdent (alterF (Ident . f) k m)) m xs--maybeDel :: Int -> Maybe Int-maybeDel n | n `mod` 3 == 0 = Nothing-           | otherwise      = Just n
− benchmarks/Sequence.hs 
@@ -1,244 +0,0 @@-module Main where--import Control.Applicative-import Control.DeepSeq (rnf)-import Control.Exception (evaluate)-import Control.Monad.Trans.State.Strict-import Criterion.Main (bench, bgroup, defaultMain, nf)-import Data.Foldable (foldl', foldr')-import qualified Data.Sequence as S-import qualified Data.Foldable-import Data.Traversable (traverse)-import System.Random (mkStdGen, randoms)--main = do-    let s10 = S.fromList [1..10] :: S.Seq Int-        s100 = S.fromList [1..100] :: S.Seq Int-        s1000 = S.fromList [1..1000] :: S.Seq Int-        s10000 = S.fromList [1..10000] :: S.Seq Int-    evaluate $ rnf [s10, s100, s1000, s10000]-    let g = mkStdGen 1-    let rlist n = map (`mod` (n+1)) (take 10000 (randoms g)) :: [Int]-        r10 = rlist 10-        r100 = rlist 100-        r1000 = rlist 1000-        r10000 = rlist 10000-    evaluate $ rnf [r10, r100, r1000, r10000]-    let rs10 = S.fromList r10-        rs100 = S.fromList r100-        rs1000 = S.fromList r1000-        rs10000 = S.fromList r10000-    evaluate $ rnf [rs10, rs100, rs1000, rs10000]-    let u10 = S.replicate 10 () :: S.Seq ()-        u100 = S.replicate 100 () :: S.Seq ()-        u1000 = S.replicate 1000 () :: S.Seq ()-        u10000 = S.replicate 10000 () :: S.Seq ()-    evaluate $ rnf [u10, u100, u1000, u10000]-    defaultMain-      [ bgroup "splitAt/append"-         [ bench "10" $ nf (shuffle r10) s10-         , bench "100" $ nf (shuffle r100) s100-         , bench "1000" $ nf (shuffle r1000) s1000-         ]-      , bgroup "fromList"-         [ bench "10" $ nf S.fromList [(0 :: Int)..9]-         , bench "100" $ nf S.fromList [(0 :: Int)..99]-         , bench "1000" $ nf S.fromList [(0 :: Int)..999]-         , bench "10000" $ nf S.fromList [(0 :: Int)..9999]-         , bench "100000" $ nf S.fromList [(0 :: Int)..99999]-         ]-      , bgroup "partition"-         [ bench "10" $ nf (S.partition even) s10-         , bench "100" $ nf (S.partition even) s100-         , bench "1000" $ nf (S.partition even) s1000-         , bench "10000" $ nf (S.partition even) s10000-         ]-      , bgroup "foldl'"-         [ bench "10" $ nf (foldl' (+) 0) s10-         , bench "100" $ nf (foldl' (+) 0) s100-         , bench "1000" $ nf (foldl' (+) 0) s1000-         , bench "10000" $ nf (foldl' (+) 0) s10000-         ]-      , bgroup "foldr'"-         [ bench "10" $ nf (foldr' (+) 0) s10-         , bench "100" $ nf (foldr' (+) 0) s100-         , bench "1000" $ nf (foldr' (+) 0) s1000-         , bench "10000" $ nf (foldr' (+) 0) s10000-         ]-      , bgroup "update"-         [ bench "10" $ nf (updatePoints r10 10) s10-         , bench "100" $ nf (updatePoints r100 10) s100-         , bench "1000" $ nf (updatePoints r1000 10) s1000-         ]-      , bgroup "adjust"-         [ bench "10" $ nf (adjustPoints r10 (+10)) s10-         , bench "100" $ nf (adjustPoints r100 (+10)) s100-         , bench "1000" $ nf (adjustPoints r1000 (+10)) s1000-         ]-      , bgroup "deleteAt"-         [ bench "10" $ nf (deleteAtPoints r10) s10-         , bench "100" $ nf (deleteAtPoints r100) s100-         , bench "1000" $ nf (deleteAtPoints r1000) s1000-         ]-      , bgroup "insertAt"-         [ bench "10" $ nf (insertAtPoints r10 10) s10-         , bench "100" $ nf (insertAtPoints r100 10) s100-         , bench "1000" $ nf (insertAtPoints r1000 10) s1000-         ]-      , bgroup "traverseWithIndex/State"-         [ bench "10" $ nf multiplyDown s10-         , bench "100" $ nf multiplyDown s100-         , bench "1000" $ nf multiplyDown s1000-         ]-      , bgroup "traverse/State"-         [ bench "10" $ nf multiplyUp s10-         , bench "100" $ nf multiplyUp s100-         , bench "1000" $ nf multiplyUp s1000-         ]-      , bgroup "replicateA/State"-         [ bench "10" $ nf stateReplicate 10-         , bench "100" $ nf stateReplicate 100-         , bench "1000" $ nf stateReplicate 1000-         ]-      , bgroup "zip"-         [ bench "ix10000/5000" $ nf (\(xs,ys) -> S.zip xs ys `S.index` 5000) (s10000, u10000)-         , bench "nf100" $ nf (uncurry S.zip) (s100, u100)-         , bench "nf10000" $ nf (uncurry S.zip) (s10000, u10000)-         ]-      , bgroup "fromFunction"-         [ bench "ix10000/5000" $ nf (\s -> S.fromFunction s (+1) `S.index` (s `div` 2)) 10000-         , bench "nf10" $ nf (\s -> S.fromFunction s (+1)) 10-         , bench "nf100" $ nf (\s -> S.fromFunction s (+1)) 100-         , bench "nf1000" $ nf (\s -> S.fromFunction s (+1)) 1000-         , bench "nf10000" $ nf (\s -> S.fromFunction s (+1)) 10000-         ]-      , bgroup "<*>"-         [ bench "ix500/1000^2" $-              nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s `div` 2)) (S.fromFunction 1000 (+1))-         , bench "ix500000/1000^2" $-              nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s * S.length s `div` 2)) (S.fromFunction 1000 (+1))-         , bench "ixBIG" $-              nf (\s -> ((+) <$> s <*> s) `S.index` (S.length s * S.length s `div` 2))-                 (S.fromFunction (floor (sqrt $ fromIntegral (maxBound::Int))-10) (+1))-         , bench "nf100/2500/rep" $-              nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (100,2500)-         , bench "nf100/2500/ff" $-              nf (\(s,t) -> (,) <$> S.fromFunction s (+1) <*> S.fromFunction t (*2)) (100,2500)-         , bench "nf500/500/rep" $-              nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (500,500)-         , bench "nf500/500/ff" $-              nf (\(s,t) -> (,) <$> S.fromFunction s (+1) <*> S.fromFunction t (*2)) (500,500)-         , bench "nf2500/100/rep" $-              nf (\(s,t) -> (,) <$> replicate s () <*> replicate t ()) (2500,100)-         , bench "nf2500/100/ff" $-              nf (\(s,t) -> (,) <$> S.fromFunction s (+1) <*> S.fromFunction t (*2)) (2500,100)-         ]-      , bgroup "sort"-         [ bgroup "already sorted"-            [ bench "10" $ nf S.sort s10-            , bench "100" $ nf S.sort s100-            , bench "1000" $ nf S.sort s1000-            , bench "10000" $ nf S.sort s10000]-         , bgroup "random"-            [ bench "10" $ nf S.sort rs10-            , bench "100" $ nf S.sort rs100-            , bench "1000" $ nf S.sort rs1000-            , bench "10000" $ nf S.sort rs10000]-         ]-      , bgroup "unstableSort"-         [ bgroup "already sorted"-            [ bench "10" $ nf S.unstableSort s10-            , bench "100" $ nf S.unstableSort s100-            , bench "1000" $ nf S.unstableSort s1000-            , bench "10000" $ nf S.unstableSort s10000]-         , bgroup "random"-            [ bench "10" $ nf S.unstableSort rs10-            , bench "100" $ nf S.unstableSort rs100-            , bench "1000" $ nf S.unstableSort rs1000-            , bench "10000" $ nf S.unstableSort rs10000]-         ]-      , bgroup "unstableSortOn"-         [ bgroup "already sorted"-            [ bench "10"    $ nf (S.unstableSortOn id) s10-            , bench "100"   $ nf (S.unstableSortOn id) s100-            , bench "1000"  $ nf (S.unstableSortOn id) s1000-            , bench "10000" $ nf (S.unstableSortOn id) s10000]-         , bgroup "random"-            [ bench "10"    $ nf (S.unstableSortOn id) rs10-            , bench "100"   $ nf (S.unstableSortOn id) rs100-            , bench "1000"  $ nf (S.unstableSortOn id) rs1000-            , bench "10000" $ nf (S.unstableSortOn id) rs10000]-         ]-      ]--{---- This is around 4.6 times as slow as insertAt-fakeInsertAt :: Int -> a -> S.Seq a -> S.Seq a-fakeInsertAt i x xs = case S.splitAt i xs of-  (before, after) -> before S.>< x S.<| after--}--adjustPoints :: [Int] -> (a -> a) -> S.Seq a -> S.Seq a-adjustPoints points f xs =-  foldl' (\acc k -> S.adjust f k acc) xs points--insertAtPoints :: [Int] -> a -> S.Seq a -> S.Seq a-insertAtPoints points x xs =-  foldl' (\acc k -> S.insertAt k x acc) xs points--updatePoints :: [Int] -> a -> S.Seq a -> S.Seq a-updatePoints points x xs =-  foldl' (\acc k -> S.update k x acc) xs points--{---- For comparison. Using the old implementation of update,--- which this simulates, can cause thunks to build up in the leaves.-fakeupdatePoints :: [Int] -> a -> S.Seq a -> S.Seq a-fakeupdatePoints points x xs =-  foldl' (\acc k -> S.adjust (const x) k acc) xs points--}--deleteAtPoints :: [Int] -> S.Seq a -> S.Seq a-deleteAtPoints points xs =-  foldl' (\acc k -> S.deleteAt k acc) xs points--{--fakedeleteAtPoints :: [Int] -> S.Seq a -> S.Seq a-fakedeleteAtPoints points xs =-  foldl' (\acc k -> fakeDeleteAt k acc) xs points--- For comparison with deleteAt. deleteAt is several--- times faster for long sequences.-fakeDeleteAt :: Int -> S.Seq a -> S.Seq a-fakeDeleteAt i xs-  | 0 < i && i < S.length xs = case S.splitAt i xs of-                               (before, after) -> before S.>< S.drop 1 after-  | otherwise = xs--}---- splitAt+append: repeatedly cut the sequence at a random point--- and rejoin the pieces in the opposite order.--- Finally getting the middle element forces the whole spine.-shuffle :: [Int] -> S.Seq Int -> Int-shuffle ps s = case S.viewl (S.drop (S.length s `div` 2) (foldl' cut s ps)) of-    x S.:< _ -> x-  where cut xs p = let (front, back) = S.splitAt p xs in back S.>< front--stateReplicate :: Int -> S.Seq Char-stateReplicate n = flip evalState 0 . S.replicateA n $ do-  old <- get-  if old > (10 :: Int) then put 0 else put (old + 1)-  return $ toEnum old--multiplyUp :: S.Seq Int -> S.Seq Int-multiplyUp = flip evalState 0 . traverse go where-  go x = do-    s <- get-    put (s + 1)-    return (s * x)--multiplyDown :: S.Seq Int -> S.Seq Int-multiplyDown = flip evalState 0 . S.traverseWithIndex go where-  go i x = do-    s <- get-    put (s - 1)-    return (s * i * x)
− benchmarks/Set.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Main where--import Control.DeepSeq (rnf)-import Control.Exception (evaluate)-import Criterion.Main (bench, defaultMain, whnf)-import Data.List (foldl')-import qualified Data.Set as S--main = do-    let s = S.fromAscList elems :: S.Set Int-        s_even = S.fromAscList elems_even :: S.Set Int-        s_odd = S.fromAscList elems_odd :: S.Set Int-    evaluate $ rnf [s, s_even, s_odd]-    defaultMain-        [ bench "member" $ whnf (member elems) s-        , bench "insert" $ whnf (ins elems) S.empty-        , bench "map" $ whnf (S.map (+ 1)) s-        , bench "filter" $ whnf (S.filter ((== 0) . (`mod` 2))) s-        , bench "partition" $ whnf (S.partition ((== 0) . (`mod` 2))) s-        , bench "fold" $ whnf (S.fold (:) []) s-        , bench "delete" $ whnf (del elems) s-        , bench "findMin" $ whnf S.findMin s-        , bench "findMax" $ whnf S.findMax s-        , bench "deleteMin" $ whnf S.deleteMin s-        , bench "deleteMax" $ whnf S.deleteMax s-        , bench "unions" $ whnf S.unions [s_even, s_odd]-        , bench "union" $ whnf (S.union s_even) s_odd-        , bench "difference" $ whnf (S.difference s) s_even-        , bench "intersection" $ whnf (S.intersection s) s_even-        , bench "fromList" $ whnf S.fromList elems-        , bench "fromList-desc" $ whnf S.fromList (reverse elems)-        , bench "fromAscList" $ whnf S.fromAscList elems-        , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems-        , bench "disjoint:false" $ whnf (S.disjoint s) s_even-        , bench "disjoint:true" $ whnf (S.disjoint s_odd) s_even-        , bench "null.intersection:false" $ whnf (S.null. S.intersection s) s_even-        , bench "null.intersection:true" $ whnf (S.null. S.intersection s_odd) s_even-        ]-  where-    elems = [1..2^12]-    elems_even = [2,4..2^12]-    elems_odd = [1,3..2^12]--member :: [Int] -> S.Set Int -> Int-member xs s = foldl' (\n x -> if S.member x s then n + 1 else n) 0 xs--ins :: [Int] -> S.Set Int -> S.Set Int-ins xs s0 = foldl' (\s a -> S.insert a s) s0 xs--del :: [Int] -> S.Set Int -> S.Set Int-del xs s0 = foldl' (\s k -> S.delete k s) s0 xs
− benchmarks/SetOperations/Makefile 
@@ -1,3 +0,0 @@-TOP = ../--include ../Makefile
− benchmarks/SetOperations/SetOperations-IntMap.hs 
@@ -1,6 +0,0 @@-module Main where--import Data.IntMap as C-import SetOperations--main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True [("union", C.union), ("difference", C.difference), ("intersection", C.intersection)]
− benchmarks/SetOperations/SetOperations-IntSet.hs 
@@ -1,6 +0,0 @@-module Main where--import Data.IntSet as C-import SetOperations--main = benchmark fromList True [("union", C.union), ("difference", C.difference), ("intersection", C.intersection)]
− benchmarks/SetOperations/SetOperations-Map.hs 
@@ -1,6 +0,0 @@-module Main where--import Data.Map as C-import SetOperations--main = benchmark (\xs -> fromList [(x, x) | x <- xs]) True [("union", C.union), ("difference", C.difference), ("intersection", C.intersection)]
− benchmarks/SetOperations/SetOperations-Set.hs 
@@ -1,6 +0,0 @@-module Main where--import Data.Set as C-import SetOperations--main = benchmark fromList True [("union", C.union), ("difference", C.difference), ("intersection", C.intersection)]
− benchmarks/SetOperations/SetOperations.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module SetOperations (benchmark) where--import Criterion.Main (bench, defaultMain, whnf)-import Data.List (partition)--benchmark :: ([Int] -> container) -> Bool -> [(String, container -> container -> container)] -> IO ()-benchmark fromList swap methods = do-  defaultMain $ [ bench (method_str++"-"++input_str) $ whnf (method input1) input2 | (method_str, method) <- methods, (input_str, input1, input2) <- inputs ]--  where-    n, s, t :: Int-    n = 100000-    s {-small-} = n `div` 10-    t {-tiny-} = round $ sqrt $ fromIntegral n--    inputs = [ (mode_str, left, right)-             | (mode_str, (left, right)) <- [ ("disj_nn", disj_nn), ("disj_ns", disj_ns), ("disj_nt", disj_nt)-                                            , ("common_nn", common_nn), ("common_ns", common_ns), ("common_nt", common_nt)-                                            , ("mix_nn", mix_nn), ("mix_ns", mix_ns), ("mix_nt", mix_nt)-                                            , ("block_nn", block_nn), ("block_ns", block_ns)-                                            ]--             , (mode_str, left, right) <- replicate 2 (mode_str, left, right) ++-                                          replicate (if swap && take 4 mode_str /= "diff" && last mode_str /= last (init mode_str) then 2 else 0)-                                            (init (init mode_str) ++ [last mode_str] ++ [last (init mode_str)], right, left)-             ]--    all_n = fromList [1..n]--    !disj_nn = seqPair $ (all_n, fromList [n+1..n+n])-    !disj_ns = seqPair $ (all_n, fromList [n+1..n+s])-    !disj_nt = seqPair $ (all_n, fromList [n+1..n+t])-    !common_nn = seqPair $ (all_n, fromList [2,4..n])-    !common_ns = seqPair $ (all_n, fromList [0,1+n`div`s..n])-    !common_nt = seqPair $ (all_n, fromList [0,1+n`div`t..n])-    !mix_nn = seqPair $ fromLists $ partition ((/= 0) . (`mod` 2)) [1..n+n]-    !mix_ns = seqPair $ fromLists $ partition ((/= 0) . (`mod` (1 + n`div`s))) [1..s+n]-    !mix_nt = seqPair $ fromLists $ partition ((/= 0) . (`mod` (1 + n`div`t))) [1..t+n]-    !block_nn = seqPair $ fromLists $ partition ((>= t) . (`mod` (t * 2))) [1..n+n]-    !block_ns = seqPair $ fromLists $ partition ((>= t) . (`mod` (t * (1 + n`div`s)))) [1..s+n]--    fromLists (xs, ys) = (fromList xs, fromList ys)-    seqPair pair@(xs, ys) = xs `seq` ys `seq` pair
− benchmarks/bench-cmp.pl 
@@ -1,24 +0,0 @@-#!/usr/bin/perl-use warnings;-use strict;--@ARGV >= 2 or die "Usage: bench-cmp.pl csv_file_1 csv_file_2";-open (my $f1, "<", $ARGV[0]) or die "Cannot open file $ARGV[0]";-open (my $f2, "<", $ARGV[1]) or die "Cannot open file $ARGV[1]";--my $l1 = <$f1>;-my $l2 = <$f2>;-$l1 eq $l2 or die "CSV files do not correspond -- $l1 and $l2";--while (defined($l1 = <$f1>)) {-  $l2 = <$f2>;--  my @parts1 = split /,/, $l1;-  my @parts2 = split /,/, $l2;--  $parts1[0] eq $parts2[0] or die "CSV files do not correspond -- $parts1[0] and $parts2[0]";-  printf "%s;%+7.2f%%;%.2e\n", $parts1[0], 100 * $parts2[1] / $parts1[1] - 100, $parts1[1];-}--close $f2;-close $f1;
− benchmarks/bench-cmp.sh 
@@ -1,3 +0,0 @@-#!/bin/sh--(echo 'Benchmark;Runtime change;Original runtime'; ./bench-cmp.pl "$@") | column -ts\;
changelog.md view
@@ -1,5 +1,471 @@ # Changelog for [`containers` package](http://github.com/haskell/containers) +## 0.8  *March 2025*++### Breaking changes++* `Data.IntMap.Lazy.split`, `Data.IntMap.Strict.split`,+  `Data.IntMap.Lazy.splitLookup`, `Data.IntMap.Strict.splitLookup` and+  `Data.IntSet.splitMember` are now strict in the key. Previously, the key was+  ignored for an empty map or set. (Soumik Sarkar)+  ([#982](https://github.com/haskell/containers/pull/982),+  [#983](https://github.com/haskell/containers/pull/983))++* These functions have been updated to match the strictness of their+  `fromList` counterparts:++  * `Data.Map.Strict`: `fromAscList`, `fromAscListWith`, `fromAscListWithKey`+    `fromDescList`, `fromDescListWith`, `fromDescListWithKey`+  * `Data.IntMap.Strict`: `fromAscList`, `fromAscListWith`, `fromAscListWithKey`++  Previously they were lazier and did not force the first value in runs of at+  least 2 entries with equal keys. (Soumik Sarkar)+  ([#1023](https://github.com/haskell/containers/pull/1023))++* `Data.Set.fold` and `Data.IntSet.fold` are deprecated. One should instead use+  `Data.Set.foldr` and `Data.IntSet.foldr`. (Soumik Sarkar)+  ([#1049](https://github.com/haskell/containers/pull/1049))++* For `Data.IntMap.{Lazy,Strict}`, `updateMin`, `updateMax`, `updateMinWithKey`,+  `updateMaxWithKey` now return an empty map for an input empty map instead of+  calling `error`. This matches the behavior of `Data.Map`. (Kushagra Gupta)+  ([#1065](https://github.com/haskell/containers/pull/1065))++* `foldl'` and `foldr'` for `Seq` are now strict in the initial value. This+  matches the behavior of the default implementations and of other structures in+  the library. (Soumik Sarkar)+  ([#1077](https://github.com/haskell/containers/pull/1077))++* Some long deprecated functions, whose definitions currently cause type errors,+  have been removed. (Soumik Sarkar)+  ([#1046](https://github.com/haskell/containers/pull/1046))++### Bug fixes++* Make the package compile with [MicroHs](https://github.com/augustss/MicroHs).+  (Lennart Augustsson)+  ([#1043](https://github.com/haskell/containers/pull/1043),+  [#1081](https://github.com/haskell/containers/pull/1081))++* Fix a strictness bug in `Data.Map.Strict.fromDistinctAscList` and+  `Data.Map.Strict.fromDistinctDescList` where all values were not forced to+  WHNF. This bug affects versions 0.6.8 and 0.7. (Neil Mayhew)+  ([#996](https://github.com/haskell/containers/pull/996))++* Fix a bug in `Data.IntMap`'s `isProperSubmapOfBy` where it could incorrectly+  return `False`. (Soumik Sarkar)+  ([#1008](https://github.com/haskell/containers/pull/1008))++* Make `Data.Map.Merge.{Lazy,Strict}.filterAMissing` sequence effects in the+  correct order. (j6carey)+  ([#1005](https://github.com/haskell/containers/pull/1005))++* `Data.Map.Strict.mergeWithKey` now forces the result of the combining function+  to WHNF. (Soumik Sarkar)+  ([#1024](https://github.com/haskell/containers/pull/1024))++* Fix an issue where `Data.Map.mergeWithKey`, `Data.Map.Strict.mergeWithKey`,+  `Data.IntMap.mergeWithKey`, `Data.IntMap.Strict.mergeWithKey` could call the+  provided `only2` function with empty maps, contrary to documentation.+  (Soumik Sarkar) ([#1025](https://github.com/haskell/containers/pull/1025))++### Additions++* Add `Data.Graph.flattenSCC1`. (Andreas Abel)+  ([#987](https://github.com/haskell/containers/pull/987))++* Add `symmetricDifference` for `Set`, `Map`, `IntSet`, `IntMap`.+  (Soumik Sarkar) ([#1009](https://github.com/haskell/containers/pull/1009))++* Add `lookupMin` and `lookupMax` for `Data.IntSet`. (Soumik Sarkar)+  ([#976](https://github.com/haskell/containers/pull/976))++* Add `Intersection` and `intersections` for `Data.Set` and `Data.IntSet`.+  (Reed Mullanix, Soumik Sarkar)+  ([#756](https://github.com/haskell/containers/pull/756),+  [#1040](https://github.com/haskell/containers/pull/1040),+  [#1052](https://github.com/haskell/containers/pull/1052),+  [#1080](https://github.com/haskell/containers/pull/1080))++* Add `foldMap` for `Data.IntSet`. (Soumik Sarkar)+  ([#1048](https://github.com/haskell/containers/pull/1048))++* Add `filterKeys` for `Data.Map` and `Data.IntMap`. (flip111)+  ([#972](https://github.com/haskell/containers/pull/972))++* `NFData1`, `NFData2` instances for `SCC`, `IntMap`, `Map`, `Sequence`, `Set`,+  `Tree` and relevant internal dependencies (David Beacham)+  ([#992](https://github.com/haskell/containers/pull/992))++* Add `leaves`, `edges`, `pathsToRoot`, `pathsFromRoot`, `PostOrder` to+  `Data.Tree`. (Soumik Sarkar)+  ([#1109](https://github.com/haskell/containers/pull/1109))++### Performance improvements++* The internal representations of `IntMap` and `IntSet` have been changed+  to be a little more memory efficient. Consequently, many functions on+  `IntMap`s and `IntSet`s are a little faster now. (Soumik Sarkar)+  ([#995](https://github.com/haskell/containers/pull/995),+  [#998](https://github.com/haskell/containers/pull/998))++* Improved performance for `Data.Map`'s `minView`, `maxView`, `difference`.+  (Soumik Sarkar) ([#1001](https://github.com/haskell/containers/pull/1001))++* For `Data.Graph.SCC`, `Foldable.toList` and `Foldable1.toNonEmpty` now+  do not perform an unnecessary copy. (Soumik Sarkar)+  ([#1057](https://github.com/haskell/containers/pull/1057))++* Improved performance for `Data.Intset`'s `foldr`, `foldl'`, `foldl`, `foldr'`.+  (Soumik Sarkar) ([#1079](https://github.com/haskell/containers/pull/1079))++* Improved performance for `Data.Set` and `Data.Map`'s `fromAscList*` and+  `fromDescList*` functions. (Soumik Sarkar)+  ([#1083](https://github.com/haskell/containers/pull/1083))++* Improved performance for `Data.Set`'s `fromList`, `map` and `Data.Map`'s+  `fromList`, `fromListWith`, `fromListWithKey`, `mapKeys`, `mapKeysWith`.+  (Soumik Sarkar) ([#1042](https://github.com/haskell/containers/pull/1042))++* Improved performance for many `Set` and `Map` modification operations,+  including `insert` and `delete`, by inlining part of the balancing+  routine. (Soumik Sarkar)+  ([#1056](https://github.com/haskell/containers/pull/1056))++* Improved performance for `Eq` and `Ord` instances of `Set`, `Map`, `IntSet`,+  `IntMap`, `Seq`. (Soumik Sarkar)+  ([#1028](https://github.com/haskell/containers/pull/1028),+  [#1017](https://github.com/haskell/containers/pull/1017),+  [#1035](https://github.com/haskell/containers/pull/1035),+  [#1086](https://github.com/haskell/containers/pull/1086),+  [#1112](https://github.com/haskell/containers/pull/1112))++### Documentation++* Add and improve documentation (Bodigrim, konsumlamm, Toni Dietze, alexfmpe,+  Soumik Sarkar, Jonathan Knowles, Xavier Góngora, Xia Li-yao, eyelash)+  ([#957](https://github.com/haskell/containers/pull/957),+  [#1006](https://github.com/haskell/containers/pull/1006),+  [#877](https://github.com/haskell/containers/pull/877),+  [#960](https://github.com/haskell/containers/pull/960),+  [#1033](https://github.com/haskell/containers/pull/1033),+  [#1041](https://github.com/haskell/containers/pull/1041),+  [#1039](https://github.com/haskell/containers/pull/1039),+  [#1050](https://github.com/haskell/containers/pull/1050),+  [#1088](https://github.com/haskell/containers/pull/1088),+  [#1087](https://github.com/haskell/containers/pull/1087),+  [#1098](https://github.com/haskell/containers/pull/1098),+  [#1106](https://github.com/haskell/containers/pull/1106),+  [#1104](https://github.com/haskell/containers/pull/1104),+  [#1105](https://github.com/haskell/containers/pull/1105),+  [#1111](https://github.com/haskell/containers/pull/1111),+  [#1110](https://github.com/haskell/containers/pull/1110),+  [#1114](https://github.com/haskell/containers/pull/1114),+  [#1115](https://github.com/haskell/containers/pull/1115))++### Miscellaneous/internal++* Internal modules `Utils.Containers.Internal.BitUtil`,+  `Utils.Containers.Internal.BitQueue`, `Utils.Containers.Internal.StrictPair`+  are no longer exposed. (Soumik Sarkar)+  ([#1101](https://github.com/haskell/containers/pull/1101))++* Test and CI maintenance. (Andreas Abel, Soumik Sarkar)+  ([#986](https://github.com/haskell/containers/pull/986),+  [#1015](https://github.com/haskell/containers/pull/1015),+  [#1030](https://github.com/haskell/containers/pull/1030),+  [#1055](https://github.com/haskell/containers/pull/1055),+  [#1067](https://github.com/haskell/containers/pull/1067))++* Internal cleanups and improvements. (Soumik Sarkar, alexfmpe)+  ([#1000](https://github.com/haskell/containers/pull/1000),+  [#959](https://github.com/haskell/containers/pull/959),+  [#1020](https://github.com/haskell/containers/pull/1020),+  [#1029](https://github.com/haskell/containers/pull/1029),+  [#1031](https://github.com/haskell/containers/pull/1031),+  [#1037](https://github.com/haskell/containers/pull/1037),+  [#1058](https://github.com/haskell/containers/pull/1058),+  [#1076](https://github.com/haskell/containers/pull/1076),+  [#1084](https://github.com/haskell/containers/pull/1084),+  [#1085](https://github.com/haskell/containers/pull/1085),+  [#1093](https://github.com/haskell/containers/pull/1093),+  [#1094](https://github.com/haskell/containers/pull/1094),+  [#1095](https://github.com/haskell/containers/pull/1095),+  [#1097](https://github.com/haskell/containers/pull/1097),+  [#1103](https://github.com/haskell/containers/pull/1103),+  [#1117](https://github.com/haskell/containers/pull/1117))++* Add new tests and benchmarks (Soumik Sarkar)+  ([#962](https://github.com/haskell/containers/pull/962),+  [#1021](https://github.com/haskell/containers/pull/1021),+  [#1063](https://github.com/haskell/containers/pull/1063),+  [#1068](https://github.com/haskell/containers/pull/1068),+  [#1071](https://github.com/haskell/containers/pull/1071),+  [#1075](https://github.com/haskell/containers/pull/1075),+  [#1082](https://github.com/haskell/containers/pull/1082))++* Fix the Read the Docs tutorial (Soumik Sarkar)+  ([#1091](https://github.com/haskell/containers/pull/1091),+  [#1099](https://github.com/haskell/containers/pull/1099))++## 0.7++### Breaking changes++* Breaking changes to `Data.Graph.SCC v` (bodʲɪˈɡrʲim):+  * `CyclicSCC [v]` is now not a constructor,+    but a bundled pattern synonym for backward compatibility.+  * `NECyclicSCC (NonEmpty v)` is a new constructor, maintaining an invariant+    that a set of mutually reachable vertices is non-empty.++## 0.6.8++### Additions++* Add `Data.IntSet.fromRange`. (Soumik Sarkar)++### Improvements++* Speed up conversion from monotonic lists to `Set`s and+  `Map`s. (Soumik Sarkar)++### Documentation and other++* Add, improve, and correct documentation. (Niklas Hambüchen, Soumik Sarkar,+  tomjaguarpaw, Alice Rixte, Tom Smeding)++### Other/internal++* Remove the `stack.yaml` file. It was extremely stale, and its utility was a+  bit dubious in a GHC boot package. Closes #938.++* Add a bunch of new tests and benchmarks. (Soumik Sarkar)++* Future-proof test suite against export of `foldl'` from `Prelude`.+  (Teo Camarasu)++## 0.6.7++### Additions++* Add `takeWhileAntitone`, `dropWhileAntitone`, and `spanAntitone` for `IntMap`+  and `IntSet`. (Soumik Sarkar)++* Add a `Foldable1` instance for `Data.Tree`.++### Improvements++* Speed up splitting functions for `IntSet` and `IntMap`. (Soumik Sarkar)++* Speed up `Foldable` methods for `Data.Tree`. (Soumik Sarkar)++* Speed up `Data.Graph.dfs` (Soumik Sarkar)++* Inline a few functions in `Data.Graph` to enable list fusion. This+  immediately improves the performance of the `transposeG` and `scc` functions.+  Mark several others `INLINABLE` to allow specialization.  (Soumik Sarkar)++* Optimize `Data.Graph.bcc`, most notably replacing lists by difference lists+  to avoid quadratic complexity. (Soumik Sarkar)++### Documentation++* Improve various documentation and documentation formatting (Joseph C. Sible,+  konsumlamm, Soumik Sarkar, Alberto Fanton)++* Add and correct time complexity documentation. (Soumik Sarkar)++* Update `CONTRIBUTING.md` instructions for building with `stack` and `cabal`,+  and add a note about how to avoid unnecessary recompilations. (Melanie+  Phoenix)++### Miscellaneous/internal++* Remove now-redundant CPP. (Alexandre Esteves)+* Avoid `head` and `tail`. (Bodigrim)+* Fix build paths in `gitignore`. (Alexandre Esteves)+* Add extra implicit dependencies for `DeriveLift`. (Matthew Pickering)+* Work around `Prelude` changes for `liftA2`. (David Feuer)+* Add several property tests and too many benchmarks to count. (Soumik Sarkar)+* Add benchmarks for `Data.Set.powerSet`. (jwaldmann)+* Improve `Data.Set.powerSet` property test. (David Feuer)+* Fix test name. (Marcin Szamotulski)+* Fix error messages in internal `Data.Set` functions. (Erik de Castro Lopo)++## 0.6.6++### Additions++* Add `Lift` instances for use with Template Haskell. Specifically:+  `Seq`, `ViewL`, and `ViewR` (in `Data.Sequence`), `Map`, `Set`,+  `IntMap`, `IntSet`, `Tree`, and `SCC` (in `Data.Graph`). (David Feuer)++* Add `argSet` and `fromArgSet` for `Data.Map`. (Joseph C. Sible)++### Performance improvements++* Remove short-circuiting from certain `IntMap` functions to improve+  performance for successful lookups. (Callan McGill)++### Other changes++* Drop support for GHC versions before 8.0.2. (David Feuer)++* Various documentation improvements. (Will Hawkins, Eric Lindblad, konsumlamm,+  Joseph C. Sible)++### Miscellaneous/internal++* Bump Cabal version for tests, and use `common` clauses to reduce+  duplication. (David Feuer)++* Migrate from test-framework to tasty. (Bodigrim)++* Migrate from gauge to tasty-bench. (Bodigrim)++* Enable `TypeOperators` to address a future GHC requirement.+  (Vladislav Zavialov)++* Work around an issue with unboxed arrays on big-endian systems.+  (Peter Trommler)++## 0.6.5.1++### Bug fixes++* `foldr'` and `foldl'` for `Map` and `Set` are now strict everywhere they+  should be, and we have detailed tests to make sure they stay that way.+  (Thanks, coot.)++* The `Ord IntSet` instance, which was broken in 0.6.3.1, has been+  repaired.++### New instance++* We now have `Ord a => Ord (Tree a)` (Thanks, Ericson2314.)++### Testing fixes++* Thanks to konsumlamm and infinity0 for various bug fixes in the test suite.++## 0.6.4.1++### Bug fixes++* [Replace value-forcing variants of `compose` with lazy variants.](https://github.com/haskell/containers/pull/745)+  *  This brings `compose` closer in line with functions like `union` and `intersection` which don't evaluate any map values. (Thanks, Simon Jakobi)++### Additions++* [Add `reverseTopSort` to `Data.Graph`](https://github.com/haskell/containers/pull/638) (Thanks, James Parker)++* [Expose `traverseMaybeWithKey` from `Data.IntMap.{Lazy,Strict}`](https://github.com/haskell/containers/pull/743) (Thanks, Simon+  Jakobi)++### Other changes++* Improvements to the testsuite: [#663](https://github.com/haskell/containers/pull/663), [#662](https://github.com/haskell/containers/pull/662) (Thanks, Bertram Felgenhauer)++* [Fix build with `stack test`](https://github.com/haskell/containers/pull/738) (Thanks, Simon Jakobi)++[0.6.4.1]: https://github.com/haskell/containers/compare/v0.6.3.1-release...v0.6.4.1++## 0.6.3.1++### Bug fixes++* Fix `traverse` and `traverseWithKey` for `IntMap`, which would+  previously produce invalid `IntMap`s when the input contained+  negative keys (Thanks, Felix Paulusma).++* Fix the traversal order of various functions for `Data.IntMap`:+  `traverseWithKey`, `traverseMaybeWithKey`, `filterWithKeyA`,+  `minimum`, `maximum`, `mapAccum`, `mapAccumWithKey`, `mapAccumL`,+  `mapAccumRWithKey`, `mergeA` (Thanks, Felix Paulusma, Simon Jakobi).++### Additions++* Add `compose` for `Map` and `IntMap` (Thanks, Alexandre Esteves).++* Add `alterF` for `Set` and `IntSet` (Thanks, Simon Jakobi).++* Add `Data.IntSet.mapMonotonic` (Thanks, Javran Cheng).++* Add `instance Bifoldable Map` (Thanks, Joseph C. Sible).++### Performance improvements++* Make `(<*)` for `Data.Sequence` incrementally asymptotically optimal.+  This finally completes the task, begun in December 2014, of making all+  the `Applicative` methods for sequences asymptotically optimal+  even when their results are consumed incrementally. Many thanks to+  Li-Yao Xia and Bertram Felgenhauer for helping to clean up and begin+  to document this rather tricky code.++* Speed up `fromList` and related functions in `Data.IntSet`, `Data.IntMap`+  and `Data.IntMap.Strict` (Thanks, Bertram Felgenhauer).++* Use `count{Leading,Trailing}Zeros` in `Data.IntSet` internals (Thanks, Alex+  Biehl).++### Other changes++* Reduce usage of the `Forest` type synonym in `Data.Tree` (Thanks, David+  Feuer).++* Address a Core lint warning for `foldToMaybeTree` (Thanks, Matthew Pickering).++* Improve documentation (Thanks to Daniel Wagner, Johannes Waldmann, Steve Mao,+  Gabriel Greif, Jean-Baptiste Mazon, Ziyang Liu, Matt Renaud, Li-Yao Xia).++* Improvements to the testsuite and benchmarks (Thanks, Bertram Felgenhauer,+  Simon Jakobi, Johannes Waldmann).++* Canonicalise `Seq`'s `Monoid` instance (Thanks, Fumiaki Kinoshita).++## 0.6.2.1++* Add `disjoint` for `Map` and `IntMap` (Thanks, Simon Jakobi).++* Fix documentation bugs (Thanks, olligobber).++* Fix unused imports (Thanks, Ben Gamari).++## 0.6.1.1++* Fix Foldable instance for IntMap, which previously placed positively+  keyed entries before negatively keyed ones for `fold`, `foldMap`, and+  `traverse`.++* Make strict `IntMap` merges strict.++* Make `Data.IntMap.Merge.Strict` tactics (except `preserveMissing`)+  strict.++* Add a strict `Data.Map.Merge.Strict.preserveMissing'` tactic.++* Make `stimes` for sequences work with 0 arguments, and make it more+  efficient.++* Speed up `cartesianProduct` for `Data.Set`.++* Speed up `Data.Set.isSubsetOf`, `Data.Map.isSubmapOf`, and `Data.Set.disjoint`.++* Allow inlining for `Data.Sequence.traverseWithIndex`, making it faster+  than `sequence` combined with `mapWithIndex`.++* Produce more concise assembly from `maskW`. (Thanks, Mateusz Kowalczyk)++* Use `countLeadingZeros` to implement `highestBitMask` (Thanks, Dmitry+  Ivanov)++* Improve documentation. (Thanks to jwaldmann, Yuji Yamamoto, David Sanders,+  Alec Theriault, Vaibhav Sagar, Boro Sitnikovski, Morten Kolstad, Vados,+  Benjamin Web, Chris Martin, Alexandre Esteves).++* Clean up packaging and testing. (Thanks, David Eichmann, Simon Jakobi,+  Oleg Grenrus, Andreas Klebinger)+ ## 0.6.0.1  * Released with GHC 8.6@@ -86,13 +552,13 @@  * Rewrite the `IsString` instance head for sequences, improving compatibility   with the list instance and also improving type inference. We used to have-  +   ```haskell   instance IsString (Seq Char)   ```-  +   Now we commit more eagerly with-  +   ```haskell   instance a ~ Char => IsString (Seq a)   ```@@ -166,7 +632,7 @@ * Fix completely incorrect implementations of `Data.IntMap.restrictKeys` and   `Data.IntMap.withoutKeys`. Make the tests for these actually run. (Thanks   to Tom Smalley for reporting this.)-  + * Fix a minor bug in the `Show1` instance of `Data.Tree`. This produced valid   output, but with fewer parentheses than `Show`. (Thanks, Ryan Scott.) @@ -221,7 +687,7 @@     before 7.0.    * Integrate benchmarks with Cabal. (Thanks, Gabriel Gonzalez!)-  +   * Make Cabal report required extensions properly, and stop using     default extensions. Note that we do *not* report extensions conditionally enabled     based on GHC version, as doing so would lead to a maintenance nightmare@@ -271,7 +737,7 @@     it returned a lazy pair.    * Fix completely erroneous definition of `length` for `Data.Sequence.ViewR`.-  +   * Make `Data.Map.Strict.traverseWithKey` force result values before     installing them in the new map.
containers.cabal view
@@ -1,8 +1,10 @@+cabal-version: 2.2 name: containers-version: 0.6.0.1-license: BSD3+version: 0.8+license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org+homepage: https://github.com/haskell/containers bug-reports: https://github.com/haskell/containers/issues synopsis: Assorted concrete container types category: Data Structures@@ -20,30 +22,26 @@     remains valid even if structures are shared.  build-type: Simple-cabal-version:  >=1.8+extra-doc-files:+    changelog.md extra-source-files:     include/containers.h-    tests/Makefile-    tests/*.hs-    benchmarks/Makefile-    benchmarks/bench-cmp.pl-    benchmarks/bench-cmp.sh-    benchmarks/*.hs-    benchmarks/SetOperations/Makefile-    benchmarks/SetOperations/*.hs-    benchmarks/LookupGE/Makefile-    benchmarks/LookupGE/*.hs-    changelog.md+    mkappend.hs +tested-with:+  GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 ||+      ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1+ source-repository head     type:     git-    location: http://github.com/haskell/containers.git+    location: https://github.com/haskell/containers  Library-    build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5+    default-language: Haskell2010+    build-depends: base >= 4.10 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.6     if impl(ghc)-        build-depends: ghc-prim-+       build-depends: template-haskell+    hs-source-dirs: src     ghc-options: -O2 -Wall      other-extensions: CPP, BangPatterns@@ -53,11 +51,13 @@         Data.IntMap         Data.IntMap.Lazy         Data.IntMap.Strict+        Data.IntMap.Strict.Internal         Data.IntMap.Internal         Data.IntMap.Internal.Debug         Data.IntMap.Merge.Lazy         Data.IntMap.Merge.Strict         Data.IntSet.Internal+        Data.IntSet.Internal.IntTreeCommons         Data.IntSet         Data.Map         Data.Map.Lazy@@ -74,523 +74,15 @@         Data.Sequence.Internal         Data.Sequence.Internal.Sorting         Data.Tree-        Utils.Containers.Internal.BitUtil-        Utils.Containers.Internal.BitQueue-        Utils.Containers.Internal.StrictPair      other-modules:+        Utils.Containers.Internal.Prelude         Utils.Containers.Internal.State         Utils.Containers.Internal.StrictMaybe         Utils.Containers.Internal.PtrEquality-        Utils.Containers.Internal.Coercions-    if impl(ghc)-      other-modules:-        Utils.Containers.Internal.TypeError-        Data.Map.Internal.DeprecatedShowTree-        Data.IntMap.Internal.DeprecatedDebug--    include-dirs: include---------------------------------- B E N C H M A R K I N G ----------------------------------benchmark intmap-benchmarks-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks-  main-is: IntMap.hs-  ghc-options: -O2-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3,-    deepseq >= 1.1.0.0 && < 1.5--benchmark intset-benchmarks-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks-  main-is: IntSet.hs-  ghc-options: -O2-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3,-    deepseq >= 1.1.0.0 && < 1.5--benchmark map-benchmarks-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks-  main-is: Map.hs-  ghc-options: -O2-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3,-    deepseq >= 1.1.0.0 && < 1.5,-    transformers--benchmark sequence-benchmarks-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks-  main-is: Sequence.hs-  ghc-options: -O2-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3,-    deepseq >= 1.1.0.0 && < 1.5,-    random < 1.2,-    transformers--benchmark set-benchmarks-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks-  main-is: Set.hs-  ghc-options: -O2-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3,-    deepseq >= 1.1.0.0 && < 1.5--benchmark set-operations-intmap-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks/SetOperations-  main-is: SetOperations-IntMap.hs-  other-modules: SetOperations-  ghc-options: -O2-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3--benchmark set-operations-intset-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks/SetOperations-  main-is: SetOperations-IntSet.hs-  other-modules: SetOperations-  ghc-options: -O2-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3--benchmark set-operations-map-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks/SetOperations-  main-is: SetOperations-Map.hs-  other-modules: SetOperations-  ghc-options: -O2-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3--benchmark set-operations-set-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks/SetOperations-  main-is: SetOperations-Set.hs-  other-modules: SetOperations-  ghc-options: -O2-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3--benchmark lookupge-intmap-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks/LookupGE, .-  main-is: IntMap.hs-  other-modules:-      Data.IntMap-      Data.IntMap.Internal.DeprecatedDebug-      Data.IntMap.Lazy-      Data.IntMap.Strict-      Data.IntSet.Internal-      LookupGE_IntMap-      Utils.Containers.Internal.BitUtil-      Utils.Containers.Internal.StrictPair-      Utils.Containers.Internal.TypeError-  ghc-options: -O2-  cpp-options: -DTESTING-  other-modules:-    Data.IntMap.Internal-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3,-    deepseq >= 1.1.0.0 && < 1.5,-    ghc-prim--benchmark lookupge-map-  type: exitcode-stdio-1.0-  hs-source-dirs: benchmarks/LookupGE, .-  main-is: Map.hs-  other-modules:-      Data.Map-      Data.Map.Internal.Debug-      Data.Map.Internal.DeprecatedShowTree-      Data.Map.Lazy-      Data.Map.Strict-      Data.Map.Strict.Internal-      Data.Set.Internal-      LookupGE_Map-      Utils.Containers.Internal.BitQueue-      Utils.Containers.Internal.BitUtil-      Utils.Containers.Internal.PtrEquality-      Utils.Containers.Internal.StrictMaybe-      Utils.Containers.Internal.StrictPair-  ghc-options: -O2-  cpp-options: -DTESTING-  other-modules:-    Data.Map.Internal-  build-depends:-    base >= 4.6 && < 5,-    containers,-    criterion >= 0.4.0 && < 1.3,-    deepseq >= 1.1.0.0 && < 1.5,-    ghc-prim------------------------ T E S T I N G -------------------------- Every test-suite contains the build-depends and options of the library,--- plus the testing stuff.--Test-suite map-lazy-properties-    hs-source-dirs: tests, .-    main-is: map-properties.hs-    other-modules:-        Data.Map.Internal-        Data.Map.Internal.Debug-        Data.Map.Internal.DeprecatedShowTree-        Data.Map.Lazy-        Data.Map.Merge.Lazy-        Data.Set-        Data.Set.Internal-        Utils.Containers.Internal.BitQueue+        Utils.Containers.Internal.EqOrdUtil         Utils.Containers.Internal.BitUtil-        Utils.Containers.Internal.PtrEquality-        Utils.Containers.Internal.StrictMaybe-        Utils.Containers.Internal.StrictPair-    type: exitcode-stdio-1.0-    cpp-options: -DTESTING--    build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim-    ghc-options: -O2-    other-extensions: CPP, BangPatterns-    include-dirs: include--    build-depends:-        HUnit,-        QuickCheck >= 2.7.1,-        test-framework,-        test-framework-hunit,-        test-framework-quickcheck2,-        transformers--Test-suite map-strict-properties-    hs-source-dirs: tests, .-    main-is: map-properties.hs-    other-modules:-        Data.Map.Internal-        Data.Map.Internal.Debug-        Data.Map.Internal.DeprecatedShowTree-        Data.Map.Merge.Strict-        Data.Map.Strict-        Data.Map.Strict.Internal-        Data.Set-        Data.Set.Internal         Utils.Containers.Internal.BitQueue-        Utils.Containers.Internal.BitUtil-        Utils.Containers.Internal.PtrEquality-        Utils.Containers.Internal.StrictMaybe         Utils.Containers.Internal.StrictPair-    type: exitcode-stdio-1.0-    cpp-options: -DTESTING -DSTRICT -    build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim-    ghc-options: -O2-    other-extensions: CPP, BangPatterns     include-dirs: include--    build-depends:-        HUnit,-        QuickCheck >= 2.7.1,-        test-framework,-        test-framework-hunit,-        test-framework-quickcheck2,-        transformers--Test-suite bitqueue-properties-    hs-source-dirs: tests, .-    main-is: bitqueue-properties.hs-    other-modules:-        Utils.Containers.Internal.BitQueue-        Utils.Containers.Internal.BitUtil-    type: exitcode-stdio-1.0-    cpp-options: -DTESTING--    build-depends: base >= 4.6 && < 5, ghc-prim-    ghc-options: -O2-    other-extensions: CPP, BangPatterns-    include-dirs: include--    build-depends:-        QuickCheck >= 2.7.1,-        test-framework,-        test-framework-quickcheck2--Test-suite set-properties-    hs-source-dirs: tests, .-    main-is: set-properties.hs-    other-modules:-        Data.IntSet-        Data.IntSet.Internal-        Data.Set-        Data.Set.Internal-        Utils.Containers.Internal.BitUtil-        Utils.Containers.Internal.PtrEquality-        Utils.Containers.Internal.StrictPair-    type: exitcode-stdio-1.0-    cpp-options: -DTESTING--    build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim-    ghc-options: -O2-    other-extensions: CPP, BangPatterns-    include-dirs: include--    build-depends:-        HUnit,-        QuickCheck >= 2.7.1,-        test-framework,-        test-framework-hunit,-        test-framework-quickcheck2,-        transformers--Test-suite intmap-lazy-properties-    hs-source-dirs: tests, .-    main-is: intmap-properties.hs-    other-modules:-        Data.IntMap.Internal-        Data.IntMap.Internal.Debug-        Data.IntMap.Internal.DeprecatedDebug-        Data.IntMap.Lazy-        Data.IntSet-        Data.IntSet.Internal-        IntMapValidity-        Utils.Containers.Internal.BitUtil-        Utils.Containers.Internal.StrictPair-        Utils.Containers.Internal.TypeError-    type: exitcode-stdio-1.0-    cpp-options: -DTESTING--    build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim-    ghc-options: -O2-    other-extensions: CPP, BangPatterns-    include-dirs: include--    build-depends:-        HUnit,-        QuickCheck >= 2.7.1,-        test-framework,-        test-framework-hunit,-        test-framework-quickcheck2--Test-suite intmap-strict-properties-    hs-source-dirs: tests, .-    main-is: intmap-properties.hs-    other-modules:-        Data.IntMap.Internal-        Data.IntMap.Internal.Debug-        Data.IntMap.Internal.DeprecatedDebug-        Data.IntMap.Strict-        Data.IntSet-        Data.IntSet.Internal-        IntMapValidity-        Utils.Containers.Internal.BitUtil-        Utils.Containers.Internal.StrictPair-        Utils.Containers.Internal.TypeError-    type: exitcode-stdio-1.0-    cpp-options: -DTESTING -DSTRICT--    build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim-    ghc-options: -O2-    other-extensions: CPP, BangPatterns-    include-dirs: include--    build-depends:-        HUnit,-        QuickCheck >= 2.7.1,-        test-framework,-        test-framework-hunit,-        test-framework-quickcheck2--Test-suite intset-properties-    hs-source-dirs: tests, .-    main-is: intset-properties.hs-    other-modules:-        Data.IntSet-        Data.IntSet.Internal-        Data.Set-        Data.Set.Internal-        IntSetValidity-        Utils.Containers.Internal.BitUtil-        Utils.Containers.Internal.PtrEquality-        Utils.Containers.Internal.StrictPair-    type: exitcode-stdio-1.0-    cpp-options: -DTESTING--    build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim-    ghc-options: -O2-    other-extensions: CPP, BangPatterns-    include-dirs: include--    build-depends:-        HUnit,-        QuickCheck >= 2.7.1,-        test-framework,-        test-framework-hunit,-        test-framework-quickcheck2--Test-suite seq-properties-    hs-source-dirs: tests, .-    main-is: seq-properties.hs-    other-modules:-        Data.Sequence-        Data.Sequence.Internal-        Utils.Containers.Internal.StrictPair-    type: exitcode-stdio-1.0-    cpp-options: -DTESTING--    build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim-    ghc-options: -O2-    other-extensions: CPP, BangPatterns-    include-dirs: include--    build-depends:-        QuickCheck >= 2.7.1,-        test-framework,-        test-framework-quickcheck2,-        transformers--Test-suite tree-properties-    hs-source-dirs: tests, .-    main-is: tree-properties.hs-    other-modules:-        Data.Tree-    type: exitcode-stdio-1.0-    cpp-options: -DTESTING--    build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5, ghc-prim-    ghc-options: -O2-    other-extensions: CPP, BangPatterns-    include-dirs: include--    build-depends:-        QuickCheck >= 2.7.1,-        test-framework,-        test-framework-quickcheck2,-        transformers--test-suite map-strictness-properties-  hs-source-dirs: tests, .-  main-is: map-strictness.hs-  other-modules:-      Data.Map.Internal-      Data.Map.Internal.Debug-      Data.Map.Internal.DeprecatedShowTree-      Data.Map.Strict-      Data.Map.Strict.Internal-      Data.Set.Internal-      Utils.Containers.Internal.BitQueue-      Utils.Containers.Internal.BitUtil-      Utils.Containers.Internal.PtrEquality-      Utils.Containers.Internal.StrictMaybe-      Utils.Containers.Internal.StrictPair-  type: exitcode-stdio-1.0--  build-depends:-    array >= 0.4.0.0,-    base >= 4.6 && < 5,-    ChasingBottoms,-    deepseq >= 1.2 && < 1.5,-    QuickCheck >= 2.7.1,-    ghc-prim,-    test-framework >= 0.3.3,-    test-framework-quickcheck2 >= 0.2.9--  ghc-options: -Wall-  other-extensions: CPP, BangPatterns-  include-dirs: include--test-suite intmap-strictness-properties-  hs-source-dirs: tests, .-  main-is: intmap-strictness.hs-  other-modules:-      Data.IntMap.Internal-      Data.IntMap.Internal.DeprecatedDebug-      Data.IntMap.Strict-      Data.IntSet.Internal-      Utils.Containers.Internal.BitUtil-      Utils.Containers.Internal.StrictPair-      Utils.Containers.Internal.TypeError-  type: exitcode-stdio-1.0-  other-extensions: CPP, BangPatterns--  build-depends:-    array >= 0.4.0.0,-    base >= 4.6 && < 5,-    ChasingBottoms,-    deepseq >= 1.2 && < 1.5,-    QuickCheck >= 2.7.1,-    ghc-prim,-    test-framework >= 0.3.3,-    test-framework-quickcheck2 >= 0.2.9--  ghc-options: -Wall-  include-dirs: include--test-suite intset-strictness-properties-  hs-source-dirs: tests, .-  main-is: intset-strictness.hs-  other-modules:-      Data.IntSet-      Data.IntSet.Internal-      Utils.Containers.Internal.BitUtil-      Utils.Containers.Internal.StrictPair-  type: exitcode-stdio-1.0-  other-extensions: CPP, BangPatterns--  build-depends:-    array >= 0.4.0.0,-    base >= 4.6 && < 5,-    ChasingBottoms,-    deepseq >= 1.2 && < 1.5,-    QuickCheck >= 2.7.1,-    ghc-prim,-    test-framework >= 0.3.3,-    test-framework-quickcheck2 >= 0.2.9--  ghc-options: -Wall-  include-dirs: include--test-suite listutils-properties-  hs-source-dirs: tests, .-  main-is: listutils-properties.hs-  other-modules:-      Data.Containers.ListUtils-  type: exitcode-stdio-1.0--  build-depends:-    base >= 4.6 && < 5,-    ChasingBottoms,-    deepseq >= 1.2 && < 1.5,-    QuickCheck >= 2.7.1,-    ghc-prim,-    test-framework >= 0.3.3,-    test-framework-quickcheck2 >= 0.2.9--  ghc-options: -Wall-  include-dirs: include
include/containers.h view
@@ -6,36 +6,25 @@ #define HASKELL_CONTAINERS_H  /*- * On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.+ * On GHC and MicroHs, include MachDeps.h to get WORD_SIZE_IN_BITS macro.  */-#ifdef __GLASGOW_HASKELL__+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) #include "MachDeps.h" #endif -/*- * Define INSTANCE_TYPEABLE[0-2]- */-#if __GLASGOW_HASKELL__ >= 707-#define INSTANCE_TYPEABLE0(tycon) deriving instance Typeable tycon-#define INSTANCE_TYPEABLE1(tycon) deriving instance Typeable tycon-#define INSTANCE_TYPEABLE2(tycon) deriving instance Typeable tycon-#elif defined(__GLASGOW_HASKELL__)-#define INSTANCE_TYPEABLE0(tycon) deriving instance Typeable tycon-#define INSTANCE_TYPEABLE1(tycon) deriving instance Typeable1 tycon-#define INSTANCE_TYPEABLE2(tycon) deriving instance Typeable2 tycon-#else-#define INSTANCE_TYPEABLE0(tycon)-#define INSTANCE_TYPEABLE1(tycon)-#define INSTANCE_TYPEABLE2(tycon)-#endif--#if __GLASGOW_HASKELL__ >= 800+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__) #define DEFINE_PATTERN_SYNONYMS 1 #endif  #ifdef __GLASGOW_HASKELL__ # define USE_ST_MONAD 1+#ifndef WORDS_BIGENDIAN+/*+ * Unboxed arrays are broken on big-endian architectures.+ * See https://gitlab.haskell.org/ghc/ghc/-/issues/16998+ */ # define USE_UNBOXED_ARRAYS 1+#endif #endif  #endif
+ mkappend.hs view
@@ -0,0 +1,96 @@+-- Generate appendTree<0..4> and addDigits<1..4> for Data.Sequence+module Main where++main :: IO ()+main = putStr (compose [showAppend n | n <- [0..4]] "")++showAppend :: Int -> ShowS+showAppend n =+    showChar '\n' .+    showString "appendTree" . shows n . showString " :: " .+        showFunType+            ([fingertree] ++ replicate n tyarg ++ [fingertree]) fingertree .+            showString "\n" .+    appendTreeClause "EmptyT" "xs" (showCons (args n) (showString "xs")) .+    appendTreeClause "xs" "EmptyT" (showSnoc (showString "xs") (args n)) .+    appendTreeClause "(Single x)" "xs"+        (showCons ('x':args n) (showString "xs")) .+    appendTreeClause "xs" "(Single x)"+        (showSnoc (showString "xs") (args n++"x")) .+    appendTreeClause "(Deep s1 pr1 m1 sf1)" "(Deep s2 pr2 m2 sf2)"+        (showString "Deep (s1" .+         compose [showString " + size " . showChar v | v <- args n] .+         showString " + s2) pr1 (addDigits" . shows n .+         showString " m1 sf1" . showArgList (args n) .+         showString " pr2 m2) sf2") .+    showChar '\n' .+    showString "addDigits" . shows n . showString " :: " .+        showFunType+            ([fingertree_node, digit] ++ replicate n tyarg ++ [digit, fingertree_node])+            fingertree_node .+        showString "\n" .+    compose [addDigitsClause n1 n2 | n1 <- [1..4], n2 <- [1..4]]+  where+    fingertree = tyapp "FingerTree" tyarg+    digit = tyapp "Digit" tyarg+    fingertree_node = tyapp "FingerTree" (tyapp "Node" tyarg)+    showFunType ts tr =+        compose [showString t . showString " -> " | t <- ts] . showString tr+    tyapp tc t = tc ++ " (" ++ t ++ ")"+    tyarg+      | n == 0 = "Elem a"+      | otherwise = "Node a"+    appendTreeClause t1 t2 rhs =+        showString "appendTree" . shows n .+            showChar ' ' . showString t1 . showArgList (args n) .+            showChar ' ' . showString t2 .+            showString " =\n    " . rhs . showChar '\n'+    addDigitsClause n1 n2 =+        showString "addDigits" . shows n .+            showString " m1 (" . showDigit vs1 . showChar ')' .+            showArgList vsm .+            showString " (" . showDigit vs2 . showString ") m2" .+            showString " =\n    " .+            showString "appendTree" . shows (length ns) .+            showString " m1" .+            compose [showString " (" .  showNode node . showChar ')' |+                node <- ns] .+            showString " m2" . showChar '\n'+      where+        vs = args (n1+n+n2)+        vs1 = take n1 vs+        vsm = take n (drop n1 vs)+        vs2 = drop (n1+n) vs+        ns = nodes vs++data Node a = Node2 a a | Node3 a a a++nodes :: [a] -> [Node a]+nodes [a, b] = [Node2 a b]+nodes [a, b, c] = [Node3 a b c]+nodes [a, b, c, d] = [Node2 a b, Node2 c d]+nodes (a:b:c:xs) = Node3 a b c : nodes xs++showNode (Node2 a b) =+    showString "node2 " . showChar a . showChar ' ' . showChar b+showNode (Node3 a b c) =+    showString "node3 " . showChar a . showChar ' ' . showChar b .+        showChar ' ' . showChar c++showDigit vs =+    showString (["One", "Two", "Three", "Four"]!!(length vs-1)) .+    showArgList vs++showArgList :: [Char] -> ShowS+showArgList vs = compose [showChar ' ' . showChar c | c <- vs]++args :: Int -> [Char]+args n = take n ['a'..]++showCons xs sf =+    compose [showChar x . showString " `consTree` " | x <- xs] . sf+showSnoc sf xs =+    sf . compose [showString " `snocTree` " . showChar x | x <- xs]++compose :: [a -> a] -> a -> a+compose = flip (foldr id)
+ src/Data/Containers/ListUtils.hs view
@@ -0,0 +1,197 @@+{-# 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.+--+-- In the documentation, \(n\) is the number of elements in the list while+-- \(d\) is the number of distinct elements in the list. \(W\) is the number+-- of bits in an 'Int'.+--+-- @since 0.6.0.1+-----------------------------------------------------------------------------++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 d) \). 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, although it can be a little worse in certain+-- pathological cases. For example, to nub a list of characters, use+--+-- @ nubIntOn fromEnum xs @+--+-- @since 0.6.0.1+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.+--+-- @since 0.6.0.1+nubOrdOn :: Ord b => (a -> b) -> [a] -> [a]+-- For some reason we need to write an explicit lambda here to allow this+-- to inline when only applied to a function.+nubOrdOn f = \xs -> nubOrdOnExcluding f Set.empty xs+{-# 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(d,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.+--+-- @since 0.6.0.1+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. For example, @nubIntOn 'fromEnum'@ can be used to+-- nub characters and typical fixed-with numerical types efficiently.+--+-- ==== Strictness+--+-- @nubIntOn@ is strict in the values of the function applied to the+-- elements of the list.+--+-- @since 0.6.0.1+nubIntOn :: (a -> Int) -> [a] -> [a]+-- For some reason we need to write an explicit lambda here to allow this+-- to inline when only applied to a function.+nubIntOn f = \xs -> nubIntOnExcluding f IntSet.empty xs+{-# 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
+ src/Data/Graph.hs view
@@ -0,0 +1,826 @@+{-# LANGUAGE CPP #-}+#include "containers.h"+{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+#endif+#ifdef DEFINE_PATTERN_SYNONYMS+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+#endif+#ifdef USE_ST_MONAD+{-# LANGUAGE RankNTypes #-}+#endif++-----------------------------------------------------------------------------+-- |+-- 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+--+--   * David King and John Launchbury,+--     \"/Structuring Depth-First Search Algorithms in Haskell/\",+--     Proceedings of the 22nd ACM SIGPLAN-SIGACT Symposium on Principles of+--     Programming Languages, 344-354, 1995,+--     <https://doi.org/10.1145/199448.199530>.+--+-----------------------------------------------------------------------------++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+    , reverseTopSort+    , components+    , scc+    , bcc+    , reachable+    , path+++    -- * Strongly Connected Components+    , SCC(..+#ifdef DEFINE_PATTERN_SYNONYMS+      , CyclicSCC+#endif+      )++    -- ** Construction+    , stronglyConnComp+    , stronglyConnCompR++    -- ** Conversion+    , flattenSCC+    , flattenSCC1+    , flattenSCCs++    -- * Trees+    , module Data.Tree++    ) where++import Utils.Containers.Internal.Prelude+import Prelude ()+#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 Data.Foldable as F+#if MIN_VERSION_base(4,18,0)+import qualified Data.Foldable1 as F1+#endif+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf))+import Data.Maybe+import Data.Array+#if USE_UNBOXED_ARRAYS+import qualified Data.Array.Unboxed as UA+import Data.Array.Unboxed ( UArray )+#else+import qualified Data.Array as UA+#endif+import qualified Data.List as L+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Functor.Classes+#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif+#ifdef __GLASGOW_HASKELL__+import GHC.Generics (Generic, Generic1)+import Data.Data (Data)+import Language.Haskell.TH.Syntax (Lift(..))+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif++-- Make sure we don't use Integer by mistake.+default ()++-------------------------------------------------------------------------+--                                                                      -+--      Strongly Connected Components+--                                                                      -+-------------------------------------------------------------------------++-- | Strongly connected component.+data SCC vertex+  = AcyclicSCC vertex+  -- ^ A single vertex that is not in any cycle.+  | NECyclicSCC {-# UNPACK #-} !(NonEmpty vertex)+  -- ^ A maximal set of mutually reachable vertices.+  --+  -- @since 0.7+  deriving ( Eq   -- ^ @since 0.5.9+           , Show -- ^ @since 0.5.9+           , Read -- ^ @since 0.5.9+           )++#ifdef DEFINE_PATTERN_SYNONYMS+-- | Partial pattern synonym for backward compatibility with @containers < 0.7@.+pattern CyclicSCC :: [vertex] -> SCC vertex+pattern CyclicSCC xs <- NECyclicSCC (NE.toList -> xs) where+  CyclicSCC [] = error "CyclicSCC: an argument cannot be an empty list"+  CyclicSCC (x : xs) = NECyclicSCC (x :| xs)++{-# COMPLETE AcyclicSCC, CyclicSCC #-}+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.9+deriving instance Data vertex => Data (SCC vertex)++-- | @since 0.5.9+deriving instance Generic1 SCC++-- | @since 0.5.9+deriving instance Generic (SCC vertex)++-- There is no instance Lift (NonEmpty v) before template-haskell-2.15.+#if MIN_VERSION_template_haskell(2,15,0)+-- | @since 0.6.6+deriving instance Lift vertex => Lift (SCC vertex)+#else+instance Lift vertex => Lift (SCC vertex) where+  lift (AcyclicSCC v) = [| AcyclicSCC v |]+  lift (NECyclicSCC (v :| vs)) = [| NECyclicSCC (v :| vs) |]+#endif++#endif++-- | @since 0.5.9+instance Eq1 SCC where+  liftEq eq (AcyclicSCC v1) (AcyclicSCC v2) = eq v1 v2+  liftEq eq (NECyclicSCC vs1) (NECyclicSCC vs2) = liftEq eq vs1 vs2+  liftEq _ _ _ = False+-- | @since 0.5.9+instance Show1 SCC where+  liftShowsPrec sp _sl d (AcyclicSCC v) = showsUnaryWith sp "AcyclicSCC" d v+  liftShowsPrec sp sl d (NECyclicSCC vs) = showsUnaryWith (liftShowsPrec sp sl) "NECyclicSCC" d vs+-- | @since 0.5.9+instance Read1 SCC where+  liftReadsPrec rp rl = readsData $+    readsUnaryWith rp "AcyclicSCC" AcyclicSCC <>+    readsUnaryWith (liftReadsPrec rp rl) "NECyclicSCC" NECyclicSCC+#ifdef __GLASGOW_HASKELL__+    <> readsUnaryWith (const rl) "CyclicSCC" CyclicSCC+#endif++-- | @since 0.5.9+instance F.Foldable SCC where+  foldr c n (AcyclicSCC v) = c v n+  foldr c n (NECyclicSCC vs) = foldr c n vs++  toList = flattenSCC++#if MIN_VERSION_base(4,18,0)+-- | @since 0.7+instance F1.Foldable1 SCC where+  foldMap1 f (AcyclicSCC v) = f v+  foldMap1 f (NECyclicSCC vs) = F1.foldMap1 f vs++  toNonEmpty = flattenSCC1++  -- TODO define more methods+#endif++-- | @since 0.5.9+instance Traversable SCC where+  traverse f (AcyclicSCC vertex) = AcyclicSCC <$> f vertex+  -- Avoid traverse from instance Traversable NonEmpty,+  -- it is redundantly lazy.+  traverse f (NECyclicSCC (x :| xs)) =+    liftA2 (\x' xs' -> NECyclicSCC (x' :| xs')) (f x) (traverse f xs)++instance NFData a => NFData (SCC a) where+    rnf (AcyclicSCC v) = rnf v+    rnf (NECyclicSCC vs) = rnf vs++-- | @since 0.8+instance NFData1 SCC where+    liftRnf rnfx (AcyclicSCC v)   = rnfx v+    liftRnf rnfx (NECyclicSCC vs) = liftRnf rnfx vs++-- | @since 0.5.4+instance Functor SCC where+    fmap f (AcyclicSCC v) = AcyclicSCC (f v)+    -- Avoid fmap from instance Functor NonEmpty,+    -- it is redundantly lazy.+    fmap f (NECyclicSCC (x :| xs)) = NECyclicSCC (f x :| map f xs)++-- | The vertices of a list of strongly connected components.+flattenSCCs :: [SCC a] -> [a]+flattenSCCs = concatMap flattenSCC++-- | The vertices of a strongly connected component.+--+-- @flattenSCC = 'Data.List.NonEmpty.toList' . 'flattenSCC1'@.+--+-- This function is retained for backward compatibility,+-- 'flattenSCC1' has the more precise type.+flattenSCC :: SCC vertex -> [vertex]+flattenSCC (AcyclicSCC v) = [v]+flattenSCC (NECyclicSCC (v :| vs)) = v : vs+-- Note: Best to avoid NE.toList, it is too lazy.++-- | The vertices of a strongly connected component.+--+-- @since 0.8+flattenSCC1 :: SCC vertex -> NonEmpty vertex+flattenSCC1 (AcyclicSCC v) = v :| []+flattenSCC1 (NECyclicSCC vs) = vs++-- | \(O((V+E) \log V)\). The strongly connected components of a directed graph,+-- reverse topologically sorted.+--+-- ==== __Examples__+--+-- > stronglyConnComp [("a",0,[1]),("b",1,[2,3]),("c",2,[1]),("d",3,[3])]+-- >   == [CyclicSCC ["d"],CyclicSCC ["b","c"],AcyclicSCC "a"]+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 (NECyclicSCC ((n0, _, _) :| triples)) =+      NECyclicSCC (n0 :| [n | (n, _, _) <- triples])+{-# INLINABLE stronglyConnComp #-}++-- | \(O((V+E) \log V)\). The strongly connected components of a directed graph,+-- reverse topologically sorted.  The function is the same as+-- 'stronglyConnComp', except that all the information about each node retained.+-- This interface is used when you expect to apply 'SCC' to+-- (some of) the result of 'SCC', so you don't want to lose the+-- dependency information.+--+-- ==== __Examples__+--+-- > stronglyConnCompR [("a",0,[1]),("b",1,[2,3]),("c",2,[1]),("d",3,[3])]+-- >  == [CyclicSCC [("d",3,[3])],CyclicSCC [("b",1,[2,3]),("c",2,[1])],AcyclicSCC ("a",0,[1])]+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])]     -- ^ Reverse 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 = NECyclicSCC (vertex_fn v :| [])+                       | otherwise         = AcyclicSCC (vertex_fn v)+    decode (Node v ts) = NECyclicSCC (vertex_fn v :| foldr dec [] ts)++    dec (Node v ts) vs = vertex_fn v : foldr dec vs ts+    mentions_itself v = v `elem` (graph ! v)+{-# INLINABLE stronglyConnCompR #-}++-------------------------------------------------------------------------+--                                                                      -+--      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++-- | \(O(V)\). 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+-- See Note [Inline for fusion]+{-# INLINE vertices #-}++-- | \(O(V+E)\). 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 ]+-- See Note [Inline for fusion]+{-# INLINE edges #-}++-- | \(O(V+E)\). Build a graph from a list of edges.+--+-- Warning: This function will cause a runtime exception if a vertex in the edge+-- list is not within the given @Bounds@.+--+-- ==== __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 = accumArray (flip (:)) []+-- See Note [Inline for fusion]+{-# INLINE buildG #-}++-- | \(O(V+E)\). 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 ]+-- See Note [Inline for fusion]+{-# INLINE reverseE #-}++-- | \(O(V+E)\). 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++-- | \(O(V+E)\). 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]++-- | \(O((V+E) \log V)\). Identical to 'graphFromEdges', except that the return+-- value does not include the function which maps keys to vertices. This+-- version of 'graphFromEdges' is for backwards compatibility.+graphFromEdges'+        :: Ord key+        => [(node, key, [key])]+        -> (Graph, Vertex -> (node, key, [key]))+graphFromEdges' x = (a,b) where+    (a,b,_) = graphFromEdges x+{-# INLINABLE graphFromEdges' #-}++-- | \(O((V+E) \log V)\). Build a graph from a list of nodes uniquely identified+-- by keys, with a list of keys of nodes this node should have edges to.+--+-- This function takes an adjacency list representing a graph with vertices of+-- type @key@ labeled by values of type @node@ and produces a @Graph@-based+-- 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 retrieve 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. This+--   runs in \(O(1)\) time.+-- * @vertexFromKey :: key -> Maybe Vertex@ returns the @Int@ vertex for the+--   key if it exists in the graph, @Nothing@ otherwise. This runs in+--   \(O(\log V)\) time.+--+-- To safely use this API you must either extract the list of vertices directly+-- from the graph or first call @vertexFromKey k@ to check if a vertex+-- 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    = L.sortBy lt edges0+    edges1          = zipWith (,) [0..] sorted_edges++    graph           = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_,    _, ks) <- edges1]+    key_map         = array bounds0 [(,) v k                       | (,) v (_,    k, _ ) <- edges1]+    vertex_map      = array bounds0 edges1++    (_,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+{-# INLINABLE graphFromEdges #-}++-------------------------------------------------------------------------+--                                                                      -+--      Depth first search+--                                                                      -+-------------------------------------------------------------------------++-- | \(O(V+E)\). A spanning forest of the graph, obtained from a depth-first+-- search of the graph starting from each vertex in an unspecified order.+dff          :: Graph -> [Tree Vertex]+dff g         = dfs g (vertices g)++-- | \(O(V+E)\). A spanning forest of the part of the graph reachable from the+-- listed vertices, obtained from a depth-first search of the graph starting at+-- each of the listed vertices in order.++-- This function deviates from King and Launchbury's implementation by+-- bundling together the functions generate, prune, and chop for efficiency+-- reasons.+dfs :: Graph -> [Vertex] -> [Tree Vertex]+dfs !g vs0 = run (bounds g) $ \contains include ->+  let+    go [] = pure []+    go (v:vs) = do+      visited <- contains v+      if visited+      then go vs+      else do+        include v+        as <- go (g!v)+        bs <- go vs+        pure $ Node v as : bs+  in go vs0++#if USE_ST_MONAD++-- Use the ST monad if available, for constant-time primitives.++newArrayBool+  :: Bounds+#if USE_UNBOXED_ARRAYS+  -> ST s (STUArray s Vertex Bool)+#else+  -> ST s (STArray s Vertex Bool)+#endif+newArrayBool bnds = newArray bnds False++run+  :: Bounds+  -> (forall s. (Vertex -> ST s Bool) -> (Vertex -> ST s ()) -> ST s a)+  -> a+run bnds f = runST $ do+  m <- newArrayBool bnds+  f (readArray m) (\v -> writeArray m v True)+{-# INLINE run #-}++#else /* !USE_ST_MONAD */++-- Portable implementation using IntSet.++newtype SetM a = SetM { runSetM :: IntSet -> (a, IntSet) }++instance Monad SetM where+    SetM v >>= f = SetM $ \s -> case v s of (x, s') -> runSetM (f x) s'++instance Functor SetM where+    f `fmap` SetM v = SetM $ \s -> case v s of (x, s') -> (f x, s')+    {-# INLINE fmap #-}++instance Applicative SetM where+    pure x = SetM $ \s -> (x, s)+    {-# INLINE pure #-}+    SetM f <*> SetM v = SetM $ \s -> case f s of (k, s') -> case v s' of (x, s'') -> (k x, s'')+    {-# INLINE (<*>) #-}++run :: Bounds -> ((Vertex -> SetM Bool) -> (Vertex -> SetM ()) -> SetM a) -> a+run _ f = fst (runSetM (f contains include) Set.empty)+  where+    contains v = SetM $ \m -> (Set.member v m, m)+    include v = SetM $ \m -> ((), Set.insert v m)++#endif /* !USE_ST_MONAD */++-------------------------------------------------------------------------+--                                                                      -+--      Algorithms+--                                                                      -+-------------------------------------------------------------------------++------------------------------------------------------------+-- Algorithm 1: depth first search numbering+------------------------------------------------------------++preorder' :: Tree a -> [a] -> [a]+preorder' (Node a ts) = (a :) . preorderF' ts++preorderF' :: [Tree a] -> [a] -> [a]+preorderF' ts = foldr (.) id $ map preorder' ts++preorderF :: [Tree a] -> [a]+preorderF ts = preorderF' ts []++tabulate        :: Bounds -> [Vertex] -> UArray Vertex Int+tabulate bnds vs = UA.array bnds (zipWith (flip (,)) [1..] vs)+-- Why zipWith (flip (,)) instead of just using zip with the+-- 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 -> [Tree 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   :: [Tree a] -> [a] -> [a]+postorderF ts = foldr (.) id $ map postorder ts++postOrd :: Graph -> [Vertex]+postOrd g = postorderF (dff g) []++-- | \(O(V+E)\). A topological sort of the graph.+-- The order is partially specified by the condition that a vertex /i/+-- precedes /j/ whenever /j/ is reachable from /i/ but not vice versa.+--+-- Note: A topological sort exists only when there are no cycles in the graph.+-- If the graph has cycles, the output of this function will not be a+-- topological sort. In such a case consider using 'scc'.+topSort      :: Graph -> [Vertex]+topSort       = reverse . postOrd++-- | \(O(V+E)\). Reverse ordering of `topSort`.+--+-- See note in 'topSort'.+--+-- @since 0.6.4+reverseTopSort :: Graph -> [Vertex]+reverseTopSort = postOrd++------------------------------------------------------------+-- Algorithm 3: connected components+------------------------------------------------------------++-- | \(O(V+E)\). The connected components of a graph.+-- Two vertices are connected if there is a path between them, traversing+-- edges in either direction.+components   :: Graph -> [Tree Vertex]+components    = dff . undirected++undirected   :: Graph -> Graph+undirected g  = buildG (bounds g) (edges g ++ reverseE g)++-- Algorithm 4: strongly connected components++-- | \(O(V+E)\). The strongly connected components of a graph, in reverse+-- topological order.+--+-- ==== __Examples__+--+-- > scc (buildG (0,3) [(3,1),(1,2),(2,0),(0,1)])+-- >   == [Node {rootLabel = 0, subForest = [Node {rootLabel = 1, subForest = [Node {rootLabel = 2, subForest = []}]}]}+-- >      ,Node {rootLabel = 3, subForest = []}]++scc  :: Graph -> [Tree Vertex]+scc g = dfs g (reverse (postOrd (transposeG g)))++------------------------------------------------------------+-- 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+------------------------------------------------------------++-- | \(O(V+E)\). 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])++-- | \(O(V+E)\). 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+------------------------------------------------------------++-- | \(O(V+E)\). The biconnected components of a graph.+-- An undirected graph is biconnected if the deletion of any vertex+-- leaves it connected.+--+-- The input graph is expected to be undirected, i.e. for every edge in the+-- graph the reverse edge is also in the graph. If the graph is not undirected+-- the output is arbitrary.+bcc :: Graph -> [Tree [Vertex]]+bcc g = concatMap bicomps forest+  where+    -- The algorithm here is the same as given by King and Launchbury, which is+    -- an adaptation of Hopcroft and Tarjan's. The implementation, however, has+    -- been modified from King and Launchbury to make it efficient.++    forest = dff g++    -- dnum!v is the index of vertex v in the dfs preorder of vertices+    dnum = preArr (bounds g) forest++    -- Wraps up the component of every child of the root+    bicomps :: Tree Vertex -> [Tree [Vertex]]+    bicomps (Node v tws) =+      [Node (v : curw []) (donew []) | (_, curw, donew) <- map collect tws]++    -- Returns a triple of+    -- * lowpoint of v+    -- * difference list of vertices in v's component+    -- * difference list of trees of components, whose root components are+    --   adjacent to v's component+    collect :: Tree Vertex+            -> (Int, [Vertex] -> [Vertex], [Tree [Vertex]] -> [Tree [Vertex]])+    collect (Node v tws) = (lowv, (v:) . curv, donev)+      where+        dv = dnum UA.! v+        accf (lowv', curv', donev') tw+          | loww < dv  -- w's component extends through v+            = (lowv'', curv' . curw, donev' . donew)+          | otherwise  -- w's component ends with v as an articulation point+            = (lowv'', curv', donev' . (Node (v : curw []) (donew []) :))+          where+            (loww, curw, donew) = collect tw+            !lowv'' = min lowv' loww+        !lowv0 = F.foldl' min dv [dnum UA.! w | w <- g!v]+        !(lowv, curv, donev) = F.foldl' accf (lowv0, id, id) tws++--------------------------------------------------------------------------------++-- Note [Inline for fusion]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We inline simple functions that produce or consume lists so that list fusion+-- can fire. transposeG is a function where this is particularly useful; it has+-- two intermediate lists in its definition which get fused away.
+ src/Data/IntMap.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Safe #-}+#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+--+--+-- = Finite Int Maps (lazy interface)+--+-- This module re-exports the value lazy "Data.IntMap.Lazy" API.+--+-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @Int@ to values of type @v@.+--+-- The functions in "Data.IntMap.Strict" are careful to force values before+-- installing them in an 'IntMap'. This is usually more efficient in cases where+-- laziness is not essential. The functions in this module do not do so.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- > import Data.IntMap.Lazy (IntMap)+-- > import qualified Data.IntMap.Lazy as IntMap+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. Additionally, benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced map implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>.+--+--+-- == Performance information+--+-- Operation comments contain the operation time complexity in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'lookup', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+--   the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+--   shared by all subelements, so there could not be more+--   than \(W\) levels.+--+-- If all \(n\) keys in the tree are between 0 and \(N\) (or, say, between \(-N\) and \(N\)),+-- the estimate can be refined to \(O(\min(n, \log N))\). If the set of keys+-- is sufficiently "dense", this becomes \(O(\min(n, \log n))\) or simply+-- the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntMap' are keys from a contiguous subset,+-- in which case the complexity is proportional to \(\log n\), capped by \(W\).+-- The worst scenario are exponentially growing keys \(1,2,4,\ldots,2^n\),+-- for which complexity grows as fast as \(n\) but again is capped by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-----------------------------------------------------------------------------++module Data.IntMap+    ( module Data.IntMap.Lazy+    ) where++import Data.IntMap.Lazy
+ src/Data/IntMap/Internal.hs view
@@ -0,0 +1,3886 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IntMap.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+--                (c) wren romano 2016+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Int Maps (lazy interface internals)+--+-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @Int@ to values of type @v@.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. Additionally, benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced map implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of IntMap matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.+--++module Data.IntMap.Internal (+    -- * Map type+      IntMap(..)          -- instance Eq,Show+    , Key++    -- * Operators+    , (!), (!?), (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookup+    , findWithDefault+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , disjoint++    -- * Construction+    , empty+    , singleton++    -- ** Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- ** Delete\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Symmetric difference+    , symmetricDifference++    -- ** Compose+    , compose++    -- ** General combining function+    , SimpleWhenMissing+    , SimpleWhenMatched+    , runWhenMatched+    , runWhenMissing+    , merge+    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched+    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , mapMissing+    , filterMissing++    -- ** Applicative general combining function+    , WhenMissing (..)+    , WhenMatched (..)+    , mergeA+    -- *** @WhenMatched@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , zipWithMaybeAMatched+    , zipWithAMatched+    -- *** @WhenMissing@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , traverseMaybeMissing+    , traverseMissing+    , filterAMissing++    -- ** Deprecated general combining function+    , mergeWithKey+    , mergeWithKey'++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , fromSet++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * Filter+    , filter+    , filterKeys+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- * Debugging+    , showTree+    , showTreeWith++    -- * Utility+    , link+    , linkKey+    , linkWithMask+    , bin+    , binCheckLeft+    , binCheckRight++    -- * Used by "IntMap.Merge.Lazy" and "IntMap.Merge.Strict"+    , mapWhenMissing+    , mapWhenMatched+    , lmapWhenMissing+    , contramapFirstWhenMatched+    , contramapSecondWhenMatched+    , mapGentlyWhenMissing+    , mapGentlyWhenMatched+    ) where++import Data.Functor.Identity (Identity (..))+import Data.Semigroup (Semigroup(stimes))+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+import Data.Semigroup (stimesIdempotentMonoid)+import Data.Functor.Classes++import Control.DeepSeq (NFData(rnf),NFData1(liftRnf))+import Data.Bits+import qualified Data.Foldable as Foldable+import Data.Maybe (fromMaybe)+import Utils.Containers.Internal.Prelude hiding+  (lookup, map, filter, foldr, foldl, foldl', null)+import Prelude ()++import qualified Data.IntSet.Internal as IntSet+import Data.IntSet.Internal.IntTreeCommons+  ( Key+  , Prefix(..)+  , nomatch+  , left+  , signBranch+  , mask+  , branchMask+  , TreeTreeBranch(..)+  , treeTreeBranch+  , i2w+  , Order(..)+  )+import Utils.Containers.Internal.BitUtil (shiftLL, shiftRL, iShiftRL)+import Utils.Containers.Internal.StrictPair++#ifdef __GLASGOW_HASKELL__+import Data.Coerce+import Data.Data (Data(..), Constr, mkConstr, constrIndex,+                  DataType, mkDataType, gcast1)+import qualified Data.Data as Data+import GHC.Exts (build)+import qualified GHC.Exts as GHCExts+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+import Text.Read+#endif+import qualified Control.Category as Category+++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}+++-- | A map of integers to values @a@.++-- See Note: Order of constructors+data IntMap a = Bin {-# UNPACK #-} !Prefix+                    !(IntMap a)+                    !(IntMap a)+              | Tip {-# UNPACK #-} !Key a+              | Nil++--+-- Note [IntMap structure and invariants]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- * Nil is never found as a child of Bin.+--+-- * The Prefix of a Bin indicates the common high-order bits that all keys in+--   the Bin share.+--+-- * The least significant set bit of the Int value of a Prefix is called the+--   mask bit.+--+-- * All the bits to the left of the mask bit are called the shared prefix. All+--   keys stored in the Bin begin with the shared prefix.+--+-- * All keys in the left child of the Bin have the mask bit unset, and all keys+--   in the right child have the mask bit set. It follows that+--+--   1. The Int value of the Prefix of a Bin is the smallest key that can be+--      present in the right child of the Bin.+--+--   2. All keys in the right child of a Bin are greater than keys in the+--      left child, with one exceptional situation. If the Bin separates+--      negative and non-negative keys, the mask bit is the sign bit and the+--      left child stores the non-negative keys while the right child stores the+--      negative keys.+--+-- * All bits to the right of the mask bit are set to 0 in a Prefix.+--++-- See Note [Okasaki-Gill] for how the implementation here relates to the one in+-- Okasaki and Gill's paper.++-- Some stuff from "Data.IntSet.Internal", for 'restrictKeys' and+-- 'withoutKeys' to use.+type IntSetPrefix = Int+type IntSetBitMap = Word++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+deriving instance Lift a => Lift (IntMap a)+#endif++bitmapOf :: Int -> IntSetBitMap+bitmapOf x = shiftLL 1 (x .&. IntSet.suffixBitMask)+{-# INLINE bitmapOf #-}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: IntMap a -> Key -> a+(!) m k = find k m++-- | \(O(\min(n,W))\). Find the value at a key.+-- Returns 'Nothing' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing+-- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a'+--+-- @since 0.5.11++(!?) :: IntMap a -> Key -> Maybe a+(!?) m k = lookup k m++-- | Same as 'difference'.+(\\) :: IntMap a -> IntMap b -> IntMap a+m1 \\ m2 = difference m1 m2++infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}++-- | @mempty@ = 'empty'+instance Monoid (IntMap a) where+    mempty  = empty+    mconcat = unions+    mappend = (<>)++-- | @(<>)@ = 'union'+--+-- @since 0.5.7+instance Semigroup (IntMap a) where+    (<>)    = union+    stimes  = stimesIdempotentMonoid++-- | Folds in order of increasing key.+instance Foldable.Foldable IntMap where+  fold = go+    where go Nil = mempty+          go (Tip _ v) = v+          go (Bin p l r)+            | signBranch p = go r `mappend` go l+            | otherwise = go l `mappend` go r+  {-# INLINABLE fold #-}+  foldr = foldr+  {-# INLINE foldr #-}+  foldl = foldl+  {-# INLINE foldl #-}+  foldMap f t = go t+    where go Nil = mempty+          go (Tip _ v) = f v+          go (Bin p l r)+            | signBranch p = go r `mappend` go l+            | otherwise = go l `mappend` go r+  {-# INLINE foldMap #-}+  foldl' = foldl'+  {-# INLINE foldl' #-}+  foldr' = foldr'+  {-# INLINE foldr' #-}+  length = size+  {-# INLINE length #-}+  null   = null+  {-# INLINE null #-}+  toList = elems -- NB: Foldable.toList /= IntMap.toList+  {-# INLINE toList #-}+  elem = go+    where go !_ Nil = False+          go x (Tip _ y) = x == y+          go x (Bin _ l r) = go x l || go x r+  {-# INLINABLE elem #-}+  maximum = start+    where start Nil = error "Data.Foldable.maximum (for Data.IntMap): empty map"+          start (Tip _ y) = y+          start (Bin p l r)+            | signBranch p = go (start r) l+            | otherwise = go (start l) r++          go !m Nil = m+          go m (Tip _ y) = max m y+          go m (Bin _ l r) = go (go m l) r+  {-# INLINABLE maximum #-}+  minimum = start+    where start Nil = error "Data.Foldable.minimum (for Data.IntMap): empty map"+          start (Tip _ y) = y+          start (Bin p l r)+            | signBranch p = go (start r) l+            | otherwise = go (start l) r++          go !m Nil = m+          go m (Tip _ y) = min m y+          go m (Bin _ l r) = go (go m l) r+  {-# INLINABLE minimum #-}+  sum = foldl' (+) 0+  {-# INLINABLE sum #-}+  product = foldl' (*) 1+  {-# INLINABLE product #-}++-- | Traverses in order of increasing key.+instance Traversable IntMap where+    traverse f = traverseWithKey (\_ -> f)+    {-# INLINE traverse #-}++instance NFData a => NFData (IntMap a) where+    rnf Nil = ()+    rnf (Tip _ v) = rnf v+    rnf (Bin _ l r) = rnf l `seq` rnf r++-- | @since 0.8+instance NFData1 IntMap where+    liftRnf rnfx = go+      where+      go Nil         = ()+      go (Tip _ v)   = rnfx v+      go (Bin _ l r) = go l `seq` go r++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data a => Data (IntMap a) where+  gfoldl f z im = z fromList `f` (toList im)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = intMapDataType+  dataCast1 f    = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr intMapDataType "fromList" [] Data.Prefix++intMapDataType :: DataType+intMapDataType = mkDataType "Data.IntMap.Internal.IntMap" [fromListConstr]++#endif++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the map empty?+--+-- > Data.IntMap.null (empty)           == True+-- > Data.IntMap.null (singleton 1 'a') == False++null :: IntMap a -> Bool+null Nil = True+null _   = False+{-# INLINE null #-}++-- | \(O(n)\). Number of elements in the map.+--+-- > size empty                                   == 0+-- > size (singleton 1 'a')                       == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3+size :: IntMap a -> Int+size = go 0+  where+    go !acc (Bin _ l r) = go (go acc l) r+    go acc (Tip _ _) = 1 + acc+    go acc Nil = acc++-- | \(O(\min(n,W))\). Is the key a member of the map?+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False++-- See Note: Local 'go' functions and capturing]+member :: Key -> IntMap a -> Bool+member !k = go+  where+    go (Bin p l r)+      | nomatch k p = False+      | left k p    = go l+      | otherwise   = go r+    go (Tip kx _) = k == kx+    go Nil = False++-- | \(O(\min(n,W))\). Is the key not a member of the map?+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Key -> IntMap a -> Bool+notMember k m = not $ member k m++-- | \(O(\min(n,W))\). Look up the value at a key in the map. See also 'Data.Map.lookup'.++-- See Note: Local 'go' functions and capturing+lookup :: Key -> IntMap a -> Maybe a+lookup !k = go+  where+    go (Bin p l r) | left k p  = go l+                   | otherwise = go r+    go (Tip kx x) | k == kx   = Just x+                  | otherwise = Nothing+    go Nil = Nothing++-- See Note: Local 'go' functions and capturing]+find :: Key -> IntMap a -> a+find !k = go+  where+    go (Bin p l r) | left k p  = go l+                   | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = not_found+    go Nil = not_found++    not_found = error ("IntMap.!: key " ++ show k ++ " is not an element of the map")++-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See Note: Local 'go' functions and capturing]+findWithDefault :: a -> Key -> IntMap a -> a+findWithDefault def !k = go+  where+    go (Bin p l r) | nomatch k p = def+                   | left k p    = go l+                   | otherwise   = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = def+    go Nil = def++-- | \(O(\min(n,W))\). Find largest key smaller than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> IntMap a -> Maybe (Key, a)+lookupLT !k t = case t of+    Bin p l r | signBranch p -> if k >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p l r)+      | nomatch k p = if k < unPrefix p then unsafeFindMax def else unsafeFindMax r+      | left k p  = go def l+      | otherwise = go l r+    go def (Tip ky y)+      | k <= ky   = unsafeFindMax def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMax def++-- | \(O(\min(n,W))\). Find smallest key greater than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> IntMap a -> Maybe (Key, a)+lookupGT !k t = case t of+    Bin p l r | signBranch p -> if k >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p l r)+      | nomatch k p = if k < unPrefix p then unsafeFindMin l else unsafeFindMin def+      | left k p  = go r l+      | otherwise = go def r+    go def (Tip ky y)+      | k >= ky   = unsafeFindMin def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMin def++-- | \(O(\min(n,W))\). Find largest key smaller or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> IntMap a -> Maybe (Key, a)+lookupLE !k t = case t of+    Bin p l r | signBranch p -> if k >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p l r)+      | nomatch k p = if k < unPrefix p then unsafeFindMax def else unsafeFindMax r+      | left k p  = go def l+      | otherwise = go l r+    go def (Tip ky y)+      | k < ky    = unsafeFindMax def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMax def++-- | \(O(\min(n,W))\). Find smallest key greater or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> IntMap a -> Maybe (Key, a)+lookupGE !k t = case t of+    Bin p l r | signBranch p -> if k >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p l r)+      | nomatch k p = if k < unPrefix p then unsafeFindMin l else unsafeFindMin def+      | left k p  = go r l+      | otherwise = go def r+    go def (Tip ky y)+      | k > ky    = unsafeFindMin def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMin def+++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: IntMap a -> Maybe (Key, a)+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip ky y) = Just (ky, y)+unsafeFindMin (Bin _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: IntMap a -> Maybe (Key, a)+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip ky y) = Just (ky, y)+unsafeFindMax (Bin _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Check whether the key sets of two maps are disjoint+-- (i.e. their 'intersection' is empty).+--+-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())])   == True+-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False+-- > disjoint (fromList [])        (fromList [])                 == True+--+-- > disjoint a b == null (intersection a b)+--+-- @since 0.6.2.1+disjoint :: IntMap a -> IntMap b -> Bool+disjoint Nil _ = True+disjoint _ Nil = True+disjoint (Tip kx _) ys = notMember kx ys+disjoint xs (Tip ky _) = notMember ky xs+disjoint t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> disjoint l1 t2+  ABR -> disjoint r1 t2+  BAL -> disjoint t1 l2+  BAR -> disjoint t1 r2+  EQL -> disjoint l1 l2 && disjoint r1 r2+  NOM -> True++{--------------------------------------------------------------------+  Compose+--------------------------------------------------------------------}+-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument+--+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- __Note:__ Prior to v0.6.4, "Data.IntMap.Strict" exposed a version of+-- 'compose' that forced the values of the output 'IntMap'. This version does+-- not force these values.+--+-- @since 0.6.3.1+compose :: IntMap c -> IntMap Int -> IntMap c+compose bc !ab+  | null bc = empty+  | otherwise = mapMaybe (bc !?) ab++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty map.+--+-- > empty      == fromList []+-- > size empty == 0++empty :: IntMap a+empty+  = Nil+{-# INLINE empty #-}++-- | \(O(1)\). A map of one element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: Key -> a -> IntMap a+singleton k x+  = Tip k x+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty                         == singleton 5 'x'++insert :: Key -> a -> IntMap a -> IntMap a+insert !k x t@(Bin p l r)+  | nomatch k p = linkKey k (Tip k x) p t+  | left k p    = Bin p (insert k x l) r+  | otherwise   = Bin p l (insert k x r)+insert k x t@(Tip ky _)+  | k==ky         = Tip k x+  | otherwise     = link k (Tip k x) ky t+insert k x Nil = Tip k x++-- right-biased insertion, used by 'union'+-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWith f k x t+  = insertWithKey (\_ x' y' -> f x' y') k x t++-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithKey f !k x t@(Bin p l r)+  | nomatch k p = linkKey k (Tip k x) p t+  | left k p    = Bin p (insertWithKey f k x l) r+  | otherwise   = Bin p l (insertWithKey f k x r)+insertWithKey f k x t@(Tip ky y)+  | k == ky       = Tip k (f k x y)+  | otherwise     = link k (Tip k x) ky t+insertWithKey _ k x Nil = Tip k x++-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])+--+-- Also see the performance note on 'fromListWith'.++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)+insertLookupWithKey f !k x t@(Bin p l r)+  | nomatch k p = (Nothing,linkKey k (Tip k x) p t)+  | left k p    = let (found,l') = insertLookupWithKey f k x l+                  in (found,Bin p l' r)+  | otherwise   = let (found,r') = insertLookupWithKey f k x r+                  in (found,Bin p l r')+insertLookupWithKey f k x t@(Tip ky y)+  | k == ky       = (Just y,Tip k (f k x y))+  | otherwise     = (Nothing,link k (Tip k x) ky t)+insertLookupWithKey _ k x Nil = (Nothing,Tip k x)+++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > delete 5 empty                         == empty++delete :: Key -> IntMap a -> IntMap a+delete !k t@(Bin p l r)+  | nomatch k p = t+  | left k p    = binCheckLeft p (delete k l) r+  | otherwise   = binCheckRight p l (delete k r)+delete k t@(Tip ky _)+  | k == ky       = Nil+  | otherwise     = t+delete _k Nil = Nil++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty                         == empty++adjust ::  (a -> a) -> Key -> IntMap a -> IntMap a+adjust f k m+  = adjustWithKey (\_ x -> f x) k m++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty                         == empty++adjustWithKey ::  (Key -> a -> a) -> Key -> IntMap a -> IntMap a+adjustWithKey f !k (Bin p l r)+  | left k p      = Bin p (adjustWithKey f k l) r+  | otherwise     = Bin p l (adjustWithKey f k r)+adjustWithKey f k t@(Tip ky y)+  | k == ky       = Tip ky (f k y)+  | otherwise     = t+adjustWithKey _ _ Nil = Nil+++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update ::  (a -> Maybe a) -> Key -> IntMap a -> IntMap a+update f+  = updateWithKey (\_ x -> f x)++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a+updateWithKey f !k (Bin p l r)+  | left k p      = binCheckLeft p (updateWithKey f k l) r+  | otherwise     = binCheckRight p l (updateWithKey f k r)+updateWithKey f k t@(Tip ky y)+  | k == ky       = case (f k y) of+                      Just y' -> Tip ky y'+                      Nothing -> Nil+  | otherwise     = t+updateWithKey _ _ Nil = Nil++-- | \(O(\min(n,W))\). Look up and update.+-- This function returns the original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)+updateLookupWithKey f !k (Bin p l r)+  | left k p      = let !(found,l') = updateLookupWithKey f k l+                    in (found,binCheckLeft p l' r)+  | otherwise     = let !(found,r') = updateLookupWithKey f k r+                    in (found,binCheckRight p l r')+updateLookupWithKey f k t@(Tip ky y)+  | k==ky         = case (f k y) of+                      Just y' -> (Just y,Tip ky y')+                      Nothing -> (Just y,Nil)+  | otherwise     = (Nothing,t)+updateLookupWithKey _ _ Nil = (Nothing,Nil)++++-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a+alter f !k t@(Bin p l r)+  | nomatch k p = case f Nothing of+                    Nothing -> t+                    Just x -> linkKey k (Tip k x) p t+  | left k p    = binCheckLeft p (alter f k l) r+  | otherwise   = binCheckRight p l (alter f k r)+alter f k t@(Tip ky y)+  | k==ky         = case f (Just y) of+                      Just x -> Tip ky x+                      Nothing -> Nil+  | otherwise     = case f Nothing of+                      Just x -> link k (Tip k x) ky t+                      Nothing -> Tip ky y+alter f k Nil     = case f Nothing of+                      Just x -> Tip k x+                      Nothing -> Nil++-- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,+-- or update a value in an 'IntMap'.  In short : @'lookup' k \<$\> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)+-- interactiveAlter k m = alterF f k m where+--   f Nothing = do+--      putStrLn $ show k +++--          " was not found in the map. Would you like to add it?"+--      getUserResponse1 :: IO (Maybe String)+--   f (Just old) = do+--      putStrLn $ "The key is currently bound to " ++ show old +++--          ". Would you like to change or delete it?"+--      getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map.+--+-- Note: 'alterF' is a flipped version of the @at@ combinator from+-- @Control.Lens.At@.+--+-- @since 0.5.8++alterF :: Functor f+       => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)+-- This implementation was stolen from 'Control.Lens.At'.+alterF f k m = (<$> f mv) $ \fres ->+  case fres of+    Nothing -> maybe m (const (delete k m)) mv+    Just v' -> insert k v' m+  where mv = lookup k m++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+--+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "b"), (5, "a"), (7, "C")]+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]+-- >     == fromList [(3, "B3"), (5, "A3"), (7, "C")]++unions :: Foldable f => f (IntMap a) -> IntMap a+unions xs+  = Foldable.foldl' union empty xs++-- | The union of a list of maps, with a combining operation.+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Foldable f => (a->a->a) -> f (IntMap a) -> IntMap a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The (left-biased) union of two maps.+-- It prefers the first map when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: IntMap a -> IntMap a -> IntMap a+union m1 m2+  = mergeWithKey' Bin const id id m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWith f m1 m2+  = unionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWithKey f m1 m2+  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference between two maps (based on keys).+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: IntMap a -> IntMap b -> IntMap a+difference m1 m2+  = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWith f m1 m2+  = differenceWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWithKey f m1 m2+  = mergeWithKey f id (const Nil) m1 m2+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Remove all the keys in a given set from a map.+--+-- @+-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``IntSet.notMember`` s) m+-- @+--+-- @since 0.5.8+withoutKeys :: IntMap a -> IntSet.IntSet -> IntMap a+withoutKeys t1@(Bin p1 l1 r1) t2@(IntSet.Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> binCheckLeft p1 (withoutKeys l1 t2) r1+  ABR -> binCheckRight p1 l1 (withoutKeys r1 t2)+  BAL -> withoutKeys t1 l2+  BAR -> withoutKeys t1 r2+  EQL -> bin p1 (withoutKeys l1 l2) (withoutKeys r1 r2)+  NOM -> t1+  where+withoutKeys t1@(Bin p1 _ _) (IntSet.Tip p2 bm2) =+    let px1 = unPrefix p1+        minbit = bitmapOf (px1 .&. (px1-1))+        lt_minbit = minbit - 1+        maxbit = bitmapOf (px1 .|. (px1-1))+        gt_maxbit = (-maxbit) `xor` maxbit+    -- TODO(wrengr): should we manually inline/unroll 'updatePrefix'+    -- and 'withoutBM' here, in order to avoid redundant case analyses?+    in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)+withoutKeys t1@(Bin _ _ _) IntSet.Nil = t1+withoutKeys t1@(Tip k1 _) t2+    | k1 `IntSet.member` t2 = Nil+    | otherwise = t1+withoutKeys Nil _ = Nil+++updatePrefix+    :: IntSetPrefix -> IntMap a -> (IntMap a -> IntMap a) -> IntMap a+updatePrefix !kp t@(Bin p l r) f+    | unPrefix p .&. IntSet.suffixBitMask /= 0 =+        if unPrefix p .&. IntSet.prefixBitMask == kp then f t else t+    | nomatch kp p = t+    | left kp p    = binCheckLeft p (updatePrefix kp l f) r+    | otherwise    = binCheckRight p l (updatePrefix kp r f)+updatePrefix kp t@(Tip kx _) f+    | kx .&. IntSet.prefixBitMask == kp = f t+    | otherwise = t+updatePrefix _ Nil _ = Nil+++withoutBM :: IntSetBitMap -> IntMap a -> IntMap a+withoutBM 0 t = t+withoutBM bm (Bin p l r) =+    let leftBits = bitmapOf (unPrefix p) - 1+        bmL = bm .&. leftBits+        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+    in  bin p (withoutBM bmL l) (withoutBM bmR r)+withoutBM bm t@(Tip k _)+    -- TODO(wrengr): need we manually inline 'IntSet.Member' here?+    | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = Nil+    | otherwise = t+withoutBM _ Nil = Nil+++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The (left-biased) intersection of two maps (based on keys).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: IntMap a -> IntMap b -> IntMap a+intersection m1 m2+  = mergeWithKey' bin const (const Nil) (const Nil) m1 m2+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The restriction of a map to the keys in a set.+--+-- @+-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``IntSet.member`` s) m+-- @+--+-- @since 0.5.8+restrictKeys :: IntMap a -> IntSet.IntSet -> IntMap a+restrictKeys t1@(Bin p1 l1 r1) t2@(IntSet.Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> restrictKeys l1 t2+  ABR -> restrictKeys r1 t2+  BAL -> restrictKeys t1 l2+  BAR -> restrictKeys t1 r2+  EQL -> bin p1 (restrictKeys l1 l2) (restrictKeys r1 r2)+  NOM -> Nil+restrictKeys t1@(Bin p1 _ _) (IntSet.Tip p2 bm2) =+    let px1 = unPrefix p1+        minbit = bitmapOf (px1 .&. (px1-1))+        ge_minbit = complement (minbit - 1)+        maxbit = bitmapOf (px1 .|. (px1-1))+        le_maxbit = maxbit .|. (maxbit - 1)+    -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'+    -- and 'restrictBM' here, in order to avoid redundant case analyses?+    in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)+restrictKeys (Bin _ _ _) IntSet.Nil = Nil+restrictKeys t1@(Tip k1 _) t2+    | k1 `IntSet.member` t2 = t1+    | otherwise = Nil+restrictKeys Nil _ = Nil+++-- | \(O(\min(n,W))\). Restrict to the sub-map with all keys matching+-- a key prefix.+lookupPrefix :: IntSetPrefix -> IntMap a -> IntMap a+lookupPrefix !kp t@(Bin p l r)+    | unPrefix p .&. IntSet.suffixBitMask /= 0 =+        if unPrefix p .&. IntSet.prefixBitMask == kp then t else Nil+    | nomatch kp p = Nil+    | left kp p    = lookupPrefix kp l+    | otherwise    = lookupPrefix kp r+lookupPrefix kp t@(Tip kx _)+    | (kx .&. IntSet.prefixBitMask) == kp = t+    | otherwise = Nil+lookupPrefix _ Nil = Nil+++restrictBM :: IntSetBitMap -> IntMap a -> IntMap a+restrictBM 0 _ = Nil+restrictBM bm (Bin p l r) =+    let leftBits = bitmapOf (unPrefix p) - 1+        bmL = bm .&. leftBits+        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+    in  bin p (restrictBM bmL l) (restrictBM bmR r)+restrictBM bm t@(Tip k _)+    -- TODO(wrengr): need we manually inline 'IntSet.Member' here?+    | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = t+    | otherwise = Nil+restrictBM _ Nil = Nil+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWith f m1 m2+  = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWithKey f m1 m2+  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2++{--------------------------------------------------------------------+  Symmetric difference+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The symmetric difference of two maps.+--+-- The result contains entries whose keys appear in exactly one of the two maps.+--+-- @+-- symmetricDifference+--   (fromList [(0,\'q\'),(2,\'b\'),(4,\'w\'),(6,\'o\')])+--   (fromList [(0,\'e\'),(3,\'r\'),(6,\'t\'),(9,\'s\')])+-- ==+-- fromList [(2,\'b\'),(3,\'r\'),(4,\'w\'),(9,\'s\')]+-- @+--+-- @since 0.8+symmetricDifference :: IntMap a -> IntMap a -> IntMap a+symmetricDifference t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) =+  case treeTreeBranch p1 p2 of+    ABL -> bin p1 (symmetricDifference l1 t2) r1+    ABR -> bin p1 l1 (symmetricDifference r1 t2)+    BAL -> bin p2 (symmetricDifference t1 l2) r2+    BAR -> bin p2 l2 (symmetricDifference t1 r2)+    EQL -> bin p1 (symmetricDifference l1 l2) (symmetricDifference r1 r2)+    NOM -> link (unPrefix p1) t1 (unPrefix p2) t2+symmetricDifference t1@(Bin _ _ _) t2@(Tip k2 _) = symDiffTip t2 k2 t1+symmetricDifference t1@(Bin _ _ _) Nil = t1+symmetricDifference t1@(Tip k1 _) t2 = symDiffTip t1 k1 t2+symmetricDifference Nil t2 = t2++symDiffTip :: IntMap a -> Int -> IntMap a -> IntMap a+symDiffTip !t1 !k1 = go+  where+    go t2@(Bin p2 l2 r2)+      | nomatch k1 p2 = linkKey k1 t1 p2 t2+      | left k1 p2 = bin p2 (go l2) r2+      | otherwise = bin p2 l2 (go r2)+    go t2@(Tip k2 _)+      | k1 == k2 = Nil+      | otherwise = link k1 t1 k2 t2+    go Nil = t1++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- A high-performance universal combining function. Using+-- 'mergeWithKey', all combining functions can be defined without any loss of+-- efficiency (with exception of 'union', 'difference' and 'intersection',+-- where sharing of some nodes is lost with 'mergeWithKey').+--+-- __Warning__: Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'IntMap's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++-- See Note [IntMap merge complexity]+mergeWithKey :: (Key -> a -> b -> Maybe c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)+             -> IntMap a -> IntMap b -> IntMap c+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2+  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.+        combine = \(Tip k1 x1) (Tip _k2 x2) ->+          case f k1 x1 x2 of+            Nothing -> Nil+            Just x -> Tip k1 x+        {-# INLINE combine #-}+{-# INLINE mergeWithKey #-}++-- Slightly more general version of mergeWithKey. It differs in the following:+--+-- * the combining function operates on maps instead of keys and values. The+--   reason is to enable sharing in union, difference and intersection.+--+-- * mergeWithKey' is given an equivalent of bin. The reason is that in union*,+--   Bin constructor can be used, because we know both subtrees are nonempty.++mergeWithKey' :: (Prefix -> IntMap c -> IntMap c -> IntMap c)+              -> (IntMap a -> IntMap b -> IntMap c) -> (IntMap a -> IntMap c) -> (IntMap b -> IntMap c)+              -> IntMap a -> IntMap b -> IntMap c+mergeWithKey' bin' f g1 g2 = go+  where+    go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+      ABL -> bin' p1 (go l1 t2) (g1 r1)+      ABR -> bin' p1 (g1 l1) (go r1 t2)+      BAL -> bin' p2 (go t1 l2) (g2 r2)+      BAR -> bin' p2 (g2 l2) (go t1 r2)+      EQL -> bin' p1 (go l1 l2) (go r1 r2)+      NOM -> maybe_link (unPrefix p1) (g1 t1) (unPrefix p2) (g2 t2)++    go t1'@(Bin _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1'+      where+        merge0 t2 k2 t1@(Bin p1 l1 r1)+          | nomatch k2 p1 = maybe_link (unPrefix p1) (g1 t1) k2 (g2 t2)+          | left k2 p1    = bin' p1 (merge0 t2 k2 l1) (g1 r1)+          | otherwise     = bin' p1 (g1 l1) (merge0 t2 k2 r1)+        merge0 t2 k2 t1@(Tip k1 _)+          | k1 == k2 = f t1 t2+          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+        merge0 t2 _  Nil = g2 t2++    go t1@(Bin _ _ _) Nil = g1 t1++    go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'+      where+        merge0 t1 k1 t2@(Bin p2 l2 r2)+          | nomatch k1 p2 = maybe_link k1 (g1 t1) (unPrefix p2) (g2 t2)+          | left k1 p2    = bin' p2 (merge0 t1 k1 l2) (g2 r2)+          | otherwise     = bin' p2 (g2 l2) (merge0 t1 k1 r2)+        merge0 t1 k1 t2@(Tip k2 _)+          | k1 == k2 = f t1 t2+          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+        merge0 t1 _  Nil = g1 t1++    go Nil Nil = Nil++    go Nil t2 = g2 t2++    maybe_link _ Nil _ t2 = t2+    maybe_link _ t1 _ Nil = t1+    maybe_link k1 t1 k2 t2 = link k1 t1 k2 t2+    {-# INLINE maybe_link #-}+{-# INLINE mergeWithKey' #-}+++{--------------------------------------------------------------------+  mergeA+--------------------------------------------------------------------}++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge' or 'mergeA'.+--+-- A tactic of type @WhenMissing f k x z@ is an abstract representation+-- of a function of type @Key -> x -> f (Maybe z)@.+--+-- @since 0.5.9++data WhenMissing f x y = WhenMissing+  { missingSubtree :: IntMap x -> f (IntMap y)+  , missingKey :: Key -> x -> f (Maybe y)}++-- | @since 0.5.9+instance (Applicative f, Monad f) => Functor (WhenMissing f x) where+  fmap = mapWhenMissing+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Applicative f, Monad f) => Category.Category (WhenMissing f)+  where+    id = preserveMissing+    f . g =+      traverseMaybeMissing $ \ k x -> do+        y <- missingKey g k x+        case y of+          Nothing -> pure Nothing+          Just q  -> missingKey f k q+    {-# INLINE id #-}+    {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where+  pure x = mapMissing (\ _ _ -> x)+  f <*> g =+    traverseMaybeMissing $ \k x -> do+      res1 <- missingKey f k x+      case res1 of+        Nothing -> pure Nothing+        Just r  -> (pure $!) . fmap r =<< missingKey g k x+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Monad (WhenMissing f x) where+  m >>= f =+    traverseMaybeMissing $ \k x -> do+      res1 <- missingKey m k x+      case res1 of+        Nothing -> pure Nothing+        Just r  -> missingKey (f r) k x+  {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMissing' f x@.+--+-- @since 0.5.9+mapWhenMissing+  :: (Applicative f, Monad f)+  => (a -> b)+  -> WhenMissing f x a+  -> WhenMissing f x b+mapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'+  , missingKey     = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }+{-# INLINE mapWhenMissing #-}+++-- | Map covariantly over a @'WhenMissing' f x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMissing+  :: Functor f+  => (a -> b)+  -> WhenMissing f x a+  -> WhenMissing f x b+mapGentlyWhenMissing f t = WhenMissing+  { missingSubtree = \m -> fmap f <$> missingSubtree t m+  , missingKey     = \k x -> fmap f <$> missingKey t k x }+{-# INLINE mapGentlyWhenMissing #-}+++-- | Map covariantly over a @'WhenMatched' f k x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMatched+  :: Functor f+  => (a -> b)+  -> WhenMatched f x y a+  -> WhenMatched f x y b+mapGentlyWhenMatched f t =+  zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y+{-# INLINE mapGentlyWhenMatched #-}+++-- | Map contravariantly over a @'WhenMissing' f _ x@.+--+-- @since 0.5.9+lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x+lmapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t (fmap f m)+  , missingKey     = \k x -> missingKey t k (f x) }+{-# INLINE lmapWhenMissing #-}+++-- | Map contravariantly over a @'WhenMatched' f _ y z@.+--+-- @since 0.5.9+contramapFirstWhenMatched+  :: (b -> a)+  -> WhenMatched f a y z+  -> WhenMatched f b y z+contramapFirstWhenMatched f t =+  WhenMatched $ \k x y -> runWhenMatched t k (f x) y+{-# INLINE contramapFirstWhenMatched #-}+++-- | Map contravariantly over a @'WhenMatched' f x _ z@.+--+-- @since 0.5.9+contramapSecondWhenMatched+  :: (b -> a)+  -> WhenMatched f x a z+  -> WhenMatched f x b z+contramapSecondWhenMatched f t =+  WhenMatched $ \k x y -> runWhenMatched t k x (f y)+{-# INLINE contramapSecondWhenMatched #-}+++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge'.+--+-- A tactic of type @SimpleWhenMissing x z@ is an abstract+-- representation of a function of type @Key -> x -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMissing = WhenMissing Identity+++-- | A tactic for dealing with keys present in both maps in 'merge'+-- or 'mergeA'.+--+-- A tactic of type @WhenMatched f x y z@ is an abstract representation+-- of a function of type @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+newtype WhenMatched f x y z = WhenMatched+  { matchedKey :: Key -> x -> y -> f (Maybe z) }+++-- | Along with zipWithMaybeAMatched, witnesses the isomorphism+-- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z)+runWhenMatched = matchedKey+{-# INLINE runWhenMatched #-}+++-- | Along with traverseMaybeMissing, witnesses the isomorphism+-- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@.+--+-- @since 0.5.9+runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y)+runWhenMissing = missingKey+{-# INLINE runWhenMissing #-}+++-- | @since 0.5.9+instance Functor f => Functor (WhenMatched f x y) where+  fmap = mapWhenMatched+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Monad f, Applicative f) => Category.Category (WhenMatched f x)+  where+    id = zipWithMatched (\_ _ y -> y)+    f . g =+      zipWithMaybeAMatched $ \k x y -> do+        res <- runWhenMatched g k x y+        case res of+          Nothing -> pure Nothing+          Just r  -> runWhenMatched f k x r+    {-# INLINE id #-}+    {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where+  pure x = zipWithMatched (\_ _ _ -> x)+  fs <*> xs =+    zipWithMaybeAMatched $ \k x y -> do+      res <- runWhenMatched fs k x y+      case res of+        Nothing -> pure Nothing+        Just r  -> (pure $!) . fmap r =<< runWhenMatched xs k x y+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where+  m >>= f =+    zipWithMaybeAMatched $ \k x y -> do+      res <- runWhenMatched m k x y+      case res of+        Nothing -> pure Nothing+        Just r  -> runWhenMatched (f r) k x y+  {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMatched' f x y@.+--+-- @since 0.5.9+mapWhenMatched+  :: Functor f+  => (a -> b)+  -> WhenMatched f x y a+  -> WhenMatched f x y b+mapWhenMatched f (WhenMatched g) =+  WhenMatched $ \k x y -> fmap (fmap f) (g k x y)+{-# INLINE mapWhenMatched #-}+++-- | A tactic for dealing with keys present in both maps in 'merge'.+--+-- A tactic of type @SimpleWhenMatched x y z@ is an abstract+-- representation of a function of type @Key -> x -> y -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMatched = WhenMatched Identity+++-- | When a key is found in both maps, apply a function to the key+-- and values and use the result in the merged map.+--+-- > zipWithMatched+-- >   :: (Key -> x -> y -> z)+-- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMatched+  :: Applicative f+  => (Key -> x -> y -> z)+  -> WhenMatched f x y z+zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y+{-# INLINE zipWithMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values to produce an action and use its result in the merged+-- map.+--+-- @since 0.5.9+zipWithAMatched+  :: Applicative f+  => (Key -> x -> y -> f z)+  -> WhenMatched f x y z+zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y+{-# INLINE zipWithAMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values and maybe use the result in the merged map.+--+-- > zipWithMaybeMatched+-- >   :: (Key -> x -> y -> Maybe z)+-- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMaybeMatched+  :: Applicative f+  => (Key -> x -> y -> Maybe z)+  -> WhenMatched f x y z+zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y+{-# INLINE zipWithMaybeMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values, perform the resulting action, and maybe use the+-- result in the merged map.+--+-- This is the fundamental 'WhenMatched' tactic.+--+-- @since 0.5.9+zipWithMaybeAMatched+  :: (Key -> x -> y -> f (Maybe z))+  -> WhenMatched f x y z+zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y+{-# INLINE zipWithMaybeAMatched #-}+++-- | Drop all the entries whose keys are missing from the other+-- map.+--+-- > dropMissing :: SimpleWhenMissing x y+--+-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)+--+-- but @dropMissing@ is much faster.+--+-- @since 0.5.9+dropMissing :: Applicative f => WhenMissing f x y+dropMissing = WhenMissing+  { missingSubtree = const (pure Nil)+  , missingKey     = \_ _ -> pure Nothing }+{-# INLINE dropMissing #-}+++-- | Preserve, unchanged, the entries whose keys are missing from+-- the other map.+--+-- > preserveMissing :: SimpleWhenMissing x x+--+-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)+--+-- but @preserveMissing@ is much faster.+--+-- @since 0.5.9+preserveMissing :: Applicative f => WhenMissing f x x+preserveMissing = WhenMissing+  { missingSubtree = pure+  , missingKey     = \_ v -> pure (Just v) }+{-# INLINE preserveMissing #-}+++-- | Map over the entries whose keys are missing from the other map.+--+-- > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+--+-- @since 0.5.9+mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y+mapMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapWithKey f m+  , missingKey     = \k x -> pure $ Just (f k x) }+{-# INLINE mapMissing #-}+++-- | Map over the entries whose keys are missing from the other+-- map, optionally removing some. This is the most powerful+-- 'SimpleWhenMissing' tactic, but others are usually more efficient.+--+-- > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y+--+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))+--+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative'+-- operations.+--+-- @since 0.5.9+mapMaybeMissing+  :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y+mapMaybeMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapMaybeWithKey f m+  , missingKey     = \k x -> pure $! f k x }+{-# INLINE mapMaybeMissing #-}+++-- | Filter the entries whose keys are missing from the other map.+--+-- > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x+--+-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterMissing+  :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x+filterMissing f = WhenMissing+  { missingSubtree = \m -> pure $! filterWithKey f m+  , missingKey     = \k x -> pure $! if f k x then Just x else Nothing }+{-# INLINE filterMissing #-}+++-- | Filter the entries whose keys are missing from the other map+-- using some 'Applicative' action.+--+-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $+-- >   \k x -> (\b -> guard b *> Just x) <$> f k x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterAMissing+  :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x+filterAMissing f = WhenMissing+  { missingSubtree = \m -> filterWithKeyA f m+  , missingKey     = \k x -> bool Nothing (Just x) <$> f k x }+{-# INLINE filterAMissing #-}+++-- | \(O(n)\). Filter keys and values using an 'Applicative' predicate.+filterWithKeyA+  :: Applicative f => (Key -> a -> f Bool) -> IntMap a -> f (IntMap a)+filterWithKeyA _ Nil           = pure Nil+filterWithKeyA f t@(Tip k x)   = (\b -> if b then t else Nil) <$> f k x+filterWithKeyA f (Bin p l r)+  | signBranch p = liftA2 (flip (bin p)) (filterWithKeyA f r) (filterWithKeyA f l)+  | otherwise = liftA2 (bin p) (filterWithKeyA f l) (filterWithKeyA f r)++-- | This wasn't in Data.Bool until 4.7.0, so we define it here+bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True  = t+++-- | Traverse over the entries whose keys are missing from the other+-- map.+--+-- @since 0.5.9+traverseMissing+  :: Applicative f => (Key -> x -> f y) -> WhenMissing f x y+traverseMissing f = WhenMissing+  { missingSubtree = traverseWithKey f+  , missingKey = \k x -> Just <$> f k x }+{-# INLINE traverseMissing #-}+++-- | Traverse over the entries whose keys are missing from the other+-- map, optionally producing values to put in the result. This is+-- the most powerful 'WhenMissing' tactic, but others are usually+-- more efficient.+--+-- @since 0.5.9+traverseMaybeMissing+  :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y+traverseMaybeMissing f = WhenMissing+  { missingSubtree = traverseMaybeWithKey f+  , missingKey = f }+{-# INLINE traverseMaybeMissing #-}+++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.6.4+traverseMaybeWithKey+  :: Applicative f => (Key -> a -> f (Maybe b)) -> IntMap a -> f (IntMap b)+traverseMaybeWithKey f = go+    where+    go Nil           = pure Nil+    go (Tip k x)     = maybe Nil (Tip k) <$> f k x+    go (Bin p l r)+      | signBranch p = liftA2 (flip (bin p)) (go r) (go l)+      | otherwise = liftA2 (bin p) (go l) (go r)+++-- | Merge two maps.+--+-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic+-- and two maps. It uses the tactics to merge the maps. Its behavior+-- is best understood via its fundamental tactics, 'mapMaybeMissing'+-- and 'zipWithMaybeMatched'.+--+-- Consider+--+-- @+-- merge (mapMaybeMissing g1)+--              (mapMaybeMissing g2)+--              (zipWithMaybeMatched f)+--              m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'merge' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]+-- m2 =           [(1, "one"), (2, "two"),           (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- This produces a 'Maybe' for each key:+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'mapMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+--+-- When 'merge' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should typically use+-- 'merge' to define your custom combining functions.+--+--+-- Examples:+--+-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)+-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)+-- prop> differenceWith f = merge diffPreserve diffDrop f+-- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)+-- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)+--+-- @since 0.5.9+merge+  :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@+  -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@+  -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> IntMap a -- ^ Map @m1@+  -> IntMap b -- ^ Map @m2@+  -> IntMap c+merge g1 g2 f m1 m2 =+  runIdentity $ mergeA g1 g2 f m1 m2+{-# INLINE merge #-}+++-- | An applicative version of 'merge'.+--+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'+-- tactic and two maps. It uses the tactics to merge the maps.+-- Its behavior is best understood via its fundamental tactics,+-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+--               (traverseMaybeMissing g2)+--               (zipWithMaybeAMatched f)+--               m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'mergeA' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]+-- m2 =           [(1, "one"), (2, "two"),           (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- Next, it will perform the actions in the @actions@ list in order from+-- left to right.+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'traverseMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+-- * 'mapMaybeMissing' does not use the 'Applicative' context.+--+-- When 'mergeA' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should generally only use+-- 'mergeA' to define custom combining functions.+--+-- @since 0.5.9+mergeA+  :: (Applicative f)+  => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@+  -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@+  -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> IntMap a -- ^ Map @m1@+  -> IntMap b -- ^ Map @m2@+  -> f (IntMap c)+mergeA+    WhenMissing{missingSubtree = g1t, missingKey = g1k}+    WhenMissing{missingSubtree = g2t, missingKey = g2k}+    WhenMatched{matchedKey = f}+    = go+  where+    go t1  Nil = g1t t1+    go Nil t2  = g2t t2++    -- This case is already covered below.+    -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2++    go (Tip k1 x1) t2' = merge2 t2'+      where+        merge2 t2@(Bin p2 l2 r2)+          | nomatch k1 p2 = linkA k1 (subsingletonBy g1k k1 x1) (unPrefix p2) (g2t t2)+          | left k1 p2    = binA p2 (merge2 l2) (g2t r2)+          | otherwise     = binA p2 (g2t l2) (merge2 r2)+        merge2 (Tip k2 x2)   = mergeTips k1 x1 k2 x2+        merge2 Nil           = subsingletonBy g1k k1 x1++    go t1' (Tip k2 x2) = merge1 t1'+      where+        merge1 t1@(Bin p1 l1 r1)+          | nomatch k2 p1 = linkA (unPrefix p1) (g1t t1) k2 (subsingletonBy g2k k2 x2)+          | left k2 p1    = binA p1 (merge1 l1) (g1t r1)+          | otherwise     = binA p1 (g1t l1) (merge1 r1)+        merge1 (Tip k1 x1)   = mergeTips k1 x1 k2 x2+        merge1 Nil           = subsingletonBy g2k k2 x2++    go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+      ABL -> binA p1 (go l1 t2) (g1t r1)+      ABR -> binA p1 (g1t l1) (go r1 t2)+      BAL -> binA p2 (go t1 l2) (g2t r2)+      BAR -> binA p2 (g2t l2) (go t1 r2)+      EQL -> binA p1 (go l1 l2) (go r1 r2)+      NOM -> linkA (unPrefix p1) (g1t t1) (unPrefix p2) (g2t t2)++    subsingletonBy :: Functor f => (Key -> a -> f (Maybe c)) -> Key -> a -> f (IntMap c)+    subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x+    {-# INLINE subsingletonBy #-}++    mergeTips k1 x1 k2 x2+      | k1 == k2  = maybe Nil (Tip k1) <$> f k1 x1 x2+      | k1 <  k2  = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2)+        {-+        = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2+        -}+      | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1)+    {-# INLINE mergeTips #-}++    subdoubleton _ _   Nothing Nothing     = Nil+    subdoubleton _ k2  Nothing (Just y2)   = Tip k2 y2+    subdoubleton k1 _  (Just y1) Nothing   = Tip k1 y1+    subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2)+    {-# INLINE subdoubleton #-}++    -- | A variant of 'link_' which makes sure to execute side-effects+    -- in the right order.+    linkA+        :: Applicative f+        => Int -> f (IntMap a)+        -> Int -> f (IntMap a)+        -> f (IntMap a)+    linkA k1 t1 k2 t2+      | i2w k1 < i2w k2 = binA p t1 t2+      | otherwise = binA p t2 t1+      where+        m = branchMask k1 k2+        p = Prefix (mask k1 m .|. m)+    {-# INLINE linkA #-}++    -- A variant of 'bin' that ensures that effects for negative keys are executed+    -- first.+    binA+        :: Applicative f+        => Prefix+        -> f (IntMap a)+        -> f (IntMap a)+        -> f (IntMap a)+    binA p a b+      | signBranch p = liftA2 (flip (bin p)) b a+      | otherwise = liftA2 (bin p) a b+    {-# INLINE binA #-}+{-# INLINE mergeA #-}+++{--------------------------------------------------------------------+  Min\/Max+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMinWithKey f t =+  case t of Bin p l r | signBranch p -> binCheckRight p l (go f r)+            _ -> go f t+  where+    go f' (Bin p l r) = binCheckLeft p (go f' l) r+    go f' (Tip k y) = case f' k y of+                        Just y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil =  Nil++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMaxWithKey f t =+  case t of Bin p l r | signBranch p -> binCheckLeft p (go f l) r+            _ -> go f t+  where+    go f' (Bin p l r) = binCheckRight p l (go f' r)+    go f' (Tip k y) = case f' k y of+                        Just y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = Nil+++data View a = View {-# UNPACK #-} !Key a !(IntMap a)++-- | \(O(\min(n,W))\). Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)+maxViewWithKey t = case t of+  Nil -> Nothing+  _ -> Just $ case maxViewWithKeySure t of+                View k v t' -> ((k, v), t')+{-# INLINE maxViewWithKey #-}++maxViewWithKeySure :: IntMap a -> View a+maxViewWithKeySure t =+  case t of+    Nil -> error "maxViewWithKeySure Nil"+    Bin p l r | signBranch p ->+      case go l of View k a l' -> View k a (binCheckLeft p l' r)+    _ -> go t+  where+    go (Bin p l r) =+        case go r of View k a r' -> View k a (binCheckRight p l r')+    go (Tip k y) = View k y Nil+    go Nil = error "maxViewWithKey_go Nil"+-- See note on NOINLINE at minViewWithKeySure+{-# NOINLINE maxViewWithKeySure #-}++-- | \(O(\min(n,W))\). Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)+minViewWithKey t =+  case t of+    Nil -> Nothing+    _ -> Just $ case minViewWithKeySure t of+                  View k v t' -> ((k, v), t')+-- We inline this to give GHC the best possible chance of+-- getting rid of the Maybe, pair, and Int constructors, as+-- well as a thunk under the Just. That is, we really want to+-- be certain this inlines!+{-# INLINE minViewWithKey #-}++minViewWithKeySure :: IntMap a -> View a+minViewWithKeySure t =+  case t of+    Nil -> error "minViewWithKeySure Nil"+    Bin p l r | signBranch p ->+      case go r of+        View k a r' -> View k a (binCheckRight p l r')+    _ -> go t+  where+    go (Bin p l r) =+        case go l of View k a l' -> View k a (binCheckLeft p l' r)+    go (Tip k y) = View k y Nil+    go Nil = error "minViewWithKey_go Nil"+-- There's never anything significant to be gained by inlining+-- this. Sufficiently recent GHC versions will inline the wrapper+-- anyway, which should be good enough.+{-# NOINLINE minViewWithKeySure #-}++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> IntMap a -> IntMap a+updateMax f = updateMaxWithKey (const f)++-- | \(O(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a+updateMin f = updateMinWithKey (const f)++-- | \(O(\min(n,W))\). Retrieves the maximal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+maxView :: IntMap a -> Maybe (a, IntMap a)+maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t)++-- | \(O(\min(n,W))\). Retrieves the minimal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+minView :: IntMap a -> Maybe (a, IntMap a)+minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t)++-- | \(O(\min(n,W))\). Delete and find the maximal element.+-- This function throws an error if the map is empty. Use 'maxViewWithKey'+-- if the map may be empty.+deleteFindMax :: IntMap a -> ((Key, a), IntMap a)+deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey++-- | \(O(\min(n,W))\). Delete and find the minimal element.+-- This function throws an error if the map is empty. Use 'minViewWithKey'+-- if the map may be empty.+deleteFindMin :: IntMap a -> ((Key, a), IntMap a)+deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey++-- The KeyValue type is used when returning a key-value pair and helps with+-- GHC optimizations.+--+-- For lookupMinSure, if the return type is (Int, a), GHC compiles it to a+-- worker $wlookupMinSure :: IntMap a -> (# Int, a #). If the return type is+-- KeyValue a instead, the worker does not box the int and returns+-- (# Int#, a #).+-- For a modern enough GHC (>=9.4), this measure turns out to be unnecessary in+-- this instance. We still use it for older GHCs and to make our intent clear.++data KeyValue a = KeyValue {-# UNPACK #-} !Key a++kvToTuple :: KeyValue a -> (Key, a)+kvToTuple (KeyValue k x) = (k, x)+{-# INLINE kvToTuple #-}++lookupMinSure :: IntMap a -> KeyValue a+lookupMinSure (Tip k v)   = KeyValue k v+lookupMinSure (Bin _ l _) = lookupMinSure l+lookupMinSure Nil         = error "lookupMinSure Nil"++-- | \(O(\min(n,W))\). The minimal key of the map. Returns 'Nothing' if the map is empty.+lookupMin :: IntMap a -> Maybe (Key, a)+lookupMin Nil         = Nothing+lookupMin (Tip k v)   = Just (k,v)+lookupMin (Bin p l r) =+  Just $! kvToTuple (lookupMinSure (if signBranch p then r else l))+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The minimal key of the map. Calls 'error' if the map is empty.+findMin :: IntMap a -> (Key, a)+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "findMin: empty map has no minimal element"++lookupMaxSure :: IntMap a -> KeyValue a+lookupMaxSure (Tip k v)   = KeyValue k v+lookupMaxSure (Bin _ _ r) = lookupMaxSure r+lookupMaxSure Nil         = error "lookupMaxSure Nil"++-- | \(O(\min(n,W))\). The maximal key of the map. Returns 'Nothing' if the map is empty.+lookupMax :: IntMap a -> Maybe (Key, a)+lookupMax Nil         = Nothing+lookupMax (Tip k v)   = Just (k,v)+lookupMax (Bin p l r) =+  Just $! kvToTuple (lookupMaxSure (if signBranch p then l else r))+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The maximal key of the map. Calls 'error' if the map is empty.+findMax :: IntMap a -> (Key, a)+findMax t+  | Just r <- lookupMax t = r+  | otherwise = error "findMax: empty map has no maximal element"++-- | \(O(\min(n,W))\). Delete the minimal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;+-- versions prior to 0.5 threw an error if the 'IntMap' was already empty.+deleteMin :: IntMap a -> IntMap a+deleteMin = maybe Nil snd . minView++-- | \(O(\min(n,W))\). Delete the maximal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;+-- versions prior to 0.5 threw an error if the 'IntMap' was already empty.+deleteMax :: IntMap a -> IntMap a+deleteMax = maybe Nil snd . maxView+++{--------------------------------------------------------------------+  Submap+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+isProperSubmapOf m1 m2+  = isProperSubmapOfBy (==) m1 m2++{- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+ Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @keys m1@ and @keys m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])+-}+isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isProperSubmapOfBy predicate t1 t2+  = case submapCmp predicate t1 t2 of+      LT -> True+      _  -> False++submapCmp :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Ordering+submapCmp predicate t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> GT+  ABR -> GT+  BAL -> submapCmpLt l2+  BAR -> submapCmpLt r2+  EQL -> submapCmpEq+  NOM -> GT  -- disjoint+  where+    submapCmpLt t = case submapCmp predicate t1 t of+                      GT -> GT+                      _  -> LT+    submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of+                    (GT,_ ) -> GT+                    (_ ,GT) -> GT+                    (EQ,EQ) -> EQ+                    _       -> LT++submapCmp _         (Bin _ _ _) _  = GT+submapCmp predicate (Tip kx x) (Tip ky y)+  | (kx == ky) && predicate x y = EQ+  | otherwise                   = GT  -- disjoint+submapCmp predicate (Tip k x) t+  = case lookup k t of+     Just y | predicate x y -> LT+     _                      -> GT -- disjoint+submapCmp _    Nil Nil = EQ+submapCmp _    Nil _   = LT++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Is this a submap?+-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+isSubmapOf m1 m2+  = isSubmapOfBy (==) m1 m2++{- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+ The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+-}+isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isSubmapOfBy predicate t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> False+  ABR -> False+  BAL -> isSubmapOfBy predicate t1 l2+  BAR -> isSubmapOfBy predicate t1 r2+  EQL -> isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2+  NOM -> False+isSubmapOfBy _         (Bin _ _ _) _ = False+isSubmapOfBy predicate (Tip k x) t     = case lookup k t of+                                         Just y  -> predicate x y+                                         Nothing -> False+isSubmapOfBy _         Nil _           = True++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | \(O(n)\). Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> IntMap a -> IntMap b+map f = go+  where+    go (Bin p l r) = Bin p (go l) (go r)+    go (Tip k x)   = Tip k (f x)+    go Nil         = Nil++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+"map/coerce" map coerce = coerce+ #-}+#endif++-- | \(O(n)\). Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKey f t+  = case t of+      Bin p l r -> Bin p (mapWithKey f l) (mapWithKey f r)+      Tip k x   -> Tip k (f k x)+      Nil       -> Nil++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif++-- | \(O(n)\).+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b)+traverseWithKey f = go+  where+    go Nil = pure Nil+    go (Tip k v) = Tip k <$> f k v+    go (Bin p l r)+      | signBranch p = liftA2 (flip (Bin p)) (go r) (go l)+      | otherwise = liftA2 (Bin p) (go l) (go r)+{-# INLINE traverseWithKey #-}++-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)++-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumL f a t+  = case t of+      Bin p l r+        | signBranch p ->+            let (a1,r') = mapAccumL f a r+                (a2,l') = mapAccumL f a1 l+            in (a2,Bin p l' r')+        | otherwise  ->+            let (a1,l') = mapAccumL f a l+                (a2,r') = mapAccumL f a1 r+            in (a2,Bin p l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumRWithKey f a t+  = case t of+      Bin p l r+        | signBranch p ->+            let (a1,l') = mapAccumRWithKey f a l+                (a2,r') = mapAccumRWithKey f a1 r+            in (a2,Bin p l' r')+        | otherwise  ->+            let (a1,r') = mapAccumRWithKey f a r+                (a2,l') = mapAccumRWithKey f a1 l+            in (a2,Bin p l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++-- | \(O(n \min(n,W))\).+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the value at the greatest of the+-- original keys is retained.+--+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])                        == fromList [(4, "b"), (6, "a")]+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"++mapKeys :: (Key->Key) -> IntMap a -> IntMap a+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | \(O(n \min(n,W))\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"+--+-- Also see the performance note on 'fromListWith'.++mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a+mapKeysWith c f+  = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | \(O(n)\).+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapKeysMonotonic f s == mapKeys f s+-- >     where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has slightly better performance than 'mapKeys'.+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'mapKeys' if the+-- precondition may not hold.+--+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]++mapKeysMonotonic :: (Key->Key) -> IntMap a -> IntMap a+mapKeysMonotonic f+  = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) []++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all values that satisfy some predicate.+--+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty++filter :: (a -> Bool) -> IntMap a -> IntMap a+filter p m+  = filterWithKey (\_ x -> p x) m++-- | \(O(n)\). Filter all keys that satisfy some predicate.+--+-- @+-- filterKeys p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- > filterKeys (> 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+--+-- @since 0.8++filterKeys :: (Key -> Bool) -> IntMap a -> IntMap a+filterKeys predicate = filterWithKey (\k _ -> predicate k)++-- | \(O(n)\). Filter all keys\/values that satisfy some predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a+filterWithKey predicate = go+    where+    go Nil         = Nil+    go t@(Tip k x) = if predicate k x then t else Nil+    go (Bin p l r) = bin p (go l) (go r)++-- | \(O(n)\). Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partition p m+  = partitionWithKey (\_ x -> p x) m++-- | \(O(n)\). Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partitionWithKey predicate0 t0 = toPair $ go predicate0 t0+  where+    go predicate t =+      case t of+        Bin p l r ->+          let (l1 :*: l2) = go predicate l+              (r1 :*: r2) = go predicate r+          in bin p l1 r1 :*: bin p l2 r2+        Tip k x+          | predicate k x -> (t :*: Nil)+          | otherwise     -> (Nil :*: t)+        Nil -> (Nil :*: Nil)++-- | \(O(\min(n,W))\). Take while a predicate on the keys holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'+-- takeWhileAntitone p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- @since 0.6.7+takeWhileAntitone :: (Key -> Bool) -> IntMap a -> IntMap a+takeWhileAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then bin p (go predicate l) r+        else go predicate r+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = bin p l (go predicate' r)+      | otherwise               = go predicate' l+    go predicate' t'@(Tip ky _)+      | predicate' ky = t'+      | otherwise     = Nil+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Drop while a predicate on the keys holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'+-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k))+-- @+--+-- @since 0.6.7+dropWhileAntitone :: (Key -> Bool) -> IntMap a -> IntMap a+dropWhileAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then go predicate l+        else bin p l (go predicate r)+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = go predicate' r+      | otherwise               = bin p (go predicate' l) r+    go predicate' t'@(Tip ky _)+      | predicate' ky = Nil+      | otherwise     = t'+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Divide a map at the point where a predicate on the keys stops holding.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = 'partitionWithKey' (\\k _ -> p k) xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map+-- at some /unspecified/ point.+--+-- @since 0.6.7+spanAntitone :: (Key -> Bool) -> IntMap a -> (IntMap a, IntMap a)+spanAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then+          case go predicate l of+            (lt :*: gt) ->+              let !lt' = bin p lt r+              in (lt', gt)+        else+          case go predicate r of+            (lt :*: gt) ->+              let !gt' = bin p l gt+              in (lt, gt')+    _ -> case go predicate t of+          (lt :*: gt) -> (lt, gt)+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p)+      = case go predicate' r of (lt :*: gt) -> bin p l lt :*: gt+      | otherwise+      = case go predicate' l of (lt :*: gt) -> lt :*: bin p gt r+    go predicate' t'@(Tip ky _)+      | predicate' ky = (t' :*: Nil)+      | otherwise     = (Nil :*: t')+    go _ Nil = (Nil :*: Nil)++-- | \(O(n)\). Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | \(O(n)\). Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b+mapMaybeWithKey f (Bin p l r)+  = bin p (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey _ Nil = Nil++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go f (Bin p l r) =+      bin p l1 r1 :*: bin p l2 r2+      where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r+    go f (Tip k x) = case f k x of+      Left y  -> (Tip k y :*: Nil)+      Right z -> (Nil :*: Tip k z)+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). The expression (@'split' k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)++split :: Key -> IntMap a -> (IntMap a, IntMap a)+split k t =+  case t of+    Bin p l r+      | signBranch p ->+        if k >= 0 -- handle negative numbers.+        then+          case go k l of+            (lt :*: gt) ->+              let !lt' = bin p lt r+              in (lt', gt)+        else+          case go k r of+            (lt :*: gt) ->+              let !gt' = bin p l gt+              in (lt, gt')+    _ -> case go k t of+          (lt :*: gt) -> (lt, gt)+  where+    go !k' t'@(Bin p l r)+      | nomatch k' p = if k' < unPrefix p then Nil :*: t' else t' :*: Nil+      | left k' p = case go k' l of (lt :*: gt) -> lt :*: bin p gt r+      | otherwise = case go k' r of (lt :*: gt) -> bin p l lt :*: gt+    go k' t'@(Tip ky _)+      | k' > ky   = (t' :*: Nil)+      | k' < ky   = (Nil :*: t')+      | otherwise = (Nil :*: Nil)+    go _ Nil = (Nil :*: Nil)+++data SplitLookup a = SplitLookup !(IntMap a) !(Maybe a) !(IntMap a)++mapLT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a+mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt+{-# INLINE mapLT #-}++mapGT :: (IntMap a -> IntMap a) -> SplitLookup a -> SplitLookup a+mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt)+{-# INLINE mapGT #-}++-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+--+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)++splitLookup :: Key -> IntMap a -> (IntMap a, Maybe a, IntMap a)+splitLookup k t =+  case+    case t of+      Bin p l r+        | signBranch p ->+          if k >= 0 -- handle negative numbers.+          then mapLT (flip (bin p) r) (go k l)+          else mapGT (bin p l) (go k r)+      _ -> go k t+  of SplitLookup lt fnd gt -> (lt, fnd, gt)+  where+    go !k' t'@(Bin p l r)+      | nomatch k' p =+          if k' < unPrefix p+          then SplitLookup Nil Nothing t'+          else SplitLookup t' Nothing Nil+      | left k' p = mapGT (flip (bin p) r) (go k' l)+      | otherwise  = mapLT (bin p l) (go k' r)+    go k' t'@(Tip ky y)+      | k' > ky   = SplitLookup t'  Nothing  Nil+      | k' < ky   = SplitLookup Nil Nothing  t'+      | otherwise = SplitLookup Nil (Just y) Nil+    go _ Nil      = SplitLookup Nil Nothing  Nil++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr :: (a -> b -> b) -> b -> IntMap a -> b+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip _ x)   = f x z'+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> IntMap a -> b+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip _ x)   = f x z'+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+--+-- For example,+--+-- > elems = reverse . foldl (flip (:)) []+--+-- > let f len a = len + (length a)+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldl :: (a -> b -> a) -> a -> IntMap b -> a+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip _ x)   = f z' x+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> IntMap b -> a+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip _ x)   = f z' x+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip kx x)  = f kx x z'+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldrWithKey #-}++-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip kx x)  = f kx x z'+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldrWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+--+-- For example,+--+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []+--+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"+foldlWithKey :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip kx x)  = f z' kx x+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldlWithKey #-}++-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin p l r+      | signBranch p -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip kx x)  = f z' kx x+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldlWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that+--+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@+--+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.+--+-- @since 0.5.4+foldMapWithKey :: Monoid m => (Key -> a -> m) -> IntMap a -> m+foldMapWithKey f = go+  where+    go Nil           = mempty+    go (Tip kx x)    = f kx x+    go (Bin p l r)+      | signBranch p = go r `mappend` go l+      | otherwise = go l `mappend` go r+{-# INLINE foldMapWithKey #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\).+-- Return all elements of the map in the ascending order of their keys.+-- Subject to list fusion.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: IntMap a -> [a]+elems = foldr (:) []++-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list+-- fusion.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys  :: IntMap a -> [Key]+keys = foldrWithKey (\k _ ks -> k : ks) []++-- | \(O(n)\). An alias for 'toAscList'. Returns all key\/value pairs in the+-- map in ascending key order. Subject to list fusion.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: IntMap a -> [(Key,a)]+assocs = toAscList++-- | \(O(n)\). The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]+-- > keysSet empty == Data.IntSet.empty++keysSet :: IntMap a -> IntSet.IntSet+keysSet Nil = IntSet.Nil+keysSet (Tip kx _) = IntSet.singleton kx+keysSet (Bin p l r)+  | unPrefix p .&. IntSet.suffixBitMask == 0+  = IntSet.Bin p (keysSet l) (keysSet r)+  | otherwise+  = IntSet.Tip (unPrefix p .&. IntSet.prefixBitMask) (computeBm (computeBm 0 l) r)+  where computeBm !acc (Bin _ l' r') = computeBm (computeBm acc l') r'+        computeBm acc (Tip kx _) = acc .|. IntSet.bitmapOf kx+        computeBm _   Nil = error "Data.IntSet.keysSet: Nil"++-- | \(O(n)\). Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.IntSet.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.IntSet.empty == empty++fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a+fromSet _ IntSet.Nil = Nil+fromSet f (IntSet.Bin p l r) = Bin p (fromSet f l) (fromSet f r)+fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)+  where+    -- This is slightly complicated, as we to convert the dense+    -- representation of IntSet into tree representation of IntMap.+    --+    -- We are given a nonzero bit mask 'bmask' of 'bits' bits with+    -- prefix 'prefix'. We split bmask into halves corresponding+    -- to left and right subtree. If they are both nonempty, we+    -- create a Bin node, otherwise exactly one of them is nonempty+    -- and we construct the IntMap from that half.+    buildTree g !prefix !bmask bits = case bits of+      0 -> Tip prefix (g prefix)+      _ -> case bits `iShiftRL` 1 of+        bits2+          | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->+              buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2+          | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->+              buildTree g prefix bmask bits2+          | otherwise ->+              Bin (Prefix (prefix .|. bits2))+                (buildTree g prefix bmask bits2)+                (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.6.2+instance GHCExts.IsList (IntMap a) where+  type Item (IntMap a) = (Key,a)+  fromList = fromList+  toList   = toList+#endif++-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list+-- fusion.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: IntMap a -> [(Key,a)]+toList = toAscList++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the+-- keys are in ascending order. Subject to list fusion.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: IntMap a -> [(Key,a)]+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys+-- are in descending order. Subject to list fusion.+--+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]++toDescList :: IntMap a -> [(Key,a)]+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.+-- They are important to convert unfused methods back, see mapFB in prelude.+foldrFB :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldrFB = foldrWithKey+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> b -> a) -> a -> IntMap b -> a+foldlFB = foldlWithKey+{-# INLINE[0] foldlFB #-}++-- Inline assocs and toList, so that we need to fuse only toAscList.+{-# INLINE assocs #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to+-- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to+-- inline it before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] elems #-}+{-# NOINLINE[0] keys #-}+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "IntMap.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}+{-# RULES "IntMap.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}+{-# RULES "IntMap.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}+{-# RULES "IntMap.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}+{-# RULES "IntMap.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}+{-# RULES "IntMap.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}+{-# RULES "IntMap.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}+{-# RULES "IntMap.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}+#endif+++-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> IntMap a+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x)  = insert k x t++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")]+-- > fromListWith (++) [] == empty+--+-- Note the reverse ordering of @"cba"@ in the example.+--+-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@.+--+-- === Performance+--+-- You should ensure that the given @f@ is fast with this order of arguments.+--+-- Symmetric functions may be slow in one order, and fast in another.+-- For the common case of collecting values of matching keys in a list, as above:+--+-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument.+-- Thus:+--+-- > fromListWith       (++)  (replicate 1000000 (3, "x"))   -- O(n),  fast+-- > fromListWith (flip (++)) (replicate 1000000 (3, "x"))   -- O(n²), extremely slow+--+-- because they evaluate as, respectively:+--+-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))]   -- O(n)+-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")]   -- O(n²)+--+-- Thus, to get good performance with an operation like @(++)@ while also preserving+-- the same order as in the input list, reverse the input:+--+-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")]+--+-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in:+--+-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples++fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty+--+-- Also see the performance note on 'fromListWith'.++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> IntMap a+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+--+-- Also see the performance note on 'fromListWith'.++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)+{-# NOINLINE fromAscListWith #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")]+--+-- Also see the performance note on 'fromListWith'.++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWithKey f = fromMonoListWithKey Nondistinct f+{-# NOINLINE fromAscListWithKey #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+--+-- __Warning__: This function should be used only if the keys are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++fromDistinctAscList :: [(Key,a)] -> IntMap a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.+--+-- Also see the performance note on 'fromListWith'.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromMonoListWithKey distinct f = go+  where+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1++    -- `addAll'` collects all keys equal to `kx` into a single value,+    -- and then proceeds with `addAll`.+    addAll' !kx vx []+        = Tip kx vx+    addAll' !kx vx ((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let v = f kx vy vx in addAll' ky v zs+        -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty kx (Tip kx vx)) zs'++    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_kx !tx []+        = tx+    addAll !kx !tx ((ky,vy) : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty kx tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !kx vx []+        = Inserted (Tip kx vx) []+    addMany' !m !kx vx zs0@((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let v = f kx vy vx in addMany' m ky v zs+        -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)+        | mask kx m /= mask ky m+        = Inserted (Tip kx vx) zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty kx (Tip kx vx)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.+    addMany !_m !_kx tx []+        = Inserted tx []+    addMany !m !kx tx zs0@((ky,vy) : zs)+        | mask kx m /= mask ky m+        = Inserted tx zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty kx tx) zs'+{-# INLINE fromMonoListWithKey #-}++data Inserted a = Inserted !(IntMap a) ![(Key,a)]++data Distinct = Distinct | Nondistinct++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq a => Eq (IntMap a) where+  (==) = equal++equal :: Eq a => IntMap a -> IntMap a -> Bool+equal (Bin p1 l1 r1) (Bin p2 l2 r2)+  = (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx x) (Tip ky y)+  = (kx == ky) && (x==y)+equal Nil Nil = True+equal _   _   = False+{-# INLINABLE equal #-}++-- | @since 0.5.9+instance Eq1 IntMap where+  liftEq eq = go+    where+      go (Bin p1 l1 r1) (Bin p2 l2 r2) = p1 == p2 && go l1 l2 && go r1 r2+      go (Tip kx x) (Tip ky y) = kx == ky && eq x y+      go Nil Nil = True+      go _   _   = False+  {-# INLINE liftEq #-}++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord a => Ord (IntMap a) where+  compare m1 m2 = liftCmp compare m1 m2+  {-# INLINABLE compare #-}++-- | @since 0.5.9+instance Ord1 IntMap where+  liftCompare = liftCmp++liftCmp :: (a -> b -> Ordering) -> IntMap a -> IntMap b -> Ordering+liftCmp cmp m1 m2 = case (splitSign m1, splitSign m2) of+  ((l1, r1), (l2, r2)) -> case go l1 l2 of+    A_LT_B -> LT+    A_Prefix_B -> if null r1 then LT else GT+    A_EQ_B -> case go r1 r2 of+      A_LT_B -> LT+      A_Prefix_B -> LT+      A_EQ_B -> EQ+      B_Prefix_A -> GT+      A_GT_B -> GT+    B_Prefix_A -> if null r2 then GT else LT+    A_GT_B -> GT+  where+    go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+      ABL -> case go l1 t2 of+        A_Prefix_B -> A_GT_B+        A_EQ_B -> B_Prefix_A+        o -> o+      ABR -> A_LT_B+      BAL -> case go t1 l2 of+        A_EQ_B -> A_Prefix_B+        B_Prefix_A -> A_LT_B+        o -> o+      BAR -> A_GT_B+      EQL -> case go l1 l2 of+        A_Prefix_B -> A_GT_B+        A_EQ_B -> go r1 r2+        B_Prefix_A -> A_LT_B+        o -> o+      NOM -> if unPrefix p1 < unPrefix p2 then A_LT_B else A_GT_B+    go (Bin _ l1 _) (Tip k2 x2) = case lookupMinSure l1 of+      KeyValue k1 x1 -> case compare k1 k2 <> cmp x1 x2 of+        LT -> A_LT_B+        EQ -> B_Prefix_A+        GT -> A_GT_B+    go (Tip k1 x1) (Bin _ l2 _) = case lookupMinSure l2 of+      KeyValue k2 x2 -> case compare k1 k2 <> cmp x1 x2 of+        LT -> A_LT_B+        EQ -> A_Prefix_B+        GT -> A_GT_B+    go (Tip k1 x1) (Tip k2 x2) = case compare k1 k2 <> cmp x1 x2 of+      LT -> A_LT_B+      EQ -> A_EQ_B+      GT -> A_GT_B+    go Nil Nil = A_EQ_B+    go Nil _ = A_Prefix_B+    go _ Nil = B_Prefix_A+{-# INLINE liftCmp #-}++-- Split into negative and non-negative+splitSign :: IntMap a -> (IntMap a, IntMap a)+splitSign t@(Bin p l r)+  | signBranch p = (r, l)+  | unPrefix p < 0 = (t, Nil)+  | otherwise = (Nil, t)+splitSign t@(Tip k _)+  | k < 0 = (t, Nil)+  | otherwise = (Nil, t)+splitSign Nil = (Nil, Nil)+{-# INLINE splitSign #-}++{--------------------------------------------------------------------+  Functor+--------------------------------------------------------------------}++instance Functor IntMap where+    fmap = map++#ifdef __GLASGOW_HASKELL__+    a <$ Bin p l r = Bin p (a <$ l) (a <$ r)+    a <$ Tip k _   = Tip k a+    _ <$ Nil       = Nil+#endif++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}++instance Show a => Show (IntMap a) where+  showsPrec d m   = showParen (d > 10) $+    showString "fromList " . shows (toList m)++-- | @since 0.5.9+instance Show1 IntMap where+    liftShowsPrec sp sl d m =+        showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)+      where+        sp' = liftShowsPrec sp sl+        sl' = liftShowList sp sl++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance (Read e) => Read (IntMap e) where+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault+#else+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)+#endif++-- | @since 0.5.9+instance Read1 IntMap where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}++-- | Link two @IntMap@s. The maps must not be empty. The @Prefix@es of the two+-- maps must be different. @k1@ must share the prefix of @t1@. @p2@ must be the+-- prefix of @t2@.+linkKey :: Key -> IntMap a -> Prefix -> IntMap a -> IntMap a+linkKey k1 t1 p2 t2 = link k1 t1 (unPrefix p2) t2+{-# INLINE linkKey #-}++-- | Link two @IntMap@s. The maps must not be empty. The @Prefix@es of the two+-- maps must be different. @k1@ must share the prefix of @t1@ and @k2@ must+-- share the prefix of @t2@.+link :: Int -> IntMap a -> Int -> IntMap a -> IntMap a+link k1 t1 k2 t2 = linkWithMask (branchMask k1 k2) k1 t1 k2 t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Int -> Key -> IntMap a -> Key -> IntMap a -> IntMap a+linkWithMask m k1 t1 k2 t2+  | i2w k1 < i2w k2 = Bin p t1 t2+  | otherwise = Bin p t2 t1+  where+    p = Prefix (mask k1 m .|. m)+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}++bin :: Prefix -> IntMap a -> IntMap a -> IntMap a+bin _ l Nil = l+bin _ Nil r = r+bin p l r   = Bin p l r+{-# INLINE bin #-}++-- binCheckLeft only checks that the left subtree is non-empty+binCheckLeft :: Prefix -> IntMap a -> IntMap a -> IntMap a+binCheckLeft _ Nil r = r+binCheckLeft p l r   = Bin p l r+{-# INLINE binCheckLeft #-}++-- binCheckRight only checks that the right subtree is non-empty+binCheckRight :: Prefix -> IntMap a -> IntMap a -> IntMap a+binCheckRight _ l Nil = l+binCheckRight p l r   = Bin p l r+{-# INLINE binCheckRight #-}++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | \(O(1)\).  Decompose a map into pieces based on the structure+-- of the underlying tree. This function is useful for consuming a+-- map in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==+-- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]+--+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than two submaps,+--  but you should not depend on this behaviour because it can change in the+--  future without notice.+splitRoot :: IntMap a -> [IntMap a]+splitRoot orig =+  case orig of+    Nil -> []+    x@(Tip _ _) -> [x]+    Bin p l r+      | signBranch p -> [r, l]+      | otherwise -> [l, r]+{-# INLINE splitRoot #-}+++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}++-- | \(O(n \min(n,W))\). Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => IntMap a -> String+showTree s+  = showTreeWith True False s+++{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the map. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS+showsTree wide lbars rbars t = case t of+  Bin p l r ->+    showsTree wide (withBar rbars) (withEmpty rbars) r .+    showWide wide rbars .+    showsBars lbars . showString (showBin p) . showString "\n" .+    showWide wide lbars .+    showsTree wide (withEmpty lbars) (withBar lbars) l+  Tip k x ->+    showsBars lbars .+    showString " " . shows k . showString ":=" . shows x . showString "\n"+  Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS+showsTreeHang wide bars t = case t of+  Bin p l r ->+    showsBars bars . showString (showBin p) . showString "\n" .+    showWide wide bars .+    showsTreeHang wide (withBar bars) l .+    showWide wide bars .+    showsTreeHang wide (withEmpty bars) r+  Tip k x ->+    showsBars bars .+    showString " " . shows k . showString ":=" . shows x . showString "\n"+  Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> String+showBin _+  = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _ : tl -> showString (concat (reverse tl)) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars++{--------------------------------------------------------------------+  Notes+--------------------------------------------------------------------}++-- Note [Okasaki-Gill]+-- ~~~~~~~~~~~~~~~~~~~+--+-- The IntMap structure is based on the map described in the paper "Fast+-- Mergeable Integer Maps" by Chris Okasaki and Andy Gill, with some+-- differences.+--+-- The paper spends most of its time describing a little-endian tree, where the+-- branching is done first on low bits then high bits. It then briefly describes+-- a big-endian tree. The implementation here is big-endian.+--+-- The definition of Okasaki and Gill's map would be written in Haskell as+--+-- data Dict a+--   = Empty+--   | Lf !Int a+--   | Br !Int !Int !(Dict a) !(Dict a)+--+-- Empty is the same as IntMap's Nil, and Lf is the same as Tip.+--+-- In Br, the first Int is the shared prefix and the second is the mask bit by+-- itself. For the big-endian map, the paper suggests that the prefix be the+-- common prefix, followed by a 0-bit, followed by all 1-bits. This is so that+-- the prefix value can be used as a point of split for binary search.+--+-- IntMap's Bin corresponds to Br, but is different because it has only one+-- Int (newtyped as Prefix). This describes both prefix and mask, so it is not+-- necessary to store them separately. This value is, in fact, one plus the+-- value suggested for the prefix in the paper. This representation is chosen+-- because it saves one word per Bin without detriment to the efficiency of+-- operations.+--+-- The implementation of operations such as lookup, insert, union, follow+-- the described implementations on Dict and split into the same cases. For+-- instance, for insert, the three cases on a Br are whether the key belongs+-- outside the map, or it belongs in the left child, or it belongs in the+-- right child. We have the same three cases for a Bin. However, the bitwise+-- operations we use to determine the case is naturally different due to the+-- difference in representation.++-- Note [IntMap merge complexity]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The merge algorithm (used for union, intersection, etc.) is adopted from+-- Okasaki-Gill who give the complexity as O(m+n), where m and n are the sizes+-- of the two input maps. This is correct, since we visit all constructors in+-- both maps in the worst case, but we can try to find a tighter bound.+--+-- Consider that m<=n, i.e. m is the size of the smaller map and n is the size+-- of the larger. It does not matter which map is the first argument.+--+-- Now we have O(n) as one upper bound for our complexity, since O(n) is the+-- same as O(m+n) for m<=n.+--+-- Next, consider the smaller map. For this map, we will visit some+-- constructors, plus all the Bins of the larger map that lie in our way.+-- For the former, the worst case is that we visit all constructors, which is+-- O(m).+-- For the latter, the worst case is that we encounter Bins at every point+-- possible. This happens when for every key in the smaller map, the path to+-- that key's Tip in the larger map has a full length of W, with a Bin at every+-- bit position. To maximize the total number of Bins, the paths should be as+-- disjoint as possible. But even if the paths are spread out, at least O(m)+-- Bins are unavoidably shared, which extend up to a depth of lg(m) from the+-- root. Beyond this, the paths may be disjoint. This gives us a total of+-- O(m + m (W - lg m)) = O(m log (2^W / m)).+-- The number of Bins we encounter is also bounded by the total number of Bins,+-- which is n-1, but we already have O(n) as an upper bound.+--+-- Combining our bounds, we have the final complexity as+-- O(min(n, m log (2^W / m))).+--+-- Note that+-- * This is similar to the Map merge complexity, which is O(m log (n/m)).+-- * When m is a small constant the term simplifies to O(min(n, W)), which is+--   just the complexity we expect for single operations like insert and delete.
+ src/Data/IntMap/Internal/Debug.hs view
@@ -0,0 +1,6 @@+module Data.IntMap.Internal.Debug+  ( showTree+  , showTreeWith+  ) where++import Data.IntMap.Internal
+ src/Data/IntMap/Lazy.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE CPP #-}+#ifdef __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, e.g.+--+-- > import Data.IntMap.Lazy (IntMap)+-- > import qualified Data.IntMap.Lazy as IntMap+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union' and+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster+-- on insertions and deletions when compared to a generic size-balanced map+-- implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>.+--+--+-- == Performance information+--+-- Operation comments contain the operation time complexity in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'lookup', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+--   the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+--   shared by all subelements, so there could not be more+--   than \(W\) levels.+--+-- If all \(n\) keys in the tree are between 0 and \(N\) (or, say, between+-- \(-N\) and \(N\)), the estimate can be refined to \(O(\min(n, \log N))\). If+-- the set of keys is sufficiently "dense", this becomes \(O(\min(n, \log n))\)+-- or simply the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntMap' are keys from a contiguous subset,+-- in which case the complexity is proportional to \(\log n\), capped by \(W\).+-- The worst scenario are exponentially growing keys \(1,2,4,\ldots,2^n\),+-- for which complexity grows as fast as \(n\) but again is capped by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.IntMap.Lazy" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+--+-----------------------------------------------------------------------------++module Data.IntMap.Lazy (+    -- * Map type+    IntMap, Key          -- instance Eq,Show++    -- * 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++    -- ** Symmetric difference+    , symmetricDifference++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , IM.map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , IM.foldr+    , IM.foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , IM.foldr'+    , IM.foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet++    -- ** Lists+    , toList++    -- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , IM.filter+    , filterKeys+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey+    ) where++import Data.IntMap.Internal as IM
+ src/Data/IntMap/Merge/Lazy.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Safe #-}+#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 'Control.Category.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
+ src/Data/IntMap/Merge/Strict.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Trustworthy #-}+#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 'Control.Category.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+  ( SimpleWhenMissing+  , SimpleWhenMatched+  , merge+  , dropMissing+  , preserveMissing+  , filterMissing+  , WhenMissing (..)+  , WhenMatched (..)+  , mergeA+  , filterAMissing+  , runWhenMatched+  , runWhenMissing+  )+import Data.IntMap.Strict.Internal+import Prelude hiding (filter, map, foldl, foldr)++-- | Map covariantly over a @'WhenMissing' f k x@.+mapWhenMissing :: Functor f => (a -> b) -> WhenMissing f x a -> WhenMissing f x b+mapWhenMissing f q = WhenMissing+  { missingSubtree = fmap (map f) . missingSubtree q+  , missingKey = \k x -> fmap (forceMaybe . fmap f) $ missingKey q k x}++-- | Map covariantly over a @'WhenMatched' f k x y@.+mapWhenMatched :: Functor f => (a -> b) -> WhenMatched f x y a -> WhenMatched f x y b+mapWhenMatched f q = WhenMatched+  { matchedKey = \k x y -> fmap (forceMaybe . fmap f) $ runWhenMatched q k x y }++-- | When a key is found in both maps, apply a function to the+-- key and values and maybe use the result in the merged map.+--+-- @+-- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)+--                     -> SimpleWhenMatched k x y z+-- @+zipWithMaybeMatched :: Applicative f+                    => (Key -> x -> y -> Maybe z)+                    -> WhenMatched f x y z+zipWithMaybeMatched f = WhenMatched $+  \k x y -> pure $! forceMaybe $! 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.+zipWithMaybeAMatched :: Applicative f+                     => (Key -> x -> y -> f (Maybe z))+                     -> WhenMatched f x y z+zipWithMaybeAMatched f = WhenMatched $+  \ k x y -> forceMaybe <$> f k x y+{-# INLINE zipWithMaybeAMatched #-}++-- | 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.+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 use the result in the merged map.+--+-- @+-- zipWithMatched :: (k -> x -> y -> z)+--                -> SimpleWhenMatched k x y z+-- @+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 #-}++-- | Map over the entries whose keys are missing from the other map,+-- optionally removing some. This is the most powerful 'SimpleWhenMissing'+-- tactic, but others are usually more efficient.+--+-- @+-- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y+-- @+--+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))+--+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.+mapMaybeMissing :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y+mapMaybeMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapMaybeWithKey f m+  , missingKey = \k x -> pure $! forceMaybe $! f k x }+{-# INLINE mapMaybeMissing #-}++-- | Map over the entries whose keys are missing from the other map.+--+-- @+-- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y+-- @+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+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 #-}++-- | 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.+traverseMaybeMissing :: Applicative f+                     => (Key -> x -> f (Maybe y)) -> WhenMissing f x y+traverseMaybeMissing f = WhenMissing+  { missingSubtree = traverseMaybeWithKey f+  , missingKey = \k x -> forceMaybe <$> f k x }+{-# INLINE traverseMaybeMissing #-}++-- | Traverse over the entries whose keys are missing from the other map.+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 #-}++forceMaybe :: Maybe a -> Maybe a+forceMaybe Nothing = Nothing+forceMaybe m@(Just !_) = m+{-# INLINE forceMaybe #-}
+ src/Data/IntMap/Strict.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE CPP #-}+#ifdef __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 an 'IntMap'. This is usually more efficient when laziness is not+-- necessary. When laziness /is/ required, use the functions in+-- "Data.IntMap.Lazy".+--+-- In particular, the functions in this module obey the following law:+--+--  - If all values stored in all maps in the arguments are in WHNF, then all+--    values stored in all maps in the results will be in WHNF once those maps+--    are evaluated.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- > import Data.IntMap.Strict (IntMap)+-- > import qualified Data.IntMap.Strict as IntMap+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Warning+--+-- The 'IntMap' type is shared between the lazy and strict modules, meaning that+-- the same 'IntMap' value can be passed to functions in both modules. This+-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are+-- the same as for the "Data.IntMap.Lazy" module, so if they are used the+-- resulting map may contain suspended values (thunks).+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union' and+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster+-- on insertions and deletions when compared to a generic size-balanced map+-- implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>.+--+--+-- == Performance information+--+-- Operation comments contain the operation time complexity in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'lookup', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+--   the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+--   shared by all subelements, so there could not be more+--   than \(W\) levels.+--+-- If all \(n\) keys in the tree are between 0 and \(N\) (or, say, between+-- \(-N\) and \(N\)), the estimate can be refined to \(O(\min(n, \log N))\). If+-- the set of keys is sufficiently "dense", this becomes \(O(\min(n, \log n))\)+-- or simply the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntMap' are keys from a contiguous subset,+-- in which case the complexity is proportional to \(\log n\), capped by \(W\).+-- The worst scenario are exponentially growing keys \(1,2,4,\ldots,2^n\),+-- for which complexity grows as fast as \(n\) but again is capped by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.IntMap.Strict" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+--+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.IntMap.Internal.++module Data.IntMap.Strict (+    -- * Map type+    IntMap, Key          -- instance Eq,Show++    -- * 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++    -- ** Symmetric difference+    , symmetricDifference++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet++    -- ** Lists+    , toList++-- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , filter+    , filterKeys+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey+    ) where++import Data.IntMap.Strict.Internal+import Prelude ()
+ src/Data/IntMap/Strict/Internal.hs view
@@ -0,0 +1,1236 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}++{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IntMap.Strict.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Int Maps (strict interface internals)+--+-- The @'IntMap' v@ type represents a finite map (sometimes called a dictionary)+-- from key of type @Int@ to values of type @v@.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union' and+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster+-- on insertions and deletions when compared to a generic size-balanced map+-- implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>.+--+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.IntMap.Internal.++module Data.IntMap.Strict.Internal (+    -- * Map type+    IntMap, Key          -- instance Eq,Show++    -- * 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++    -- ** Symmetric difference+    , symmetricDifference++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet++    -- ** Lists+    , toList++-- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , filter+    , filterKeys+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey+    ) where++import Utils.Containers.Internal.Prelude hiding+  (lookup,map,filter,foldr,foldl,foldl',null)+import Prelude ()++import Data.Bits+import qualified Data.IntMap.Internal as L+import Data.IntSet.Internal.IntTreeCommons+  (Key, Prefix(..), nomatch, left, signBranch, mask, branchMask)+import Data.IntMap.Internal+  ( IntMap (..)+  , bin+  , binCheckLeft+  , binCheckRight+  , link+  , linkKey+  , linkWithMask++  , (\\)+  , (!)+  , (!?)+  , empty+  , assocs+  , filter+  , filterKeys+  , filterWithKey+  , findMin+  , findMax+  , foldMapWithKey+  , foldr+  , foldl+  , foldr'+  , foldl'+  , foldlWithKey+  , foldrWithKey+  , foldlWithKey'+  , foldrWithKey'+  , keysSet+  , mergeWithKey'+  , compose+  , delete+  , deleteMin+  , deleteMax+  , deleteFindMax+  , deleteFindMin+  , difference+  , elems+  , intersection+  , disjoint+  , isProperSubmapOf+  , isProperSubmapOfBy+  , isSubmapOf+  , isSubmapOfBy+  , lookup+  , findWithDefault+  , lookupLE+  , lookupGE+  , lookupLT+  , lookupGT+  , lookupMin+  , lookupMax+  , minView+  , maxView+  , minViewWithKey+  , maxViewWithKey+  , keys+  , mapKeys+  , mapKeysMonotonic+  , member+  , notMember+  , null+  , partition+  , partitionWithKey+  , takeWhileAntitone+  , dropWhileAntitone+  , spanAntitone+  , restrictKeys+  , size+  , split+  , splitLookup+  , splitRoot+  , symmetricDifference+  , toAscList+  , toDescList+  , toList+  , union+  , unions+  , withoutKeys+  )+import qualified Data.IntSet.Internal as IntSet+import Utils.Containers.Internal.BitUtil (iShiftRL, shiftLL, shiftRL)+import Utils.Containers.Internal.StrictPair+import qualified Data.Foldable as Foldable++{--------------------------------------------------------------------+  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 l r+      | nomatch k p -> linkKey k (Tip k x) p t+      | left k p    -> Bin p (insert k x l) r+      | otherwise   -> Bin p l (insert k x r)+    Tip ky _+      | k==ky         -> Tip k x+      | otherwise     -> link k (Tip k x) ky t+    Nil -> Tip k x++-- right-biased insertion, used by 'union'+-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWith f k x t+  = insertWithKey (\_ x' y' -> f x' y') k x t++-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"+--+-- If the key exists in the map, this function is lazy in @value@ but strict+-- in the result of @f@.+--+-- Also see the performance note on 'fromListWith'.++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithKey f !k x t =+  case t of+    Bin p l r+      | nomatch k p -> linkKey k (singleton k x) p t+      | left k p    -> Bin p (insertWithKey f k x l) r+      | otherwise   -> Bin p l (insertWithKey f k x r)+    Tip ky y+      | k==ky         -> Tip k $! f k x y+      | otherwise     -> link k (singleton k x) ky t+    Nil -> singleton k x++-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])+--+-- Also see the performance note on 'fromListWith'.++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)+insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0+  where+    go f k x t =+      case t of+        Bin p l r+          | nomatch k p -> Nothing :*: linkKey k (singleton k x) p t+          | left k p    -> let (found :*: l') = go f k x l in (found :*: Bin p l' r)+          | otherwise   -> let (found :*: r') = go f k x r in (found :*: Bin p l r')+        Tip ky y+          | k==ky         -> (Just y :*: (Tip k $! f k x y))+          | otherwise     -> (Nothing :*: link k (singleton k x) ky t)+        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 l r+      | nomatch k p -> t+      | left k p    -> Bin p (adjustWithKey f k l) r+      | otherwise   -> Bin p l (adjustWithKey f k r)+    Tip ky y+      | k==ky         -> Tip ky $! f k y+      | otherwise     -> t+    Nil -> Nil++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- 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 l r+      | nomatch k p -> t+      | left k p    -> binCheckLeft p (updateWithKey f k l) r+      | otherwise   -> binCheckRight p l (updateWithKey f k r)+    Tip ky y+      | k==ky         -> case f k y of+                           Just !y' -> Tip ky y'+                           Nothing -> Nil+      | otherwise     -> t+    Nil -> Nil++-- | \(O(\min(n,W))\). Look up and update.+-- The function returns original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > 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 l r+          | nomatch k p -> (Nothing :*: t)+          | left k p    -> let (found :*: l') = go f k l in (found :*: binCheckLeft p l' r)+          | otherwise   -> let (found :*: r') = go f k r in (found :*: binCheckRight p l r')+        Tip ky y+          | k==ky         -> case f k y of+                               Just !y' -> (Just y :*: Tip ky y')+                               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 l r+      | nomatch k p -> case f Nothing of+                         Nothing -> t+                         Just !x  -> linkKey k (Tip k x) p t+      | left k p    -> binCheckLeft p (alter f k l) r+      | otherwise   -> binCheckRight p l (alter f k r)+    Tip ky y+      | k==ky         -> case f (Just y) of+                           Just !x -> Tip ky x+                           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(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,+-- or update a value in an 'IntMap'.  In short : @'lookup' k \<$\> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> IntMap String -> IO (IntMap String)+-- interactiveAlter k m = alterF f k m where+--   f Nothing = do+--      putStrLn $ show k +++--          " was not found in the map. Would you like to add it?"+--      getUserResponse1 :: IO (Maybe String)+--   f (Just old) = do+--      putStrLn $ "The key is currently bound to " ++ show old +++--          ". Would you like to change or delete it?"+--      getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map.++-- Note: 'alterF' is a flipped version of the 'at' combinator from+-- 'Control.Lens.At'.+--+-- @since 0.5.8++alterF :: Functor f+       => (Maybe a -> f (Maybe a)) -> Key -> IntMap a -> f (IntMap a)+-- This implementation was 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(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWith f m1 m2+  = unionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWithKey f m1 m2+  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) id id m1 m2++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWith f m1 m2+  = differenceWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWithKey f m1 m2+  = mergeWithKey f id (const Nil) m1 m2++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWith f m1 m2+  = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWithKey f m1 m2+  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- A high-performance universal combining function. Using+-- 'mergeWithKey', all combining functions can be defined without any loss of+-- efficiency (with exception of 'union', 'difference' and 'intersection',+-- where sharing of some nodes is lost with 'mergeWithKey').+--+-- __Warning__: Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'IntMap's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily.  Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++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(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMinWithKey f t =+  case t of Bin p l r | signBranch p -> binCheckRight p l (go f r)+            _ -> go f t+  where+    go f' (Bin p l r) = binCheckLeft p (go f' l) r+    go f' (Tip k y) = case f' k y of+                        Just !y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (Key -> a -> Maybe a) -> IntMap a -> IntMap a+updateMaxWithKey f t =+  case t of Bin p l r | signBranch p -> binCheckLeft p (go f l) r+            _ -> go f t+  where+    go f' (Bin p l r) = binCheckRight p l (go f' r)+    go f' (Tip k y) = case f' k y of+                        Just !y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = Nil++-- | \(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)+++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | \(O(n)\). Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> IntMap a -> IntMap b+map f = go+  where+    go (Bin p l r) = Bin p (go l) (go r)+    go (Tip k x)   = Tip k $! f x+    go Nil         = Nil++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (\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 l r -> Bin p (mapWithKey f l) (mapWithKey f r)+      Tip k x   -> Tip k $! f k x+      Nil       -> Nil++#ifdef __GLASGOW_HASKELL__+-- Pay close attention to strictness here. We need to force the+-- 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 l r) = Bin p (lsmap f g l) (lsmap f g r)+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  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 l r)+      | signBranch p = liftA2 (flip (Bin p)) (go r) (go l)+      | otherwise = liftA2 (Bin p) (go l) (go r)+{-# INLINE traverseWithKey #-}++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.6.4+traverseMaybeWithKey+  :: Applicative f => (Key -> a -> f (Maybe b)) -> IntMap a -> f (IntMap b)+traverseMaybeWithKey f = go+    where+    go Nil           = pure Nil+    go (Tip k x)     = maybe Nil (Tip k $!) <$> f k x+    go (Bin p l r)+      | signBranch p = liftA2 (flip (bin p)) (go r) (go l)+      | otherwise = liftA2 (bin p) (go l) (go r)++-- | \(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 l r+            | signBranch p ->+                let (a1 :*: r') = go f a r+                    (a2 :*: l') = go f a1 l+                in (a2 :*: Bin p l' r')+            | otherwise ->+                let (a1 :*: l') = go f a l+                    (a2 :*: r') = go f a1 r+                in (a2 :*: Bin p l' r')+          Tip k x     -> let !(a',!x') = f a k x in (a' :*: Tip k x')+          Nil         -> (a :*: Nil)++-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0+  where+    go f a t+      = case t of+          Bin p l r+            | signBranch p ->+              let (a1 :*: l') = go f a l+                  (a2 :*: r') = go f a1 r+              in (a2 :*: Bin p l' r')+            | otherwise ->+              let (a1 :*: r') = go f a r+                  (a2 :*: l') = go f a1 l+              in (a2 :*: Bin p 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))\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"+--+-- Also see the performance note on 'fromListWith'.++mapKeysWith :: (a -> a -> a) -> (Key->Key) -> IntMap a -> IntMap a+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []++{--------------------------------------------------------------------+  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 l r)+  = bin p (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just !y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey _ Nil = Nil++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go f (Bin p l r)+      = bin p l1 r1 :*: bin p l2 r2+      where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r+    go f (Tip k x) = case f k x of+      Left !y  -> (Tip k y :*: Nil)+      Right !z -> (Nil :*: Tip k z)+    go _ Nil = (Nil :*: Nil)++{--------------------------------------------------------------------+  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 l r) = Bin p (fromSet f l) (fromSet f r)+fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1)+  where -- This is slightly complicated, as we to convert the dense+        -- representation of IntSet into tree representation of IntMap.+        --+        -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'.+        -- We split bmask into halves corresponding to left and right subtree.+        -- If they are both nonempty, we create a Bin node, otherwise exactly+        -- one of them is nonempty and we construct the IntMap from that half.+        buildTree g !prefix !bmask bits = case bits of+          0 -> Tip prefix $! g prefix+          _ -> case bits `iShiftRL` 1 of+                 bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 ->+                           buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2+                       | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 ->+                           buildTree g prefix bmask bits2+                       | otherwise ->+                           Bin (Prefix (prefix .|. bits2)) (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> IntMap a+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x)  = insert k x t++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")]+-- > fromListWith (++) [] == empty+--+-- Note the reverse ordering of @"cba"@ in the example.+--+-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@.+--+-- === Performance+--+-- You should ensure that the given @f@ is fast with this order of arguments.+--+-- Symmetric functions may be slow in one order, and fast in another.+-- For the common case of collecting values of matching keys in a list, as above:+--+-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument.+-- Thus:+--+-- > fromListWith       (++)  (replicate 1000000 (3, "x"))   -- O(n),  fast+-- > fromListWith (flip (++)) (replicate 1000000 (3, "x"))   -- O(n²), extremely slow+--+-- because they evaluate as, respectively:+--+-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))]   -- O(n)+-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")]   -- O(n²)+--+-- Thus, to get good performance with an operation like @(++)@ while also preserving+-- the same order as in the input list, reverse the input:+--+-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")]+--+-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in:+--+-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples++fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty+--+-- Also see the performance note on 'fromListWith'.++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> IntMap a+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+--+-- Also see the performance note on 'fromListWith'.++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)+{-# NOINLINE fromAscListWith #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+--+-- Also see the performance note on 'fromListWith'.++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWithKey f = fromMonoListWithKey Nondistinct f+{-# NOINLINE fromAscListWithKey #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+--+-- __Warning__: This function should be used only if the keys are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++fromDistinctAscList :: [(Key,a)] -> IntMap a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.+--+-- Also see the performance note on 'fromListWith'.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromMonoListWithKey distinct f = go+  where+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1++    -- `addAll'` collects all keys equal to `kx` into a single value,+    -- and then proceeds with `addAll`.+    --+    -- We want to have the same strictness as fromListWithKey, which is achieved+    -- with the bang on vx.+    addAll' !kx !vx []+        = Tip kx vx+    addAll' !kx !vx ((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = addAll' ky (f kx vy vx) zs+        -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty kx (Tip kx vx)) zs'++    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_kx !tx []+        = tx+    addAll !kx !tx ((ky,vy) : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty kx tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    --+    -- We want to have the same strictness as fromListWithKey, which is achieved+    -- with the bang on vx.+    addMany' !_m !kx !vx []+        = Inserted (Tip kx vx) []+    addMany' !m !kx !vx zs0@((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = addMany' m ky (f kx vy vx) zs+        -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)+        | mask kx m /= mask ky m+        = Inserted (Tip kx vx) zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty kx (Tip kx vx)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.+    addMany !_m !_kx tx []+        = Inserted tx []+    addMany !m !kx tx zs0@((ky,vy) : zs)+        | mask kx m /= mask ky m+        = Inserted tx zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty kx tx) zs'+{-# INLINE fromMonoListWithKey #-}++data Inserted a = Inserted !(IntMap a) ![(Key,a)]++data Distinct = Distinct | Nondistinct
+ src/Data/IntSet.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE CPP #-}+#ifdef __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@. An @IntSet@+-- is strict in its elements.+--+-- For a walkthrough of the most commonly used functions see their+-- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>.+--+-- 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+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. Additionally, benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced set implementation (see "Data.Set").+--+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>.+--+-- Additionally, this implementation places bitmaps in the leaves of the tree.+-- Their size is the natural size of a machine word (32 or 64 bits) and greatly+-- reduces the memory footprint and execution times for dense sets, e.g. sets+-- where it is likely that many values lie close to each other. The asymptotics+-- are not affected by this optimization.+--+--+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map and \(W\) referring to the+-- number of bits in an 'Int' (32 or 64).+--+-- Operations like 'member', 'insert', and 'delete' have a worst-case+-- complexity of \(O(\min(n,W))\). This means that the operation can become+-- linear in the number of elements with a maximum of \(W\) -- the number of+-- bits in an 'Int' (32 or 64). These peculiar asymptotics are determined by the+-- depth of the Patricia trees:+--+-- * even for an extremely unbalanced tree, the depth cannot be larger than+--   the number of elements \(n\),+-- * each level of a Patricia tree determines at least one more bit+--   shared by all subelements, so there could not be more+--   than \(W\) levels.+--+-- If all \(n\) elements in the tree are between 0 and \(N\) (or, say, between+-- \(-N\) and \(N\)), the estimate can be refined to \(O(\min(n, \log N))\). If+-- the set is sufficiently "dense", this becomes \(O(\min(n, \log n))\) or+-- simply the familiar \(O(\log n)\), matching balanced binary trees.+--+-- The most performant scenario for 'IntSet' are elements from a contiguous+-- subset, in which case the complexity is proportional to \(\log n\), capped+-- by \(W\). The worst scenario are exponentially growing elements \(1,2,4,+-- \ldots,2^n\), for which complexity grows as fast as \(n\) but again is capped+-- by \(W\).+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O(\min(n, m \log \frac{2^W}{m}))\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input sets respectively.+--+-----------------------------------------------------------------------------++module Data.IntSet (+            -- * Set type+              IntSet          -- instance Eq,Show+            , Key++            -- * Construction+            , empty+            , singleton+            , fromList+            , fromRange+            , fromAscList+            , fromDistinctAscList++            -- * Insertion+            , insert++            -- * Deletion+            , delete++            -- * Generalized insertion/deletion+            , alterF++            -- * Query+            , member+            , notMember+            , lookupLT+            , lookupGT+            , lookupLE+            , lookupGE+            , IS.null+            , size+            , isSubsetOf+            , isProperSubsetOf+            , disjoint++            -- * Combine+            , union+            , unions+            , difference+            , (\\)+            , intersection+            , intersections+            , symmetricDifference+            , Intersection(..)++            -- * Filter+            , IS.filter+            , partition++            , takeWhileAntitone+            , dropWhileAntitone+            , spanAntitone++            , split+            , splitMember+            , splitRoot++            -- * Map+            , IS.map+            , mapMonotonic++            -- * Folds+            , IS.foldr+            , IS.foldl+            , IS.foldMap+            -- ** Strict folds+            , IS.foldr'+            , IS.foldl'+            -- ** Legacy folds+            , fold++            -- * Min\/Max+            , lookupMin+            , lookupMax+            , findMin+            , findMax+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , maxView+            , minView++            -- * Conversion++            -- ** List+            , elems+            , toList+            , toAscList+            , toDescList++            -- * Debugging+            , showTree+            , showTreeWith+            ) where++import Data.IntSet.Internal as IS
+ src/Data/IntSet/Internal.hs view
@@ -0,0 +1,2002 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE Trustworthy #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.IntSet.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Joachim Breitner 2011+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Int Sets (internals)+--+-- The @'IntSet'@ type represents a set of elements of type @Int@. An @IntSet@+-- is strict in its elements.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. Additionally, benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced set implementation (see "Data.Set").+--+--    * Chris Okasaki and Andy Gill,+--      \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <https://web.archive.org/web/20150417234429/https://ittc.ku.edu/~andygill/papers/IntMap98.pdf>.+--+--    * D.R. Morrison,+--      \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534,+--      <https://doi.org/10.1145/321479.321481>.+--+-- Additionally, this implementation places bitmaps in the leaves of the tree.+-- Their size is the natural size of a machine word (32 or 64 bits) and greatly+-- reduces the memory footprint and execution times for dense sets, e.g. sets+-- where it is likely that many values lie close to each other. The asymptotics+-- are not affected by this optimization.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of IntSet matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.++module Data.IntSet.Internal (+    -- * Set type+      IntSet(..) -- instance Eq,Show+    , Key+    , BitMap++    -- * Operators+    , (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , isSubsetOf+    , isProperSubsetOf+    , disjoint++    -- * Construction+    , empty+    , singleton+    , fromRange+    , insert+    , delete+    , alterF++    -- * Combine+    , union+    , unions+    , difference+    , intersection+    , intersections+    , symmetricDifference+    , Intersection(..)++    -- * Filter+    , filter+    , partition++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , split+    , splitMember+    , splitRoot++    -- * Map+    , map+    , mapMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldMap+    -- ** Strict folds+    , foldr'+    , foldl'+    -- ** Legacy folds+    , fold++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , maxView+    , minView++    -- * Conversion++    -- ** List+    , elems+    , toList+    , fromList++    -- ** Ordered list+    , toAscList+    , toDescList+    , fromAscList+    , fromDistinctAscList++    -- * Debugging+    , showTree+    , showTreeWith++    -- * Internals+    , suffixBitMask+    , prefixBitMask+    , bitmapOf+    ) where++import Control.Applicative (Const(..))+import Control.DeepSeq (NFData(rnf))+import Data.Bits+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (fromMaybe)+import Data.Semigroup (Semigroup(..), stimesIdempotent, stimesIdempotentMonoid)+import Utils.Containers.Internal.Prelude hiding+  (filter, foldr, foldl, foldl', foldMap, null, map)+import Prelude ()++import Utils.Containers.Internal.BitUtil (iShiftRL, shiftLL, shiftRL)+import Utils.Containers.Internal.StrictPair+import Data.IntSet.Internal.IntTreeCommons+  ( Key+  , Prefix(..)+  , nomatch+  , left+  , signBranch+  , mask+  , branchMask+  , TreeTreeBranch(..)+  , treeTreeBranch+  , i2w+  , Order(..)+  )++#if __GLASGOW_HASKELL__+import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType)+import qualified Data.Data+import Text.Read+import Data.Coerce (coerce)+#endif++#if __GLASGOW_HASKELL__+import qualified GHC.Exts+#  if !(WORD_SIZE_IN_BITS==64)+import qualified GHC.Int+#  endif+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif++import qualified Data.Foldable as Foldable+import Data.Functor.Identity (Identity(..))++infixl 9 \\{-This comment teaches CPP correct behaviour -}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- See 'difference'.+(\\) :: IntSet -> IntSet -> IntSet+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}++-- | A set of integers.++-- See Note: Order of constructors+data IntSet = Bin {-# UNPACK #-} !Prefix+                  !IntSet+                  !IntSet+            | Tip {-# UNPACK #-} !Int+                  {-# UNPACK #-} !BitMap+            | Nil++type BitMap = Word++--+-- Note [IntSet structure and invariants]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- * Nil is never found as a child of Bin.+--+-- * The Prefix of a Bin indicates the common high-order bits that all keys in+--   the Bin share.+--+-- * The least significant set bit of the Int value of a Prefix is called the+--   mask bit.+--+-- * All the bits to the left of the mask bit are called the shared prefix. All+--   keys stored in the Bin begin with the shared prefix.+--+-- * All keys in the left child of the Bin have the mask bit unset, and all keys+--   in the right child have the mask bit set. It follows that+--+--   1. The Int value of the Prefix of a Bin is the smallest key that can be+--      present in the right child of the Bin.+--+--   2. All keys in the right child of a Bin are greater than keys in the+--      left child, with one exceptional situation. If the Bin separates+--      negative and non-negative keys, the mask bit is the sign bit and the+--      left child stores the non-negative keys while the right child stores the+--      negative keys.+--+-- * All bits to the right of the mask bit are set to 0 in a Prefix.+--+-- * The shared prefix of a Bin is never longer than+--   (WORD_SIZE - lg(WORD_SIZE) - 1) bits.+--+-- * In the context of a Tip, the highest (WORD_SIZE - lg(WORD_SIZE)) bits of+--   a key are called "prefix" and the lowest lg(WORD_SIZE) bits are called+--   "suffix". In Tip kx bm, kx is the shared prefix and bm is a bitmask of the+--   suffixes of the keys. In other words, the keys of Tip kx bm are (kx .|. i)+--   for every set bit i in bm.+--+-- * In Tip kx _, the lowest lg(WORD_SIZE) bits of kx are set to 0.+--+-- * In Tip _ bm, bm is never 0.+--++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+deriving instance Lift IntSet+#endif++-- | @mempty@ = 'empty'+instance Monoid IntSet where+    mempty  = empty+    mconcat = unions+    mappend = (<>)++-- | @(<>)@ = 'union'+--+-- @since 0.5.7+instance Semigroup IntSet where+    (<>)    = union+    stimes  = stimesIdempotentMonoid++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data IntSet where+  gfoldl f z is = z fromList `f` (toList is)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = intSetDataType++fromListConstr :: Constr+fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix++intSetDataType :: DataType+intSetDataType = mkDataType "Data.IntSet.Internal.IntSet" [fromListConstr]++#endif++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the set empty?+null :: IntSet -> Bool+null Nil = True+null _   = False+{-# INLINE null #-}++-- | \(O(n)\). Cardinality of the set.+size :: IntSet -> Int+size = go 0+  where+    go !acc (Bin _ l r) = go (go acc l) r+    go acc (Tip _ bm) = acc + popCount bm+    go acc Nil = acc++-- | \(O(\min(n,W))\). Is the value a member of the set?++-- See Note: Local 'go' functions and capturing.+member :: Key -> IntSet -> Bool+member !x = go+  where+    go (Bin p l r)+      | nomatch x p = False+      | left x p    = go l+      | otherwise   = go r+    go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0+    go Nil = False++-- | \(O(\min(n,W))\). Is the element not in the set?+notMember :: Key -> IntSet -> Bool+notMember k = not . member k++-- | \(O(\min(n,W))\). Find largest element smaller than the given one.+--+-- > lookupLT 3 (fromList [3, 5]) == Nothing+-- > lookupLT 5 (fromList [3, 5]) == Just 3++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> IntSet -> Maybe Key+lookupLT !x t = case t of+    Bin p l r | signBranch p -> if x >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMax def else unsafeFindMax r+                       | left x p  = go def l+                       | otherwise = go l r+    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm+                       | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT+                       | otherwise = unsafeFindMax def+                       where maskLT = (bitmapOf x - 1) .&. bm+    go def Nil = unsafeFindMax def+++-- | \(O(\min(n,W))\). Find smallest element greater than the given one.+--+-- > lookupGT 4 (fromList [3, 5]) == Just 5+-- > lookupGT 5 (fromList [3, 5]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> IntSet -> Maybe Key+lookupGT !x t = case t of+    Bin p l r | signBranch p -> if x >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMin l else unsafeFindMin def+                       | left x p  = go r l+                       | otherwise = go def r+    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm+                       | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT+                       | otherwise = unsafeFindMin def+                       where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm+    go def Nil = unsafeFindMin def+++-- | \(O(\min(n,W))\). Find largest element smaller or equal to the given one.+--+-- > lookupLE 2 (fromList [3, 5]) == Nothing+-- > lookupLE 4 (fromList [3, 5]) == Just 3+-- > lookupLE 5 (fromList [3, 5]) == Just 5++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> IntSet -> Maybe Key+lookupLE !x t = case t of+    Bin p l r | signBranch p -> if x >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMax def else unsafeFindMax r+                       | left x p  = go def l+                       | otherwise = go l r+    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm+                       | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE+                       | otherwise = unsafeFindMax def+                       where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm+    go def Nil = unsafeFindMax def+++-- | \(O(\min(n,W))\). Find smallest element greater or equal to the given one.+--+-- > lookupGE 3 (fromList [3, 5]) == Just 3+-- > lookupGE 4 (fromList [3, 5]) == Just 5+-- > lookupGE 6 (fromList [3, 5]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> IntSet -> Maybe Key+lookupGE !x t = case t of+    Bin p l r | signBranch p -> if x >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p l r) | nomatch x p = if x < unPrefix p then unsafeFindMin l else unsafeFindMin def+                       | left x p  = go r l+                       | otherwise = go def r+    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm+                       | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE+                       | otherwise = unsafeFindMin def+                       where maskGE = (- (bitmapOf x)) .&. bm+    go def Nil = unsafeFindMin def++++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: IntSet -> Maybe Key+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm+unsafeFindMin (Bin _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: IntSet -> Maybe Key+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm+unsafeFindMax (Bin _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty set.+empty :: IntSet+empty+  = Nil+{-# INLINE empty #-}++-- | \(O(1)\). A set of one element.+singleton :: Key -> IntSet+singleton x+  = Tip (prefixOf x) (bitmapOf x)+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Add a value to the set. There is no left- or right bias for+-- IntSets.+insert :: Key -> IntSet -> IntSet+insert !x = insertBM (prefixOf x) (bitmapOf x)++-- Helper function for insert and union.+insertBM :: Int -> BitMap -> IntSet -> IntSet+insertBM !kx !bm t@(Bin p l r)+  | nomatch kx p = linkKey kx (Tip kx bm) p t+  | left kx p    = Bin p (insertBM kx bm l) r+  | otherwise    = Bin p l (insertBM kx bm r)+insertBM kx bm t@(Tip kx' bm')+  | kx' == kx = Tip kx' (bm .|. bm')+  | otherwise = link kx (Tip kx bm) kx' t+insertBM kx bm Nil = Tip kx bm++-- | \(O(\min(n,W))\). Delete a value in the set. Returns the+-- original set when the value was not present.+delete :: Key -> IntSet -> IntSet+delete !x = deleteBM (prefixOf x) (bitmapOf x)++-- Deletes all values mentioned in the BitMap from the set.+-- Helper function for delete and difference.+deleteBM :: Int -> BitMap -> IntSet -> IntSet+deleteBM !kx !bm t@(Bin p l r)+  | nomatch kx p = t+  | left kx p    = bin p (deleteBM kx bm l) r+  | otherwise    = bin p l (deleteBM kx bm r)+deleteBM kx bm t@(Tip kx' bm')+  | kx' == kx = tip kx (bm' .&. complement bm)+  | otherwise = t+deleteBM _ _ Nil = Nil++-- | \(O(\min(n,W))\). @('alterF' f x s)@ can delete or insert @x@ in @s@ depending+-- on whether it is already present in @s@.+--+-- In short:+--+-- @+-- 'member' x \<$\> 'alterF' f x s = f ('member' x s)+-- @+--+-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".+--+-- @since 0.6.3.1+alterF :: Functor f => (Bool -> f Bool) -> Key -> IntSet -> f IntSet+alterF f k s = fmap choose (f member_)+  where+    member_ = member k s++    (inserted, deleted)+      | member_   = (s         , delete k s)+      | otherwise = (insert k s, s         )++    choose True  = inserted+    choose False = deleted+#ifndef __GLASGOW_HASKELL__+{-# INLINE alterF #-}+#else+{-# INLINABLE [2] alterF #-}++{-# RULES+"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s+ #-}+#endif++{-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> IntSet -> Identity IntSet #-}++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of sets.+unions :: Foldable f => f IntSet -> IntSet+unions xs+  = Foldable.foldl' union empty xs+++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The union of two sets.+union :: IntSet -> IntSet -> IntSet+union t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> Bin p1 (union l1 t2) r1+  ABR -> Bin p1 l1 (union r1 t2)+  BAL -> Bin p2 (union t1 l2) r2+  BAR -> Bin p2 l2 (union t1 r2)+  EQL -> Bin p1 (union l1 l2) (union r1 r2)+  NOM -> link (unPrefix p1) t1 (unPrefix p2) t2+union t@(Bin _ _ _) (Tip kx bm) = insertBM kx bm t+union t@(Bin _ _ _) Nil = t+union (Tip kx bm) t = insertBM kx bm t+union Nil t = t+++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Difference between two sets.+difference :: IntSet -> IntSet -> IntSet+difference t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> bin p1 (difference l1 t2) r1+  ABR -> bin p1 l1 (difference r1 t2)+  BAL -> difference t1 l2+  BAR -> difference t1 r2+  EQL -> bin p1 (difference l1 l2) (difference r1 r2)+  NOM -> t1++difference t@(Bin _ _ _) (Tip kx bm) = deleteBM kx bm t+difference t@(Bin _ _ _) Nil = t++difference t1@(Tip kx bm) t2 = differenceTip t2+  where differenceTip (Bin p2 l2 r2) | nomatch kx p2 = t1+                                     | left kx p2 = differenceTip l2+                                     | otherwise = differenceTip r2+        differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2)+                                    | otherwise = t1+        differenceTip Nil = t1++difference Nil _     = Nil++++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The intersection of two sets.+intersection :: IntSet -> IntSet -> IntSet+intersection t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> intersection l1 t2+  ABR -> intersection r1 t2+  BAL -> intersection t1 l2+  BAR -> intersection t1 r2+  EQL -> bin p1 (intersection l1 l2) (intersection r1 r2)+  NOM -> Nil++intersection t1@(Bin _ _ _) (Tip kx2 bm2) = intersectBM t1+  where intersectBM (Bin p1 l1 r1) | nomatch kx2 p1 = Nil+                                   | left kx2 p1    = intersectBM l1+                                   | otherwise      = intersectBM r1+        intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+                                  | otherwise = Nil+        intersectBM Nil = Nil++intersection (Bin _ _ _) Nil = Nil++intersection (Tip kx1 bm1) t2 = intersectBM t2+  where intersectBM (Bin p2 l2 r2) | nomatch kx1 p2 = Nil+                                   | left kx1 p2    = intersectBM l2+                                   | otherwise      = intersectBM r2+        intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+                                  | otherwise = Nil+        intersectBM Nil = Nil++intersection Nil _ = Nil++-- | The intersection of a series of sets. Intersections are performed+-- left-to-right.+--+-- @since 0.8+intersections :: NonEmpty IntSet -> IntSet+intersections (s0 :| ss)+  | null s0 = empty+  | otherwise = List.foldr go id ss s0+  where+    go s r acc+      | null acc' = empty+      | otherwise = r acc'+      where+        acc' = intersection acc s+{-# INLINABLE intersections #-}++-- | @IntSet@s form a 'Semigroup' under 'intersection'.+--+-- A @Monoid@ instance is not defined because it would be impractical to+-- construct @mempty@, the @IntSet@ containing all @Int@s.+--+-- @since 0.8+newtype Intersection = Intersection { getIntersection :: IntSet }+  deriving (Show, Eq, Ord)++instance Semigroup Intersection where+  Intersection s1 <> Intersection s2 = Intersection (intersection s1 s2)++  stimes = stimesIdempotent+  {-# INLINABLE stimes #-}++  sconcat =+#ifdef __GLASGOW_HASKELL__+    coerce intersections+#else+    Intersection . intersections . fmap getIntersection+#endif++{--------------------------------------------------------------------+  Symmetric difference+--------------------------------------------------------------------}++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- The symmetric difference of two sets.+--+-- The result contains elements that appear in exactly one of the two sets.+--+-- @+-- symmetricDifference (fromList [0,2,4,6]) (fromList [0,3,6,9]) == fromList [2,3,4,9]+-- @+--+-- @since 0.8+symmetricDifference :: IntSet -> IntSet -> IntSet+symmetricDifference t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) =+  case treeTreeBranch p1 p2 of+    ABL -> bin p1 (symmetricDifference l1 t2) r1+    ABR -> bin p1 l1 (symmetricDifference r1 t2)+    BAL -> bin p2 (symmetricDifference t1 l2) r2+    BAR -> bin p2 l2 (symmetricDifference t1 r2)+    EQL -> bin p1 (symmetricDifference l1 l2) (symmetricDifference r1 r2)+    NOM -> link (unPrefix p1) t1 (unPrefix p2) t2+symmetricDifference t1@(Bin _ _ _) t2@(Tip kx2 bm2) = symDiffTip t2 kx2 bm2 t1+symmetricDifference t1@(Bin _ _ _) Nil = t1+symmetricDifference t1@(Tip kx1 bm1) t2 = symDiffTip t1 kx1 bm1 t2+symmetricDifference Nil t2 = t2++symDiffTip :: IntSet -> Int -> BitMap -> IntSet -> IntSet+symDiffTip !t1 !kx1 !bm1 = go+  where+    go t2@(Bin p2 l2 r2)+      | nomatch kx1 p2 = linkKey kx1 t1 p2 t2+      | left kx1 p2 = bin p2 (go l2) r2+      | otherwise = bin p2 l2 (go r2)+    go t2@(Tip kx2 bm2)+      | kx1 == kx2 = tip kx1 (bm1 `xor` bm2)+      | otherwise = link kx1 t1 kx2 t2+    go Nil = t1++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Is this a proper subset? (ie. a subset but not equal).+isProperSubsetOf :: IntSet -> IntSet -> Bool+isProperSubsetOf t1 t2+  = case subsetCmp t1 t2 of+      LT -> True+      _  -> False++subsetCmp :: IntSet -> IntSet -> Ordering+subsetCmp t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> GT+  ABR -> GT+  BAL -> case subsetCmp t1 l2 of GT -> GT ; _ -> LT+  BAR -> case subsetCmp t1 r2 of GT -> GT ; _ -> LT+  EQL -> subsetCmpEq+  NOM -> GT  -- disjoint+  where+    subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of+                    (GT,_ ) -> GT+                    (_ ,GT) -> GT+                    (EQ,EQ) -> EQ+                    _       -> LT++subsetCmp (Bin _ _ _) _ = GT+subsetCmp (Tip kx1 bm1) (Tip kx2 bm2)+  | kx1 /= kx2                  = GT -- disjoint+  | bm1 == bm2                  = EQ+  | bm1 .&. complement bm2 == 0 = LT+  | otherwise                   = GT+subsetCmp t1@(Tip kx _) (Bin p l r)+  | nomatch kx p = GT+  | left kx p    = case subsetCmp t1 l of GT -> GT ; _ -> LT+  | otherwise    = case subsetCmp t1 r of GT -> GT ; _ -> LT+subsetCmp (Tip _ _) Nil = GT -- disjoint+subsetCmp Nil Nil = EQ+subsetCmp Nil _   = LT++-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Is this a subset?+-- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.++isSubsetOf :: IntSet -> IntSet -> Bool+isSubsetOf t1@(Bin p1 l1 r1) (Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> False+  ABR -> False+  BAL -> isSubsetOf t1 l2+  BAR -> isSubsetOf t1 r2+  EQL -> isSubsetOf l1 l2 && isSubsetOf r1 r2+  NOM -> False+isSubsetOf (Bin _ _ _) _ = False+isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0+isSubsetOf t1@(Tip kx _) (Bin p l r)+  | nomatch kx p = False+  | left kx p    = isSubsetOf t1 l+  | otherwise    = isSubsetOf t1 r+isSubsetOf (Tip _ _) Nil = False+isSubsetOf Nil _         = True+++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | \(O(\min(n, m \log \frac{2^W}{m})), m \leq n\).+-- Check whether two sets are disjoint (i.e. their intersection+--   is empty).+--+-- > disjoint (fromList [2,4,6])   (fromList [1,3])     == True+-- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False+-- > disjoint (fromList [1,2])     (fromList [1,2,3,4]) == False+-- > disjoint (fromList [])        (fromList [])        == True+--+-- @since 0.5.11+disjoint :: IntSet -> IntSet -> Bool+disjoint t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+  ABL -> disjoint l1 t2+  ABR -> disjoint r1 t2+  BAL -> disjoint t1 l2+  BAR -> disjoint t1 r2+  EQL -> disjoint l1 l2 && disjoint r1 r2+  NOM -> True++disjoint t1@(Bin _ _ _) (Tip kx2 bm2) = disjointBM t1+  where disjointBM (Bin p1 l1 r1) | nomatch kx2 p1 = True+                                  | left kx2 p1    = disjointBM l1+                                  | otherwise      = disjointBM r1+        disjointBM (Tip kx1 bm1) | kx1 == kx2 = (bm1 .&. bm2) == 0+                                 | otherwise = True+        disjointBM Nil = True++disjoint (Bin _ _ _) Nil = True++disjoint (Tip kx1 bm1) t2 = disjointBM t2+  where disjointBM (Bin p2 l2 r2) | nomatch kx1 p2 = True+                                  | left kx1 p2    = disjointBM l2+                                  | otherwise      = disjointBM r2+        disjointBM (Tip kx2 bm2) | kx1 == kx2 = (bm1 .&. bm2) == 0+                                 | otherwise = True+        disjointBM Nil = True++disjoint Nil _ = True+++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all elements that satisfy some predicate.+filter :: (Key -> Bool) -> IntSet -> IntSet+filter predicate t+  = case t of+      Bin p l r+        -> bin p (filter predicate l) (filter predicate r)+      Tip kx bm+        -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm)+      Nil -> Nil+  where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+                         | otherwise           = bm+        {-# INLINE bitPred #-}++-- | \(O(n)\). partition the set according to some predicate.+partition :: (Key -> Bool) -> IntSet -> (IntSet,IntSet)+partition predicate0 t0 = toPair $ go predicate0 t0+  where+    go predicate t+      = case t of+          Bin p l r+            -> let (l1 :*: l2) = go predicate l+                   (r1 :*: r2) = go predicate r+               in bin p l1 r1 :*: bin p l2 r2+          Tip kx bm+            -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm+               in  tip kx bm1 :*: tip kx (bm `xor` bm1)+          Nil -> (Nil :*: Nil)+      where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+                             | otherwise           = bm+            {-# INLINE bitPred #-}++-- | \(O(\min(n,W))\). Take while a predicate on the elements holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'+-- takeWhileAntitone p = 'filter' p+-- @+--+-- @since 0.6.7+takeWhileAntitone :: (Key -> Bool) -> IntSet -> IntSet+takeWhileAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then bin p (go predicate l) r+        else go predicate r+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = bin p l (go predicate' r)+      | otherwise               = go predicate' l+    go predicate' (Tip kx bm) = tip kx (takeWhileAntitoneBits kx predicate' bm)+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Drop while a predicate on the elements holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'+-- dropWhileAntitone p = 'filter' (not . p)+-- @+--+-- @since 0.6.7+dropWhileAntitone :: (Key -> Bool) -> IntSet -> IntSet+dropWhileAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then go predicate l+        else bin p l (go predicate r)+    _ -> go predicate t+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = go predicate' r+      | otherwise               = bin p (go predicate' l) r+    go predicate' (Tip kx bm) = tip kx (bm `xor` takeWhileAntitoneBits kx predicate' bm)+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Divide a set at the point where a predicate on the elements stops holding.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = 'partition' p xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set+-- at some /unspecified/ point.+--+-- @since 0.6.7+spanAntitone :: (Key -> Bool) -> IntSet -> (IntSet, IntSet)+spanAntitone predicate t =+  case t of+    Bin p l r+      | signBranch p ->+        if predicate 0 -- handle negative numbers.+        then+          case go predicate l of+            (lt :*: gt) ->+              let !lt' = bin p lt r+              in (lt', gt)+        else+          case go predicate r of+            (lt :*: gt) ->+              let !gt' = bin p l gt+              in (lt, gt')+    _ -> case go predicate t of+          (lt :*: gt) -> (lt, gt)+  where+    go predicate' (Bin p l r)+      | predicate' (unPrefix p) = case go predicate' r of (lt :*: gt) -> bin p l lt :*: gt+      | otherwise               = case go predicate' l of (lt :*: gt) -> lt :*: bin p gt r+    go predicate' (Tip kx bm) = let bm' = takeWhileAntitoneBits kx predicate' bm+                                in (tip kx bm' :*: tip kx (bm `xor` bm'))+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). The expression (@'split' x set@) is a pair @(set1,set2)@+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@+-- comprises the elements of @set@ greater than @x@.+--+-- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])+split :: Key -> IntSet -> (IntSet,IntSet)+split x t =+  case t of+    Bin p l r+      | signBranch p ->+        if x >= 0  -- handle negative numbers.+        then+          case go x l of+            (lt :*: gt) ->+              let !lt' = bin p lt r+              in (lt', gt)+        else+          case go x r of+            (lt :*: gt) ->+              let !gt' = bin p l gt+              in (lt, gt')+    _ -> case go x t of+          (lt :*: gt) -> (lt, gt)+  where+    go !x' t'@(Bin p l r)+        | nomatch x' p = if x' < unPrefix p then (Nil :*: t') else (t' :*: Nil)+        | left x' p    = case go x' l of (lt :*: gt) -> lt :*: bin p gt r+        | otherwise    = case go x' r of (lt :*: gt) -> bin p l lt :*: gt+    go x' t'@(Tip kx' bm)+        | kx' > x'          = (Nil :*: t')+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = (t' :*: Nil)+        | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)+            where lowerBitmap = bitmapOf x' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOf x')+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Key -> IntSet -> (IntSet,Bool,IntSet)+splitMember x t =+  case t of+    Bin p l r+      | signBranch p ->+        if x >= 0 -- handle negative numbers.+        then+          case go x l of+            (lt, fnd, gt) ->+              let !lt' = bin p lt r+              in (lt', fnd, gt)+        else+          case go x r of+            (lt, fnd, gt) ->+              let !gt' = bin p l gt+              in (lt, fnd, gt')+    _ -> go x t+  where+    go !x' t'@(Bin p l r)+        | nomatch x' p = if x' < unPrefix p then (Nil, False, t') else (t', False, Nil)+        | left x' p =+          case go x' l of+            (lt, fnd, gt) ->+              let !gt' = bin p gt r+              in (lt, fnd, gt')+        | otherwise =+          case go x' r of+            (lt, fnd, gt) ->+              let !lt' = bin p l lt+              in (lt', fnd, gt)+    go x' t'@(Tip kx' bm)+        | kx' > x'          = (Nil, False, t')+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = (t', False, Nil)+        | otherwise = let !lt = tip kx' (bm .&. lowerBitmap)+                          !found = (bm .&. bitmapOfx') /= 0+                          !gt = tip kx' (bm .&. higherBitmap)+                      in (lt, found, gt)+            where bitmapOfx' = bitmapOf x'+                  lowerBitmap = bitmapOfx' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOfx')+    go _ Nil = (Nil, False, Nil)++{----------------------------------------------------------------------+  Min/Max+----------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Retrieves the maximal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+maxView :: IntSet -> Maybe (Key, IntSet)+maxView t =+  case t of Nil -> Nothing+            Bin p l r | signBranch p -> case go l of (result, l') -> Just (result, bin p l' r)+            _ -> Just (go t)+  where+    go (Bin p l r) = case go r of (result, r') -> (result, bin p l r')+    go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))+    go Nil = error "maxView Nil"++-- | \(O(\min(n,W))\). Retrieves the minimal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+minView :: IntSet -> Maybe (Key, IntSet)+minView t =+  case t of Nil -> Nothing+            Bin p l r | signBranch p -> case go r of (result, r') -> Just (result, bin p l r')+            _ -> Just (go t)+  where+    go (Bin p l r) = case go l of (result, l') -> (result, bin p l' r)+    go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))+    go Nil = error "minView Nil"++-- | \(O(\min(n,W))\). Delete and find the minimal element.+--+-- > deleteFindMin set = (findMin set, deleteMin set)+deleteFindMin :: IntSet -> (Key, IntSet)+deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView++-- | \(O(\min(n,W))\). Delete and find the maximal element.+--+-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: IntSet -> (Key, IntSet)+deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView++lookupMinSure :: IntSet -> Key+lookupMinSure (Tip kx bm) = kx + lowestBitSet bm+lookupMinSure (Bin _ l _) = lookupMinSure l+lookupMinSure Nil         = error "lookupMin Nil"++-- | \(O(\min(n,W))\). The minimal element of the set. Returns 'Nothing' if the+-- set is empty.+--+-- @since 0.8+lookupMin :: IntSet -> Maybe Key+lookupMin Nil         = Nothing+lookupMin (Tip kx bm) = Just $! kx + lowestBitSet bm+lookupMin (Bin p l r) = Just $! lookupMinSure (if signBranch p then r else l)+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The minimal element of the set. Calls 'error' if the set+-- is empty.+findMin :: IntSet -> Key+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "findMin: empty set has no minimal element"++lookupMaxSure :: IntSet -> Key+lookupMaxSure (Tip kx bm) = kx + highestBitSet bm+lookupMaxSure (Bin _ _ r) = lookupMaxSure r+lookupMaxSure Nil         = error "lookupMax Nil"++-- | \(O(\min(n,W))\). The maximal element of the set. Returns 'Nothing' if the+-- set is empty.+--+-- @since 0.8+lookupMax :: IntSet -> Maybe Key+lookupMax Nil         = Nothing+lookupMax (Tip kx bm) = Just $! kx + highestBitSet bm+lookupMax (Bin p l r) = Just $! lookupMaxSure (if signBranch p then l else r)+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\min(n,W))\). The maximal element of the set. Calls 'error' if the set+-- is empty.+findMax :: IntSet -> Key+findMax t+  | Just r <- lookupMax t = r+  | otherwise = error "findMax: empty set has no maximal element"++-- | \(O(\min(n,W))\). Delete the minimal element. Returns an empty set if the set is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#8211;+-- versions prior to 0.5 threw an error if the 'IntSet' was already empty.+deleteMin :: IntSet -> IntSet+deleteMin = maybe Nil snd . minView++-- | \(O(\min(n,W))\). Delete the maximal element. Returns an empty set if the set is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#8211;+-- versions prior to 0.5 threw an error if the 'IntSet' was already empty.+deleteMax :: IntSet -> IntSet+deleteMax = maybe Nil snd . maxView++{----------------------------------------------------------------------+  Map+----------------------------------------------------------------------}++-- | \(O(n \min(n,W))\).+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.+--+-- It's worth noting that the size of the result may be smaller if,+-- for some @(x,y)@, @x \/= y && f x == f y@++map :: (Key -> Key) -> IntSet -> IntSet+map f = fromList . List.map f . toList++-- | \(O(n)\). The+--+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapMonotonic f s == map f s+-- >     where ls = toList s+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'map' if the+-- precondition may not hold.+--+-- @since 0.6.3.1++-- Note that for now the test is insufficient to support any fancier implementation.+mapMonotonic :: (Key -> Key) -> IntSet -> IntSet+mapMonotonic f = fromDistinctAscList . List.map f . toAscList+++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator.+--+{-# DEPRECATED fold "Use Data.IntSet.foldr instead" #-}+fold :: (Key -> b -> b) -> b -> IntSet -> b+fold = foldr+{-# INLINE fold #-}++-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.+--+-- For example,+--+-- > toAscList set = foldr (:) [] set+foldr :: (Key -> b -> b) -> b -> IntSet -> b+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin p l r | signBranch p -> go (go z l) r -- put negative numbers before+                      | otherwise -> go (go z r) l+            _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip kx bm) = foldrBits kx f z' bm+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (Key -> b -> b) -> b -> IntSet -> b+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin p l r | signBranch p -> go (go z l) r -- put negative numbers before+                      | otherwise -> go (go z r) l+            _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip kx bm) = foldr'Bits kx f z' bm+    go z' (Bin _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the elements in the set using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.+--+-- For example,+--+-- > toDescList set = foldl (flip (:)) [] set+foldl :: (a -> Key -> a) -> a -> IntSet -> a+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin p l r | signBranch p -> go (go z r) l -- put negative numbers before+                      | otherwise -> go (go z l) r+            _ -> go z t+  where+    go z' Nil         = z'+    go z' (Tip kx bm) = foldlBits kx f z' bm+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> Key -> a) -> a -> IntSet -> a+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin p l r | signBranch p -> go (go z r) l -- put negative numbers before+                      | otherwise -> go (go z l) r+            _ -> go z t+  where+    go !z' Nil        = z'+    go z' (Tip kx bm) = foldl'Bits kx f z' bm+    go z' (Bin _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++-- | \(O(n)\). Map the elements in the set to a monoid and combine with @(<>)@.+--+-- @since 0.8+foldMap :: Monoid a => (Key -> a) -> IntSet -> a+foldMap f = \t ->  -- Use lambda t to be inlinable with one argument only.+  case t of+    Bin p l r+#if MIN_VERSION_base(4,11,0)+      | signBranch p -> go r <> go l  -- handle negative numbers+      | otherwise -> go l <> go r+#else+      | signBranch p -> go r `mappend` go l  -- handle negative numbers+      | otherwise -> go l `mappend` go r+#endif+    _ -> go t+  where+#if MIN_VERSION_base(4,11,0)+    go (Bin _ l r) = go l <> go r+#else+    go (Bin _ l r) = go l `mappend` go r+#endif+    go (Tip kx bm) = foldMapBits kx f bm+    go Nil = mempty+{-# INLINE foldMap #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order.+-- Subject to list fusion.+elems :: IntSet -> [Key]+elems+  = toAscList++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.6.2+instance GHC.Exts.IsList IntSet where+  type Item IntSet = Key+  fromList = fromList+  toList   = toList+#endif++-- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion.+toList :: IntSet -> [Key]+toList+  = toAscList++-- | \(O(n)\). Convert the set to an ascending list of elements. Subject to list+-- fusion.+toAscList :: IntSet -> [Key]+toAscList = foldr (:) []++-- | \(O(n)\). Convert the set to a descending list of elements. Subject to list+-- fusion.+toDescList :: IntSet -> [Key]+toDescList = foldl (flip (:)) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.+-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.+foldrFB :: (Key -> b -> b) -> b -> IntSet -> b+foldrFB = foldr+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> a) -> a -> IntSet -> a+foldlFB = foldl+{-# INLINE[0] foldlFB #-}++-- Inline elems and toList, so that we need to fuse only toAscList.+{-# INLINE elems #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded to{Asc,Desc}List calls back to+-- to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were used in+-- a list fusion, otherwise it would go away in phase 1), and let compiler do+-- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it+-- before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "IntSet.toAscList" [~1] forall s . toAscList s = GHC.Exts.build (\c n -> foldrFB c n s) #-}+{-# RULES "IntSet.toAscListBack" [1] foldrFB (:) [] = toAscList #-}+{-# RULES "IntSet.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}+{-# RULES "IntSet.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}+#endif+++-- | \(O(n \min(n,W))\). Create a set from a list of integers.+fromList :: [Key] -> IntSet+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t x  = insert x t++-- | \(O(n / W)\). Create a set from a range of integers.+--+-- > fromRange (low, high) == fromList [low..high]+--+-- @since 0.7+fromRange :: (Key, Key) -> IntSet+fromRange (lx,rx)+  | lx > rx  = empty+  | lp == rp = Tip lp (bitmapOf rx `shiftLL` 1 - bitmapOf lx)+  | otherwise =+      let m = branchMask lx rx+          p = Prefix (mask lx m .|. m)+      in if signBranch p  -- handle negative numbers+         then Bin p (goR 0) (goL 0)+         else Bin p (goL (unPrefix p)) (goR (unPrefix p))+  where+    lp = prefixOf lx+    rp = prefixOf rx+    -- goL p0 = fromList [lx .. p0-1]+    -- Expected: p0 is lx where one 0-bit is flipped to 1 and all bits lower than that are 0.+    --           p0 can be 0 (pretend that bit WORD_SIZE is flipped to 1).+    goL :: Int -> IntSet+    goL !p0 = go (Tip lp (- bitmapOf lx)) (lp + lbm prefixBitMask)+      where+        go !l p | p == p0 = l+        go l p =+          let m = lbm p+              l' = Bin (Prefix p) l (goFull p (shr1 m))+          in go l' (p + m)+    -- goR p0 = fromList [p0 .. rx]+    -- Expected: p0 is a prefix of rx+    goR :: Int -> IntSet+    goR !p0 = go (Tip rp (bitmapOf rx `shiftLL` 1 - 1)) rp+      where+        go !r p | p == p0 = r+        go r p =+          let m = lbm p+              p' = p `xor` m+              r' = Bin (Prefix p) (goFull p' (shr1 m)) r+          in go r' p'+    -- goFull p m = fromList [p .. p+2*m-1]+    -- Expected: popCount m == 1, p == mask p m+    goFull :: Int -> Int -> IntSet+    goFull p m+      | m < suffixBitMask = Tip p (complement 0)+      | otherwise         = Bin (Prefix (p .|. m)) (goFull p (shr1 m)) (goFull (p .|. m) (shr1 m))+    lbm :: Int -> Int+    lbm p = p .&. negate p -- lowest bit mask+    {-# INLINE lbm #-}+    shr1 :: Int -> Int+    shr1 m = m `iShiftRL` 1+    {-# INLINE shr1 #-}++-- | \(O(n)\). Build a set from an ascending list of elements.+--+-- __Warning__: This function should be used only if the elements are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+fromAscList :: [Key] -> IntSet+fromAscList = fromMonoList+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a set from an ascending list of distinct elements.+--+-- __Warning__: This function should be used only if the elements are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+fromDistinctAscList :: [Key] -> IntSet+fromDistinctAscList = fromAscList+{-# INLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a set from a monotonic list of elements.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.+fromMonoList :: [Key] -> IntSet+fromMonoList []         = Nil+fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1+  where+    -- `addAll'` collects all keys with the prefix `px` into a single+    -- bitmap, and then proceeds with `addAll`.+    addAll' !px !bm []+        = Tip px bm+    addAll' !px !bm (ky : zs)+        | px == prefixOf ky+        = addAll' px (bm .|. bitmapOf ky) zs+        -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs)+        | py <- prefixOf ky+        , m <- branchMask px py+        , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs+        = addAll px (linkWithMask m py ty px (Tip px bm)) zs'++    -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_px !tx []+        = tx+    addAll !px !tx (ky : zs)+        | py <- prefixOf ky+        , m <- branchMask px py+        , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs+        = addAll px (linkWithMask m py ty px tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !px !bm []+        = Inserted (Tip px bm) []+    addMany' !m !px !bm zs0@(ky : zs)+        | px == prefixOf ky+        = addMany' m px (bm .|. bitmapOf ky) zs+        -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs)+        | mask px m /= mask ky m+        = Inserted (Tip (prefixOf px) bm) zs0+        | py <- prefixOf ky+        , mxy <- branchMask px py+        , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs+        = addMany m px (linkWithMask mxy py ty px (Tip px bm)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`.+    addMany !_m !_px tx []+        = Inserted tx []+    addMany !m !px tx zs0@(ky : zs)+        | mask px m /= mask ky m+        = Inserted tx zs0+        | py <- prefixOf ky+        , mxy <- branchMask px py+        , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs+        = addMany m px (linkWithMask mxy py ty px tx) zs'+{-# INLINE fromMonoList #-}++data Inserted = Inserted !IntSet ![Key]++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq IntSet where+  (==) = equal++equal :: IntSet -> IntSet -> Bool+equal (Bin p1 l1 r1) (Bin p2 l2 r2)+  = (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx1 bm1) (Tip kx2 bm2)+  = kx1 == kx2 && bm1 == bm2+equal Nil Nil = True+equal _   _   = False++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord IntSet where+  compare = compareIntSets++compareIntSets :: IntSet -> IntSet -> Ordering+compareIntSets s1 s2 = case (splitSign s1, splitSign s2) of+  ((l1, r1), (l2, r2)) -> case go l1 l2 of+    A_LT_B -> LT+    A_Prefix_B -> if null r1 then LT else GT+    A_EQ_B -> case go r1 r2 of+      A_LT_B -> LT+      A_Prefix_B -> LT+      A_EQ_B -> EQ+      B_Prefix_A -> GT+      A_GT_B -> GT+    B_Prefix_A -> if null r2 then GT else LT+    A_GT_B -> GT+  where+    go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of+      ABL -> case go l1 t2 of+        A_Prefix_B -> A_GT_B+        A_EQ_B -> B_Prefix_A+        o -> o+      ABR -> A_LT_B+      BAL -> case go t1 l2 of+        A_EQ_B -> A_Prefix_B+        B_Prefix_A -> A_LT_B+        o -> o+      BAR -> A_GT_B+      EQL -> case go l1 l2 of+        A_Prefix_B -> A_GT_B+        A_EQ_B -> go r1 r2+        B_Prefix_A -> A_LT_B+        o -> o+      NOM -> if unPrefix p1 < unPrefix p2 then A_LT_B else A_GT_B+    go (Bin _ l1 _) (Tip k2 bm2) = case leftmostTipSure l1 of+      Tip' k1 bm1 -> case orderTips k1 bm1 k2 bm2 of+        A_Prefix_B -> A_GT_B+        A_EQ_B -> B_Prefix_A+        o -> o+    go (Tip k1 bm1) (Bin _ l2 _) = case leftmostTipSure l2 of+      Tip' k2 bm2 -> case orderTips k1 bm1 k2 bm2 of+        A_EQ_B -> A_Prefix_B+        B_Prefix_A -> A_LT_B+        o -> o+    go (Tip k1 bm1) (Tip k2 bm2) = orderTips k1 bm1 k2 bm2+    go Nil Nil = A_EQ_B+    go Nil _ = A_Prefix_B+    go _ Nil = B_Prefix_A++-- This type allows GHC to return unboxed ints from leftmostTipSure, as+-- $wleftmostTipSure :: IntSet -> (# Int#, Word# #)+-- On a modern enough GHC (>=9.4) this is unnecessary, we could use StrictPair+-- instead and get the same Core.+data Tip' = Tip' {-# UNPACK #-} !Int {-# UNPACK #-} !BitMap++leftmostTipSure :: IntSet -> Tip'+leftmostTipSure (Bin _ l _) = leftmostTipSure l+leftmostTipSure (Tip k bm) = Tip' k bm+leftmostTipSure Nil = error "leftmostTipSure: Nil"++orderTips :: Int -> BitMap -> Int -> BitMap -> Order+orderTips k1 bm1 k2 bm2 = case compare k1 k2 of+  LT -> A_LT_B+  EQ | bm1 == bm2 -> A_EQ_B+     | otherwise ->+         -- To lexicographically compare the elements of two BitMaps,+         -- - Find the lowest bit where they differ.+         -- - For the BitMap with this bit 0, check if all higher bits are also+         --   0. If yes it is a prefix, otherwise it is greater.+         let diff = bm1 `xor` bm2+             lowestDiff = diff .&. negate diff+             highMask = negate lowestDiff+         in if bm1 .&. lowestDiff == 0+            then (if bm1 .&. highMask == 0 then A_Prefix_B else A_GT_B)+            else (if bm2 .&. highMask == 0 then B_Prefix_A else A_LT_B)+  GT -> A_GT_B+{-# INLINE orderTips #-}++-- Split into negative and non-negative+splitSign :: IntSet -> (IntSet, IntSet)+splitSign t@(Bin p l r)+  | signBranch p = (r, l)+  | unPrefix p < 0 = (t, Nil)+  | otherwise = (Nil, t)+splitSign t@(Tip k _)+  | k < 0 = (t, Nil)+  | otherwise = (Nil, t)+splitSign Nil = (Nil, Nil)+{-# INLINE splitSign #-}++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance Show IntSet where+  showsPrec p xs = showParen (p > 10) $+    showString "fromList " . shows (toList xs)++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance Read IntSet where+#ifdef __GLASGOW_HASKELL__+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault+#else+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)+#endif++{--------------------------------------------------------------------+  NFData+--------------------------------------------------------------------}++-- The IntSet constructors consist only of strict fields of Ints and+-- IntSets, thus the default NFData instance which evaluates to whnf+-- should suffice+instance NFData IntSet where rnf x = seq x ()++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | \(O(n \min(n,W))\). Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: IntSet -> String+showTree s+  = showTreeWith True False s+++{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the set. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Bool -> Bool -> IntSet -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS+showsTree wide lbars rbars t+  = case t of+      Bin p l r+          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . showString (showBin p) . showString "\n" .+             showWide wide lbars .+             showsTree wide (withEmpty lbars) (withBar lbars) l+      Tip kx bm+          -> showsBars lbars . showString " " . shows kx . showString " + " .+                                                showsBitMap bm . showString "\n"+      Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Bool -> [String] -> IntSet -> ShowS+showsTreeHang wide bars t+  = case t of+      Bin p l r+          -> showsBars bars . showString (showBin p) . showString "\n" .+             showWide wide bars .+             showsTreeHang wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang wide (withEmpty bars) r+      Tip kx bm+          -> showsBars bars . showString " " . shows kx . showString " + " .+                                               showsBitMap bm . showString "\n"+      Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> String+showBin _+  = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars [] = id+showsBars (_ : tl) = showString (concat (reverse tl)) . showString node++showsBitMap :: Word -> ShowS+showsBitMap = showString . showBitMap++showBitMap :: Word -> String+showBitMap w = show $ foldrBits 0 (:) [] w++node :: String+node           = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars+++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}++-- | Link two @IntSet@s. The sets must not be empty. The @Prefix@es of the two+-- sets must be different. @k1@ must share the prefix of @t1@. @p2@ must be the+-- prefix of @t2@.+linkKey :: Key -> IntSet -> Prefix -> IntSet -> IntSet+linkKey k1 t1 p2 t2 = link k1 t1 (unPrefix p2) t2+{-# INLINE linkKey #-}++-- | Link two @IntSets. The sets must not be empty. The @Prefix@es of the two+-- sets must be different. @k1@ must share the prefix of @t1@ and @k2@ must+-- share the prefix of @t2@.+link :: Int -> IntSet -> Int -> IntSet -> IntSet+link k1 t1 k2 t2 = linkWithMask (branchMask k1 k2) k1 t1 k2 t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Int -> Key -> IntSet -> Key -> IntSet -> IntSet+linkWithMask m k1 t1 k2 t2+  | i2w k1 < i2w k2 = Bin p t1 t2+  | otherwise = Bin p t2 t1+  where+    p = Prefix (mask k1 m .|. m)+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> IntSet -> IntSet -> IntSet+bin _ l Nil = l+bin _ Nil r = r+bin p l r   = Bin p l r+{-# INLINE bin #-}++{--------------------------------------------------------------------+  @tip@ assures that we never have empty bitmaps within a tree.+--------------------------------------------------------------------}+tip :: Int -> BitMap -> IntSet+tip _ 0 = Nil+tip kx bm = Tip kx bm+{-# INLINE tip #-}+++{----------------------------------------------------------------------+  Functions that generate Prefix and BitMap of a Key or a Suffix.+----------------------------------------------------------------------}++suffixBitMask :: Int+suffixBitMask = finiteBitSize (undefined::Word) - 1+{-# INLINE suffixBitMask #-}++prefixBitMask :: Int+prefixBitMask = complement suffixBitMask+{-# INLINE prefixBitMask #-}++prefixOf :: Int -> Int+prefixOf x = x .&. prefixBitMask+{-# INLINE prefixOf #-}++suffixOf :: Int -> Int+suffixOf x = x .&. suffixBitMask+{-# INLINE suffixOf #-}++bitmapOfSuffix :: Int -> BitMap+bitmapOfSuffix s = 1 `shiftLL` s+{-# INLINE bitmapOfSuffix #-}++bitmapOf :: Int -> BitMap+bitmapOf x = bitmapOfSuffix (suffixOf x)+{-# INLINE bitmapOf #-}+++{----------------------------------------------------------------------+  To get best performance, we provide fast implementations of+  lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.+  If the intel bsf and bsr instructions ever become GHC primops,+  this code should be reimplemented using these.++  Performance of this code is crucial for folds, toList, filter, partition.++  The signatures of methods in question are placed after this comment.+----------------------------------------------------------------------}++lowestBitSet :: Word -> Int+highestBitSet :: Word -> Int+foldlBits :: Int -> (a -> Int -> a) -> a -> Word -> a+foldl'Bits :: Int -> (a -> Int -> a) -> a -> Word -> a+foldrBits :: Int -> (Int -> a -> a) -> a -> Word -> a+foldr'Bits :: Int -> (Int -> a -> a) -> a -> Word -> a+#if MIN_VERSION_base(4,11,0)+foldMapBits :: Semigroup a => Int -> (Int -> a) -> Word -> a+#else+foldMapBits :: Monoid a => Int -> (Int -> a) -> Word -> a+#endif+takeWhileAntitoneBits :: Int -> (Int -> Bool) -> Word -> Word++{-# INLINE lowestBitSet #-}+{-# INLINE highestBitSet #-}+{-# INLINE foldlBits #-}+{-# INLINE foldl'Bits #-}+{-# INLINE foldrBits #-}+{-# INLINE foldr'Bits #-}+{-# INLINE foldMapBits #-}+{-# INLINE takeWhileAntitoneBits #-}++#if defined(__GLASGOW_HASKELL__)++lowestBitSet x = countTrailingZeros x++highestBitSet x = WORD_SIZE_IN_BITS - 1 - countLeadingZeros x++-- Reverse the order of bits in the Word.+revWord :: Word -> Word+#if WORD_SIZE_IN_BITS==32+revWord x1 = case ((x1 `shiftRL` 1) .&. 0x55555555) .|. ((x1 .&. 0x55555555) `shiftLL` 1) of+              x2 -> case ((x2 `shiftRL` 2) .&. 0x33333333) .|. ((x2 .&. 0x33333333) `shiftLL` 2) of+                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F) `shiftLL` 4) of+                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF) .|. ((x4 .&. 0x00FF00FF) `shiftLL` 8) of+                     x5 -> ( x5 `shiftRL` 16             ) .|. ( x5               `shiftLL` 16);+#else+revWord x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of+              x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of+                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of+                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of+                     x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of+                       x6 -> ( x6 `shiftRL` 32             ) .|. ( x6               `shiftLL` 32);+#endif++foldlBits prefix f z0 bitmap = go z0 $! revWord bitmap+  where+    -- Note: We pass the z as a static argument because it helps GHC with demand+    -- analysis. See GHC #25578 for details.+    go z !bm = f (if bm' == 0 then z else go z bm') x+      where+        bi = WORD_SIZE_IN_BITS - 1 - countTrailingZeros bm+        !x = prefix .|. bi+        bm' = bm .&. (bm-1)++foldl'Bits prefix f z0 bitmap = go z0 bitmap+  where+    go !z !bm = if bm' == 0 then z' else go z' bm'+      where+        bi = countTrailingZeros bm+        !x = prefix .|. bi+        !z' = f z x+        bm' = bm .&. (bm-1)++foldrBits prefix f z0 bitmap = go bitmap z0+  where+    -- Note: We pass the z as a static argument because it helps GHC with demand+    -- analysis. See GHC #25578 for details.+    go !bm z = f x (if bm' == 0 then z else go bm' z)+      where+        bi = countTrailingZeros bm+        !x = prefix .|. bi+        bm' = bm .&. (bm-1)++foldr'Bits prefix f z0 bitmap = (go $! revWord bitmap) z0+  where+    go !bm !z = if bm' == 0 then z' else go bm' z'+      where+        bi = WORD_SIZE_IN_BITS - 1 - countTrailingZeros bm+        !x = prefix .|. bi+        !z' = f x z+        bm' = bm .&. (bm-1)++foldMapBits prefix f bitmap = go bitmap+  where+    go !bm = if bm' == 0+             then f x+#if MIN_VERSION_base(4,11,0)+             else f x <> go bm'+#else+             else f x `mappend` go bm'+#endif+      where+        bi = countTrailingZeros bm+        !x = prefix .|. bi+        bm' = bm .&. (bm-1)++takeWhileAntitoneBits prefix predicate bitmap =+  -- Binary search for the first index where the predicate returns false, but skip a predicate+  -- call if the high half of the current range is empty. This ensures+  -- min (log2 WORD_SIZE_IN_BITS + 1) (popcount bitmap) predicate calls.+  let next d h (n',b') =+        if n' .&. h /= 0 && (predicate $! prefix+b'+d) then (n' `shiftRL` d, b'+d) else (n',b')+      {-# INLINE next #-}+      (_,b) = next 1  0x2 $+              next 2  0xC $+              next 4  0xF0 $+              next 8  0xFF00 $+              next 16 0xFFFF0000 $+#if WORD_SIZE_IN_BITS==64+              next 32 0xFFFFFFFF00000000 $+#endif+              (bitmap,0)+      m = if b /= 0 || (bitmap .&. 0x1 /= 0 && predicate prefix)+          then ((2 `shiftLL` b) - 1)+          else ((1 `shiftLL` b) - 1)+  in bitmap .&. m++#else+{----------------------------------------------------------------------+  In general case we use logarithmic implementation of+  lowestBitSet and highestBitSet, which works up to bit sizes of 64.++  Folds are linear scans.+----------------------------------------------------------------------}++lowestBitSet n0 =+    let (n1,b1) = if n0 .&. 0xFFFFFFFF /= 0 then (n0,0)  else (n0 `shiftRL` 32, 32)+        (n2,b2) = if n1 .&. 0xFFFF /= 0     then (n1,b1) else (n1 `shiftRL` 16, 16+b1)+        (n3,b3) = if n2 .&. 0xFF /= 0       then (n2,b2) else (n2 `shiftRL` 8,  8+b2)+        (n4,b4) = if n3 .&. 0xF /= 0        then (n3,b3) else (n3 `shiftRL` 4,  4+b3)+        (n5,b5) = if n4 .&. 0x3 /= 0        then (n4,b4) else (n4 `shiftRL` 2,  2+b4)+        b6      = if n5 .&. 0x1 /= 0        then     b5  else                   1+b5+    in b6++highestBitSet n0 =+    let (n1,b1) = if n0 .&. 0xFFFFFFFF00000000 /= 0 then (n0 `shiftRL` 32, 32)    else (n0,0)+        (n2,b2) = if n1 .&. 0xFFFF0000 /= 0         then (n1 `shiftRL` 16, 16+b1) else (n1,b1)+        (n3,b3) = if n2 .&. 0xFF00 /= 0             then (n2 `shiftRL` 8,  8+b2)  else (n2,b2)+        (n4,b4) = if n3 .&. 0xF0 /= 0               then (n3 `shiftRL` 4,  4+b3)  else (n3,b3)+        (n5,b5) = if n4 .&. 0xC /= 0                then (n4 `shiftRL` 2,  2+b4)  else (n4,b4)+        b6      = if n5 .&. 0x2 /= 0                then                   1+b5   else     b5+    in b6++foldlBits prefix f z bm = let lb = lowestBitSet bm+                          in  go (prefix+lb) z (bm `shiftRL` lb)+  where go !_ acc 0 = acc+        go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)+                    | otherwise     = go (bi + 1)    acc     (n `shiftRL` 1)++foldl'Bits prefix f z bm = let lb = lowestBitSet bm+                           in  go (prefix+lb) z (bm `shiftRL` lb)+  where go !_ !acc 0 = acc+        go bi acc n | n `testBit` 0 = go (bi + 1) (f acc bi) (n `shiftRL` 1)+                    | otherwise     = go (bi + 1)    acc     (n `shiftRL` 1)++foldrBits prefix f z bm = let lb = lowestBitSet bm+                          in  go (prefix+lb) (bm `shiftRL` lb)+  where go !_ 0 = z+        go bi n | n `testBit` 0 = f bi (go (bi + 1) (n `shiftRL` 1))+                | otherwise     =       go (bi + 1) (n `shiftRL` 1)++foldr'Bits prefix f z bm = let lb = lowestBitSet bm+                           in  go (prefix+lb) (bm `shiftRL` lb)+  where+        go !_ 0 = z+        go bi n | n `testBit` 0 = f bi $! go (bi + 1) (n `shiftRL` 1)+                | otherwise     =         go (bi + 1) (n `shiftRL` 1)++foldMapBits prefix f bm = go x0 (x0 + 1) ((bm `shiftRL` lb) `shiftRL` 1)+  where+    lb = lowestBitSet bm+    x0 = prefix + lb+    go !x !_ 0 = f x+    go !x !bi n+#if MIN_VERSION_base(4,11,0)+      | n `testBit` 0 = f x <> go bi (bi + 1) (n `shiftRL` 1)+#else+      | n `testBit` 0 = f x `mappend` go bi (bi + 1) (n `shiftRL` 1)+#endif+      | otherwise = go x (bi + 1) (n `shiftRL` 1)++takeWhileAntitoneBits prefix predicate = foldl'Bits prefix f 0 -- Does not use antitone property+  where+    f acc bi | predicate bi = acc .|. bitmapOf bi+             | otherwise    = acc++#endif+++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | \(O(1)\).  Decompose a set into pieces based on the structure of the underlying+-- tree.  This function is useful for consuming a set in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than two subsets,+--  but you should not depend on this behaviour because it can change in the+--  future without notice. Also, the current version does not continue+--  splitting all the way to individual singleton sets -- it stops at some+--  point.+splitRoot :: IntSet -> [IntSet]+splitRoot Nil = []+-- NOTE: we don't currently split below Tip, but we could.+splitRoot x@(Tip _ _) = [x]+splitRoot (Bin p l r) | signBranch p = [r, l]+                      | otherwise = [l, r]+{-# INLINE splitRoot #-}
+ src/Data/IntSet/Internal/IntTreeCommons.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE StandaloneDeriving #-}+#endif++-- |+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- This module defines common constructs used by both "Data.IntSet" and+-- "Data.IntMap".+--+-- @since 0.8+--++module Data.IntSet.Internal.IntTreeCommons+  ( Key+  , Prefix(..)+  , nomatch+  , left+  , signBranch+  , TreeTreeBranch(..)+  , treeTreeBranch+  , mask+  , branchMask+  , i2w+  , Order(..)+  ) where++import Data.Bits (Bits(..), countLeadingZeros)+import Utils.Containers.Internal.BitUtil (wordSize)++#ifdef __GLASGOW_HASKELL__+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif+++type Key = Int++-- | A @Prefix@ represents some prefix of high-order bits of an @Int@.+--+-- A @Prefix@ is usually considered in the context of a+-- 'Data.IntSet.Internal.Bin' or 'Data.IntMap.Internal.Bin'.++-- See Note [IntSet structure and invariants] in Data.IntSet.Internal and+-- Note [IntMap structure and invariants] in Data.IntMap.Internal for details.+newtype Prefix = Prefix { unPrefix :: Int }+  deriving Eq++#ifdef __GLASGOW_HASKELL__+deriving instance Lift Prefix+#endif++-- | Whether the @Int@ does not start with the given @Prefix@.+--+-- An @Int@ starts with a @Prefix@ if it shares the high bits with the internal+-- @Int@ value of the @Prefix@ up to the mask bit.+--+-- @nomatch@ is usually used to determine whether a key belongs in a @Bin@,+-- since all keys in a @Bin@ share a @Prefix@.+nomatch :: Int -> Prefix -> Bool+nomatch i p = (i `xor` px) .&. prefixMask /= 0+  where+    px = unPrefix p+    prefixMask = px `xor` (-px)+{-# INLINE nomatch #-}++-- | Whether the @Int@ is to the left of the split created by a @Bin@ with this+-- @Prefix@.+--+-- This does not imply that the @Int@ belongs in this @Bin@. That fact is+-- usually determined first using @nomatch@.+left :: Int -> Prefix -> Bool+left i p = i2w i < i2w (unPrefix p)+{-# INLINE left #-}++-- | A @TreeTreeBranch@ is returned by 'treeTreeBranch' to indicate how two+-- @Bin@s relate to each other.+--+-- Consider that @A@ and @B@ are the @Bin@s whose @Prefix@es are given to+-- @treeTreeBranch@ as the first and second arguments respectively.+data TreeTreeBranch+  = ABL  -- ^ A contains B in the left child+  | ABR  -- ^ A contains B in the right child+  | BAL  -- ^ B contains A in the left child+  | BAR  -- ^ B contains A in the right child+  | EQL  -- ^ A and B have equal prefixes+  | NOM  -- ^ A and B have prefixes that do not match++-- | Calculates how two @Bin@s relate to each other by comparing their+-- @Prefix@es.++-- Notes:+-- * pw .|. (pw-1) sets every bit below the mask bit to 1. This is the greatest+--   key the Bin can have.+-- * pw .&. (pw-1) sets the mask bit and every bit below it to 0. This is the+--   smallest key the Bin can have.+--+-- First, we compare the prefixes to each other. Then we compare a prefix+-- against the greatest/smallest keys the other prefix's Bin could have. This is+-- enough to determine how the two Bins relate to each other. The conditions can+-- be stated as:+--+-- * If pw1 from Bin A is less than pw2 from Bin B, and pw2 is <= the greatest+--   key of Bin A, then Bin A contains Bin B in its right child.+-- * ...and so on++treeTreeBranch :: Prefix -> Prefix -> TreeTreeBranch+treeTreeBranch p1 p2 = case compare pw1 pw2 of+  LT | pw2 <= greatest pw1 -> ABR+     | smallest pw2 <= pw1 -> BAL+     | otherwise           -> NOM+  GT | pw1 <= greatest pw2 -> BAR+     | smallest pw1 <= pw2 -> ABL+     | otherwise           -> NOM+  EQ                       -> EQL+  where+    pw1 = i2w (unPrefix p1)+    pw2 = i2w (unPrefix p2)+    greatest pw = pw .|. (pw-1)+    smallest pw = pw .&. (pw-1)+{-# INLINE treeTreeBranch #-}++-- | Whether this @Prefix@ splits a @Bin@ at the sign bit.+--+-- This can only be True at the top level.+-- If it is true, the left child contains non-negative keys and the right child+-- contains negative keys.+signBranch :: Prefix -> Bool+signBranch p = unPrefix p == (minBound :: Int)+{-# INLINE signBranch #-}++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@.+mask :: Key -> Int -> Int+mask i m = i .&. ((-m) `xor` m)+{-# INLINE mask #-}++-- | The first switching bit where the two prefixes disagree.+--+-- Precondition for defined behavior: p1 /= p2+branchMask :: Int -> Int -> Int+branchMask p1 p2 =+  unsafeShiftL 1 (wordSize - 1 - countLeadingZeros (p1 `xor` p2))+{-# INLINE branchMask #-}++i2w :: Int -> Word+i2w = fromIntegral+{-# INLINE i2w #-}++-- Used to compare IntSets and IntMaps+data Order+  = A_LT_B     -- holds for [0,3,4] [0,3,5,1]+  | A_Prefix_B -- holds for [0,3,4] [0,3,4,5]+  | A_EQ_B     -- holds for [0,3,4] [0,3,4]+  | B_Prefix_A -- holds for [0,3,4] [0,3]+  | A_GT_B     -- holds for [0,3,4] [0,2,5]++{--------------------------------------------------------------------+  Notes+--------------------------------------------------------------------}++-- Note [INLINE bit fiddling]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It is essential that the bit fiddling functions like nomatch, mask,+-- branchMask etc are inlined. If they do not, the memory allocation skyrockets.+-- The GHC usually gets it right, but it is disastrous if it does not. Therefore+-- we explicitly mark these functions INLINE.
+ src/Data/Map.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Safe #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Map+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Maps (lazy interface)+--+-- This module re-exports the value lazy "Data.Map.Lazy" API.+--+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@. A 'Map' is strict in its keys but lazy+-- in its values.+--+-- The functions in "Data.Map.Strict" are careful to force values before+-- installing them in a 'Map'. This is usually more efficient in cases where+-- laziness is not essential. The functions in this module do not do so.+--+-- When deciding if this is the correct data structure to use, consider:+--+-- * If you are using 'Prelude.Int' keys, you will get much better performance for most+-- operations using "Data.IntMap.Lazy".+--+-- * If you don't care about ordering, consider using @Data.HashMap.Lazy@ from the+-- <https://hackage.haskell.org/package/unordered-containers unordered-containers>+-- package instead.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- > import Data.Map (Map)+-- > import qualified Data.Map as Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Warning+--+-- The size of a 'Map' must not exceed @'Prelude.maxBound' :: 'Prelude.Int'@.+-- Violation of this condition is not detected and if the size limit is exceeded,+-- its behaviour is undefined.+--+--+-- == Implementation+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104>+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>.+--+--+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map.+--+-- Operations like 'lookup', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-----------------------------------------------------------------------------++module Data.Map+    ( module Data.Map.Lazy+    ) where++import Data.Map.Lazy
+ src/Data/Map/Internal.hs view
@@ -0,0 +1,4574 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+#if defined(__GLASGOW_HASKELL__)+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+#define USE_MAGIC_PROXY 1+#endif++#ifdef USE_MAGIC_PROXY+{-# LANGUAGE MagicHash #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++#include "containers.h"++#if !(WORD_SIZE_IN_BITS >= 61)+#define DEFINE_ALTERF_FALLBACK 1+#endif++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Map.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Maps (lazy interface internals)+--+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@. A 'Map' is strict in its keys+-- but lazy in its values.+--+--+-- == Implementation+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104>+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>.+--+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: Using INLINABLE]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- It is crucial to the performance that the functions specialize on the Ord+-- type when possible. GHC 7.0 and higher does this by itself when it sees th+-- unfolding of a function -- that is why all public functions are marked+-- INLINABLE (that exposes the unfolding).+++-- [Note: Using INLINE]+-- ~~~~~~~~~~~~~~~~~~~~+-- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.+-- We mark the functions that just navigate down the tree (lookup, insert,+-- delete and similar). That navigation code gets inlined and thus specialized+-- when possible. There is a price to pay -- code growth. The code INLINED is+-- therefore only the tree navigation, all the real work (rebalancing) is not+-- INLINED by using a NOINLINE.+--+-- All methods marked INLINE have to be nonrecursive -- a 'go' function doing+-- the real work is provided.+++-- [Note: Type of local 'go' function]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- If the local 'go' function uses an Ord class, it sometimes heap-allocates+-- the Ord dictionary when the 'go' function does not have explicit type.+-- In that case we give 'go' explicit type. But this slightly decrease+-- performance, as the resulting 'go' function can float out to top level.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- As opposed to Map, when 'go' function captures an argument, increased+-- heap-allocation can occur: sometimes in a polymorphic function, the 'go'+-- floats out of its enclosing function and then it heap-allocates the+-- dictionary and the argument. Maybe it floats out too late and strictness+-- analyzer cannot see that these could be passed on stack.+--++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of Map matters when considering performance.+-- Currently in GHC 7.0, when type has 2 constructors, a forward conditional+-- jump is made when successfully matching second constructor. Successful match+-- of first constructor results in the forward jump not taken.+-- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip+-- improves the benchmark by up to 10% on x86.++module Data.Map.Internal (+    -- * Map type+      Map(..)          -- instance Eq,Show,Read+    , Size++    -- * Operators+    , (!), (!?), (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookup+    , findWithDefault+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE++    -- * Construction+    , empty+    , singleton++    -- ** Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- ** Delete\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Symmetric difference+    , symmetricDifference++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** General combining function+    , SimpleWhenMissing+    , SimpleWhenMatched+    , runWhenMatched+    , runWhenMissing+    , merge+    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched+    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , preserveMissing'+    , mapMissing+    , filterMissing++    -- ** Applicative general combining function+    , WhenMissing (..)+    , WhenMatched (..)+    , mergeA++    -- *** @WhenMatched@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , zipWithMaybeAMatched+    , zipWithAMatched++    -- *** @WhenMissing@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , traverseMaybeMissing+    , traverseMissing+    , filterAMissing++    -- ** Deprecated general combining function++    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , argSet+    , fromSet+    , fromArgSet++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList+    , fromDescList+    , fromDescListWith+    , fromDescListWithKey+    , fromDistinctDescList++    -- * Filter+    , filter+    , filterKeys+    , filterWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Indexed+    , lookupIndex+    , findIndex+    , elemAt+    , updateAt+    , deleteAt+    , take+    , drop+    , splitAt++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- Used by the strict version+    , AreWeStrict (..)+    , atKeyImpl+#ifdef __GLASGOW_HASKELL__+    , atKeyPlain+#endif+    , bin+    , balance+    , balanceL+    , balanceR+    , delta+    , insertMax+    , link+    , link2+    , glue+    , ascLinkTop+    , ascLinkAll+    , descLinkTop+    , descLinkAll+    , MaybeS(..)+    , Identity(..)+    , Stack(..)+    , foldl'Stack+    , MapBuilder(..)+    , emptyB+    , insertB+    , finishB++    -- Used by Map.Merge.Lazy+    , mapWhenMissing+    , mapWhenMatched+    , lmapWhenMissing+    , contramapFirstWhenMatched+    , contramapSecondWhenMatched+    , mapGentlyWhenMissing+    , mapGentlyWhenMatched+    ) where++import Data.Functor.Identity (Identity (..))+import Control.Applicative (liftA3)+import Data.Functor.Classes+import Data.Semigroup (stimesIdempotentMonoid)+import Data.Semigroup (Arg(..), Semigroup(stimes))+#if !(MIN_VERSION_base(4,11,0))+import Data.Semigroup (Semigroup((<>)))+#endif+import Control.Applicative (Const (..))+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf),NFData2(liftRnf2))+import qualified Data.Foldable as Foldable+import Data.Bifoldable+import Utils.Containers.Internal.Prelude hiding+  (lookup, map, filter, foldr, foldl, foldl', null, splitAt, take, drop)+import Prelude ()++import qualified Data.Set.Internal as Set+import Data.Set.Internal (Set)+import Utils.Containers.Internal.PtrEquality (ptrEq)+import Utils.Containers.Internal.StrictPair+import Utils.Containers.Internal.StrictMaybe+import Utils.Containers.Internal.BitQueue+import Utils.Containers.Internal.EqOrdUtil (EqM(..), OrdM(..))+#ifdef DEFINE_ALTERF_FALLBACK+import Utils.Containers.Internal.BitUtil (wordSize)+#endif++#if __GLASGOW_HASKELL__+import GHC.Exts (build, lazy)+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#  ifdef USE_MAGIC_PROXY+import GHC.Exts (Proxy#, proxy# )+#  endif+import qualified GHC.Exts as GHCExts+import Data.Data+import Data.Coerce+#endif+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+import Text.Read hiding (lift)+#endif+import qualified Control.Category as Category++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 !,!?,\\ --++-- | \(O(\log n)\). Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: Ord k => Map k a -> k -> a+(!) m k = find k m+#if __GLASGOW_HASKELL__+{-# INLINE (!) #-}+#endif++-- | \(O(\log n)\). Find the value at a key.+-- Returns 'Nothing' when the element can not be found.+--+-- prop> fromList [(5, 'a'), (3, 'b')] !? 1 == Nothing+-- prop> fromList [(5, 'a'), (3, 'b')] !? 5 == Just 'a'+--+-- @since 0.5.9++(!?) :: Ord k => Map k a -> k -> Maybe a+(!?) m k = lookup k m+#if __GLASGOW_HASKELL__+{-# INLINE (!?) #-}+#endif++-- | Same as 'difference'.+(\\) :: Ord k => Map k a -> Map k b -> Map k a+m1 \\ m2 = difference m1 m2+#if __GLASGOW_HASKELL__+{-# INLINE (\\) #-}+#endif++{--------------------------------------------------------------------+  Size balanced trees.+--------------------------------------------------------------------}+-- | A Map from keys @k@ to values @a@.++-- See Note: Order of constructors+data Map k a  = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)+              | Tip++type Size     = Int++#ifdef __GLASGOW_HASKELL__+type role Map nominal representational+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+deriving instance (Lift k, Lift a) => Lift (Map k a)+#endif++-- | @mempty@ = 'empty'+instance (Ord k) => Monoid (Map k v) where+    mempty  = empty+    mconcat = unions+    mappend = (<>)++-- | @(<>)@ = 'union'+--+-- @since 0.5.7+instance (Ord k) => Semigroup (Map k v) where+    (<>)    = union+    stimes  = stimesIdempotentMonoid++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance (Data k, Data a, Ord k) => Data (Map k a) where+  gfoldl f z m   = z fromList `f` toList m+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = mapDataType+  dataCast2 f    = gcast2 f++fromListConstr :: Constr+fromListConstr = mkConstr mapDataType "fromList" [] Prefix++mapDataType :: DataType+mapDataType = mkDataType "Data.Map.Internal.Map" [fromListConstr]++#endif++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the map empty?+--+-- > Data.Map.null (empty)           == True+-- > Data.Map.null (singleton 1 'a') == False++null :: Map k a -> Bool+null Tip      = True+null (Bin {}) = False+{-# INLINE null #-}++-- | \(O(1)\). The number of elements in the map.+--+-- > size empty                                   == 0+-- > size (singleton 1 'a')                       == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3++size :: Map k a -> Int+size Tip              = 0+size (Bin sz _ _ _ _) = sz+{-# INLINE size #-}+++-- | \(O(\log n)\). Look up the value at a key in the map.+--+-- The function will return the corresponding value as @('Just' value)@,+-- or 'Nothing' if the key isn't in the map.+--+-- An example of using @lookup@:+--+-- > import Prelude hiding (lookup)+-- > import Data.Map+-- >+-- > employeeDept = fromList([("John","Sales"), ("Bob","IT")])+-- > deptCountry = fromList([("IT","USA"), ("Sales","France")])+-- > countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])+-- >+-- > employeeCurrency :: String -> Maybe String+-- > employeeCurrency name = do+-- >     dept <- lookup name employeeDept+-- >     country <- lookup dept deptCountry+-- >     lookup country countryCurrency+-- >+-- > main = do+-- >     putStrLn $ "John's currency: " ++ (show (employeeCurrency "John"))+-- >     putStrLn $ "Pete's currency: " ++ (show (employeeCurrency "Pete"))+--+-- The output of this program:+--+-- >   John's currency: Just "Euro"+-- >   Pete's currency: Nothing+lookup :: Ord k => k -> Map k a -> Maybe a+lookup = go+  where+    go !_ Tip = Nothing+    go k (Bin _ kx x l r) = case compare k kx of+      LT -> go k l+      GT -> go k r+      EQ -> Just x+#if __GLASGOW_HASKELL__+{-# INLINABLE lookup #-}+#else+{-# INLINE lookup #-}+#endif++-- | \(O(\log n)\). Is the key a member of the map? See also 'notMember'.+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False+member :: Ord k => k -> Map k a -> Bool+member = go+  where+    go !_ Tip = False+    go k (Bin _ kx _ l r) = case compare k kx of+      LT -> go k l+      GT -> go k r+      EQ -> True+#if __GLASGOW_HASKELL__+{-# INLINABLE member #-}+#else+{-# INLINE member #-}+#endif++-- | \(O(\log n)\). Is the key not a member of the map? See also 'member'.+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Ord k => k -> Map k a -> Bool+notMember k m = not $ member k m+#if __GLASGOW_HASKELL__+{-# INLINABLE notMember #-}+#else+{-# INLINE notMember #-}+#endif++-- | \(O(\log n)\). Find the value at a key.+-- Calls 'error' when the element can not be found.+find :: Ord k => k -> Map k a -> a+find = go+  where+    go !_ Tip = error "Map.!: given key is not an element in the map"+    go k (Bin _ kx x l r) = case compare k kx of+      LT -> go k l+      GT -> go k r+      EQ -> x+#if __GLASGOW_HASKELL__+{-# INLINABLE find #-}+#else+{-# INLINE find #-}+#endif++-- | \(O(\log n)\). The expression @('findWithDefault' def k map)@ returns+-- the value at key @k@ or returns default value @def@+-- when the key is not in the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'+findWithDefault :: Ord k => a -> k -> Map k a -> a+findWithDefault = go+  where+    go def !_ Tip = def+    go def k (Bin _ kx x l r) = case compare k kx of+      LT -> go def k l+      GT -> go def k r+      EQ -> x+#if __GLASGOW_HASKELL__+{-# INLINABLE findWithDefault #-}+#else+{-# INLINE findWithDefault #-}+#endif++-- | \(O(\log n)\). Find largest key smaller than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+lookupLT :: Ord k => k -> Map k v -> Maybe (k, v)+lookupLT = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing k (Bin _ kx x l r) | k <= kx = goNothing k l+                                 | otherwise = goJust k kx x r++    goJust !_ kx' x' Tip = Just (kx', x')+    goJust k kx' x' (Bin _ kx x l r) | k <= kx = goJust k kx' x' l+                                     | otherwise = goJust k kx x r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupLT #-}+#else+{-# INLINE lookupLT #-}+#endif++-- | \(O(\log n)\). Find smallest key greater than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing+lookupGT :: Ord k => k -> Map k v -> Maybe (k, v)+lookupGT = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing k (Bin _ kx x l r) | k < kx = goJust k kx x l+                                 | otherwise = goNothing k r++    goJust !_ kx' x' Tip = Just (kx', x')+    goJust k kx' x' (Bin _ kx x l r) | k < kx = goJust k kx x l+                                     | otherwise = goJust k kx' x' r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupGT #-}+#else+{-# INLINE lookupGT #-}+#endif++-- | \(O(\log n)\). Find largest key smaller or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+lookupLE :: Ord k => k -> Map k v -> Maybe (k, v)+lookupLE = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goNothing k l+                                                        EQ -> Just (kx, x)+                                                        GT -> goJust k kx x r++    goJust !_ kx' x' Tip = Just (kx', x')+    goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx' x' l+                                                            EQ -> Just (kx, x)+                                                            GT -> goJust k kx x r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupLE #-}+#else+{-# INLINE lookupLE #-}+#endif++-- | \(O(\log n)\). Find smallest key greater or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing+lookupGE :: Ord k => k -> Map k v -> Maybe (k, v)+lookupGE = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing k (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l+                                                        EQ -> Just (kx, x)+                                                        GT -> goNothing k r++    goJust !_ kx' x' Tip = Just (kx', x')+    goJust k kx' x' (Bin _ kx x l r) = case compare k kx of LT -> goJust k kx x l+                                                            EQ -> Just (kx, x)+                                                            GT -> goJust k kx' x' r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupGE #-}+#else+{-# INLINE lookupGE #-}+#endif++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty map.+--+-- > empty      == fromList []+-- > size empty == 0++empty :: Map k a+empty = Tip+{-# INLINE empty #-}++-- | \(O(1)\). A map with a single element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: k -> a -> Map k a+singleton k x = Bin 1 k x Tip Tip+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insertion+--------------------------------------------------------------------}+-- | \(O(\log n)\). Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty                         == singleton 5 'x'++-- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper+insert :: Ord k => k -> a -> Map k a -> Map k a+insert kx0 = go kx0 kx0+  where+    -- Unlike insertR, we only get sharing here+    -- when the inserted value is at the same address+    -- as the present value. We try anyway; this condition+    -- seems particularly likely to occur in 'union'.+    go :: Ord k => k -> k -> a -> Map k a -> Map k a+    go orig !_  x Tip = singleton (lazy orig) x+    go orig !kx x t@(Bin sz ky y l r) =+        case compare kx ky of+            LT | l' `ptrEq` l -> t+               | otherwise -> balanceL ky y l' r+               where !l' = go orig kx x l+            GT | r' `ptrEq` r -> t+               | otherwise -> balanceR ky y l r'+               where !r' = go orig kx x r+            EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t+               | otherwise -> Bin sz (lazy orig) x l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insert #-}+#else+{-# INLINE insert #-}+#endif++#ifndef __GLASGOW_HASKELL__+lazy :: a -> a+lazy a = a+#endif++-- [Note: Avoiding worker/wrapper]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- 'insert' has to go to great lengths to get pointer equality right and+-- to prevent unnecessary allocation. The trouble is that GHC *really* wants+-- to unbox the key and throw away the boxed one. This is bad for us, because+-- we want to compare the pointer of the box we are given to the one already+-- present if they compare EQ. It's also bad for us because it leads to the+-- key being *reboxed* if it's actually stored in the map. Ugh! So we pass the+-- 'go' function *two copies* of the key we're given. One of them we use for+-- comparisons; the other we keep in our pocket. To prevent worker/wrapper from+-- messing with the copy in our pocket, we sprinkle about calls to the magical+-- function 'lazy'. This is all horrible, but it seems to work okay.+++-- Insert a new key and value in the map if it is not already present.+-- Used by `union`.++-- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper+insertR :: Ord k => k -> a -> Map k a -> Map k a+insertR kx0 = go kx0 kx0+  where+    go :: Ord k => k -> k -> a -> Map k a -> Map k a+    go orig !_  x Tip = singleton (lazy orig) x+    go orig !kx x t@(Bin _ ky y l r) =+        case compare kx ky of+            LT | l' `ptrEq` l -> t+               | otherwise -> balanceL ky y l' r+               where !l' = go orig kx x l+            GT | r' `ptrEq` r -> t+               | otherwise -> balanceR ky y l r'+               where !r' = go orig kx x r+            EQ -> t+#if __GLASGOW_HASKELL__+{-# INLINABLE insertR #-}+#else+{-# INLINE insertR #-}+#endif++-- | \(O(\log n)\). Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWith = go+  where+    -- We have no hope of making pointer equality tricks work+    -- here, because lazy insertWith *always* changes the tree,+    -- either adding a new entry or replacing an element with a+    -- thunk.+    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f !kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> Bin sy kx (f x y) l r++#if __GLASGOW_HASKELL__+{-# INLINABLE insertWith #-}+#else+{-# INLINE insertWith #-}+#endif++-- | A helper function for 'unionWith'. When the key is already in+-- the map, the key is left alone, not replaced. The combining+-- function is flipped--it is applied to the old value and then the+-- new value.+--+-- Also see the performance note on 'fromListWith'.++insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithR = go+  where+    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f !kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> Bin sy ky (f y x) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithR #-}+#else+{-# INLINE insertWithR #-}+#endif++-- | \(O(\log n)\). Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++-- See Note: Type of local 'go' function+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey = go+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> Bin sy kx (f kx x y) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithKey #-}+#else+{-# INLINE insertWithKey #-}+#endif++-- | A helper function for 'unionWithKey'. When the key is already in+-- the map, the key is left alone, not replaced. The combining+-- function is flipped--it is applied to the old value and then the+-- new value.+--+-- Also see the performance note on 'fromListWith'.++insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKeyR = go+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> Bin sy ky (f ky y x) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithKeyR #-}+#else+{-# INLINE insertWithKeyR #-}+#endif++-- | \(O(\log n)\). Combines insert operation with old value retrieval.+-- The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])+--+-- Also see the performance note on 'fromListWith'.++-- See Note: Type of local 'go' function+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a+                    -> (Maybe a, Map k a)+insertLookupWithKey f0 k0 x0 = toPair . go f0 k0 x0+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)+    go _ !kx x Tip = (Nothing :*: singleton kx x)+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> let !(found :*: l') = go f kx x l+                      !t' = balanceL ky y l' r+                  in (found :*: t')+            GT -> let !(found :*: r') = go f kx x r+                      !t' = balanceR ky y l r'+                  in (found :*: t')+            EQ -> (Just y :*: Bin sy kx (f kx x y) l r)+#if __GLASGOW_HASKELL__+{-# INLINABLE insertLookupWithKey #-}+#else+{-# INLINE insertLookupWithKey #-}+#endif++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}+-- | \(O(\log n)\). Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > delete 5 empty                         == empty++-- See Note: Type of local 'go' function+delete :: Ord k => k -> Map k a -> Map k a+delete = go+  where+    go :: Ord k => k -> Map k a -> Map k a+    go !_ Tip = Tip+    go k t@(Bin _ kx x l r) =+        case compare k kx of+            LT | l' `ptrEq` l -> t+               | otherwise -> balanceR kx x l' r+               where !l' = go k l+            GT | r' `ptrEq` r -> t+               | otherwise -> balanceL kx x l r'+               where !r' = go k r+            EQ -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE delete #-}+#else+{-# INLINE delete #-}+#endif++-- | \(O(\log n)\). Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty                         == empty++adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a+adjust f = adjustWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__+{-# INLINABLE adjust #-}+#else+{-# INLINE adjust #-}+#endif++-- | \(O(\log n)\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty                         == empty++adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+adjustWithKey = go+  where+    go :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+    go _ !_ Tip = Tip+    go f k (Bin sx kx x l r) =+        case compare k kx of+           LT -> Bin sx kx x (go f k l) r+           GT -> Bin sx kx x l (go f k r)+           EQ -> Bin sx kx (f kx x) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE adjustWithKey #-}+#else+{-# INLINE adjustWithKey #-}+#endif++-- | \(O(\log n)\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a+update f = updateWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__+{-# INLINABLE update #-}+#else+{-# INLINE update #-}+#endif++-- | \(O(\log n)\). The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++-- See Note: Type of local 'go' function+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+updateWithKey = go+  where+    go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+    go _ !_ Tip = Tip+    go f k(Bin sx kx x l r) =+        case compare k kx of+           LT -> balanceR kx x (go f k l) r+           GT -> balanceL kx x l (go f k r)+           EQ -> case f kx x of+                   Just x' -> Bin sx kx x' l r+                   Nothing -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE updateWithKey #-}+#else+{-# INLINE updateWithKey #-}+#endif++-- | \(O(\log n)\). Look up and update. See also 'updateWithKey'.+-- This function returns the changed value, if it is updated.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++-- See Note: Type of local 'go' function+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)+updateLookupWithKey f0 k0 = toPair . go f0 k0+ where+   go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)+   go _ !_ Tip = (Nothing :*: Tip)+   go f k (Bin sx kx x l r) =+          case compare k kx of+               LT -> let !(found :*: l') = go f k l+                         !t' = balanceR kx x l' r+                     in (found :*: t')+               GT -> let !(found :*: r') = go f k r+                         !t' = balanceL kx x l r'+                     in (found :*: t')+               EQ -> case f kx x of+                       Just x' -> (Just x' :*: Bin sx kx x' l r)+                       Nothing -> let !glued = glue l r+                                  in (Just x :*: glued)+#if __GLASGOW_HASKELL__+{-# INLINABLE updateLookupWithKey #-}+#else+{-# INLINE updateLookupWithKey #-}+#endif++-- | \(O(\log n)\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+--+-- > let f _ = Nothing+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- >+-- > let f _ = Just "c"+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]+--+-- Note that @'adjust' = alter . fmap@.++-- See Note: Type of local 'go' function+alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+alter = go+  where+    go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+    go f !k Tip = case f Nothing of+               Nothing -> Tip+               Just x  -> singleton k x++    go f k (Bin sx kx x l r) = case compare k kx of+               LT -> balance kx x (go f k l) r+               GT -> balance kx x l (go f k r)+               EQ -> case f (Just x) of+                       Just x' -> Bin sx kx x' l r+                       Nothing -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE alter #-}+#else+{-# INLINE alter #-}+#endif++-- Used to choose the appropriate alterF implementation.+data AreWeStrict = Strict | Lazy++-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,+-- or update a value in a 'Map'.  In short: @'lookup' k \<$\> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)+-- interactiveAlter k m = alterF f k m where+--   f Nothing = do+--      putStrLn $ show k +++--          " was not found in the map. Would you like to add it?"+--      getUserResponse1 :: IO (Maybe String)+--   f (Just old) = do+--      putStrLn $ "The key is currently bound to " ++ show old +++--          ". Would you like to change or delete it?"+--      getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map. When used with trivial+-- functors like 'Identity' and 'Const', it is often slightly slower than+-- more specialized combinators like 'lookup' and 'insert'. However, when+-- the functor is non-trivial and key comparison is not particularly cheap,+-- it is the fastest way.+--+-- Note on rewrite rules:+--+-- This module includes GHC rewrite rules to optimize 'alterF' for+-- the 'Const' and 'Identity' functors. In general, these rules+-- improve performance. The sole exception is that when using+-- 'Identity', deleting a key that is already absent takes longer+-- than it would without the rules. If you expect this to occur+-- a very large fraction of the time, you might consider using a+-- private copy of the 'Identity' type.+--+-- Note: 'alterF' is a flipped version of the @at@ combinator from+-- @Control.Lens.At@.+--+-- @since 0.5.8+alterF :: (Functor f, Ord k)+       => (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)+alterF f k m = atKeyImpl Lazy k f m++#ifndef __GLASGOW_HASKELL__+{-# INLINE alterF #-}+#else+{-# INLINABLE [2] alterF #-}++-- We can save a little time by recognizing the special case of+-- `Control.Applicative.Const` and just doing a lookup.+{-# RULES+"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m+ #-}++-- base 4.8 and above include Data.Functor.Identity, so we can+-- save a pretty decent amount of time by handling it specially.+{-# RULES+"alterF/Identity" forall k f . alterF f k = atKeyIdentity k f+ #-}+#endif++atKeyImpl :: (Functor f, Ord k) =>+      AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)+#ifdef DEFINE_ALTERF_FALLBACK+atKeyImpl strict !k f m+-- It doesn't seem sensible to worry about overflowing the queue+-- if the word size is 61 or more. If I calculate it correctly,+-- that would take a map with nearly a quadrillion entries.+  | wordSize < 61 && size m >= alterFCutoff = alterFFallback strict k f m+#endif+atKeyImpl strict !k f m = case lookupTrace k m of+  TraceResult mv q -> (<$> f mv) $ \ fres ->+    case fres of+      Nothing -> case mv of+                   Nothing -> m+                   Just old -> deleteAlong old q m+      Just new -> case strict of+         Strict -> new `seq` case mv of+                      Nothing -> insertAlong q k new m+                      Just _ -> replaceAlong q new m+         Lazy -> case mv of+                      Nothing -> insertAlong q k new m+                      Just _ -> replaceAlong q new m++{-# INLINE atKeyImpl #-}++#ifdef DEFINE_ALTERF_FALLBACK+alterFCutoff :: Int+#if WORD_SIZE_IN_BITS == 32+alterFCutoff = 55744454+#else+alterFCutoff = case wordSize of+      30 -> 17637893+      31 -> 31356255+      32 -> 55744454+      x -> (4^(x*2-2)) `quot` (3^(x*2-2))  -- Unlikely+#endif+#endif++data TraceResult a = TraceResult (Maybe a) {-# UNPACK #-} !BitQueue++-- Look up a key and return a result indicating whether it was found+-- and what path was taken.+lookupTrace :: Ord k => k -> Map k a -> TraceResult a+lookupTrace = go emptyQB+  where+    go :: Ord k => BitQueueB -> k -> Map k a -> TraceResult a+    go !q !_ Tip = TraceResult Nothing (buildQ q)+    go q k (Bin _ kx x l r) = case compare k kx of+      LT -> (go $! q `snocQB` False) k l+      GT -> (go $! q `snocQB` True) k r+      EQ -> TraceResult (Just x) (buildQ q)++#ifdef __GLASGOW_HASKELL__+{-# INLINABLE lookupTrace #-}+#else+{-# INLINE lookupTrace #-}+#endif++-- Insert at a location (which will always be a leaf)+-- described by the path passed in.+insertAlong :: BitQueue -> k -> a -> Map k a -> Map k a+insertAlong !_ kx x Tip = singleton kx x+insertAlong q kx x (Bin sz ky y l r) =+  case unconsQ q of+        Just (False, tl) -> balanceL ky y (insertAlong tl kx x l) r+        Just (True,tl) -> balanceR ky y l (insertAlong tl kx x r)+        Nothing -> Bin sz kx x l r  -- Shouldn't happen++-- Delete from a location (which will always be a node)+-- described by the path passed in.+--+-- This is fairly horrifying! We don't actually have any+-- use for the old value we're deleting. But if GHC sees+-- that, then it will allocate a thunk representing the+-- Map with the key deleted before we have any reason to+-- believe we'll actually want that. This transformation+-- enhances sharing, but we don't care enough about that.+-- So deleteAlong needs to take the old value, and we need+-- to convince GHC somehow that it actually uses it. We+-- can't NOINLINE deleteAlong, because that would prevent+-- the BitQueue from being unboxed. So instead we pass the+-- old value to a NOINLINE constant function and then+-- convince GHC that we use the result throughout the+-- computation. Doing the obvious thing and just passing+-- the value itself through the recursion costs 3-4% time,+-- so instead we convert the value to a magical zero-width+-- proxy that's ultimately erased.+deleteAlong :: any -> BitQueue -> Map k a -> Map k a+deleteAlong old !q0 !m = go (bogus old) q0 m where+#ifdef USE_MAGIC_PROXY+  go :: Proxy# () -> BitQueue -> Map k a -> Map k a+#else+  go :: any -> BitQueue -> Map k a -> Map k a+#endif+  go !_ !_ Tip = Tip+  go foom q (Bin _ ky y l r) =+      case unconsQ q of+        Just (False, tl) -> balanceR ky y (go foom tl l) r+        Just (True, tl) -> balanceL ky y l (go foom tl r)+        Nothing -> glue l r++#ifdef USE_MAGIC_PROXY+{-# NOINLINE bogus #-}+bogus :: a -> Proxy# ()+bogus _ = proxy#+#else+-- No point hiding in this case.+{-# INLINE bogus #-}+bogus :: a -> a+bogus a = a+#endif++-- Replace the value found in the node described+-- by the given path with a new one.+replaceAlong :: BitQueue -> a -> Map k a -> Map k a+replaceAlong !_ _ Tip = Tip -- Should not happen+replaceAlong q  x (Bin sz ky y l r) =+      case unconsQ q of+        Just (False, tl) -> Bin sz ky y (replaceAlong tl x l) r+        Just (True,tl) -> Bin sz ky y l (replaceAlong tl x r)+        Nothing -> Bin sz ky x l r++#ifdef __GLASGOW_HASKELL__+atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)+atKeyIdentity k f t = Identity $ atKeyPlain Lazy k (coerce f) t+{-# INLINABLE atKeyIdentity #-}++atKeyPlain :: Ord k => AreWeStrict -> k -> (Maybe a -> Maybe a) -> Map k a -> Map k a+atKeyPlain strict k0 f0 t = case go k0 f0 t of+    AltSmaller t' -> t'+    AltBigger t' -> t'+    AltAdj t' -> t'+    AltSame -> t+  where+    go :: Ord k => k -> (Maybe a -> Maybe a) -> Map k a -> Altered k a+    go !k f Tip = case f Nothing of+                   Nothing -> AltSame+                   Just x  -> case strict of+                     Lazy -> AltBigger $ singleton k x+                     Strict -> x `seq` (AltBigger $ singleton k x)++    go k f (Bin sx kx x l r) = case compare k kx of+                   LT -> case go k f l of+                           AltSmaller l' -> AltSmaller $ balanceR kx x l' r+                           AltBigger l' -> AltBigger $ balanceL kx x l' r+                           AltAdj l' -> AltAdj $ Bin sx kx x l' r+                           AltSame -> AltSame+                   GT -> case go k f r of+                           AltSmaller r' -> AltSmaller $ balanceL kx x l r'+                           AltBigger r' -> AltBigger $ balanceR kx x l r'+                           AltAdj r' -> AltAdj $ Bin sx kx x l r'+                           AltSame -> AltSame+                   EQ -> case f (Just x) of+                           Just x' -> case strict of+                             Lazy -> AltAdj $ Bin sx kx x' l r+                             Strict -> x' `seq` (AltAdj $ Bin sx kx x' l r)+                           Nothing -> AltSmaller $ glue l r+{-# INLINE atKeyPlain #-}++data Altered k a = AltSmaller !(Map k a) | AltBigger !(Map k a) | AltAdj !(Map k a) | AltSame+#endif++#ifdef DEFINE_ALTERF_FALLBACK+-- When the map is too large to use a bit queue, we fall back to+-- this much slower version which uses a more "natural" implementation+-- improved with Yoneda to avoid repeated fmaps. This works okayish for+-- some operations, but it's pretty lousy for lookups.+alterFFallback :: (Functor f, Ord k)+   => AreWeStrict -> k -> (Maybe a -> f (Maybe a)) -> Map k a -> f (Map k a)+alterFFallback Lazy k f t = alterFYoneda k (\m q -> q <$> f m) t id+alterFFallback Strict k f t = alterFYoneda k (\m q -> q . forceMaybe <$> f m) t id+  where+    forceMaybe Nothing = Nothing+    forceMaybe may@(Just !_) = may+{-# NOINLINE alterFFallback #-}++alterFYoneda :: Ord k =>+      k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b+alterFYoneda = go+  where+    go :: Ord k =>+      k -> (Maybe a -> (Maybe a -> b) -> f b) -> Map k a -> (Map k a -> b) -> f b+    go !k f Tip g = f Nothing $ \ mx -> case mx of+      Nothing -> g Tip+      Just x -> g (singleton k x)+    go k f (Bin sx kx x l r) g = case compare k kx of+               LT -> go k f l (\m -> g (balance kx x m r))+               GT -> go k f r (\m -> g (balance kx x l m))+               EQ -> f (Just x) $ \ mx' -> case mx' of+                       Just x' -> g (Bin sx kx x' l r)+                       Nothing -> g (glue l r)+{-# INLINE alterFYoneda #-}+#endif++{--------------------------------------------------------------------+  Indexing+--------------------------------------------------------------------}+-- | \(O(\log n)\). Return the /index/ of a key, which is its zero-based index in+-- the sequence sorted by keys. The index is a number from /0/ up to, but not+-- including, the 'size' of the map. Calls 'error' when the key is not+-- a 'member' of the map.+--+-- > findIndex 2 (fromList [(5,"a"), (3,"b")])    Error: element is not in the map+-- > findIndex 3 (fromList [(5,"a"), (3,"b")]) == 0+-- > findIndex 5 (fromList [(5,"a"), (3,"b")]) == 1+-- > findIndex 6 (fromList [(5,"a"), (3,"b")])    Error: element is not in the map++-- See Note: Type of local 'go' function+findIndex :: Ord k => k -> Map k a -> Int+findIndex = go 0+  where+    go :: Ord k => Int -> k -> Map k a -> Int+    go !_   !_ Tip  = error "Map.findIndex: element is not in the map"+    go idx k (Bin _ kx _ l r) = case compare k kx of+      LT -> go idx k l+      GT -> go (idx + size l + 1) k r+      EQ -> idx + size l+#if __GLASGOW_HASKELL__+{-# INLINABLE findIndex #-}+#endif++-- | \(O(\log n)\). Look up the /index/ of a key, which is its zero-based index in+-- the sequence sorted by keys. The index is a number from /0/ up to, but not+-- including, the 'size' of the map.+--+-- > isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")]))   == False+-- > fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) == 0+-- > fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) == 1+-- > isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")]))   == False++-- See Note: Type of local 'go' function+lookupIndex :: Ord k => k -> Map k a -> Maybe Int+lookupIndex = go 0+  where+    go :: Ord k => Int -> k -> Map k a -> Maybe Int+    go !_  !_ Tip  = Nothing+    go idx k (Bin _ kx _ l r) = case compare k kx of+      LT -> go idx k l+      GT -> go (idx + size l + 1) k r+      EQ -> Just $! idx + size l+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupIndex #-}+#endif++-- | \(O(\log n)\). Retrieve an element by its /index/, i.e. by its zero-based+-- index in the sequence sorted by keys. If the /index/ is out of range (less+-- than zero, greater or equal to 'size' of the map), 'error' is called.+--+-- > elemAt 0 (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > elemAt 1 (fromList [(5,"a"), (3,"b")]) == (5, "a")+-- > elemAt 2 (fromList [(5,"a"), (3,"b")])    Error: index out of range++elemAt :: Int -> Map k a -> (k,a)+elemAt !_ Tip = error "Map.elemAt: index out of range"+elemAt i (Bin _ kx x l r)+  = case compare i sizeL of+      LT -> elemAt i l+      GT -> elemAt (i-sizeL-1) r+      EQ -> (kx,x)+  where+    sizeL = size l++-- | \(O(\log n)\). Take a given number of entries in key order, beginning+-- with the smallest keys.+--+-- @+-- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'+-- @+--+-- @since 0.5.8++take :: Int -> Map k a -> Map k a+take i m | i >= size m = m+take i0 m0 = go i0 m0+  where+    go i !_ | i <= 0 = Tip+    go !_ Tip = Tip+    go i (Bin _ kx x l r) =+      case compare i sizeL of+        LT -> go i l+        GT -> link kx x l (go (i - sizeL - 1) r)+        EQ -> l+      where sizeL = size l++-- | \(O(\log n)\). Drop a given number of entries in key order, beginning+-- with the smallest keys.+--+-- @+-- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'+-- @+--+-- @since 0.5.8+drop :: Int -> Map k a -> Map k a+drop i m | i >= size m = Tip+drop i0 m0 = go i0 m0+  where+    go i m | i <= 0 = m+    go !_ Tip = Tip+    go i (Bin _ kx x l r) =+      case compare i sizeL of+        LT -> link kx x (go i l) r+        GT -> go (i - sizeL - 1) r+        EQ -> insertMin kx x r+      where sizeL = size l++-- | \(O(\log n)\). Split a map at a particular index.+--+-- @+-- splitAt !n !xs = ('take' n xs, 'drop' n xs)+-- @+--+-- @since 0.5.8+splitAt :: Int -> Map k a -> (Map k a, Map k a)+splitAt i0 m0+  | i0 >= size m0 = (m0, Tip)+  | otherwise = toPair $ go i0 m0+  where+    go i m | i <= 0 = Tip :*: m+    go !_ Tip = Tip :*: Tip+    go i (Bin _ kx x l r)+      = case compare i sizeL of+          LT -> case go i l of+                  ll :*: lr -> ll :*: link kx x lr r+          GT -> case go (i - sizeL - 1) r of+                  rl :*: rr -> link kx x l rl :*: rr+          EQ -> l :*: insertMin kx x r+      where sizeL = size l++-- | \(O(\log n)\). Update the element at /index/, i.e. by its zero-based index in+-- the sequence sorted by keys. If the /index/ is out of range (less than zero,+-- greater or equal to 'size' of the map), 'error' is called.+--+-- > updateAt (\ _ _ -> Just "x") 0    (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]+-- > updateAt (\ _ _ -> Just "x") 1    (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]+-- > updateAt (\ _ _ -> Just "x") 2    (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\_ _  -> Nothing)  0    (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > updateAt (\_ _  -> Nothing)  1    (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > updateAt (\_ _  -> Nothing)  2    (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\_ _  -> Nothing)  (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range++updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a+updateAt f !i t =+  case t of+    Tip -> error "Map.updateAt: index out of range"+    Bin sx kx x l r -> case compare i sizeL of+      LT -> balanceR kx x (updateAt f i l) r+      GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)+      EQ -> case f kx x of+              Just x' -> Bin sx kx x' l r+              Nothing -> glue l r+      where+        sizeL = size l++-- | \(O(\log n)\). Delete the element at /index/, i.e. by its zero-based index in+-- the sequence sorted by keys. If the /index/ is out of range (less than zero,+-- greater or equal to 'size' of the map), 'error' is called.+--+-- > deleteAt 0  (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > deleteAt 1  (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > deleteAt 2 (fromList [(5,"a"), (3,"b")])     Error: index out of range+-- > deleteAt (-1) (fromList [(5,"a"), (3,"b")])  Error: index out of range++deleteAt :: Int -> Map k a -> Map k a+deleteAt !i t =+  case t of+    Tip -> error "Map.deleteAt: index out of range"+    Bin _ kx x l r -> case compare i sizeL of+      LT -> balanceR kx x (deleteAt i l) r+      GT -> balanceL kx x l (deleteAt (i-sizeL-1) r)+      EQ -> glue l r+      where+        sizeL = size l+++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}++-- The KeyValue type is used when returning a key-value pair and helps GHC keep+-- track of the fact that key is in WHNF.+--+-- As an example, for a use case like+--+-- fmap (\(k,_) -> <strict use of k>) (lookupMin m)+--+-- on a non-empty map, GHC can decide to evaluate the usage of k if it is cheap+-- and put the result in the Just, instead of making a thunk for it.+-- If GHC does not know that k is in WHNF, it could be bottom, and so GHC must+-- always return Just with a thunk inside.++data KeyValue k a = KeyValue !k a++kvToTuple :: KeyValue k a -> (k, a)+kvToTuple (KeyValue k a) = (k, a)+{-# INLINE kvToTuple #-}++lookupMinSure :: k -> a -> Map k a -> KeyValue k a+lookupMinSure !k a Tip = KeyValue k a+lookupMinSure _ _ (Bin _ k a l _) = lookupMinSure k a l++-- | \(O(\log n)\). The minimal key of the map. Returns 'Nothing' if the map is empty.+--+-- > lookupMin (fromList [(5,"a"), (3,"b")]) == Just (3,"b")+-- > lookupMin empty = Nothing+--+-- @since 0.5.9++lookupMin :: Map k a -> Maybe (k,a)+lookupMin Tip = Nothing+lookupMin (Bin _ k x l _) = Just $! kvToTuple (lookupMinSure k x l)+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\log n)\). The minimal key of the map. Calls 'error' if the map is empty.+--+-- > findMin (fromList [(5,"a"), (3,"b")]) == (3,"b")+-- > findMin empty                            Error: empty map has no minimal element++findMin :: Map k a -> (k,a)+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "Map.findMin: empty map has no minimal element"++lookupMaxSure :: k -> a -> Map k a -> KeyValue k a+lookupMaxSure !k a Tip = KeyValue k a+lookupMaxSure _ _ (Bin _ k a _ r) = lookupMaxSure k a r++-- | \(O(\log n)\). The maximal key of the map. Returns 'Nothing' if the map is empty.+--+-- > lookupMax (fromList [(5,"a"), (3,"b")]) == Just (5,"a")+-- > lookupMax empty = Nothing+--+-- @since 0.5.9++lookupMax :: Map k a -> Maybe (k, a)+lookupMax Tip = Nothing+lookupMax (Bin _ k x _ r) = Just $! kvToTuple (lookupMaxSure k x r)+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin] in Data.Set.Internal++-- | \(O(\log n)\). The maximal key of the map. Calls 'error' if the map is empty.+--+-- > findMax (fromList [(5,"a"), (3,"b")]) == (5,"a")+-- > findMax empty                            Error: empty map has no maximal element++findMax :: Map k a -> (k,a)+findMax t+  | Just r <- lookupMax t = r+  | otherwise = error "Map.findMax: empty map has no maximal element"++-- | \(O(\log n)\). Delete the minimal key. Returns an empty map if the map is empty.+--+-- > deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(5,"a"), (7,"c")]+-- > deleteMin empty == empty++deleteMin :: Map k a -> Map k a+deleteMin (Bin _ _  _ Tip r)  = r+deleteMin (Bin _ kx x l r)    = balanceR kx x (deleteMin l) r+deleteMin Tip                 = Tip++-- | \(O(\log n)\). Delete the maximal key. Returns an empty map if the map is empty.+--+-- > deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) == fromList [(3,"b"), (5,"a")]+-- > deleteMax empty == empty++deleteMax :: Map k a -> Map k a+deleteMax (Bin _ _  _ l Tip)  = l+deleteMax (Bin _ kx x l r)    = balanceL kx x l (deleteMax r)+deleteMax Tip                 = Tip++-- | \(O(\log n)\). Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> Map k a -> Map k a+updateMin f m+  = updateMinWithKey (\_ x -> f x) m++-- | \(O(\log n)\). Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> Map k a -> Map k a+updateMax f m+  = updateMaxWithKey (\_ x -> f x) m+++-- | \(O(\log n)\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMinWithKey _ Tip                 = Tip+updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of+                                           Nothing -> r+                                           Just x' -> Bin sx kx x' Tip r+updateMinWithKey f (Bin _ kx x l r)    = balanceR kx x (updateMinWithKey f l) r++-- | \(O(\log n)\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMaxWithKey _ Tip                 = Tip+updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of+                                           Nothing -> l+                                           Just x' -> Bin sx kx x' l Tip+updateMaxWithKey f (Bin _ kx x l r)    = balanceL kx x l (updateMaxWithKey f r)++-- | \(O(\log n)\). Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: Map k a -> Maybe ((k,a), Map k a)+minViewWithKey Tip = Nothing+minViewWithKey (Bin _ k x l r) = Just $+  case minViewSure k x l r of+    MinView km xm t -> ((km, xm), t)+-- We inline this to give GHC the best possible chance of getting+-- rid of the Maybe and pair constructors, as well as the thunk under+-- the Just.+{-# INLINE minViewWithKey #-}++-- | \(O(\log n)\). Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a)+maxViewWithKey Tip = Nothing+maxViewWithKey (Bin _ k x l r) = Just $+  case maxViewSure k x l r of+    MaxView km xm t -> ((km, xm), t)+-- See note on inlining at minViewWithKey+{-# INLINE maxViewWithKey #-}++-- | \(O(\log n)\). Retrieves the value associated with minimal key of the+-- map, and the map stripped of that element, or 'Nothing' if passed an+-- empty map.+--+-- > minView (fromList [(5,"a"), (3,"b")]) == Just ("b", singleton 5 "a")+-- > minView empty == Nothing++minView :: Map k a -> Maybe (a, Map k a)+minView t = case minViewWithKey t of+              Nothing -> Nothing+              Just ~((_, x), t') -> Just (x, t')++-- | \(O(\log n)\). Retrieves the value associated with maximal key of the+-- map, and the map stripped of that element, or 'Nothing' if passed an+-- empty map.+--+-- > maxView (fromList [(5,"a"), (3,"b")]) == Just ("a", singleton 3 "b")+-- > maxView empty == Nothing++maxView :: Map k a -> Maybe (a, Map k a)+maxView t = case maxViewWithKey t of+              Nothing -> Nothing+              Just ~((_, x), t') -> Just (x, t')++{--------------------------------------------------------------------+  Union.+--------------------------------------------------------------------}+-- | The union of a list of maps:+--   (@'unions' == 'Prelude.foldl' 'union' 'empty'@).+--+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "b"), (5, "a"), (7, "C")]+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]+-- >     == fromList [(3, "B3"), (5, "A3"), (7, "C")]++unions :: (Foldable f, Ord k) => f (Map k a) -> Map k a+unions ts+  = Foldable.foldl' union empty ts+#if __GLASGOW_HASKELL__+{-# INLINABLE unions #-}+#endif++-- | The union of a list of maps, with a combining operation:+--   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts+#if __GLASGOW_HASKELL__+{-# INLINABLE unionsWith #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- The expression (@'union' t1 t2@) takes the left-biased union of @t1@ and @t2@.+-- It prefers @t1@ when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: Ord k => Map k a -> Map k a -> Map k a+union t1 Tip  = t1+union t1 (Bin _ k x Tip Tip) = insertR k x t1+union (Bin _ k x Tip Tip) t2 = insert k x t2+union Tip t2 = t2+union t1@(Bin _ k1 x1 l1 r1) t2 = case split k1 t2 of+  (l2, r2) | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1+           | otherwise -> link k1 x1 l1l2 r1r2+           where !l1l2 = union l1 l2+                 !r1r2 = union r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE union #-}+#endif++{--------------------------------------------------------------------+  Union with a combining function+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+-- QuickCheck says pointer equality never happens here.+unionWith _f t1 Tip = t1+unionWith f t1 (Bin _ k x Tip Tip) = insertWithR f k x t1+unionWith f (Bin _ k x Tip Tip) t2 = insertWith f k x t2+unionWith _f Tip t2 = t2+unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+  (l2, mb, r2) -> case mb of+      Nothing -> link k1 x1 l1l2 r1r2+      Just x2 -> link k1 (f x1 x2) l1l2 r1r2+    where !l1l2 = unionWith f l1 l2+          !r1r2 = unionWith f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE unionWith #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- Union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWithKey _f t1 Tip = t1+unionWithKey f t1 (Bin _ k x Tip Tip) = insertWithKeyR f k x t1+unionWithKey f (Bin _ k x Tip Tip) t2 = insertWithKey f k x t2+unionWithKey _f Tip t2 = t2+unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+  (l2, mb, r2) -> case mb of+      Nothing -> link k1 x1 l1l2 r1r2+      Just x2 -> link k1 (f k1 x1 x2) l1l2 r1r2+    where !l1l2 = unionWithKey f l1 l2+          !r1r2 = unionWithKey f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE unionWithKey #-}+#endif++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}++-- We don't currently attempt to use any pointer equality tricks for+-- 'difference'. To do so, we'd have to match on the first argument+-- and split the second. Unfortunately, the proof of the time bound+-- relies on doing it the way we do, and it's not clear whether that+-- bound holds the other way.++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Difference of two maps.+-- Return elements of the first map not existing in the second map.+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: Ord k => Map k a -> Map k b -> Map k a+difference Tip _   = Tip+difference t1 Tip  = t1+difference t1 (Bin _ k _ l2 r2) = case split k t1 of+  (l1, r1)+    | size l1l2 + size r1r2 == size t1 -> t1+    | otherwise -> link2 l1l2 r1r2+    where+      !l1l2 = difference l1 l2+      !r1r2 = difference r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE difference #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Remove all keys in a 'Set' from a 'Map'.+--+-- @+-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``Set.notMember`` s) m+-- m \`withoutKeys\` s = m ``difference`` 'fromSet' (const ()) s+-- @+--+-- @since 0.5.8++withoutKeys :: Ord k => Map k a -> Set k -> Map k a+withoutKeys Tip _ = Tip+withoutKeys m Set.Tip = m+withoutKeys m (Set.Bin _ k ls rs) = case splitMember k m of+  (lm, b, rm)+     | not b && lm' `ptrEq` lm && rm' `ptrEq` rm -> m+     | otherwise -> link2 lm' rm'+     where+       !lm' = withoutKeys lm ls+       !rm' = withoutKeys rm rs+#if __GLASGOW_HASKELL__+{-# INLINABLE withoutKeys #-}+#endif++-- | \(O(n+m)\). Difference with a combining function.+-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"+differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWith f = merge preserveMissing dropMissing $+       zipWithMaybeMatched (\_ x y -> f x y)+#if __GLASGOW_HASKELL__+{-# INLINABLE differenceWith #-}+#endif++-- | \(O(n+m)\). Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWithKey f =+  merge preserveMissing dropMissing (zipWithMaybeMatched f)+#if __GLASGOW_HASKELL__+{-# INLINABLE differenceWithKey #-}+#endif+++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection of two maps.+-- Return data in the first map for the keys existing in both maps.+-- (@'intersection' m1 m2 == 'intersectionWith' 'const' m1 m2@).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: Ord k => Map k a -> Map k b -> Map k a+intersection Tip _ = Tip+intersection _ Tip = Tip+intersection t1@(Bin _ k x l1 r1) t2+  | mb = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1+         then t1+         else link k x l1l2 r1r2+  | otherwise = link2 l1l2 r1r2+  where+    !(l2, mb, r2) = splitMember k t2+    !l1l2 = intersection l1 l2+    !r1r2 = intersection r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersection #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Restrict a 'Map' to only those keys+-- found in a 'Set'.+--+-- @+-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``Set.member`` s) m+-- m \`restrictKeys\` s = m ``intersection`` 'fromSet' (const ()) s+-- @+--+-- @since 0.5.8+restrictKeys :: Ord k => Map k a -> Set k -> Map k a+restrictKeys Tip _ = Tip+restrictKeys _ Set.Tip = Tip+restrictKeys m@(Bin _ k x l1 r1) s+  | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1+        then m+        else link k x l1l2 r1r2+  | otherwise = link2 l1l2 r1r2+  where+    !(l2, b, r2) = Set.splitMember k s+    !l1l2 = restrictKeys l1 l2+    !r1r2 = restrictKeys r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE restrictKeys #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c+-- We have no hope of pointer equality tricks here because every single+-- element in the result will be a thunk.+intersectionWith _f Tip _ = Tip+intersectionWith _f _ Tip = Tip+intersectionWith f (Bin _ k x1 l1 r1) t2 = case mb of+    Just x2 -> link k (f x1 x2) l1l2 r1r2+    Nothing -> link2 l1l2 r1r2+  where+    !(l2, mb, r2) = splitLookup k t2+    !l1l2 = intersectionWith f l1 l2+    !r1r2 = intersectionWith f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersectionWith #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWithKey _f Tip _ = Tip+intersectionWithKey _f _ Tip = Tip+intersectionWithKey f (Bin _ k x1 l1 r1) t2 = case mb of+    Just x2 -> link k (f k x1 x2) l1l2 r1r2+    Nothing -> link2 l1l2 r1r2+  where+    !(l2, mb, r2) = splitLookup k t2+    !l1l2 = intersectionWithKey f l1 l2+    !r1r2 = intersectionWithKey f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersectionWithKey #-}+#endif++{--------------------------------------------------------------------+  Symmetric difference+--------------------------------------------------------------------}++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- The symmetric difference of two maps.+--+-- The result contains entries whose keys appear in exactly one of the two maps.+--+-- @+-- symmetricDifference+--   (fromList [(0,\'q\'),(2,\'b\'),(4,\'w\'),(6,\'o\')])+--   (fromList [(0,\'e\'),(3,\'r\'),(6,\'t\'),(9,\'s\')])+-- ==+-- fromList [(2,\'b\'),(3,\'r\'),(4,\'w\'),(9,\'s\')]+-- @+--+-- @since 0.8+symmetricDifference :: Ord k => Map k a -> Map k a -> Map k a+symmetricDifference Tip t2 = t2+symmetricDifference t1 Tip = t1+symmetricDifference (Bin _ k x l1 r1) t2+  | found = link2 l1l2 r1r2+  | otherwise = link k x l1l2 r1r2+  where+    !(l2, found, r2) = splitMember k t2+    !l1l2 = symmetricDifference l1 l2+    !r1r2 = symmetricDifference r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE symmetricDifference #-}+#endif++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Check whether the key sets of two+-- maps are disjoint (i.e., their 'intersection' is empty).+--+-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())])   == True+-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False+-- > disjoint (fromList [])        (fromList [])                 == True+--+-- @+-- xs ``disjoint`` ys = null (xs ``intersection`` ys)+-- @+--+-- @since 0.6.2.1++-- See 'Data.Set.Internal.isSubsetOfX' for some background+-- on the implementation design.+disjoint :: Ord k => Map k a -> Map k b -> Bool+disjoint Tip _ = True+disjoint _ Tip = True+disjoint (Bin 1 k _ _ _) t = k `notMember` t+disjoint (Bin _ k _ l r) t+  = not found && disjoint l lt && disjoint r gt+  where+    (lt,found,gt) = splitMember k t++{--------------------------------------------------------------------+  Compose+--------------------------------------------------------------------}+-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O (n \log m) \), where \(m\) is the size of the first argument+--+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- __Note:__ Prior to v0.6.4, "Data.Map.Strict" exposed a version of+-- 'compose' that forced the values of the output 'Map'. This version does not+-- force these values.+--+-- ==== __Note on complexity__+--+-- This function is asymptotically optimal. Given @n :: Map a b, m :: Map b c@,+-- the composition essentially maps each @a@ in @n@ to @Maybe c@, since the+-- composed lookup yields either one of the @c@ in @m@ or @Nothing@. The number+-- of possible such mappings is \((|m| + 1) ^ {|n|}\).+-- We now follow a similar reasoning to the one for+-- [sorting](https://en.wikipedia.org/wiki/Comparison_sort#Number_of_comparisons_required_to_sort_a_list).+-- To distinguish between \(x\) possible values, we need+-- \( \lceil \log_2 x \rceil \) bits. Thus, we have a lower bound of+-- \(\log_2 \left((|m| + 1) ^{|n|} \right) = |n| \cdot \log_2 (|m| + 1)\) bits.+-- @Map@ lookups are comparison-based, and each comparison gives us at most+-- one bit of information: in the worst case we'll always be left with at least+-- half of the remaining possible values, meaning we need at least as many+-- comparisons as we need bits.+--+-- @since 0.6.3.1+compose :: Ord b => Map b c -> Map a b -> Map a c+compose bc !ab+  | null bc = empty+  | otherwise = mapMaybe (bc !?) ab++-- | A tactic for dealing with keys present in one map but not the other in+-- 'merge' or 'mergeA'.+--+-- A tactic of type @ WhenMissing f k x z @ is an abstract representation+-- of a function of type @ k -> x -> f (Maybe z) @.+--+-- @since 0.5.9++data WhenMissing f k x y = WhenMissing+  { missingSubtree :: Map k x -> f (Map k y)+  , missingKey :: k -> x -> f (Maybe y)}++-- | @since 0.5.9+instance (Applicative f, Monad f) => Functor (WhenMissing f k x) where+  fmap = mapWhenMissing+  {-# INLINE fmap #-}++-- | @since 0.5.9+instance (Applicative f, Monad f)+         => Category.Category (WhenMissing f k) where+  id = preserveMissing+  f . g = traverseMaybeMissing $+    \ k x -> missingKey g k x >>= \y ->+         case y of+           Nothing -> pure Nothing+           Just q -> missingKey f k q+  {-# INLINE id #-}+  {-# INLINE (.) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Applicative (WhenMissing f k x) where+  pure x = mapMissing (\ _ _ -> x)+  f <*> g = traverseMaybeMissing $ \k x -> do+         res1 <- missingKey f k x+         case res1 of+           Nothing -> pure Nothing+           Just r -> (pure $!) . fmap r =<< missingKey g k x+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (MaybeT f)) @.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Monad (WhenMissing f k x) where+  m >>= f = traverseMaybeMissing $ \k x -> do+         res1 <- missingKey m k x+         case res1 of+           Nothing -> pure Nothing+           Just r -> missingKey (f r) k x+  {-# INLINE (>>=) #-}++-- | Map covariantly over a @'WhenMissing' f k x@.+--+-- @since 0.5.9+mapWhenMissing :: (Applicative f, Monad f)+               => (a -> b)+               -> WhenMissing f k x a -> WhenMissing f k x b+mapWhenMissing f t = WhenMissing+    { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'+    , missingKey = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }+{-# INLINE mapWhenMissing #-}++-- | Map covariantly over a @'WhenMissing' f k x@, using only a 'Functor f'+-- constraint.+mapGentlyWhenMissing :: Functor f+               => (a -> b)+               -> WhenMissing f k x a -> WhenMissing f k x b+mapGentlyWhenMissing f t = WhenMissing+    { missingSubtree = \m -> fmap f <$> missingSubtree t m+    , missingKey = \k x -> fmap f <$> missingKey t k x }+{-# INLINE mapGentlyWhenMissing #-}++-- | Map covariantly over a @'WhenMatched' f k x@, using only a 'Functor f'+-- constraint.+mapGentlyWhenMatched :: Functor f+               => (a -> b)+               -> WhenMatched f k x y a -> WhenMatched f k x y b+mapGentlyWhenMatched f t = zipWithMaybeAMatched $+  \k x y -> fmap f <$> runWhenMatched t k x y+{-# INLINE mapGentlyWhenMatched #-}++-- | Map contravariantly over a @'WhenMissing' f k _ x@.+--+-- @since 0.5.9+lmapWhenMissing :: (b -> a) -> WhenMissing f k a x -> WhenMissing f k b x+lmapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t (fmap f m)+  , missingKey = \k x -> missingKey t k (f x) }+{-# INLINE lmapWhenMissing #-}++-- | Map contravariantly over a @'WhenMatched' f k _ y z@.+--+-- @since 0.5.9+contramapFirstWhenMatched :: (b -> a)+                          -> WhenMatched f k a y z+                          -> WhenMatched f k b y z+contramapFirstWhenMatched f t = WhenMatched $+  \k x y -> runWhenMatched t k (f x) y+{-# INLINE contramapFirstWhenMatched #-}++-- | Map contravariantly over a @'WhenMatched' f k x _ z@.+--+-- @since 0.5.9+contramapSecondWhenMatched :: (b -> a)+                           -> WhenMatched f k x a z+                           -> WhenMatched f k x b z+contramapSecondWhenMatched f t = WhenMatched $+  \k x y -> runWhenMatched t k x (f y)+{-# INLINE contramapSecondWhenMatched #-}++-- | A tactic for dealing with keys present in one map but not the other in+-- 'merge'.+--+-- A tactic of type @ SimpleWhenMissing k x z @ is an abstract representation+-- of a function of type @ k -> x -> Maybe z @.+--+-- @since 0.5.9+type SimpleWhenMissing = WhenMissing Identity++-- | A tactic for dealing with keys present in both+-- maps in 'merge' or 'mergeA'.+--+-- A tactic of type @ WhenMatched f k x y z @ is an abstract representation+-- of a function of type @ k -> x -> y -> f (Maybe z) @.+--+-- @since 0.5.9+newtype WhenMatched f k x y z = WhenMatched+  { matchedKey :: k -> x -> y -> f (Maybe z) }++-- | Along with zipWithMaybeAMatched, witnesses the isomorphism between+-- @WhenMatched f k x y z@ and @k -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+runWhenMatched :: WhenMatched f k x y z -> k -> x -> y -> f (Maybe z)+runWhenMatched = matchedKey+{-# INLINE runWhenMatched #-}++-- | Along with traverseMaybeMissing, witnesses the isomorphism between+-- @WhenMissing f k x y@ and @k -> x -> f (Maybe y)@.+--+-- @since 0.5.9+runWhenMissing :: WhenMissing f k x y -> k -> x -> f (Maybe y)+runWhenMissing = missingKey+{-# INLINE runWhenMissing #-}++-- | @since 0.5.9+instance Functor f => Functor (WhenMatched f k x y) where+  fmap = mapWhenMatched+  {-# INLINE fmap #-}++-- | @since 0.5.9+instance (Monad f, Applicative f) => Category.Category (WhenMatched f k x) where+  id = zipWithMatched (\_ _ y -> y)+  f . g = zipWithMaybeAMatched $+            \k x y -> do+              res <- runWhenMatched g k x y+              case res of+                Nothing -> pure Nothing+                Just r -> runWhenMatched f k x r+  {-# INLINE id #-}+  {-# INLINE (.) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Applicative (WhenMatched f k x y) where+  pure x = zipWithMatched (\_ _ _ -> x)+  fs <*> xs = zipWithMaybeAMatched $ \k x y -> do+    res <- runWhenMatched fs k x y+    case res of+      Nothing -> pure Nothing+      Just r -> (pure $!) . fmap r =<< runWhenMatched xs k x y+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}++-- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Monad (WhenMatched f k x y) where+  m >>= f = zipWithMaybeAMatched $ \k x y -> do+    res <- runWhenMatched m k x y+    case res of+      Nothing -> pure Nothing+      Just r -> runWhenMatched (f r) k x y+  {-# INLINE (>>=) #-}++-- | Map covariantly over a @'WhenMatched' f k x y@.+--+-- @since 0.5.9+mapWhenMatched :: Functor f+               => (a -> b)+               -> WhenMatched f k x y a+               -> WhenMatched f k x y b+mapWhenMatched f (WhenMatched g) = WhenMatched $ \k x y -> fmap (fmap f) (g k x y)+{-# INLINE mapWhenMatched #-}++-- | A tactic for dealing with keys present in both maps in 'merge'.+--+-- A tactic of type @ SimpleWhenMatched k x y z @ is an abstract representation+-- of a function of type @ k -> x -> y -> Maybe z @.+--+-- @since 0.5.9+type SimpleWhenMatched = WhenMatched Identity++-- | When a key is found in both maps, apply a function to the+-- key and values and use the result in the merged map.+--+-- @+-- zipWithMatched :: (k -> x -> y -> z)+--                -> SimpleWhenMatched k x y z+-- @+--+-- @since 0.5.9+zipWithMatched :: Applicative f+               => (k -> x -> y -> z)+               -> WhenMatched f k x y z+zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y+{-# INLINE zipWithMatched #-}++-- | When a key is found in both maps, apply a function to the+-- key and values to produce an action and use its result in the merged map.+--+-- @since 0.5.9+zipWithAMatched :: Applicative f+                => (k -> x -> y -> f z)+                -> WhenMatched f k x y z+zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y+{-# INLINE zipWithAMatched #-}++-- | When a key is found in both maps, apply a function to the+-- key and values and maybe use the result in the merged map.+--+-- @+-- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)+--                     -> SimpleWhenMatched k x y z+-- @+--+-- @since 0.5.9+zipWithMaybeMatched :: Applicative f+                    => (k -> x -> y -> Maybe z)+                    -> WhenMatched f k x y z+zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y+{-# INLINE zipWithMaybeMatched #-}++-- | When a key is found in both maps, apply a function to the+-- key and values, perform the resulting action, and maybe use+-- the result in the merged map.+--+-- This is the fundamental 'WhenMatched' tactic.+--+-- @since 0.5.9+zipWithMaybeAMatched :: (k -> x -> y -> f (Maybe z))+                     -> WhenMatched f k x y z+zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y+{-# INLINE zipWithMaybeAMatched #-}++-- | Drop all the entries whose keys are missing from the other+-- map.+--+-- @+-- dropMissing :: SimpleWhenMissing k x y+-- @+--+-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)+--+-- but @dropMissing@ is much faster.+--+-- @since 0.5.9+dropMissing :: Applicative f => WhenMissing f k x y+dropMissing = WhenMissing+  { missingSubtree = const (pure Tip)+  , missingKey = \_ _ -> pure Nothing }+{-# INLINE dropMissing #-}++-- | Preserve, unchanged, the entries whose keys are missing from+-- the other map.+--+-- @+-- preserveMissing :: SimpleWhenMissing k x x+-- @+--+-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)+--+-- but @preserveMissing@ is much faster.+--+-- @since 0.5.9+preserveMissing :: Applicative f => WhenMissing f k x x+preserveMissing = WhenMissing+  { missingSubtree = pure+  , missingKey = \_ v -> pure (Just v) }+{-# INLINE preserveMissing #-}++-- | Force the entries whose keys are missing from+-- the other map and otherwise preserve them unchanged.+--+-- @+-- preserveMissing' :: SimpleWhenMissing k x x+-- @+--+-- prop> preserveMissing' = Merge.Lazy.mapMaybeMissing (\_ x -> Just $! x)+--+-- but @preserveMissing'@ is quite a bit faster.+--+-- @since 0.5.9+preserveMissing' :: Applicative f => WhenMissing f k x x+preserveMissing' = WhenMissing+  { missingSubtree = \t -> pure $! forceTree t `seq` t+  , missingKey = \_ v -> pure $! Just $! v }+{-# INLINE preserveMissing' #-}++-- Force all the values in a tree.+forceTree :: Map k a -> ()+forceTree (Bin _ _ v l r) = v `seq` forceTree l `seq` forceTree r `seq` ()+forceTree Tip = ()++-- | Map over the entries whose keys are missing from the other map.+--+-- @+-- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y+-- @+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+--+-- @since 0.5.9+mapMissing :: Applicative f => (k -> x -> y) -> WhenMissing f k x y+mapMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapWithKey f m+  , missingKey = \ k x -> pure $ Just (f k x) }+{-# INLINE mapMissing #-}++-- | Map over the entries whose keys are missing from the other map,+-- optionally removing some. This is the most powerful 'SimpleWhenMissing'+-- tactic, but others are usually more efficient.+--+-- @+-- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y+-- @+--+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))+--+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.+--+-- @since 0.5.9+mapMaybeMissing :: Applicative f => (k -> x -> Maybe y) -> WhenMissing f k x y+mapMaybeMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapMaybeWithKey f m+  , missingKey = \k x -> pure $! f k x }+{-# INLINE mapMaybeMissing #-}++-- | Filter the entries whose keys are missing from the other map.+--+-- @+-- filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing k x x+-- @+--+-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterMissing :: Applicative f+              => (k -> x -> Bool) -> WhenMissing f k x x+filterMissing f = WhenMissing+  { missingSubtree = \m -> pure $! filterWithKey f m+  , missingKey = \k x -> pure $! if f k x then Just x else Nothing }+{-# INLINE filterMissing #-}++-- | Filter the entries whose keys are missing from the other map+-- using some 'Applicative' action.+--+-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $+-- >   \k x -> (\b -> guard b *> Just x) <$> f k x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterAMissing :: Applicative f+              => (k -> x -> f Bool) -> WhenMissing f k x x+filterAMissing f = WhenMissing+  { missingSubtree = \m -> filterWithKeyA f m+  , missingKey = \k x -> bool Nothing (Just x) <$> f k x }+{-# INLINE filterAMissing #-}++-- | This wasn't in Data.Bool until 4.7.0, so we define it here+bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True  = t++-- | Traverse over the entries whose keys are missing from the other map.+--+-- @since 0.5.9+traverseMissing :: Applicative f+                    => (k -> x -> f y) -> WhenMissing f k x y+traverseMissing f = WhenMissing+  { missingSubtree = traverseWithKey f+  , missingKey = \k x -> Just <$> f k x }+{-# INLINE traverseMissing #-}++-- | Traverse over the entries whose keys are missing from the other map,+-- optionally producing values to put in the result.+-- This is the most powerful 'WhenMissing' tactic, but others are usually+-- more efficient.+--+-- @since 0.5.9+traverseMaybeMissing :: Applicative f+                      => (k -> x -> f (Maybe y)) -> WhenMissing f k x y+traverseMaybeMissing f = WhenMissing+  { missingSubtree = traverseMaybeWithKey f+  , missingKey = f }+{-# INLINE traverseMaybeMissing #-}++-- | Merge two maps.+--+-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched'+-- tactic and two maps. It uses the tactics to merge the maps.+-- Its behavior is best understood via its fundamental tactics,+-- 'mapMaybeMissing' and 'zipWithMaybeMatched'.+--+-- Consider+--+-- @+-- merge (mapMaybeMissing g1)+--              (mapMaybeMissing g2)+--              (zipWithMaybeMatched f)+--              m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'merge' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]+-- m2 =           [(1, "one"), (2, "two"),           (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- This produces a 'Maybe' for each key:+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'mapMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+--+-- When 'merge' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should typically use 'merge'+-- to define your custom combining functions.+--+--+-- Examples:+--+-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)+-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)+-- prop> differenceWith f = merge preserveMissing dropMissing (zipWithMatched f)+-- prop> symmetricDifference = merge preserveMissing preserveMissing (zipWithMaybeMatched $ \ _ _ _ -> Nothing)+-- prop> mapEachPiece f g h = merge (mapMissing f) (mapMissing g) (zipWithMatched h)+--+-- @since 0.5.9+merge :: Ord k+             => SimpleWhenMissing k a c -- ^ What to do with keys in @m1@ but not @m2@+             -> SimpleWhenMissing k b c -- ^ What to do with keys in @m2@ but not @m1@+             -> SimpleWhenMatched k a b c -- ^ What to do with keys in both @m1@ and @m2@+             -> Map k a -- ^ Map @m1@+             -> Map k b -- ^ Map @m2@+             -> Map k c+merge g1 g2 f m1 m2 = runIdentity $+  mergeA g1 g2 f m1 m2+{-# INLINE merge #-}++-- | An applicative version of 'merge'.+--+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'+-- tactic and two maps. It uses the tactics to merge the maps.+-- Its behavior is best understood via its fundamental tactics,+-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+--               (traverseMaybeMissing g2)+--               (zipWithMaybeAMatched f)+--               m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- @mergeA@ will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]+-- m2 =           [(1, "one"), (2, "two"),           (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- Next, it will perform the actions in the @actions@ list in order from+-- left to right.+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'traverseMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+-- * 'mapMaybeMissing' does not use the 'Applicative' context.+--+-- When 'mergeA' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should generally only use+-- 'mergeA' to define custom combining functions.+--+-- @since 0.5.9+mergeA+  :: (Applicative f, Ord k)+  => WhenMissing f k a c -- ^ What to do with keys in @m1@ but not @m2@+  -> WhenMissing f k b c -- ^ What to do with keys in @m2@ but not @m1@+  -> WhenMatched f k a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> Map k a -- ^ Map @m1@+  -> Map k b -- ^ Map @m2@+  -> f (Map k c)+mergeA+    WhenMissing{missingSubtree = g1t, missingKey = g1k}+    WhenMissing{missingSubtree = g2t}+    (WhenMatched f) = go+  where+    go t1 Tip = g1t t1+    go Tip t2 = g2t t2+    go (Bin _ kx x1 l1 r1) t2 = case splitLookup kx t2 of+      (l2, mx2, r2) -> case mx2 of+          Nothing -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')+                        l1l2 (g1k kx x1) r1r2+          Just x2 -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')+                        l1l2 (f kx x1 x2) r1r2+        where+          !l1l2 = go l1 l2+          !r1r2 = go r1 r2+{-# INLINE mergeA #-}+++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | \(O(n+m)\). An unsafe general combining function.+--+-- __Warning__: This function can produce corrupt maps and its results+-- may depend on the internal structures of its inputs. Users should+-- prefer 'merge' or 'mergeA'.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'Map's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@,+-- @'filterWithKey' f@, or @'mapMaybeWithKey' f@ could be used for any @f@.++mergeWithKey :: Ord k+             => (k -> a -> b -> Maybe c)+             -> (Map k a -> Map k c)+             -> (Map k b -> Map k c)+             -> Map k a -> Map k b -> Map k c+mergeWithKey f g1 g2 = go+  where+    go Tip Tip = Tip+    go Tip t2 = g2 t2+    go t1 Tip = g1 t1+    go (Bin _ kx x l1 r1) t2 =+      case found of+        Nothing -> case g1 (singleton kx x) of+                     Tip -> link2 l' r'+                     (Bin _ _ x' Tip Tip) -> link kx x' l' r'+                     _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"+        Just x2 -> case f kx x x2 of+                     Nothing -> link2 l' r'+                     Just x' -> link kx x' l' r'+      where+        (l2, found, r2) = splitLookup kx t2+        l' = go l1 l2+        r' = go r1 r2+{-# INLINE mergeWithKey #-}++{--------------------------------------------------------------------+  Submap+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+--+isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isSubmapOf m1 m2 = isSubmapOfBy (==) m1 m2+#if __GLASGOW_HASKELL__+{-# INLINABLE isSubmapOf #-}+#endif++{- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+ The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if+ all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++ > isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)])++ But the following are all 'False':++ > isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (<)  (fromList [('a',1)]) (fromList [('a',1),('b',2)])+ > isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)])++ Note that @isSubmapOfBy (\_ _ -> True) m1 m2@ tests whether all the keys+ in @m1@ are also keys in @m2@.++-}+isSubmapOfBy :: Ord k => (a->b->Bool) -> Map k a -> Map k b -> Bool+isSubmapOfBy f t1 t2+  = size t1 <= size t2 && submap' f t1 t2+#if __GLASGOW_HASKELL__+{-# INLINABLE isSubmapOfBy #-}+#endif++-- Test whether a map is a submap of another without the *initial*+-- size test. See Data.Set.Internal.isSubsetOfX for notes on+-- implementation and analysis.+submap' :: Ord a => (b -> c -> Bool) -> Map a b -> Map a c -> Bool+submap' _ Tip _ = True+submap' _ _ Tip = False+submap' f (Bin 1 kx x _ _) t+  = case lookup kx t of+      Just y -> f x y+      Nothing -> False+submap' f (Bin _ kx x l r) t+  = case found of+      Nothing -> False+      Just y  -> f x y+                 && size l <= size lt && size r <= size gt+                 && submap' f l lt && submap' f r gt+  where+    (lt,found,gt) = splitLookup kx t+#if __GLASGOW_HASKELL__+{-# INLINABLE submap' #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool+isProperSubmapOf m1 m2+  = isProperSubmapOfBy (==) m1 m2+#if __GLASGOW_HASKELL__+{-# INLINABLE isProperSubmapOf #-}+#endif++{- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @keys m1@ and @keys m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])+++-}+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> Map k a -> Map k b -> Bool+isProperSubmapOfBy f t1 t2+  = size t1 < size t2 && submap' f t1 t2+#if __GLASGOW_HASKELL__+{-# INLINABLE isProperSubmapOfBy #-}+#endif++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all values that satisfy the predicate.+--+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty++filter :: (a -> Bool) -> Map k a -> Map k a+filter p m+  = filterWithKey (\_ x -> p x) m++-- | \(O(n)\). Filter all keys that satisfy the predicate.+--+-- @+-- filterKeys p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- > filterKeys (> 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+--+-- @since 0.8++filterKeys :: (k -> Bool) -> Map k a -> Map k a+filterKeys p m = filterWithKey (\k _ -> p k) m++-- | \(O(n)\). Filter all keys\/values that satisfy the predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a+filterWithKey _ Tip = Tip+filterWithKey p t@(Bin _ kx x l r)+  | p kx x    = if pl `ptrEq` l && pr `ptrEq` r+                then t+                else link kx x pl pr+  | otherwise = link2 pl pr+  where !pl = filterWithKey p l+        !pr = filterWithKey p r++-- | \(O(n)\). Filter keys and values using an 'Applicative'+-- predicate.+filterWithKeyA :: Applicative f => (k -> a -> f Bool) -> Map k a -> f (Map k a)+filterWithKeyA _ Tip = pure Tip+filterWithKeyA p t@(Bin _ kx x l r) =+  liftA3 combine (filterWithKeyA p l) (p kx x) (filterWithKeyA p r)+  where+    combine pl True pr+      | pl `ptrEq` l && pr `ptrEq` r = t+      | otherwise = link kx x pl pr+    combine pl False pr = link2 pl pr++-- | \(O(\log n)\). Take while a predicate on the keys holds.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'+-- takeWhileAntitone p = 'filterWithKey' (\k _ -> p k)+-- @+--+-- @since 0.5.8++takeWhileAntitone :: (k -> Bool) -> Map k a -> Map k a+takeWhileAntitone _ Tip = Tip+takeWhileAntitone p (Bin _ kx x l r)+  | p kx = link kx x l (takeWhileAntitone p r)+  | otherwise = takeWhileAntitone p l++-- | \(O(\log n)\). Drop while a predicate on the keys holds.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'+-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k))+-- @+--+-- @since 0.5.8++dropWhileAntitone :: (k -> Bool) -> Map k a -> Map k a+dropWhileAntitone _ Tip = Tip+dropWhileAntitone p (Bin _ kx x l r)+  | p kx = dropWhileAntitone p r+  | otherwise = link kx x (dropWhileAntitone p l) r++-- | \(O(\log n)\). Divide a map at the point where a predicate on the keys stops holding.+-- The user is responsible for ensuring that for all keys @j@ and @k@ in the map,+-- @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = partitionWithKey (\\k _ -> p k) xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map+-- at some /unspecified/ point where the predicate switches from holding to not+-- holding (where the predicate is seen to hold before the first key and to fail+-- after the last key).+--+-- @since 0.5.8++spanAntitone :: (k -> Bool) -> Map k a -> (Map k a, Map k a)+spanAntitone p0 m = toPair (go p0 m)+  where+    go _ Tip = Tip :*: Tip+    go p (Bin _ kx x l r)+      | p kx = let u :*: v = go p r in link kx x l u :*: v+      | otherwise = let u :*: v = go p l in u :*: link kx x v r++-- | \(O(n)\). Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partition :: (a -> Bool) -> Map k a -> (Map k a,Map k a)+partition p m+  = partitionWithKey (\_ x -> p x) m++-- | \(O(n)\). Partition the map according to a predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a,Map k a)+partitionWithKey p0 t0 = toPair $ go p0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go p t@(Bin _ kx x l r)+      | p kx x    = (if l1 `ptrEq` l && r1 `ptrEq` r+                     then t+                     else link kx x l1 r1) :*: link2 l2 r2+      | otherwise = link2 l1 r1 :*:+                    (if l2 `ptrEq` l && r2 `ptrEq` r+                     then t+                     else link kx x l2 r2)+      where+        (l1 :*: l2) = go p l+        (r1 :*: r2) = go p r++-- | \(O(n)\). Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | \(O(n)\). Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b+mapMaybeWithKey _ Tip = Tip+mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of+  Just y  -> link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)+  Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r)++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.5.8+traverseMaybeWithKey :: Applicative f+                     => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)+traverseMaybeWithKey = go+  where+    go _ Tip = pure Tip+    go f (Bin _ kx x Tip Tip) = maybe Tip (\x' -> Bin 1 kx x' Tip Tip) <$> f kx x+    go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r)+      where+        combine !l' mx !r' = case mx of+          Nothing -> link2 l' r'+          Just x' -> link kx x' l' r'++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go f (Bin _ kx x l r) = case f kx x of+      Left y  -> link kx y l1 r1 :*: link2 l2 r2+      Right z -> link2 l1 r1 :*: link kx z l2 r2+     where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | \(O(n)\). Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Map k a -> Map k b+map f = go where+  go Tip = Tip+  go (Bin sx kx x l r) = Bin sx kx (f x) (go l) (go r)+-- We use a `go` function to allow `map` to inline. This makes+-- a big difference if someone uses `map (const x) m` instead+-- of `x <$ m`; it doesn't seem to do any harm.++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+"map/coerce" map coerce = coerce+ #-}+#endif++-- | \(O(n)\). Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (k -> a -> b) -> Map k a -> Map k b+mapWithKey _ Tip = Tip+mapWithKey f (Bin sx kx x l r) = Bin sx kx (f kx x) (mapWithKey f l) (mapWithKey f r)++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}+#endif++-- | \(O(n)\).+-- @'traverseWithKey' f m == 'fromList' \<$\> 'traverse' (\\(k, v) -> (,) k \<$\> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)+traverseWithKey f = go+  where+    go Tip = pure Tip+    go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v+    go (Bin s k v l r) = liftA3 (flip (Bin s k)) (go l) (f k v) (go r)+{-# INLINE traverseWithKey #-}++-- | \(O(n)\). The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccum f a m+  = mapAccumWithKey (\a' _ x' -> f a' x') a m++-- | \(O(n)\). The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | \(O(n)\). The function 'mapAccumL' threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumL _ a Tip               = (a,Tip)+mapAccumL f a (Bin sx kx x l r) =+  let (a1,l') = mapAccumL f a l+      (a2,x') = f a1 kx x+      (a3,r') = mapAccumL f a2 r+  in (a3,Bin sx kx x' l' r')++-- | \(O(n)\). The function 'mapAccumRWithKey' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumRWithKey _ a Tip = (a,Tip)+mapAccumRWithKey f a (Bin sx kx x l r) =+  let (a1,r') = mapAccumRWithKey f a r+      (a2,x') = f a1 kx x+      (a3,l') = mapAccumRWithKey f a2 l+  in (a3,Bin sx kx x' l' r')++-- | \(O(n \log n)\).+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- If `f` is monotonically non-decreasing, this function takes \(O(n)\) time.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the value at the greatest of the+-- original keys is retained.+--+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])                        == fromList [(4, "b"), (6, "a")]+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"++mapKeys :: Ord k2 => (k1->k2) -> Map k1 a -> Map k2 a+mapKeys f m = finishB (foldlWithKey' (\b kx x -> insertB (f kx) x b) emptyB m)+#if __GLASGOW_HASKELL__+{-# INLINABLE mapKeys #-}+#endif++-- | \(O(n \log n)\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- If `f` is monotonically non-decreasing, this function takes \(O(n)\) time.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@. The value at the greater of the two original keys+-- is used as the first argument to @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"+--+-- Also see the performance note on 'fromListWith'.++mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a+mapKeysWith c f m =+  finishB (foldlWithKey' (\b kx x -> insertWithB c (f kx) x b) emptyB m)+#if __GLASGOW_HASKELL__+{-# INLINABLE mapKeysWith #-}+#endif+++-- | \(O(n)\).+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapKeysMonotonic f s == mapKeys f s+-- >     where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has better performance than 'mapKeys'.+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'mapKeys' if the+-- precondition may not hold.+--+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]+-- > valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) == True+-- > valid (mapKeysMonotonic (\ _ -> 1)     (fromList [(5,"a"), (3,"b")])) == False++mapKeysMonotonic :: (k1->k2) -> Map k1 a -> Map k2 a+mapKeysMonotonic _ Tip = Tip+mapKeysMonotonic f (Bin sz k x l r) =+    Bin sz (f k) x (mapKeysMonotonic f l) (mapKeysMonotonic f r)++{--------------------------------------------------------------------+  Folds+--------------------------------------------------------------------}++-- | \(O(n)\). Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr :: (a -> b -> b) -> b -> Map k a -> b+foldr f z = go z+  where+    go z' Tip             = z'+    go z' (Bin _ _ x l r) = go (f x (go z' r)) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> Map k a -> b+foldr' f z = go z+  where+    go !z' Tip            = z'+    go z' (Bin _ _ x l r) = go (f x $! go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+--+-- For example,+--+-- > elems = reverse . foldl (flip (:)) []+--+-- > let f len a = len + (length a)+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldl :: (a -> b -> a) -> a -> Map k b -> a+foldl f z = go z+  where+    go z' Tip             = z'+    go z' (Bin _ _ x l r) = go (f (go z' l) x) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> Map k b -> a+foldl' f z = go z+  where+    go !z' Tip            = z'+    go z' (Bin _ _ x l r) =+      let !z'' = go z' l+      in go (f z'' x) r+{-# INLINE foldl' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrWithKey f z = go z+  where+    go z' Tip             = z'+    go z' (Bin _ kx x l r) = go (f kx x (go z' r)) l+{-# INLINE foldrWithKey #-}++-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrWithKey' f z = go z+  where+    go !z' Tip              = z'+    go z' (Bin _ kx x l r) = go (f kx x $! go z' r) l+{-# INLINE foldrWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+--+-- For example,+--+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []+--+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"+foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlWithKey f z = go z+  where+    go z' Tip              = z'+    go z' (Bin _ kx x l r) = go (f (go z' l) kx x) r+{-# INLINE foldlWithKey #-}++-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlWithKey' f z = go z+  where+    go !z' Tip             = z'+    go z' (Bin _ kx x l r) =+      let !z'' = go z' l+      in go (f z'' kx x) r+{-# INLINE foldlWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that+--+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@+--+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.+--+-- @since 0.5.4+foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m+foldMapWithKey f = go+  where+    go Tip             = mempty+    go (Bin 1 k v _ _) = f k v+    go (Bin _ k v l r) = go l `mappend` (f k v `mappend` go r)+{-# INLINE foldMapWithKey #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\).+-- Return all elements of the map in the ascending order of their keys.+-- Subject to list fusion.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: Map k a -> [a]+elems = foldr (:) []++-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list+-- fusion.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys  :: Map k a -> [k]+keys = foldrWithKey (\k _ ks -> k : ks) []++-- | \(O(n)\). An alias for 'toAscList'. Return all key\/value pairs in the map+-- in ascending key order. Subject to list fusion.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: Map k a -> [(k,a)]+assocs m+  = toAscList m++-- | \(O(n)\). The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [3,5]+-- > keysSet empty == Data.Set.empty++keysSet :: Map k a -> Set.Set k+keysSet Tip = Set.Tip+keysSet (Bin sz kx _ l r) = Set.Bin sz kx (keysSet l) (keysSet r)++-- | \(O(n)\). The set of all elements of the map contained in 'Arg's.+--+-- > argSet (fromList [(5,"a"), (3,"b")]) == Data.Set.fromList [Arg 3 "b",Arg 5 "a"]+-- > argSet empty == Data.Set.empty+--+-- @since 0.6.6+argSet :: Map k a -> Set.Set (Arg k a)+argSet Tip = Set.Tip+argSet (Bin sz kx x l r) = Set.Bin sz (Arg kx x) (argSet l) (argSet r)++-- | \(O(n)\). Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Set.empty == empty++fromSet :: (k -> a) -> Set.Set k -> Map k a+fromSet _ Set.Tip = Tip+fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r)++-- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's.+--+-- > fromArgSet (Data.Set.fromList [Arg 3 "aaa", Arg 5 "aaaaa"]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromArgSet Data.Set.empty == empty+--+-- @since 0.6.6+fromArgSet :: Set.Set (Arg k a) -> Map k a+fromArgSet Set.Tip = Tip+fromArgSet (Set.Bin sz (Arg x v) l r) = Bin sz x v (fromArgSet l) (fromArgSet r)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.6.2+instance (Ord k) => GHCExts.IsList (Map k v) where+  type Item (Map k v) = (k,v)+  fromList = fromList+  toList   = toList+#endif++-- | \(O(n \log n)\). Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: Ord k => [(k,a)] -> Map k a+fromList xs = finishB (Foldable.foldl' (\b (kx, x) -> insertB kx x b) emptyB xs)+{-# INLINE fromList #-} -- INLINE for fusion++-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")]+-- > fromListWith (++) [] == empty+--+-- Note the reverse ordering of @"cba"@ in the example.+--+-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@.+--+-- === Performance+--+-- You should ensure that the given @f@ is fast with this order of arguments.+--+-- Symmetric functions may be slow in one order, and fast in another.+-- For the common case of collecting values of matching keys in a list, as above:+--+-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument.+-- Thus:+--+-- > fromListWith       (++)  (replicate 1000000 (3, "x"))   -- O(n),  fast+-- > fromListWith (flip (++)) (replicate 1000000 (3, "x"))   -- O(n²), extremely slow+--+-- because they evaluate as, respectively:+--+-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))]   -- O(n)+-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")]   -- O(n²)+--+-- Thus, to get good performance with an operation like @(++)@ while also preserving+-- the same order as in the input list, reverse the input:+--+-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")]+--+-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in:+--+-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples++fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a+fromListWith f xs =+  finishB (Foldable.foldl' (\b (kx, x) -> insertWithB f kx x b) emptyB xs)+{-# INLINE fromListWith #-}  -- INLINE for fusion++-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty+--+-- Also see the performance note on 'fromListWith'.++fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromListWithKey f xs =+  finishB (Foldable.foldl' (\b (kx, x) -> insertWithB (f kx) kx x b) emptyB xs)+{-# INLINE fromListWithKey #-}  -- INLINE for fusion++-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list fusion.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: Map k a -> [(k,a)]+toList = toAscList++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys are+-- in ascending order. Subject to list fusion.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: Map k a -> [(k,a)]+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys+-- are in descending order. Subject to list fusion.+--+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]++toDescList :: Map k a -> [(k,a)]+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.+-- They are important to convert unfused methods back, see mapFB in prelude.+foldrFB :: (k -> a -> b -> b) -> b -> Map k a -> b+foldrFB = foldrWithKey+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> k -> b -> a) -> a -> Map k b -> a+foldlFB = foldlWithKey+{-# INLINE[0] foldlFB #-}++-- Inline assocs and toList, so that we need to fuse only toAscList.+{-# INLINE assocs #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to+-- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to+-- inline it before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] elems #-}+{-# NOINLINE[0] keys #-}+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}+{-# RULES "Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}+{-# RULES "Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}+{-# RULES "Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}+{-# RULES "Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}+{-# RULES "Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}+{-# RULES "Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}+{-# RULES "Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}+#endif++{--------------------------------------------------------------------+  Building trees from ascending/descending lists can be done in linear time.++  Note that if [xs] is ascending that:+    fromAscList xs       == fromList xs+    fromAscListWith f xs == fromListWith f xs+--------------------------------------------------------------------}+-- | \(O(n)\). Build a map from an ascending list in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False++fromAscList :: Eq k => [(k,a)] -> Map k a+fromAscList xs = fromAscListWithKey (\_ x _ -> x) xs+{-# INLINE fromAscList #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from a descending list in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- > fromDescList [(5,"a"), (3,"b")]          == fromList [(3, "b"), (5, "a")]+-- > fromDescList [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False+--+-- @since 0.5.8++fromDescList :: Eq k => [(k,a)] -> Map k a+fromDescList xs = fromDescListWithKey (\_ x _ -> x) xs+{-# INLINE fromDescList #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from an ascending list in linear time with a combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False++fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWith f xs+  = fromAscListWithKey (\_ x y -> f x y) xs+{-# INLINE fromAscListWith #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from a descending list in linear time with a combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+--+-- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'.+--+-- @since 0.5.8++fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromDescListWith f xs+  = fromDescListWithKey (\_ x y -> f x y) xs+{-# INLINE fromDescListWith #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from an ascending list in linear time with a+-- combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True+-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'.++fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWithKey f xs = ascLinkAll (Foldable.foldl' next Nada xs)+  where+    next stk (!ky, y) = case stk of+      Push kx x l stk'+        | ky == kx -> Push ky (f ky y x) l stk'+        | Tip <- l -> ascLinkTop stk' 1 (singleton kx x) ky y+        | otherwise -> Push ky y Tip stk+      Nada -> Push ky y Tip stk+{-# INLINE fromAscListWithKey #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from a descending list in linear time with a+-- combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'.++fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromDescListWithKey f xs = descLinkAll (Foldable.foldl' next Nada xs)+  where+    next stk (!ky, y) = case stk of+      Push kx x r stk'+        | ky == kx -> Push ky (f ky y x) r stk'+        | Tip <- r -> descLinkTop ky y 1 (singleton kx x) stk'+        | otherwise -> Push ky y Tip stk+      Nada -> Push ky y Tip stk+{-# INLINE fromDescListWithKey #-}  -- INLINE for fusion+++-- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctAscList [(3,"b"), (5,"a")])          == True+-- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False++-- See Note [fromDistinctAscList implementation] in Data.Set.Internal.+fromDistinctAscList :: [(k,a)] -> Map k a+fromDistinctAscList xs = ascLinkAll (Foldable.foldl' next Nada xs)+  where+    next :: Stack k a -> (k, a) -> Stack k a+    next (Push kx x Tip stk) (!ky, y) = ascLinkTop stk 1 (singleton kx x) ky y+    next stk (!kx, x) = Push kx x Tip stk+{-# INLINE fromDistinctAscList #-}  -- INLINE for fusion++ascLinkTop :: Stack k a -> Int -> Map k a -> k -> a -> Stack k a+ascLinkTop (Push kx x l@(Bin lsz _ _ _ _) stk) !rsz r ky y+  | lsz == rsz = ascLinkTop stk sz (Bin sz kx x l r) ky y+  where+    sz = lsz + rsz + 1+ascLinkTop stk !_ l kx x = Push kx x l stk++ascLinkAll :: Stack k a -> Map k a+ascLinkAll stk = foldl'Stack (\r kx x l -> link kx x l r) Tip stk+{-# INLINABLE ascLinkAll #-}++-- | \(O(n)\). Build a map from a descending list of distinct elements in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- strictly decreasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctDescList [(5,"a"), (3,"b")])          == True+-- > valid (fromDistinctDescList [(5,"a"), (5,"b"), (3,"b")]) == False+--+-- @since 0.5.8++-- See Note [fromDistinctAscList implementation] in Data.Set.Internal.+fromDistinctDescList :: [(k,a)] -> Map k a+fromDistinctDescList xs = descLinkAll (Foldable.foldl' next Nada xs)+  where+    next :: Stack k a -> (k, a) -> Stack k a+    next (Push ky y Tip stk) (!kx, x) = descLinkTop kx x 1 (singleton ky y) stk+    next stk (!ky, y) = Push ky y Tip stk+{-# INLINE fromDistinctDescList #-}  -- INLINE for fusion++descLinkTop :: k -> a -> Int -> Map k a -> Stack k a -> Stack k a+descLinkTop kx x !lsz l (Push ky y r@(Bin rsz _ _ _ _) stk)+  | lsz == rsz = descLinkTop kx x sz (Bin sz ky y l r) stk+  where+    sz = lsz + rsz + 1+descLinkTop ky y !_ r stk = Push ky y r stk+{-# INLINABLE descLinkTop #-}++descLinkAll :: Stack k a -> Map k a+descLinkAll stk = foldl'Stack (\l kx x r -> link kx x l r) Tip stk+{-# INLINABLE descLinkAll #-}++data Stack k a = Push !k a !(Map k a) !(Stack k a) | Nada++foldl'Stack :: (b -> k -> a -> Map k a -> b) -> b -> Stack k a -> b+foldl'Stack f = go+  where+    go !z Nada = z+    go z (Push kx x t stk) = go (f z kx x t) stk+{-# INLINE foldl'Stack #-}++{-+-- Functions very similar to these were used to implement+-- hedge union, intersection, and difference algorithms that we no+-- longer use. These functions, however, seem likely to be useful+-- in their own right, so I'm leaving them here in case we end up+-- exporting them.++{--------------------------------------------------------------------+  [filterGt b t] filter all keys >[b] from tree [t]+  [filterLt b t] filter all keys <[b] from tree [t]+--------------------------------------------------------------------}+filterGt :: Ord k => k -> Map k v -> Map k v+filterGt !_ Tip = Tip+filterGt !b (Bin _ kx x l r) =+  case compare b kx of LT -> link kx x (filterGt b l) r+                       EQ -> r+                       GT -> filterGt b r+#if __GLASGOW_HASKELL__+{-# INLINABLE filterGt #-}+#endif++filterLt :: Ord k => k -> Map k v -> Map k v+filterLt !_ Tip = Tip+filterLt !b (Bin _ kx x l r) =+  case compare kx b of LT -> link kx x l (filterLt b r)+                       EQ -> l+                       GT -> filterLt b l+#if __GLASGOW_HASKELL__+{-# INLINABLE filterLt #-}+#endif+-}++{--------------------------------------------------------------------+  Split+--------------------------------------------------------------------}+-- | \(O(\log n)\). The expression (@'split' k map@) is a pair @(map1,map2)@ where+-- the keys in @map1@ are smaller than @k@ and the keys in @map2@ larger than @k@.+-- Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)++split :: Ord k => k -> Map k a -> (Map k a,Map k a)+split !k0 t0 = toPair $ go k0 t0+  where+    go k t =+      case t of+        Tip            -> Tip :*: Tip+        Bin _ kx x l r -> case compare k kx of+          LT -> let (lt :*: gt) = go k l in lt :*: link kx x gt r+          GT -> let (lt :*: gt) = go k r in link kx x l lt :*: gt+          EQ -> (l :*: r)+#if __GLASGOW_HASKELL__+{-# INLINABLE split #-}+#endif++-- | \(O(\log n)\). The expression (@'splitLookup' k map@) splits a map just+-- like 'split' but also returns @'lookup' k map@.+--+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)+splitLookup :: Ord k => k -> Map k a -> (Map k a,Maybe a,Map k a)+splitLookup k0 m = case go k0 m of+     StrictTriple l mv r -> (l, mv, r)+  where+    go :: Ord k => k -> Map k a -> StrictTriple (Map k a) (Maybe a) (Map k a)+    go !k t =+      case t of+        Tip            -> StrictTriple Tip Nothing Tip+        Bin _ kx x l r -> case compare k kx of+          LT -> let StrictTriple lt z gt = go k l+                    !gt' = link kx x gt r+                in StrictTriple lt z gt'+          GT -> let StrictTriple lt z gt = go k r+                    !lt' = link kx x l lt+                in StrictTriple lt' z gt+          EQ -> StrictTriple l (Just x) r+#if __GLASGOW_HASKELL__+{-# INLINABLE splitLookup #-}+#endif++-- | \(O(\log n)\). A variant of 'splitLookup' that indicates only whether the+-- key was present, rather than producing its value. This is used to+-- implement 'intersection' to avoid allocating unnecessary 'Just'+-- constructors.+splitMember :: Ord k => k -> Map k a -> (Map k a,Bool,Map k a)+splitMember k0 m = case go k0 m of+     StrictTriple l mv r -> (l, mv, r)+  where+    go :: Ord k => k -> Map k a -> StrictTriple (Map k a) Bool (Map k a)+    go !k t =+      case t of+        Tip            -> StrictTriple Tip False Tip+        Bin _ kx x l r -> case compare k kx of+          LT -> let StrictTriple lt z gt = go k l+                    !gt' = link kx x gt r+                in StrictTriple lt z gt'+          GT -> let StrictTriple lt z gt = go k r+                    !lt' = link kx x l lt+                in StrictTriple lt' z gt+          EQ -> StrictTriple l True r+#if __GLASGOW_HASKELL__+{-# INLINABLE splitMember #-}+#endif++data StrictTriple a b c = StrictTriple !a !b !c++{--------------------------------------------------------------------+  MapBuilder+--------------------------------------------------------------------}++-- See Note [SetBuilder] in Data.Set.Internal++data MapBuilder k a+  = BAsc !(Stack k a)+  | BMap !(Map k a)++-- Empty builder.+emptyB :: MapBuilder k a+emptyB = BAsc Nada++-- Insert a key and value. Replaces the old value if one already exists for+-- the key.+insertB :: Ord k => k -> a -> MapBuilder k a -> MapBuilder k a+insertB !ky y b = case b of+  BAsc stk -> case stk of+    Push kx x l stk' -> case compare ky kx of+      LT -> BMap (insert ky y (ascLinkAll stk))+      EQ -> BAsc (Push ky y l stk')+      GT -> case l of+        Tip -> BAsc (ascLinkTop stk' 1 (singleton kx x) ky y)+        Bin{} -> BAsc (Push ky y Tip stk)+    Nada -> BAsc (Push ky y Tip Nada)+  BMap m -> BMap (insert ky y m)+{-# INLINE insertB #-}++-- Insert a key and value. The new value is combined with the old value if one+-- already exists for the key.+insertWithB+  :: Ord k => (a -> a -> a) -> k -> a -> MapBuilder k a -> MapBuilder k a+insertWithB f !ky y b = case b of+  BAsc stk -> case stk of+    Push kx x l stk' -> case compare ky kx of+      LT -> BMap (insertWith f ky y (ascLinkAll stk))+      EQ -> BAsc (Push ky (f y x) l stk')+      GT -> case l of+        Tip -> BAsc (ascLinkTop stk' 1 (singleton kx x) ky y)+        Bin{} -> BAsc (Push ky y Tip stk)+    Nada -> BAsc (Push ky y Tip Nada)+  BMap m -> BMap (insertWith f ky y m)+{-# INLINE insertWithB #-}++-- Finalize the builder into a Map.+finishB :: MapBuilder k a -> Map k a+finishB (BAsc stk) = ascLinkAll stk+finishB (BMap m) = m+{-# INLINABLE finishB #-}++{--------------------------------------------------------------------+  Utility functions that maintain the balance properties of the tree.+  All constructors assume that all values in [l] < [k] and all values+  in [r] > [k], and that [l] and [r] are valid trees.++  In order of sophistication:+    [Bin sz k x l r]  The type constructor.+    [bin k x l r]     Maintains the correct size, assumes that both [l]+                      and [r] are balanced with respect to each other.+    [balance k x l r] Restores the balance and size.+                      Assumes that the original tree was balanced and+                      that [l] or [r] has changed by at most one element.+    [link k x l r]    Restores balance and size.++  Furthermore, we can construct a new tree from two trees. Both operations+  assume that all values in [l] < all values in [r] and that [l] and [r]+  are valid:+    [glue l r]        Glues [l] and [r] together. Assumes that [l] and+                      [r] are already balanced with respect to each other.+    [link2 l r]       Merges two trees and restores balance.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}+link :: k -> a -> Map k a -> Map k a -> Map k a+link kx x Tip r  = insertMin kx x r+link kx x l Tip  = insertMax kx x l+link kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)+  | delta*sizeL < sizeR  = balanceL kz z (link kx x l lz) rz+  | delta*sizeR < sizeL  = balanceR ky y ly (link kx x ry r)+  | otherwise            = bin kx x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: k -> a -> Map k a -> Map k a+insertMax kx x t+  = case t of+      Tip -> singleton kx x+      Bin _ ky y l r+          -> balanceR ky y l (insertMax kx x r)++insertMin kx x t+  = case t of+      Tip -> singleton kx x+      Bin _ ky y l r+          -> balanceL ky y (insertMin kx x l) r++{--------------------------------------------------------------------+  [link2 l r]: merges two trees.+--------------------------------------------------------------------}+link2 :: Map k a -> Map k a -> Map k a+link2 Tip r   = r+link2 l Tip   = l+link2 l@(Bin sizeL kx x lx rx) r@(Bin sizeR ky y ly ry)+  | delta*sizeL < sizeR = balanceL ky y (link2 l ly) ry+  | delta*sizeR < sizeL = balanceR kx x lx (link2 rx r)+  | otherwise           = glue l r++{--------------------------------------------------------------------+  [glue l r]: glues two trees together.+  Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: Map k a -> Map k a -> Map k a+glue Tip r = r+glue l Tip = l+glue l@(Bin sl kl xl ll lr) r@(Bin sr kr xr rl rr)+  | sl > sr = let !(MaxView km m l') = maxViewSure kl xl ll lr in Bin (sl+sr) km m l' r+  | otherwise = let !(MinView km m r') = minViewSure kr xr rl rr in Bin (sl+sr) km m l r'++data MinView k a = MinView !k a !(Map k a)+data MaxView k a = MaxView !k a !(Map k a)++minViewSure :: k -> a -> Map k a -> Map k a -> MinView k a+minViewSure !k x l !r = case l of+  Tip -> MinView k x r+  Bin _ lk lx ll lr -> case minViewSure lk lx ll lr of+    MinView km xm l' -> MinView km xm (balanceR k x l' r)++maxViewSure :: k -> a -> Map k a -> Map k a -> MaxView k a+maxViewSure !k x !l r = case r of+  Tip -> MaxView k x l+  Bin _ rk rx rl rr -> case maxViewSure rk rx rl rr of+    MaxView km xm r' -> MaxView km xm (balanceL k x l r')++-- | \(O(\log n)\). Delete and find the minimal element.+--+-- > deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((3,"b"), fromList[(5,"a"), (10,"c")])+-- > deleteFindMin empty                                      Error: can not return the minimal element of an empty map++deleteFindMin :: Map k a -> ((k,a),Map k a)+deleteFindMin t = case minViewWithKey t of+  Nothing -> (error "Map.deleteFindMin: can not return the minimal element of an empty map", Tip)+  Just res -> res++-- | \(O(\log n)\). Delete and find the maximal element.+--+-- > deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) == ((10,"c"), fromList [(3,"b"), (5,"a")])+-- > deleteFindMax empty                                      Error: can not return the maximal element of an empty map++deleteFindMax :: Map k a -> ((k,a),Map k a)+deleteFindMax t = case maxViewWithKey t of+  Nothing -> (error "Map.deleteFindMax: can not return the maximal element of an empty map", Tip)+  Just res -> res++{--------------------------------------------------------------------+  Iterator+--------------------------------------------------------------------}++-- See Note [Iterator] in Data.Set.Internal++iterDown :: Map k a -> Stack k a -> Stack k a+iterDown (Bin _ kx x l r) stk = iterDown l (Push kx x r stk)+iterDown Tip stk = stk++-- Create an iterator from a Map, starting at the smallest key.+iterator :: Map k a -> Stack k a+iterator m = iterDown m Nada++-- Get the next key-value and the remaining iterator.+iterNext :: Stack k a -> Maybe (StrictPair (KeyValue k a) (Stack k a))+iterNext (Push kx x r stk) = Just $! KeyValue kx x :*: iterDown r stk+iterNext Nada = Nothing+{-# INLINE iterNext #-}++-- Whether there are no more key-values in the iterator.+iterNull :: Stack k a -> Bool+iterNull (Push _ _ _ _) = False+iterNull Nada = True++{--------------------------------------------------------------------+  [balance l x r] balances two trees with value x.+  The sizes of the trees should balance after decreasing the+  size of one of them. (a rotation).++  [delta] is the maximal relative difference between the sizes of+          two trees, it corresponds with the [w] in Adams' paper.+  [ratio] is the ratio between an outer and inner sibling of the+          heavier subtree in an unbalanced setting. It determines+          whether a double or single rotation should be performed+          to restore balance. It is corresponds with the inverse+          of $\alpha$ in Adam's article.++  Note that according to the Adam's paper:+  - [delta] should be larger than 4.646 with a [ratio] of 2.+  - [delta] should be larger than 3.745 with a [ratio] of 1.534.++  But the Adam's paper is erroneous:+  - It can be proved that for delta=2 and delta>=5 there does+    not exist any ratio that would work.+  - Delta=4.5 and ratio=2 does not work.++  That leaves two reasonable variants, delta=3 and delta=4,+  both with ratio=2.++  - A lower [delta] leads to a more 'perfectly' balanced tree.+  - A higher [delta] performs less rebalancing.++  In the benchmarks, delta=3 is faster on insert operations,+  and delta=4 has slightly better deletes. As the insert speedup+  is larger, we currently use delta=3.++--------------------------------------------------------------------}+delta,ratio :: Int+delta = 3+ratio = 2++-- The balance function is equivalent to the following:+--+--   balance :: k -> a -> Map k a -> Map k a -> Map k a+--   balance k x l r+--     | sizeL + sizeR <= 1    = Bin sizeX k x l r+--     | sizeR > delta*sizeL   = rotateL k x l r+--     | sizeL > delta*sizeR   = rotateR k x l r+--     | otherwise             = Bin sizeX k x l r+--     where+--       sizeL = size l+--       sizeR = size r+--       sizeX = sizeL + sizeR + 1+--+--   rotateL :: a -> b -> Map a b -> Map a b -> Map a b+--   rotateL k x l r@(Bin _ _ _ ly ry) | size ly < ratio*size ry = singleL k x l r+--                                     | otherwise               = doubleL k x l r+--+--   rotateR :: a -> b -> Map a b -> Map a b -> Map a b+--   rotateR k x l@(Bin _ _ _ ly ry) r | size ry < ratio*size ly = singleR k x l r+--                                     | otherwise               = doubleR k x l r+--+--   singleL, singleR :: a -> b -> Map a b -> Map a b -> Map a b+--   singleL k1 x1 t1 (Bin _ k2 x2 t2 t3)  = bin k2 x2 (bin k1 x1 t1 t2) t3+--   singleR k1 x1 (Bin _ k2 x2 t1 t2) t3  = bin k2 x2 t1 (bin k1 x1 t2 t3)+--+--   doubleL, doubleR :: a -> b -> Map a b -> Map a b -> Map a b+--   doubleL k1 x1 t1 (Bin _ k2 x2 (Bin _ k3 x3 t2 t3) t4) = bin k3 x3 (bin k1 x1 t1 t2) (bin k2 x2 t3 t4)+--   doubleR k1 x1 (Bin _ k2 x2 t1 (Bin _ k3 x3 t2 t3)) t4 = bin k3 x3 (bin k2 x2 t1 t2) (bin k1 x1 t3 t4)+--+-- It is only written in such a way that every node is pattern-matched only once.++balance :: k -> a -> Map k a -> Map k a -> Map k a+balance k x l r = case (l, r) of+  (Bin ls _ _ _ _, Bin rs _ _ _ _)+    | rs <= delta*ls && ls <= delta*rs -> Bin (1+ls+rs) k x l r+  _ -> balance_ k x l r+{-# INLINE balance #-} -- See Note [Inlining balance] in Data.Set.Internal++balance_ :: k -> a -> Map k a -> Map k a -> Map k a+balance_ k x l r = case l of+  Tip -> case r of+           Tip -> Bin 1 k x Tip Tip+           (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+           (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+           (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+           (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+             | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+             | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++  (Bin ls lk lx ll lr) -> case r of+           Tip -> case (ll, lr) of+                    (Tip, Tip) -> Bin 2 k x l Tip+                    (Tip, (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+                    ((Bin _ _ _ _ _), Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+                    ((Bin lls _ _ _ _), (Bin lrs lrk lrx lrl lrr))+                      | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+                      | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)+           (Bin rs rk rx rl rr)+              | rs > delta*ls  -> case (rl, rr) of+                   (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+                     | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+                     | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)+                   (_, _) -> error "Failure in Data.Map.balance"+              | {- ls > delta*rs -} otherwise -> case (ll, lr) of+                   (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+                     | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+                     | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)+                   (_, _) -> error "Failure in Data.Map.balance"+{-# NOINLINE balance_ #-}++-- Functions balanceL and balanceR are specialised versions of balance.+-- balanceL only checks whether the left subtree is too big,+-- balanceR only checks whether the right subtree is too big.++-- balanceL is called when left subtree might have been inserted to or when+-- right subtree might have been deleted from.+balanceL :: k -> a -> Map k a -> Map k a -> Map k a+balanceL k x l r = case (l, r) of+  (Bin ls _ _ _ _, Bin rs _ _ _ _)+    | ls <= delta*rs -> Bin (1+ls+rs) k x l r+  _ -> balanceL_ k x l r+{-# INLINE balanceL #-} -- See Note [Inlining balance] in Data.Set.Internal++balanceL_ :: k -> a -> Map k a -> Map k a -> Map k a+balanceL_ k x l r = case r of+  Tip -> case l of+           Tip -> Bin 1 k x Tip Tip+           (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip+           (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)+           (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)+           (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))+             | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)+             | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)++  (Bin rs _ _ _ _) -> case l of+           Tip -> Bin (1+rs) k x Tip r++           (Bin ls lk lx ll lr) -> case (ll, lr) of+                   (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)+                     | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)+                     | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)+                   (_, _) -> error "Failure in Data.Map.balanceL_"+{-# NOINLINE balanceL_ #-}++-- balanceR is called when right subtree might have been inserted to or when+-- left subtree might have been deleted from.+balanceR :: k -> a -> Map k a -> Map k a -> Map k a+balanceR k x l r = case (l, r) of+  (Bin ls _ _ _ _, Bin rs _ _ _ _)+    | rs <= delta*ls -> Bin (1+ls+rs) k x l r+  _ -> balanceR_ k x l r+{-# INLINE balanceR #-} -- See Note [Inlining balance] in Data.Set.Internal++balanceR_ :: k -> a -> Map k a -> Map k a -> Map k a+balanceR_ k x l r = case l of+  Tip -> case r of+           Tip -> Bin 1 k x Tip Tip+           (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r+           (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr+           (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)+           (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))+             | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr+             | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)++  (Bin ls _ _ _ _) -> case r of+           Tip -> Bin (1+ls) k x l Tip++           (Bin rs rk rx rl rr) -> case (rl, rr) of+                   (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)+                     | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr+                     | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)+                   (_, _) -> error "Failure in Data.Map.balanceR_"+{-# NOINLINE balanceR_ #-}+++{--------------------------------------------------------------------+  The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: k -> a -> Map k a -> Map k a -> Map k a+bin k x l r+  = Bin (size l + size r + 1) k x l r+{-# INLINE bin #-}+++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}++instance (Eq k,Eq a) => Eq (Map k a) where+  m1 == m2 = liftEq2 (==) (==) m1 m2+  {-# INLINABLE (==) #-}++-- | @since 0.5.9+instance Eq k => Eq1 (Map k) where+  liftEq = liftEq2 (==)+  {-# INLINE liftEq #-}++-- | @since 0.5.9+instance Eq2 Map where+  liftEq2 keq eq m1 m2 = size m1 == size m2 && sameSizeLiftEq2 keq eq m1 m2+  {-# INLINE liftEq2 #-}++-- Assumes the maps are of equal size to skip the final check+sameSizeLiftEq2+  :: (ka -> kb -> Bool) -> (a -> b -> Bool) -> Map ka a -> Map kb b -> Bool+sameSizeLiftEq2 keq eq m1 m2 =+  case runEqM (foldMapWithKey f m1) (iterator m2) of e :*: _ -> e+  where+    f kx x = EqM $ \it -> case iterNext it of+      Nothing -> False :*: it+      Just (KeyValue ky y :*: it') -> (keq kx ky && eq x y) :*: it'+{-# INLINE sameSizeLiftEq2 #-}++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance (Ord k, Ord v) => Ord (Map k v) where+  compare m1 m2 = liftCmp2 compare compare m1 m2+  {-# INLINABLE compare #-}++-- | @since 0.5.9+instance Ord k => Ord1 (Map k) where+  liftCompare = liftCmp2 compare+  {-# INLINE liftCompare #-}++-- | @since 0.5.9+instance Ord2 Map where+  liftCompare2 = liftCmp2+  {-# INLINE liftCompare2 #-}++liftCmp2+  :: (ka -> kb -> Ordering)+  -> (a -> b -> Ordering)+  -> Map ka a+  -> Map kb b+  -> Ordering+liftCmp2 kcmp cmp m1 m2 = case runOrdM (foldMapWithKey f m1) (iterator m2) of+  o :*: it -> o <> if iterNull it then EQ else LT+  where+    f kx x = OrdM $ \it -> case iterNext it of+      Nothing -> GT :*: it+      Just (KeyValue ky y :*: it') -> (kcmp kx ky <> cmp x y) :*: it'+{-# INLINE liftCmp2 #-}++{--------------------------------------------------------------------+  Lifted instances+--------------------------------------------------------------------}++-- | @since 0.5.9+instance Show2 Map where+    liftShowsPrec2 spk slk spv slv d m =+        showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)+      where+        sp = liftShowsPrec2 spk slk spv slv+        sl = liftShowList2 spk slk spv slv++-- | @since 0.5.9+instance Show k => Show1 (Map k) where+    liftShowsPrec = liftShowsPrec2 showsPrec showList++-- | @since 0.5.9+instance (Ord k, Read k) => Read1 (Map k) where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl++{--------------------------------------------------------------------+  Functor+--------------------------------------------------------------------}+instance Functor (Map k) where+  fmap f m  = map f m+#ifdef __GLASGOW_HASKELL__+  _ <$ Tip = Tip+  a <$ (Bin sx kx _ l r) = Bin sx kx a (a <$ l) (a <$ r)+#endif++-- | Traverses in order of increasing key.+instance Traversable (Map k) where+  traverse f = traverseWithKey (\_ -> f)+  {-# INLINE traverse #-}++-- | Folds in order of increasing key.+instance Foldable.Foldable (Map k) where+  fold = go+    where go Tip = mempty+          go (Bin 1 _ v _ _) = v+          go (Bin _ _ v l r) = go l `mappend` (v `mappend` go r)+  {-# INLINABLE fold #-}+  foldr = foldr+  {-# INLINE foldr #-}+  foldl = foldl+  {-# INLINE foldl #-}+  foldMap f t = go t+    where go Tip = mempty+          go (Bin 1 _ v _ _) = f v+          go (Bin _ _ v l r) = go l `mappend` (f v `mappend` go r)+  {-# INLINE foldMap #-}+  foldl' = foldl'+  {-# INLINE foldl' #-}+  foldr' = foldr'+  {-# INLINE foldr' #-}+  length = size+  {-# INLINE length #-}+  null   = null+  {-# INLINE null #-}+  toList = elems -- NB: Foldable.toList /= Map.toList+  {-# INLINE toList #-}+  elem = go+    where go !_ Tip = False+          go x (Bin _ _ v l r) = x == v || go x l || go x r+  {-# INLINABLE elem #-}+  maximum = start+    where start Tip = error "Data.Foldable.maximum (for Data.Map): empty map"+          start (Bin _ _ v l r) = go (go v l) r++          go !m Tip = m+          go m (Bin _ _ v l r) = go (go (max m v) l) r+  {-# INLINABLE maximum #-}+  minimum = start+    where start Tip = error "Data.Foldable.minimum (for Data.Map): empty map"+          start (Bin _ _ v l r) = go (go v l) r++          go !m Tip = m+          go m (Bin _ _ v l r) = go (go (min m v) l) r+  {-# INLINABLE minimum #-}+  sum = foldl' (+) 0+  {-# INLINABLE sum #-}+  product = foldl' (*) 1+  {-# INLINABLE product #-}++-- | @since 0.6.3.1+instance Bifoldable Map where+  bifold = go+    where go Tip = mempty+          go (Bin 1 k v _ _) = k `mappend` v+          go (Bin _ k v l r) = go l `mappend` (k `mappend` (v `mappend` go r))+  {-# INLINABLE bifold #-}+  bifoldr f g z = go z+    where go z' Tip             = z'+          go z' (Bin _ k v l r) = go (f k (g v (go z' r))) l+  {-# INLINE bifoldr #-}+  bifoldl f g z = go z+    where go z' Tip             = z'+          go z' (Bin _ k v l r) = go (g (f (go z' l) k) v) r+  {-# INLINE bifoldl #-}+  bifoldMap f g t = go t+    where go Tip = mempty+          go (Bin 1 k v _ _) = f k `mappend` g v+          go (Bin _ k v l r) = go l `mappend` (f k `mappend` (g v `mappend` go r))+  {-# INLINE bifoldMap #-}++instance (NFData k, NFData a) => NFData (Map k a) where+    rnf Tip = ()+    rnf (Bin _ kx x l r) = rnf kx `seq` rnf x `seq` rnf l `seq` rnf r++-- | @since 0.8+instance NFData k => NFData1 (Map k) where+  liftRnf rnfx = go+    where+    go Tip              = ()+    go (Bin _ kx x l r) = rnf kx `seq` rnfx x `seq` go l `seq` go r++-- | @since 0.8+instance NFData2 Map where+  liftRnf2 rnfkx rnfx = go+    where+    go Tip              = ()+    go (Bin _ kx x l r) = rnfkx kx `seq` rnfx x `seq` go l `seq` go r++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance (Ord k, Read k, Read e) => Read (Map k e) where+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault+#else+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)+#endif++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance (Show k, Show a) => Show (Map k a) where+  showsPrec d m  = showParen (d > 10) $+    showString "fromList " . shows (toList m)++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | \(O(1)\).  Decompose a map into pieces based on the structure of the underlying+-- tree.  This function is useful for consuming a map in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- 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] ['a'..])) ==+-- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d')],fromList [(5,'e'),(6,'f')]]+--+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than three submaps,+--  but you should not depend on this behaviour because it can change in the+--  future without notice.+--+-- @since 0.5.4+splitRoot :: Map k b -> [Map k b]+splitRoot orig =+  case orig of+    Tip           -> []+    Bin _ k v l r -> [l, singleton k v, r]+{-# INLINE splitRoot #-}
+ src/Data/Map/Internal/Debug.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE CPP #-}+#include "containers.h"++module Data.Map.Internal.Debug where++import Data.Map.Internal (Map (..), size, delta)+import Control.Monad (guard)++-- | \(O(n \log n)\). Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format. See 'showTreeWith'.+showTree :: (Show k,Show a) => Map k a -> String+showTree m+  = showTreeWith showElem True False m+  where+    showElem k x  = show k ++ ":=" ++ show x+++{- | \(O(n \log n)\). The expression (@'showTreeWith' showelem hang wide map@) shows+ the tree that implements the map. Elements are shown using the @showElem@ function. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.++>  Map> let t = fromDistinctAscList [(x,()) | x <- [1..5]]+>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True False t+>  (4,())+>  +--(2,())+>  |  +--(1,())+>  |  +--(3,())+>  +--(5,())+>+>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) True True t+>  (4,())+>  |+>  +--(2,())+>  |  |+>  |  +--(1,())+>  |  |+>  |  +--(3,())+>  |+>  +--(5,())+>+>  Map> putStrLn $ showTreeWith (\k x -> show (k,x)) False True t+>  +--(5,())+>  |+>  (4,())+>  |+>  |  +--(3,())+>  |  |+>  +--(2,())+>     |+>     +--(1,())++-}+showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String+showTreeWith showelem hang wide t+  | hang      = (showsTreeHang showelem wide [] t) ""+  | otherwise = (showsTree showelem wide [] [] t) ""++showsTree :: (k -> a -> String) -> Bool -> [String] -> [String] -> Map k a -> ShowS+showsTree showelem wide lbars rbars t+  = case t of+      Tip -> showsBars lbars . showString "|\n"+      Bin _ kx x Tip Tip+          -> showsBars lbars . showString (showelem kx x) . showString "\n"+      Bin _ kx x l r+          -> showsTree showelem wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . showString (showelem kx x) . showString "\n" .+             showWide wide lbars .+             showsTree showelem wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: (k -> a -> String) -> Bool -> [String] -> Map k a -> ShowS+showsTreeHang showelem wide bars t+  = case t of+      Tip -> showsBars bars . showString "|\n"+      Bin _ kx x Tip Tip+          -> showsBars bars . showString (showelem kx x) . showString "\n"+      Bin _ kx x l r+          -> showsBars bars . showString (showelem kx x) . showString "\n" .+             showWide wide bars .+             showsTreeHang showelem wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang showelem wide (withEmpty bars) r++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _ : tl -> showString (concat (reverse tl)) . showString node++node :: String+node           = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars++{--------------------------------------------------------------------+  Assertions+--------------------------------------------------------------------}+-- | \(O(n)\). Test if the internal map structure is valid.+--+-- > valid (fromAscList [(3,"b"), (5,"a")]) == True+-- > valid (fromAscList [(5,"a"), (3,"b")]) == False++valid :: Ord k => Map k a -> Bool+valid t+  = balanced t && ordered t && validsize t++-- | Test if the keys are ordered correctly.+ordered :: Ord a => Map a b -> Bool+ordered t+  = bounded (const True) (const True) t+  where+    bounded lo hi t'+      = case t' of+          Tip              -> True+          Bin _ kx _ l r  -> (lo kx) && (hi kx) && bounded lo (<kx) l && bounded (>kx) hi r++-- | Test if a map obeys the balance invariants.+balanced :: Map k a -> Bool+balanced t+  = case t of+      Tip            -> True+      Bin _ _ _ l r  -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+                        balanced l && balanced r++-- | Test if each node of a map reports its size correctly.+validsize :: Map a b -> Bool+validsize t = case slowSize t of+      Nothing -> False+      Just _ -> True+  where+    slowSize Tip = Just 0+    slowSize (Bin sz _ _ l r) = do+            ls <- slowSize l+            rs <- slowSize r+            guard (sz == ls + rs + 1)+            return sz
+ src/Data/Map/Lazy.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Safe #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Map.Lazy+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Maps (lazy interface)+--+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@. A 'Map' is strict in its keys but lazy+-- in its values.+--+-- The functions in "Data.Map.Strict" are careful to force values before+-- installing them in a 'Map'. This is usually more efficient in cases where+-- laziness is not essential. The functions in this module do not do so.+--+-- When deciding if this is the correct data structure to use, consider:+--+-- * If you are using 'Prelude.Int' keys, you will get much better performance for most+-- operations using "Data.IntMap.Lazy".+--+-- * If you don't care about ordering, consider using @Data.HashMap.Lazy@ from the+-- <https://hackage.haskell.org/package/unordered-containers unordered-containers>+-- package instead.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- > import Data.Map.Lazy (Map)+-- > import qualified Data.Map.Lazy as Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Warning+--+-- The size of a 'Map' must not exceed @'Prelude.maxBound' :: 'Prelude.Int'@.+-- Violation of this condition is not detected and if the size limit is exceeded,+-- its behaviour is undefined.+--+--+-- == Implementation+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104>+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>.+--+--+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map.+--+-- Operations like 'lookup', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.Map.Lazy" with other dictionary implementations+-- can be found at https://github.com/haskell-perf/dictionaries.+--+-----------------------------------------------------------------------------++module Data.Map.Lazy (+    -- * Map type+    Map              -- instance Eq,Show,Read++    -- * Construction+    , empty+    , singleton+    , fromSet+    , fromArgSet++    -- ** From Unordered Lists+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** From Ascending Lists+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- ** From Descending Lists+    , fromDescList+    , fromDescListWith+    , fromDescListWithKey+    , fromDistinctDescList++    -- * 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++    -- ** Symmetric difference+    , symmetricDifference++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** General combining functions+    -- | See "Data.Map.Merge.Lazy"++    -- ** Unsafe general combining function++    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , argSet++    -- ** Lists+    , toList++    -- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , filter+    , filterKeys+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey+    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Indexed+    , lookupIndex+    , findIndex+    , elemAt+    , updateAt+    , deleteAt+    , take+    , drop+    , splitAt++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- * Debugging+    , valid+    ) where++import Data.Map.Internal+import Data.Map.Internal.Debug (valid)+import Prelude ()
+ src/Data/Map/Merge/Lazy.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Safe #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Map.Merge.Lazy+-- Copyright   :  (c) David Feuer 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 'Control.Category.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.Map.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.Map.Internal
+ src/Data/Map/Merge/Strict.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Safe #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Map.Merge.Strict+-- Copyright   :  (c) David Feuer 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.+--+-- == 'preserveMissing' inconsistency+--+-- For historical reasons, the preserved values are //not// forced. To force+-- them, use 'preserveMissing''.+--+-- == Efficiency note+--+-- The 'Control.Category.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.Map.Merge.Strict (+    -- ** Simple merge tactic types+      SimpleWhenMissing+    , SimpleWhenMatched++    -- ** General combining function+    , merge++    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched++    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , 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.Map.Strict.Internal
+ src/Data/Map/Strict.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Safe #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Map.Strict+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Maps (strict interface)+--+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@.+--+-- 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.Map.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.+--+-- When deciding if this is the correct data structure to use, consider:+--+-- * If you are using 'Prelude.Int' keys, you will get much better performance for+-- most operations using "Data.IntMap.Strict".+--+-- * If you don't care about ordering, consider use @Data.HashMap.Strict@ from the+-- <https://hackage.haskell.org/package/unordered-containers unordered-containers>+-- package instead.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- > import Data.Map.Strict (Map)+-- > import qualified Data.Map.Strict as Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Warning+--+-- The size of a 'Map' must not exceed @maxBound::Int@. Violation of this+-- condition is not detected and if the size limit is exceeded, its behaviour is+-- undefined.+--+-- The 'Map' type is shared between the lazy and strict modules, meaning that+-- the same 'Map' value can be passed to functions in both modules. This means+-- that the 'Data.Functor.Functor', 'Data.Traversable.Traversable' and+-- 'Data.Data.Data' instances are the same as for the "Data.Map.Lazy" module, so+-- if they are used the resulting maps may contain suspended values (thunks).+--+--+-- == Implementation+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104>+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>.+--+--+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the map.+--+-- Operations like 'lookup', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input maps respectively.+--+-- Benchmarks comparing "Data.Map.Strict" with other dictionary implementations+-- can be found at https://github.com/haskell-perf/dictionaries.+--+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.Map.Internal.++module Data.Map.Strict+    (+    -- * Map type+    Map              -- instance Eq,Show,Read++    -- * Construction+    , empty+    , singleton+    , fromSet+    , fromArgSet++    -- ** From Unordered Lists+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** From Ascending Lists+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- ** From Descending Lists+    , fromDescList+    , fromDescListWith+    , fromDescListWithKey+    , fromDistinctDescList++    -- * 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++    -- ** Symmetric difference+    , symmetricDifference++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** General combining functions+    -- | See "Data.Map.Merge.Strict"++    -- ** Deprecated general combining function++    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , argSet++    -- ** Lists+    , toList++    -- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , filter+    , filterKeys+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Indexed+    , lookupIndex+    , findIndex+    , elemAt+    , updateAt+    , deleteAt+    , take+    , drop+    , splitAt++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- * Debugging+    , valid+    ) where++import Data.Map.Strict.Internal+import Prelude ()
+ src/Data/Map/Strict/Internal.hs view
@@ -0,0 +1,1710 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+#if defined(__GLASGOW_HASKELL__)+{-# LANGUAGE Trustworthy #-}+#endif+{-# OPTIONS_HADDOCK not-home #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Map.Strict.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Maps (strict interface internals)+--+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@.+--+--+-- == Implementation+--+-- The implementation of 'Map' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104>+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>.+--+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.Map.Internal.++module Data.Map.Strict.Internal+    (+    -- * Map type+    Map(..)          -- instance Eq,Show,Read+    , L.Size++    -- * Operators+    , (!), (!?), (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookup+    , findWithDefault+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE++    -- * Construction+    , empty+    , singleton++    -- ** Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- ** Delete\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Symmetric difference+    , symmetricDifference++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** General combining function+    , SimpleWhenMissing+    , SimpleWhenMatched+    , merge+    , runWhenMatched+    , runWhenMissing++    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched++    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , preserveMissing'+    , mapMissing+    , filterMissing++    -- ** Applicative general combining function+    , WhenMissing (..)+    , WhenMatched (..)+    , mergeA++    -- *** @WhenMatched@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , zipWithMaybeAMatched+    , zipWithAMatched++    -- *** @WhenMissing@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , traverseMaybeMissing+    , traverseMissing+    , filterAMissing++    -- *** Covariant maps for tactics+    , mapWhenMissing+    , mapWhenMatched++    -- ** Deprecated general combining function++    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , argSet+    , fromSet+    , fromArgSet++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList+    , fromDescList+    , fromDescListWith+    , fromDescListWithKey+    , fromDistinctDescList++    -- * Filter+    , filter+    , filterKeys+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey+    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Indexed+    , lookupIndex+    , findIndex+    , elemAt+    , updateAt+    , deleteAt+    , take+    , drop+    , splitAt++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- * Debugging+    , valid+    ) where++import Utils.Containers.Internal.Prelude hiding+  (lookup,map,filter,foldr,foldl,foldl',null,take,drop,splitAt)+import Prelude ()++import Data.Map.Internal+  ( Map (..)+  , AreWeStrict (..)+  , WhenMissing (..)+  , WhenMatched (..)+  , runWhenMatched+  , runWhenMissing+  , SimpleWhenMissing+  , SimpleWhenMatched+  , preserveMissing+  , preserveMissing'+  , dropMissing+  , filterMissing+  , filterAMissing+  , merge+  , mergeA+  , ascLinkTop+  , ascLinkAll+  , descLinkTop+  , descLinkAll+  , Stack (..)+  , MapBuilder(..)+  , emptyB+  , insertB+  , finishB+  , (!)+  , (!?)+  , (\\)+  , argSet+  , assocs+  , atKeyImpl+#ifdef __GLASGOW_HASKELL__+  , atKeyPlain+#endif+  , balance+  , balanceL+  , balanceR+  , compose+  , elemAt+  , elems+  , empty+  , delete+  , deleteAt+  , deleteFindMax+  , deleteFindMin+  , deleteMin+  , deleteMax+  , difference+  , disjoint+  , drop+  , dropWhileAntitone+  , filter+  , filterKeys+  , filterWithKey+  , findIndex+  , findMax+  , findMin+  , foldl+  , foldl'+  , foldlWithKey+  , foldlWithKey'+  , foldMapWithKey+  , foldr+  , foldr'+  , foldrWithKey+  , foldrWithKey'+  , glue+  , intersection+  , isProperSubmapOf+  , isProperSubmapOfBy+  , isSubmapOf+  , isSubmapOfBy+  , keys+  , keysSet+  , link+  , lookup+  , findWithDefault+  , lookupGE+  , lookupGT+  , lookupIndex+  , lookupLE+  , lookupLT+  , lookupMin+  , lookupMax+  , mapKeys+  , mapKeysMonotonic+  , maxView+  , maxViewWithKey+  , member+  , link2+  , minView+  , minViewWithKey+  , notMember+  , null+  , partition+  , partitionWithKey+  , restrictKeys+  , size+  , spanAntitone+  , split+  , splitAt+  , splitLookup+  , splitRoot+  , symmetricDifference+  , take+  , takeWhileAntitone+  , toList+  , toAscList+  , toDescList+  , union+  , unions+  , withoutKeys )++import Data.Map.Internal.Debug (valid)++import Control.Applicative (Const (..), liftA3)+import Data.Semigroup (Arg (..))+import qualified Data.Set.Internal as Set+import qualified Data.Map.Internal as L+import Utils.Containers.Internal.StrictPair++#ifdef __GLASGOW_HASKELL__+import Data.Coerce+#endif++#ifdef __GLASGOW_HASKELL__+import Data.Functor.Identity (Identity (..))+#endif++import qualified Data.Foldable as Foldable++-- [Note: Pointer equality for sharing]+--+-- We use pointer equality to enhance sharing between the arguments+-- of some functions and their results. Notably, we use it+-- for insert, delete, union, intersection, and difference. We do+-- *not* use it for functions, like insertWith, unionWithKey,+-- intersectionWith, etc., that allow the user to modify the elements.+-- While we *could* do so, we would only get sharing under fairly+-- narrow conditions and at a relatively high cost. It does not seem+-- worth the price.++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}++-- | \(O(1)\). A map with a single element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: k -> a -> Map k a+singleton k x = x `seq` Bin 1 k x Tip Tip+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insertion+--------------------------------------------------------------------}+-- | \(O(\log n)\). Insert a new key and value in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty                         == singleton 5 'x'++-- See Map.Internal.Note: Type of local 'go' function+insert :: Ord k => k -> a -> Map k a -> Map k a+insert = go+  where+    go :: Ord k => k -> a -> Map k a -> Map k a+    go !kx !x Tip = singleton kx x+    go kx x (Bin sz ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go kx x l) r+            GT -> balanceR ky y l (go kx x r)+            EQ -> Bin sz kx x l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insert #-}+#else+{-# INLINE insert #-}+#endif++-- | \(O(\log n)\). Insert with a function, combining new value and old value.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key, f new_value old_value)@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWith = go+  where+    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f !kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> let !y' = f x y in Bin sy kx y' l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWith #-}+#else+{-# INLINE insertWith #-}+#endif++insertWithR :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithR = go+  where+    go :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a+    go _ !kx x Tip = singleton kx x+    go f !kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> let !y' = f y x in Bin sy ky y' l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithR #-}+#else+{-# INLINE insertWithR #-}+#endif++-- | \(O(\log n)\). Insert with a function, combining key, new value and old value.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert the pair @(key,f key new_value old_value)@.+-- Note that the key passed to f is the same key passed to 'insertWithKey'.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"+--+-- Also see the performance note on 'fromListWith'.++-- See Map.Internal.Note: Type of local 'go' function+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKey = go+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+    -- Forcing `kx` may look redundant, but it's possible `compare` will+    -- be lazy.+    go _ !kx x Tip = singleton kx x+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> let !x' = f kx x y+                  in Bin sy kx x' l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithKey #-}+#else+{-# INLINE insertWithKey #-}+#endif++insertWithKeyR :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+insertWithKeyR = go+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a+    -- Forcing `kx` may look redundant, but it's possible `compare` will+    -- be lazy.+    go _ !kx x Tip = singleton kx x+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> balanceL ky y (go f kx x l) r+            GT -> balanceR ky y l (go f kx x r)+            EQ -> let !y' = f ky y x+                  in Bin sy ky y' l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insertWithKeyR #-}+#else+{-# INLINE insertWithKeyR #-}+#endif++-- | \(O(\log n)\). Combines insert operation with old value retrieval.+-- The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])+--+-- Also see the performance note on 'fromListWith'.++-- See Map.Internal.Note: Type of local 'go' function+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a+                    -> (Maybe a, Map k a)+insertLookupWithKey f0 kx0 x0 t0 = toPair $ go f0 kx0 x0 t0+  where+    go :: Ord k => (k -> a -> a -> a) -> k -> a -> Map k a -> StrictPair (Maybe a) (Map k a)+    go _ !kx x Tip = Nothing :*: singleton kx x+    go f kx x (Bin sy ky y l r) =+        case compare kx ky of+            LT -> let (found :*: l') = go f kx x l+                  in found :*: balanceL ky y l' r+            GT -> let (found :*: r') = go f kx x r+                  in found :*: balanceR ky y l r'+            EQ -> let x' = f kx x y+                  in x' `seq` (Just y :*: Bin sy kx x' l r)+#if __GLASGOW_HASKELL__+{-# INLINABLE insertLookupWithKey #-}+#else+{-# INLINE insertLookupWithKey #-}+#endif++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}++-- | \(O(\log n)\). Update a value at a specific key with the result of the provided function.+-- When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty                         == empty++adjust :: Ord k => (a -> a) -> k -> Map k a -> Map k a+adjust f = adjustWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__+{-# INLINABLE adjust #-}+#else+{-# INLINE adjust #-}+#endif++-- | \(O(\log n)\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty                         == empty++adjustWithKey :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+adjustWithKey = go+  where+    go :: Ord k => (k -> a -> a) -> k -> Map k a -> Map k a+    go _ !_ Tip = Tip+    go f k (Bin sx kx x l r) =+        case compare k kx of+           LT -> Bin sx kx x (go f k l) r+           GT -> Bin sx kx x l (go f k r)+           EQ -> Bin sx kx x' l r+             where !x' = f kx x+#if __GLASGOW_HASKELL__+{-# INLINABLE adjustWithKey #-}+#else+{-# INLINE adjustWithKey #-}+#endif++-- | \(O(\log n)\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update :: Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a+update f = updateWithKey (\_ x -> f x)+#if __GLASGOW_HASKELL__+{-# INLINABLE update #-}+#else+{-# INLINE update #-}+#endif++-- | \(O(\log n)\). The expression (@'updateWithKey' f k map@) updates the+-- value @x@ at @k@ (if it is in the map). If (@f k x@) is 'Nothing',+-- the element is deleted. If it is (@'Just' y@), the key @k@ is bound+-- to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++-- See Map.Internal.Note: Type of local 'go' function+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+updateWithKey = go+  where+    go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> Map k a+    go _ !_ Tip = Tip+    go f k(Bin sx kx x l r) =+        case compare k kx of+           LT -> balanceR kx x (go f k l) r+           GT -> balanceL kx x l (go f k r)+           EQ -> case f kx x of+                   Just x' -> x' `seq` Bin sx kx x' l r+                   Nothing -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE updateWithKey #-}+#else+{-# INLINE updateWithKey #-}+#endif++-- | \(O(\log n)\). Look up and update. See also 'updateWithKey'.+-- This function returns the changed value, if it is updated.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++-- See Map.Internal.Note: Type of local 'go' function+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a,Map k a)+updateLookupWithKey f0 k0 t0 = toPair $ go f0 k0 t0+ where+   go :: Ord k => (k -> a -> Maybe a) -> k -> Map k a -> StrictPair (Maybe a) (Map k a)+   go _ !_ Tip = (Nothing :*: Tip)+   go f k (Bin sx kx x l r) =+          case compare k kx of+               LT -> let (found :*: l') = go f k l+                     in found :*: balanceR kx x l' r+               GT -> let (found :*: r') = go f k r+                     in found :*: balanceL kx x l r'+               EQ -> case f kx x of+                       Just x' -> x' `seq` (Just x' :*: Bin sx kx x' l r)+                       Nothing -> (Just x :*: glue l r)+#if __GLASGOW_HASKELL__+{-# INLINABLE updateLookupWithKey #-}+#else+{-# INLINE updateLookupWithKey #-}+#endif++-- | \(O(\log n)\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in a 'Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+--+-- > let f _ = Nothing+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- >+-- > let f _ = Just "c"+-- > alter f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "c")]+-- > alter f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "c")]+--+-- Note that @'adjust' = alter . fmap@.++-- See Map.Internal.Note: Type of local 'go' function+alter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+alter = go+  where+    go :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a+    go f !k Tip = case f Nothing of+               Nothing -> Tip+               Just x  -> singleton k x++    go f k (Bin sx kx x l r) = case compare k kx of+               LT -> balance kx x (go f k l) r+               GT -> balance kx x l (go f k r)+               EQ -> case f (Just x) of+                       Just x' -> x' `seq` Bin sx kx x' l r+                       Nothing -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE alter #-}+#else+{-# INLINE alter #-}+#endif++-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alterF' can be used to inspect, insert, delete, or update a value in a 'Map'.+-- In short: @'lookup' k \<$\> 'alterF' f k m = f ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> Map Int String -> IO (Map Int String)+-- interactiveAlter k m = alterF f k m where+--   f Nothing = do+--      putStrLn $ show k +++--          " was not found in the map. Would you like to add it?"+--      getUserResponse1 :: IO (Maybe String)+--   f (Just old) = do+--      putStrLn $ "The key is currently bound to " ++ show old +++--          ". Would you like to change or delete it?"+--      getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map. When used with trivial+-- functors like 'Identity' and 'Const', it is often slightly slower than+-- more specialized combinators like 'lookup' and 'insert'. However, when+-- the functor is non-trivial and key comparison is not particularly cheap,+-- it is the fastest way.+--+-- Note on rewrite rules:+--+-- This module includes GHC rewrite rules to optimize 'alterF' for+-- the 'Const' and 'Identity' functors. In general, these rules+-- improve performance. The sole exception is that when using+-- 'Identity', deleting a key that is already absent takes longer+-- than it would without the rules. If you expect this to occur+-- a very large fraction of the time, you might consider using a+-- private copy of the 'Identity' type.+--+-- Note: 'alterF' is a flipped version of the @at@ combinator from+-- @Control.Lens.At@.+--+-- @since 0.5.8+alterF :: (Functor f, Ord k)+       => (Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)+alterF f k m = atKeyImpl Strict k f m++#ifndef __GLASGOW_HASKELL__+{-# INLINE alterF #-}+#else+{-# INLINABLE [2] alterF #-}++-- We can save a little time by recognizing the special case of+-- `Control.Applicative.Const` and just doing a lookup.+{-# RULES+"alterF/Const" forall k (f :: Maybe a -> Const b (Maybe a)) . alterF f k = \m -> Const . getConst . f $ lookup k m+"alterF/Identity" forall k f . alterF f k = atKeyIdentity k f+ #-}++atKeyIdentity :: Ord k => k -> (Maybe a -> Identity (Maybe a)) -> Map k a -> Identity (Map k a)+atKeyIdentity k f t = Identity $ atKeyPlain Strict k (coerce f) t+{-# INLINABLE atKeyIdentity #-}+#endif++{--------------------------------------------------------------------+  Indexing+--------------------------------------------------------------------}++-- | \(O(\log n)\). Update the element at /index/. Calls 'error' when an+-- invalid index is used.+--+-- > updateAt (\ _ _ -> Just "x") 0    (fromList [(5,"a"), (3,"b")]) == fromList [(3, "x"), (5, "a")]+-- > updateAt (\ _ _ -> Just "x") 1    (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "x")]+-- > updateAt (\ _ _ -> Just "x") 2    (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\ _ _ -> Just "x") (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\_ _  -> Nothing)  0    (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"+-- > updateAt (\_ _  -> Nothing)  1    (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > updateAt (\_ _  -> Nothing)  2    (fromList [(5,"a"), (3,"b")])    Error: index out of range+-- > updateAt (\_ _  -> Nothing)  (-1) (fromList [(5,"a"), (3,"b")])    Error: index out of range++updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a+updateAt f i t = i `seq`+  case t of+    Tip -> error "Map.updateAt: index out of range"+    Bin sx kx x l r -> case compare i sizeL of+      LT -> balanceR kx x (updateAt f i l) r+      GT -> balanceL kx x l (updateAt f (i-sizeL-1) r)+      EQ -> case f kx x of+              Just x' -> x' `seq` Bin sx kx x' l r+              Nothing -> glue l r+      where+        sizeL = size l++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}++-- | \(O(\log n)\). Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> Map k a -> Map k a+updateMin f m+  = updateMinWithKey (\_ x -> f x) m++-- | \(O(\log n)\). Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> Map k a -> Map k a+updateMax f m+  = updateMaxWithKey (\_ x -> f x) m+++-- | \(O(\log n)\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMinWithKey _ Tip                 = Tip+updateMinWithKey f (Bin sx kx x Tip r) = case f kx x of+                                           Nothing -> r+                                           Just x' -> x' `seq` Bin sx kx x' Tip r+updateMinWithKey f (Bin _ kx x l r)    = balanceR kx x (updateMinWithKey f l) r++-- | \(O(\log n)\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a+updateMaxWithKey _ Tip                 = Tip+updateMaxWithKey f (Bin sx kx x l Tip) = case f kx x of+                                           Nothing -> l+                                           Just x' -> x' `seq` Bin sx kx x' l Tip+updateMaxWithKey f (Bin _ kx x l r)    = balanceL kx x l (updateMaxWithKey f r)++{--------------------------------------------------------------------+  Union.+--------------------------------------------------------------------}++-- | The union of a list of maps, with a combining operation:+--   (@'unionsWith' f == 'Prelude.foldl' ('unionWith' f) 'empty'@).+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: (Foldable f, Ord k) => (a->a->a) -> f (Map k a) -> Map k a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts+#if __GLASGOW_HASKELL__+{-# INLINABLE unionsWith #-}+#endif++{--------------------------------------------------------------------+  Union with a combining function+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWith :: Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWith _f t1 Tip = t1+unionWith f t1 (Bin _ k x Tip Tip) = insertWithR f k x t1+unionWith f (Bin _ k x Tip Tip) t2 = insertWith f k x t2+unionWith _f Tip t2 = t2+unionWith f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+  (l2, mb, r2) -> link k1 x1' (unionWith f l1 l2) (unionWith f r1 r2)+    where !x1' = maybe x1 (f x1) mb+#if __GLASGOW_HASKELL__+{-# INLINABLE unionWith #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- Union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]+--+-- Also see the performance note on 'fromListWith'.++unionWithKey :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a+unionWithKey _f t1 Tip = t1+unionWithKey f t1 (Bin _ k x Tip Tip) = insertWithKeyR f k x t1+unionWithKey f (Bin _ k x Tip Tip) t2 = insertWithKey f k x t2+unionWithKey _f Tip t2 = t2+unionWithKey f (Bin _ k1 x1 l1 r1) t2 = case splitLookup k1 t2 of+  (l2, mb, r2) -> link k1 x1' (unionWithKey f l1 l2) (unionWithKey f r1 r2)+    where !x1' = maybe x1 (f k1 x1) mb+#if __GLASGOW_HASKELL__+{-# INLINABLE unionWithKey #-}+#endif++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}++-- | \(O(n+m)\). Difference with a combining function.+-- When two equal keys are+-- encountered, the combining function is applied to the values of these keys.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: Ord k => (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWith f = merge preserveMissing dropMissing (zipWithMaybeMatched $ \_ x1 x2 -> f x1 x2)+#if __GLASGOW_HASKELL__+{-# INLINABLE differenceWith #-}+#endif++-- | \(O(n+m)\). Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference). If+-- it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a+differenceWithKey f = merge preserveMissing dropMissing (zipWithMaybeMatched f)+#if __GLASGOW_HASKELL__+{-# INLINABLE differenceWithKey #-}+#endif+++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: Ord k => (a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWith _f Tip _ = Tip+intersectionWith _f _ Tip = Tip+intersectionWith f (Bin _ k x1 l1 r1) t2 = case mb of+    Just x2 -> let !x1' = f x1 x2 in link k x1' l1l2 r1r2+    Nothing -> link2 l1l2 r1r2+  where+    !(l2, mb, r2) = splitLookup k t2+    !l1l2 = intersectionWith f l1 l2+    !r1r2 = intersectionWith f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersectionWith #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c+intersectionWithKey _f Tip _ = Tip+intersectionWithKey _f _ Tip = Tip+intersectionWithKey f (Bin _ k x1 l1 r1) t2 = case mb of+    Just x2 -> let !x1' = f k x1 x2 in link k x1' l1l2 r1r2+    Nothing -> link2 l1l2 r1r2+  where+    !(l2, mb, r2) = splitLookup k t2+    !l1l2 = intersectionWithKey f l1 l2+    !r1r2 = intersectionWithKey f r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersectionWithKey #-}+#endif++-- | Map covariantly over a @'WhenMissing' f k x@.+mapWhenMissing :: Functor f => (a -> b) -> WhenMissing f k x a -> WhenMissing f k x b+mapWhenMissing f q = WhenMissing+  { missingSubtree = fmap (map f) . missingSubtree q+  , missingKey = \k x -> fmap (forceMaybe . fmap f) $ missingKey q k x}++-- | Map covariantly over a @'WhenMatched' f k x y@.+mapWhenMatched :: Functor f => (a -> b) -> WhenMatched f k x y a -> WhenMatched f k x y b+mapWhenMatched f q = WhenMatched+  { matchedKey = \k x y -> fmap (forceMaybe . fmap f) $ runWhenMatched q k x y }++-- | When a key is found in both maps, apply a function to the+-- key and values and maybe use the result in the merged map.+--+-- @+-- zipWithMaybeMatched :: (k -> x -> y -> Maybe z)+--                     -> SimpleWhenMatched k x y z+-- @+zipWithMaybeMatched :: Applicative f+                    => (k -> x -> y -> Maybe z)+                    -> WhenMatched f k x y z+zipWithMaybeMatched f = WhenMatched $+  \k x y -> pure $! forceMaybe $! 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.+zipWithMaybeAMatched :: Applicative f+                     => (k -> x -> y -> f (Maybe z))+                     -> WhenMatched f k x y z+zipWithMaybeAMatched f = WhenMatched $+  \ k x y -> forceMaybe <$> f k x y+{-# INLINE zipWithMaybeAMatched #-}++-- | 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.+zipWithAMatched :: Applicative f+                => (k -> x -> y -> f z)+                -> WhenMatched f k x y z+zipWithAMatched f = WhenMatched $+  \ k x y -> (Just $!) <$> f k x y+{-# INLINE zipWithAMatched #-}++-- | When a key is found in both maps, apply a function to the+-- key and values and use the result in the merged map.+--+-- @+-- zipWithMatched :: (k -> x -> y -> z)+--                -> SimpleWhenMatched k x y z+-- @+zipWithMatched :: Applicative f+               => (k -> x -> y -> z) -> WhenMatched f k x y z+zipWithMatched f = WhenMatched $+  \k x y -> pure $! Just $! f k x y+{-# INLINE zipWithMatched #-}++-- | Map over the entries whose keys are missing from the other map,+-- optionally removing some. This is the most powerful 'SimpleWhenMissing'+-- tactic, but others are usually more efficient.+--+-- @+-- mapMaybeMissing :: (k -> x -> Maybe y) -> SimpleWhenMissing k x y+-- @+--+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))+--+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative' operations.+mapMaybeMissing :: Applicative f => (k -> x -> Maybe y) -> WhenMissing f k x y+mapMaybeMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapMaybeWithKey f m+  , missingKey = \k x -> pure $! forceMaybe $! f k x }+{-# INLINE mapMaybeMissing #-}++-- | Map over the entries whose keys are missing from the other map.+--+-- @+-- mapMissing :: (k -> x -> y) -> SimpleWhenMissing k x y+-- @+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+mapMissing :: Applicative f => (k -> x -> y) -> WhenMissing f k x y+mapMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapWithKey f m+  , missingKey = \k x -> pure $! Just $! f k x }+{-# INLINE mapMissing #-}++-- | 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.+traverseMaybeMissing :: Applicative f+                     => (k -> x -> f (Maybe y)) -> WhenMissing f k x y+traverseMaybeMissing f = WhenMissing+  { missingSubtree = traverseMaybeWithKey f+  , missingKey = \k x -> forceMaybe <$> f k x }+{-# INLINE traverseMaybeMissing #-}++-- | Traverse over the entries whose keys are missing from the other map.+traverseMissing :: Applicative f+                     => (k -> x -> f y) -> WhenMissing f k x y+traverseMissing f = WhenMissing+  { missingSubtree = traverseWithKey f+  , missingKey = \k x -> (Just $!) <$> f k x }+{-# INLINE traverseMissing #-}++forceMaybe :: Maybe a -> Maybe a+forceMaybe Nothing = Nothing+forceMaybe m@(Just !_) = m+{-# INLINE forceMaybe #-}++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | \(O(n+m)\). An unsafe universal combining function.+--+-- __Warning__: This function can produce corrupt maps and its results+-- may depend on the internal structures of its inputs. Users should+-- prefer 'Data.Map.Merge.Strict.merge' or+-- 'Data.Map.Merge.Strict.mergeA'.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'Map's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++mergeWithKey :: Ord k+             => (k -> a -> b -> Maybe c)+             -> (Map k a -> Map k c)+             -> (Map k b -> Map k c)+             -> Map k a -> Map k b -> Map k c+mergeWithKey f g1 g2 = go+  where+    go Tip Tip = Tip+    go Tip t2 = g2 t2+    go t1 Tip = g1 t1+    go (Bin _ kx x l1 r1) t2 =+      case found of+        Nothing -> case g1 (singleton kx x) of+                     Tip -> link2 l' r'+                     (Bin _ _ x' Tip Tip) -> link kx x' l' r'+                     _ -> error "mergeWithKey: Given function only1 does not fulfill required conditions (see documentation)"+        Just x2 -> case f kx x x2 of+                     Nothing -> link2 l' r'+                     Just !x' -> link kx x' l' r'+      where+        (l2, found, r2) = splitLookup kx t2+        l' = go l1 l2+        r' = go r1 r2+{-# INLINE mergeWithKey #-}++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}++-- | \(O(n)\). Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | \(O(n)\). Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b+mapMaybeWithKey _ Tip = Tip+mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of+  Just y  -> y `seq` link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)+  Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r)++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.5.8++traverseMaybeWithKey :: Applicative f+                     => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)+traverseMaybeWithKey = go+  where+    go _ Tip = pure Tip+    go f (Bin _ kx x Tip Tip) = maybe Tip (\ !x' -> Bin 1 kx x' Tip Tip) <$> f kx x+    go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r)+      where+        combine !l' mx !r' = case mx of+          Nothing -> link2 l' r'+          Just !x' -> link kx x' l' r'++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go f (Bin _ kx x l r) = case f kx x of+      Left y  -> y `seq` (link kx y l1 r1 :*: link2 l2 r2)+      Right z -> z `seq` (link2 l1 r1 :*: link kx z l2 r2)+     where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | \(O(n)\). Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Map k a -> Map k b+map f = go+  where+    go Tip = Tip+    go (Bin sx kx x l r) = let !x' = f x in Bin sx kx x' (go l) (go r)+-- We use `go` to let `map` inline. This is important if `f` is a constant+-- function.++#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 :: (k -> a -> b) -> Map k a -> Map k b+mapWithKey _ Tip = Tip+mapWithKey f (Bin sx kx x l r) =+  let x' = f kx x+  in x' `seq` Bin sx kx x' (mapWithKey f l) (mapWithKey f r)++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k $! g k a) xs+"mapWithKey/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 m == 'fromList' \<$\> 'traverse' (\\(k, v) -> (\v' -> v' \`seq\` (k,v')) \<$\> f k v) ('toList' m)@+-- That is, it behaves much like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value and the values are+-- forced before they are installed in the result map.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (k -> a -> t b) -> Map k a -> t (Map k b)+traverseWithKey f = go+  where+    go Tip = pure Tip+    go (Bin 1 k v _ _) = (\ !v' -> Bin 1 k v' Tip Tip) <$> f k v+    go (Bin s k v l r) = liftA3 (\ l' !v' r' -> Bin s k v' l' r') (go l) (f k v) (go r)+{-# INLINE traverseWithKey #-}++-- | \(O(n)\). The function 'mapAccum' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccum f a m+  = mapAccumWithKey (\a' _ x' -> f a' x') a m++-- | \(O(n)\). The function 'mapAccumWithKey' threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | \(O(n)\). The function 'mapAccumL' threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumL _ a Tip               = (a,Tip)+mapAccumL f a (Bin sx kx x l r) =+  let (a1,l') = mapAccumL f a l+      (a2,x') = f a1 kx x+      (a3,r') = mapAccumL f a2 r+  in x' `seq` (a3,Bin sx kx x' l' r')++-- | \(O(n)\). The function 'mapAccumRWithKey' threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c)+mapAccumRWithKey _ a Tip = (a,Tip)+mapAccumRWithKey f a (Bin sx kx x l r) =+  let (a1,r') = mapAccumRWithKey f a r+      (a2,x') = f a1 kx x+      (a3,l') = mapAccumRWithKey f a2 l+  in x' `seq` (a3,Bin sx kx x' l' r')++-- | \(O(n \log n)\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- If `f` is monotonically non-decreasing, this function takes \(O(n)\) time.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@. The value at the greater of the two original keys+-- is used as the first argument to @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"+--+-- Also see the performance note on 'fromListWith'.++mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1->k2) -> Map k1 a -> Map k2 a+mapKeysWith c f m =+  finishB (foldlWithKey' (\b kx x -> insertWithB c (f kx) x b) emptyB m)+#if __GLASGOW_HASKELL__+{-# INLINABLE mapKeysWith #-}+#endif++{--------------------------------------------------------------------+  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.Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Set.empty == empty++fromSet :: (k -> a) -> Set.Set k -> Map k a+fromSet _ Set.Tip = Tip+fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r)++-- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's.+--+-- > fromArgSet (Data.Set.fromList [Arg 3 "aaa", Arg 5 "aaaaa"]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromArgSet Data.Set.empty == empty++fromArgSet :: Set.Set (Arg k a) -> Map k a+fromArgSet Set.Tip = Tip+fromArgSet (Set.Bin sz (Arg x v) l r) = v `seq` Bin sz x v (fromArgSet l) (fromArgSet r)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+-- | \(O(n \log n)\). Build a map from a list of key\/value pairs. See also 'fromAscList'.+-- If the list contains more than one value for the same key, the last value+-- for the key is retained.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: Ord k => [(k,a)] -> Map k a+fromList xs =+  finishB (Foldable.foldl' (\b (kx, !x) -> insertB kx x b) emptyB xs)+{-# INLINE fromList #-} -- INLINE for fusion++-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"x"), (5,"c")] == fromList [(3, "x"), (5, "cba")]+-- > fromListWith (++) [] == empty+--+-- Note the reverse ordering of @"cba"@ in the example.+--+-- The symmetric combining function @f@ is applied in a left-fold over the list, as @f new old@.+--+-- === Performance+--+-- You should ensure that the given @f@ is fast with this order of arguments.+--+-- Symmetric functions may be slow in one order, and fast in another.+-- For the common case of collecting values of matching keys in a list, as above:+--+-- The complexity of @(++) a b@ is \(O(a)\), so it is fast when given a short list as its first argument.+-- Thus:+--+-- > fromListWith       (++)  (replicate 1000000 (3, "x"))   -- O(n),  fast+-- > fromListWith (flip (++)) (replicate 1000000 (3, "x"))   -- O(n²), extremely slow+--+-- because they evaluate as, respectively:+--+-- > fromList [(3, "x" ++ ("x" ++ "xxxxx..xxxxx"))]   -- O(n)+-- > fromList [(3, ("xxxxx..xxxxx" ++ "x") ++ "x")]   -- O(n²)+--+-- Thus, to get good performance with an operation like @(++)@ while also preserving+-- the same order as in the input list, reverse the input:+--+-- > fromListWith (++) (reverse [(5,"a"), (5,"b"), (5,"c")]) == fromList [(5, "abc")]+--+-- and it is always fast to combine singleton-list values @[v]@ with @fromListWith (++)@, as in:+--+-- > fromListWith (++) $ reverse $ map (\(k, v) -> (k, [v])) someListOfTuples++fromListWith :: Ord k => (a -> a -> a) -> [(k,a)] -> Map k a+fromListWith f xs =+  finishB (Foldable.foldl' (\b (kx, x) -> insertWithB f kx x b) emptyB xs)+{-# INLINE fromListWith #-}  -- INLINE for fusion++-- | \(O(n \log n)\). Build a map from a list of key\/value pairs with a combining function. See also 'fromAscListWithKey'.+--+-- If the keys are in non-decreasing order, this function takes \(O(n)\) time.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty+--+-- Also see the performance note on 'fromListWith'.++fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromListWithKey f xs =+  finishB (Foldable.foldl' (\b (kx, x) -> insertWithB (f kx) kx x b) emptyB xs)+{-# INLINE fromListWithKey #-}  -- INLINE for fusion++{--------------------------------------------------------------------+  Building trees from ascending/descending lists can be done in linear time.++  Note that if [xs] is ascending then:+    fromAscList xs       == fromList xs+    fromAscListWith f xs == fromListWith f xs++  If [xs] is descending then:+    fromDescList xs       == fromList xs+    fromDescListWith f xs == fromListWith f xs+--------------------------------------------------------------------}++-- | \(O(n)\). Build a map from an ascending list in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False+fromAscList :: Eq k => [(k,a)] -> Map k a+fromAscList xs+  = fromAscListWithKey (\_ x _ -> x) xs+{-# INLINE fromAscList #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from a descending list in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- > fromDescList [(5,"a"), (3,"b")]          == fromList [(3, "b"), (5, "a")]+-- > fromDescList [(5,"a"), (5,"b"), (3,"a")] == fromList [(3, "b"), (5, "b")]+-- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False+fromDescList :: Eq k => [(k,a)] -> Map k a+fromDescList xs+  = fromDescListWithKey (\_ x _ -> x) xs+{-# INLINE fromDescList #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from an ascending list in linear time with a combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) == True+-- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'.++fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWith f xs+  = fromAscListWithKey (\_ x y -> f x y) xs+{-# INLINE fromAscListWith #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from a descending list in linear time with a combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromListWith' if+-- the precondition may not hold.+--+-- > fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "ba")]+-- > valid (fromDescListWith (++) [(5,"a"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'.++fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a+fromDescListWith f xs+  = fromDescListWithKey (\_ x y -> f x y) xs+{-# INLINE fromDescListWith #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from an ascending list in linear time with a+-- combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-decreasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) == True+-- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'.++fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromAscListWithKey f xs = ascLinkAll (Foldable.foldl' next Nada xs)+  where+    next stk (!ky, y) = case stk of+      Push kx x l stk'+        | ky == kx -> let !y' = f ky y x in Push ky y' l stk'+        | Tip <- l -> y `seq` ascLinkTop stk' 1 (singleton kx x) ky y+        | otherwise -> push ky y Tip stk+      Nada -> push ky y Tip stk+    push kx !x = Push kx x+{-# INLINE fromAscListWithKey #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from a descending list in linear time with a+-- combining function for equal keys.+--+-- __Warning__: This function should be used only if the keys are in+-- non-increasing order. This precondition is not checked. Use 'fromListWithKey'+-- if the precondition may not hold.+--+-- > let f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2+-- > fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")] == fromList [(3, "b"), (5, "5:b5:ba")]+-- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True+-- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False+--+-- Also see the performance note on 'fromListWith'.++fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a+fromDescListWithKey f xs = descLinkAll (Foldable.foldl' next Nada xs)+  where+    next stk (!ky, y) = case stk of+      Push kx x r stk'+        | ky == kx -> let !y' = f ky y x in Push ky y' r stk'+        | Tip <- r -> y `seq` descLinkTop ky y 1 (singleton kx x) stk'+        | otherwise -> push ky y Tip stk+      Nada -> push ky y Tip stk+    push kx !x = Push kx x+{-# INLINE fromDescListWithKey #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctAscList [(3,"b"), (5,"a")])          == True+-- > valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) == False++-- See Note [fromDistinctAscList implementation] in Data.Set.Internal.+fromDistinctAscList :: [(k,a)] -> Map k a+fromDistinctAscList xs = ascLinkAll (Foldable.foldl' next Nada xs)+  where+    next :: Stack k a -> (k, a) -> Stack k a+    next (Push kx x Tip stk) (!ky, !y) = ascLinkTop stk 1 (singleton kx x) ky y+    next stk (!kx, !x) = Push kx x Tip stk+{-# INLINE fromDistinctAscList #-}  -- INLINE for fusion++-- | \(O(n)\). Build a map from a descending list of distinct elements in linear time.+--+-- __Warning__: This function should be used only if the keys are in+-- strictly decreasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- > fromDistinctDescList [(5,"a"), (3,"b")] == fromList [(3, "b"), (5, "a")]+-- > valid (fromDistinctDescList [(5,"a"), (3,"b")])          == True+-- > valid (fromDistinctDescList [(5,"a"), (3,"b"), (3,"a")]) == False++-- See Note [fromDistinctAscList implementation] in Data.Set.Internal.+fromDistinctDescList :: [(k,a)] -> Map k a+fromDistinctDescList xs = descLinkAll (Foldable.foldl' next Nada xs)+  where+    next :: Stack k a -> (k, a) -> Stack k a+    next (Push ky y Tip stk) (!kx, !x) = descLinkTop kx x 1 (singleton ky y) stk+    next stk (!ky, !y) = Push ky y Tip stk+{-# INLINE fromDistinctDescList #-}  -- INLINE for fusion++{--------------------------------------------------------------------+  MapBuilder+--------------------------------------------------------------------}++-- Insert a key and value. The new value is combined with the old value if one+-- already exists for the key. Strict in the inserted value.+insertWithB+  :: Ord k => (a -> a -> a) -> k -> a -> MapBuilder k a -> MapBuilder k a+insertWithB f !ky y b = case b of+  BAsc stk -> case stk of+    Push kx x l stk' -> case compare ky kx of+      LT -> BMap (insertWith f ky y (ascLinkAll stk))+      EQ -> BAsc (push' ky (f y x) l stk')+      GT -> case l of+        Tip -> y `seq` BAsc (ascLinkTop stk' 1 (singleton kx x) ky y)+        Bin{} -> BAsc (push' ky y Tip stk)+    Nada -> BAsc (push' ky y Tip Nada)+  BMap m -> BMap (insertWith f ky y m)+  where+    push' kx !x = Push kx x+{-# INLINE insertWithB #-}
+ src/Data/Sequence.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE CPP #-}+#ifdef __HADDOCK_VERSION__+{-# OPTIONS_GHC -Wno-unused-imports #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Sequence+-- Copyright   :  (c) Ross Paterson 2005+--                (c) Louis Wasserman 2009+--                (c) Bertram Felgenhauer, David Feuer, Ross Paterson, and+--                    Milan Straka 2014+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = Finite sequences+--+-- The @'Seq' a@ type represents a finite sequence of values of+-- type @a@.+--+-- Sequences generally behave very much like lists.+--+-- * The class instances for sequences are all based very closely on those for+-- lists.+--+-- * Many functions in this module have the same names as functions in+-- the "Prelude" or in "Data.List". In almost all cases, these functions+-- behave analogously. For example, 'filter' filters a sequence in exactly the+-- same way that @"Prelude".'Prelude.filter'@ filters a list. The only major+-- exception is the 'lookup' function, which is based on the function by+-- that name in "Data.IntMap" rather than the one in "Prelude".+--+-- There are two major differences between sequences and lists:+--+-- * Sequences support a wider variety of efficient operations than+-- do lists. Notably, they offer+--+--     * Constant-time access to both the front and the rear with+--     '<|', '|>', 'viewl', 'viewr'. For recent GHC versions, this can+--     be done more conveniently using the bidirectional patterns 'Empty',+--     ':<|', and ':|>'. See the detailed explanation in the \"Pattern synonyms\"+--     section.+--     * Logarithmic-time concatenation with '><'+--     * Logarithmic-time splitting with 'splitAt', 'take' and 'drop'+--     * Logarithmic-time access to any element with+--     'lookup', '!?', 'index', 'insertAt', 'deleteAt', 'adjust'', and 'update'+--+--   Note that sequences are typically /slower/ than lists when using only+--   operations for which they have the same big-\(O\) complexity: sequences+--   make rather mediocre stacks!+--+-- * Whereas lists can be either finite or infinite, sequences are+-- always finite. As a result, a sequence is strict in its+-- length. Ignoring efficiency, you can imagine that 'Seq' is defined+--+--     @ data Seq a = Empty | a :<| !(Seq a) @+--+--     This means that many operations on sequences are stricter than+--     those on lists. For example,+--+--     @ (1 : undefined) !! 0 = 1 @+--+--     but+--+--     @ (1 :<| undefined) ``index`` 0 = undefined @+--+-- Sequences may also be compared to immutable+-- [arrays](https://hackage.haskell.org/package/array)+-- or [vectors](https://hackage.haskell.org/package/vector).+-- Like these structures, sequences support fast indexing,+-- although not as fast. But editing an immutable array or vector,+-- or combining it with another, generally requires copying the+-- entire structure; sequences generally avoid that, copying only+-- the portion that has changed.+--+-- == Detailed performance information+--+-- An amortized running time is given for each operation, with \(n\) referring+-- to the length of the sequence and /i/ being the integral index used by+-- some operations. These bounds hold even in a persistent (shared) setting.+--+-- Despite sequences being structurally strict from a semantic standpoint,+-- they are in fact implemented using laziness internally. As a result,+-- many operations can be performed /incrementally/, producing their results+-- as they are demanded. This greatly improves performance in some cases. These+-- functions include+--+-- * The 'Functor' methods 'fmap' and '<$', along with 'mapWithIndex'+-- * The 'Applicative' methods '<*>', '*>', and '<*'+-- * The zips: 'zipWith', 'zip', etc.+-- * 'inits', 'tails'+-- * 'fromFunction', 'replicate', 'intersperse', and 'cycleTaking'+-- * 'reverse'+-- * 'chunksOf'+--+-- Note that the 'Monad' method, '>>=', is not particularly lazy. It will+-- take time proportional to the sum of the logarithms of the individual+-- result sequences to produce anything whatsoever.+--+-- Several functions take special advantage of sharing to produce+-- results using much less time and memory than one might expect. These+-- are documented individually for functions, but also include certain+-- class methods:+--+-- '<$' and '*>' each take time and space proportional+-- to the logarithm of the size of their result.+--+-- '<*' takes time and space proportional to the product of the length+-- of its first argument and the logarithm of the length of its second+-- argument.+--+-- == Warning+--+-- The size of a 'Seq' must not exceed @maxBound::Int@. Violation+-- of this condition is not detected and if the size limit is exceeded, the+-- behaviour of the sequence is undefined. This is unlikely to occur in most+-- applications, but some care may be required when using '><', '<*>', '*>', or+-- '>>', particularly repeatedly and particularly in combination with+-- 'replicate' or 'fromFunction'.+--+-- == Implementation+--+-- The implementation uses 2-3 finger trees annotated with sizes,+-- as described in section 4.2 of+--+--    * Ralf Hinze and Ross Paterson,+--      \"/Finger trees: a simple general-purpose data structure/\",+--      Journal of Functional Programming 16:2 (2006) pp 197-217.+--      <http://staff.city.ac.uk/~ross/papers/FingerTree.html>.+--+-----------------------------------------------------------------------------+++module Data.Sequence (+    -- * Finite sequences+#if defined(DEFINE_PATTERN_SYNONYMS)+    Seq (Empty, (:<|), (:|>)),+    -- $patterns+#else+    Seq,+#endif+    -- * Construction+    empty,          -- :: Seq a+    singleton,      -- :: a -> Seq a+    (<|),           -- :: a -> Seq a -> Seq a+    (|>),           -- :: Seq a -> a -> Seq a+    (><),           -- :: Seq a -> Seq a -> Seq a+    fromList,       -- :: [a] -> Seq a+    fromFunction,   -- :: Int -> (Int -> a) -> Seq a+    fromArray,      -- :: Ix i => Array i a -> Seq a+    -- ** Repetition+    replicate,      -- :: Int -> a -> Seq a+    replicateA,     -- :: Applicative f => Int -> f a -> f (Seq a)+    replicateM,     -- :: Applicative m => Int -> m a -> m (Seq a)+    cycleTaking,    -- :: Int -> Seq a -> Seq a+    -- ** Iterative construction+    iterateN,       -- :: Int -> (a -> a) -> a -> Seq a+    unfoldr,        -- :: (b -> Maybe (a, b)) -> b -> Seq a+    unfoldl,        -- :: (b -> Maybe (b, a)) -> b -> Seq a+    -- * Deconstruction+    -- | Additional functions for deconstructing sequences are available+    -- via the 'Data.Foldable.Foldable' instance of 'Seq'.++    -- ** Queries+    null,           -- :: Seq a -> Bool+    length,         -- :: Seq a -> Int+    -- ** Views+    ViewL(..),+    viewl,          -- :: Seq a -> ViewL a+    ViewR(..),+    viewr,          -- :: Seq a -> ViewR a+    -- * Scans+    scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a+    scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a+    scanr,          -- :: (a -> b -> b) -> b -> Seq a -> Seq b+    scanr1,         -- :: (a -> a -> a) -> Seq a -> Seq a+    -- * Sublists+    tails,          -- :: Seq a -> Seq (Seq a)+    inits,          -- :: Seq a -> Seq (Seq a)+    chunksOf,       -- :: Int -> Seq a -> Seq (Seq a)+    -- ** Sequential searches+    takeWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a+    takeWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a+    dropWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a+    dropWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a+    spanl,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    spanr,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    breakl,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    breakr,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    filter,         -- :: (a -> Bool) -> Seq a -> Seq a+    -- * Sorting+    sort,           -- :: Ord a => Seq a -> Seq a+    sortBy,         -- :: (a -> a -> Ordering) -> Seq a -> Seq a+    sortOn,         -- :: Ord b => (a -> b) -> Seq a -> Seq a+    unstableSort,   -- :: Ord a => Seq a -> Seq a+    unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a+    unstableSortOn, -- :: Ord b => (a -> b) -> Seq a -> Seq a+    -- * Indexing+    lookup,         -- :: Int -> Seq a -> Maybe a+    (!?),           -- :: Seq a -> Int -> Maybe a+    index,          -- :: Seq a -> Int -> a+    adjust,         -- :: (a -> a) -> Int -> Seq a -> Seq a+    adjust',        -- :: (a -> a) -> Int -> Seq a -> Seq a+    update,         -- :: Int -> a -> Seq a -> Seq a+    take,           -- :: Int -> Seq a -> Seq a+    drop,           -- :: Int -> Seq a -> Seq a+    insertAt,       -- :: Int -> a -> Seq a -> Seq a+    deleteAt,       -- :: Int -> Seq a -> Seq a+    splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)+    -- ** Indexing with predicates+    -- | These functions perform sequential searches from the left+    -- or right ends of the sequence, returning indices of matching+    -- elements.+    elemIndexL,     -- :: Eq a => a -> Seq a -> Maybe Int+    elemIndicesL,   -- :: Eq a => a -> Seq a -> [Int]+    elemIndexR,     -- :: Eq a => a -> Seq a -> Maybe Int+    elemIndicesR,   -- :: Eq a => a -> Seq a -> [Int]+    findIndexL,     -- :: (a -> Bool) -> Seq a -> Maybe Int+    findIndicesL,   -- :: (a -> Bool) -> Seq a -> [Int]+    findIndexR,     -- :: (a -> Bool) -> Seq a -> Maybe Int+    findIndicesR,   -- :: (a -> Bool) -> Seq a -> [Int]+    -- * Folds+    -- | General folds are available via the 'Data.Foldable.Foldable' instance+    -- of 'Seq'.+    foldMapWithIndex, -- :: Monoid m => (Int -> a -> m) -> Seq a -> m+    foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b+    foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b+    -- * Transformations+    mapWithIndex,   -- :: (Int -> a -> b) -> Seq a -> Seq b+    traverseWithIndex, -- :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)+    reverse,        -- :: Seq a -> Seq a+    intersperse,    -- :: a -> Seq a -> Seq a+    -- ** Zips and unzip+    zip,            -- :: Seq a -> Seq b -> Seq (a, b)+    zipWith,        -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+    zip3,           -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)+    zipWith3,       -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+    zip4,           -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)+    zipWith4,       -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e+    unzip,          -- :: Seq (a, b) -> (Seq a, Seq b)+    unzipWith       -- :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)+    ) where++import Data.Sequence.Internal+import Data.Sequence.Internal.Sorting+import Prelude ()+#ifdef __HADDOCK_VERSION__+import Control.Monad (Monad (..))+import Data.Functor (Functor (..))+#endif++{- $patterns++== Pattern synonyms++Much like lists can be constructed and matched using the+@:@ and @[]@ constructors, sequences can be constructed and+matched using the 'Empty', ':<|', and ':|>' pattern synonyms.++=== Note++These patterns are only available with GHC version 8.0 or later,+and version 8.2 works better with them. When writing for such recent+versions of GHC, the patterns can be used in place of 'empty',+'<|', '|>', 'viewl', and 'viewr'.++=== __Pattern synonym examples__++Import the patterns:++@+import Data.Sequence (Seq (..))+@++Look at the first three elements of a sequence++@+getFirst3 :: Seq a -> Maybe (a,a,a)+getFirst3 (x1 :<| x2 :<| x3 :<| _xs) = Just (x1,x2,x3)+getFirst3 _ = Nothing+@++@+\> getFirst3 ('fromList' [1,2,3,4]) = Just (1,2,3)+\> getFirst3 ('fromList' [1,2]) = Nothing+@++Move the last two elements from the end of the first list+onto the beginning of the second one.++@+shift2Right :: Seq a -> Seq a -> (Seq a, Seq a)+shift2Right Empty ys = (Empty, ys)+shift2Right (Empty :|> x) ys = (Empty, x :<| ys)+shift2Right (xs :|> x1 :|> x2) ys = (xs, x1 :<| x2 :<| ys)+@++@+\> shift2Right ('fromList' []) ('fromList' [10]) = ('fromList' [], 'fromList' [10])+\> shift2Right ('fromList' [9]) ('fromList' [10]) = ('fromList' [], 'fromList' [9,10])+\> shift2Right ('fromList' [8,9]) ('fromList' [10]) = ('fromList' [], 'fromList' [8,9,10])+\> shift2Right ('fromList' [7,8,9]) ('fromList' [10]) = ('fromList' [7], 'fromList' [8,9,10])+@+-}
+ src/Data/Sequence/Internal.hs view
@@ -0,0 +1,5008 @@+{-# LANGUAGE CPP #-}+#include "containers.h"+{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+#endif+#ifdef DEFINE_PATTERN_SYNONYMS+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+#endif+{-# LANGUAGE PatternGuards #-}++{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Sequence.Internal+-- Copyright   :  (c) Ross Paterson 2005+--                (c) Louis Wasserman 2009+--                (c) Bertram Felgenhauer, David Feuer, Ross Paterson, and+--                    Milan Straka 2014+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite sequences (internals)+--+-- The @'Seq' a@ type represents a finite sequence of values of type @a@.+--+--+-- == Implementation+--+-- The implementation uses 2-3 finger trees annotated with sizes,+-- as described in section 4.2 of+--+--    * Ralf Hinze and Ross Paterson,+--      \"/Finger trees: a simple general-purpose data structure/\",+--      Journal of Functional Programming 16:2 (2006) pp 197-217.+--      <http://staff.city.ac.uk/~ross/papers/FingerTree.html>.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++module Data.Sequence.Internal (+    Elem(..), FingerTree(..), Node(..), Digit(..), Sized(..), MaybeForce,+#if defined(DEFINE_PATTERN_SYNONYMS)+    Seq (.., Empty, (:<|), (:|>)),+#else+    Seq (..),+#endif+    foldDigit,+    foldNode,+    foldWithIndexDigit,+    foldWithIndexNode,++    -- * Construction+    empty,          -- :: Seq a+    singleton,      -- :: a -> Seq a+    (<|),           -- :: a -> Seq a -> Seq a+    (|>),           -- :: Seq a -> a -> Seq a+    (><),           -- :: Seq a -> Seq a -> Seq a+    fromList,       -- :: [a] -> Seq a+    fromFunction,   -- :: Int -> (Int -> a) -> Seq a+    fromArray,      -- :: Ix i => Array i a -> Seq a+    -- ** Repetition+    replicate,      -- :: Int -> a -> Seq a+    replicateA,     -- :: Applicative f => Int -> f a -> f (Seq a)+    replicateM,     -- :: Applicative m => Int -> m a -> m (Seq a)+    cycleTaking,    -- :: Int -> Seq a -> Seq a+    -- ** Iterative construction+    iterateN,       -- :: Int -> (a -> a) -> a -> Seq a+    unfoldr,        -- :: (b -> Maybe (a, b)) -> b -> Seq a+    unfoldl,        -- :: (b -> Maybe (b, a)) -> b -> Seq a+    -- * Deconstruction+    -- | Additional functions for deconstructing sequences are available+    -- via the 'Foldable' instance of 'Seq'.++    -- ** Queries+    null,           -- :: Seq a -> Bool+    length,         -- :: Seq a -> Int+    -- ** Views+    ViewL(..),+    viewl,          -- :: Seq a -> ViewL a+    ViewR(..),+    viewr,          -- :: Seq a -> ViewR a+    -- * Scans+    scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a+    scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a+    scanr,          -- :: (a -> b -> b) -> b -> Seq a -> Seq b+    scanr1,         -- :: (a -> a -> a) -> Seq a -> Seq a+    -- * Sublists+    tails,          -- :: Seq a -> Seq (Seq a)+    inits,          -- :: Seq a -> Seq (Seq a)+    chunksOf,       -- :: Int -> Seq a -> Seq (Seq a)+    -- ** Sequential searches+    takeWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a+    takeWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a+    dropWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a+    dropWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a+    spanl,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    spanr,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    breakl,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    breakr,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+    filter,         -- :: (a -> Bool) -> Seq a -> Seq a+    -- * Indexing+    lookup,         -- :: Int -> Seq a -> Maybe a+    (!?),           -- :: Seq a -> Int -> Maybe a+    index,          -- :: Seq a -> Int -> a+    adjust,         -- :: (a -> a) -> Int -> Seq a -> Seq a+    adjust',        -- :: (a -> a) -> Int -> Seq a -> Seq a+    update,         -- :: Int -> a -> Seq a -> Seq a+    take,           -- :: Int -> Seq a -> Seq a+    drop,           -- :: Int -> Seq a -> Seq a+    insertAt,       -- :: Int -> a -> Seq a -> Seq a+    deleteAt,       -- :: Int -> Seq a -> Seq a+    splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)+    -- ** Indexing with predicates+    -- | These functions perform sequential searches from the left+    -- or right ends of the sequence, returning indices of matching+    -- elements.+    elemIndexL,     -- :: Eq a => a -> Seq a -> Maybe Int+    elemIndicesL,   -- :: Eq a => a -> Seq a -> [Int]+    elemIndexR,     -- :: Eq a => a -> Seq a -> Maybe Int+    elemIndicesR,   -- :: Eq a => a -> Seq a -> [Int]+    findIndexL,     -- :: (a -> Bool) -> Seq a -> Maybe Int+    findIndicesL,   -- :: (a -> Bool) -> Seq a -> [Int]+    findIndexR,     -- :: (a -> Bool) -> Seq a -> Maybe Int+    findIndicesR,   -- :: (a -> Bool) -> Seq a -> [Int]+    -- * Folds+    -- | General folds are available via the 'Foldable' instance of 'Seq'.+    foldMapWithIndex, -- :: Monoid m => (Int -> a -> m) -> Seq a -> m+    foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b+    foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b+    -- * Transformations+    mapWithIndex,   -- :: (Int -> a -> b) -> Seq a -> Seq b+    traverseWithIndex, -- :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)+    reverse,        -- :: Seq a -> Seq a+    intersperse,    -- :: a -> Seq a -> Seq a+    liftA2Seq,      -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+    -- ** Zips and unzips+    zip,            -- :: Seq a -> Seq b -> Seq (a, b)+    zipWith,        -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+    zip3,           -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)+    zipWith3,       -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+    zip4,           -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)+    zipWith4,       -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e+    unzip,          -- :: Seq (a, b) -> (Seq a, Seq b)+    unzipWith,      -- :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)+#ifdef TESTING+    deep,+    node2,+    node3,+#endif+    ) where++import Utils.Containers.Internal.Prelude hiding (+    Functor(..),+#if MIN_VERSION_base(4,11,0)+    (<>),+#endif+    (<$>), Monoid,+    null, length, lookup, take, drop, splitAt,+    scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,+    unzip, takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)+import Prelude ()+import Control.Applicative ((<$>), (<**>),  Alternative,+                            liftA3)+import qualified Control.Applicative as Applicative+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf))+import Control.Monad (MonadPlus(..))+import Data.Monoid (Monoid(..))+import Data.Functor (Functor(..))+import Utils.Containers.Internal.State (State(..), execState)+import Data.Foldable (foldr', toList)+import qualified Data.Foldable as F++import qualified Data.Semigroup as Semigroup+import Data.Functor.Classes+import Data.Traversable++-- GHC specific stuff+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+import Text.Read (Lexeme(Ident), lexP, parens, prec,+    readPrec, readListPrec, readListPrecDefault)+#endif+#ifdef __GLASGOW_HASKELL__+import GHC.Exts (build)+import Data.Data+import Data.String (IsString(..))+import qualified Language.Haskell.TH.Syntax as TH+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+import GHC.Generics (Generic, Generic1)++-- Array stuff, with GHC.Arr on GHC+import qualified GHC.Arr+import Data.Coerce+import qualified GHC.Exts+#else+import qualified Data.List+#endif++import Data.Array (Ix, Array)+import qualified Data.Array++import Data.Functor.Identity (Identity(..))++import Utils.Containers.Internal.StrictPair (StrictPair (..), toPair)+import Control.Monad.Zip (MonadZip (..))+import Control.Monad.Fix (MonadFix (..), fix)++default ()++-- We define our own copy here, for Monoid only, even though this+-- is now a Semigroup operator in base. The essential reason is that+-- we have absolutely no use for semigroups in this module. Everything+-- that needs to sum things up requires a Monoid constraint to deal+-- with empty sequences. I'm not sure if there's a risk of walking+-- through dictionaries to reach <> from Monoid, but I see no reason+-- to risk it.+infixr 6 <>+(<>) :: Monoid m => m -> m -> m+(<>) = mappend+{-# INLINE (<>) #-}++infixr 5 `consTree`+infixl 5 `snocTree`+infixr 5 `appendTree0`++infixr 5 ><+infixr 5 <|, :<+infixl 5 |>, :>++#ifdef DEFINE_PATTERN_SYNONYMS+infixr 5 :<|+infixl 5 :|>++{-# COMPLETE (:<|), Empty #-}+{-# COMPLETE (:|>), Empty #-}++-- | A bidirectional pattern synonym matching an empty sequence.+--+-- @since 0.5.8+pattern Empty :: Seq a+pattern Empty = Seq EmptyT++-- | A bidirectional pattern synonym viewing the front of a non-empty+-- sequence.+--+-- @since 0.5.8+pattern (:<|) :: a -> Seq a -> Seq a+pattern x :<| xs <- (viewl -> x :< xs)+  where+    x :<| xs = x <| xs++-- | A bidirectional pattern synonym viewing the rear of a non-empty+-- sequence.+--+-- @since 0.5.8+pattern (:|>) :: Seq a -> a -> Seq a+pattern xs :|> x <- (viewr -> xs :> x)+  where+    xs :|> x = xs |> x+#endif++class Sized a where+    size :: a -> Int++-- In much the same way that Sized lets us handle the+-- sizes of elements and nodes uniformly, MaybeForce lets+-- us handle their strictness (or lack thereof) uniformly.+-- We can `mseq` something and not have to worry about+-- whether it's an element or a node.+class MaybeForce a where+  maybeRwhnf :: a -> ()++mseq :: MaybeForce a => a -> b -> b+mseq a b = case maybeRwhnf a of () -> b+{-# INLINE mseq #-}++infixr 0 $!?+($!?) :: MaybeForce a => (a -> b) -> a -> b+f $!? a = case maybeRwhnf a of () -> f a+{-# INLINE ($!?) #-}++instance MaybeForce (Elem a) where+  maybeRwhnf _ = ()+  {-# INLINE maybeRwhnf #-}++instance MaybeForce (Node a) where+  maybeRwhnf !_ = ()+  {-# INLINE maybeRwhnf #-}++-- A wrapper making mseq = seq+newtype ForceBox a = ForceBox a+instance MaybeForce (ForceBox a) where+  maybeRwhnf !_ = ()+instance Sized (ForceBox a) where+  size _ = 1++-- | General-purpose finite sequences.+newtype Seq a = Seq (FingerTree (Elem a))++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.6+instance TH.Lift a => TH.Lift (Seq a) where+#  if MIN_VERSION_template_haskell(2,16,0)+  liftTyped t = [|| coerceFT z ||]+#  else+  lift t = [| coerceFT z |]+#  endif+    where+      -- We rebalance the sequence to use only 3-nodes before lifting its+      -- underlying finger tree. This should minimize the size and depth of the+      -- tree generated at run-time. It also reduces the size of the splice,+      -- but I don't know how that affects the size of the resulting Core once+      -- all the types are added.+      Seq ft = zipWith (flip const) (replicate (length t) ()) t++      -- We remove the 'Elem' constructors to reduce the size of the splice+      -- and the number of types and coercions in the generated Core. Instead+      -- of, say,+      --+      --   Seq (Deep 3 (Two (Elem 1) (Elem 2)) EmptyT (One (Elem 3)))+      --+      -- we generate+      --+      --   coerceFT (Deep 3 (Two 1 2)) EmptyT (One 3)+      z :: FingerTree a+      z = coerce ft++-- | We use this to help the types work out for splices in the+-- Lift instance. Things get a bit yucky otherwise.+coerceFT :: FingerTree a -> Seq a+coerceFT = coerce++#endif++instance Functor Seq where+    fmap = fmapSeq+#ifdef __GLASGOW_HASKELL__+    x <$ s = replicate (length s) x+#endif++fmapSeq :: (a -> b) -> Seq a -> Seq b+fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)+#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] fmapSeq #-}+{-# RULES+"fmapSeq/fmapSeq" forall f g xs . fmapSeq f (fmapSeq g xs) = fmapSeq (f . g) xs+"fmapSeq/coerce" fmapSeq coerce = coerce+ #-}+#endif++instance Foldable Seq where+#ifdef __GLASGOW_HASKELL__+    foldMap :: forall m a. Monoid m => (a -> m) -> Seq a -> m+    foldMap = coerce (foldMap :: (Elem a -> m) -> FingerTree (Elem a) -> m)++    foldr :: forall a b. (a -> b -> b) -> b -> Seq a -> b+    foldr = coerce (foldr :: (Elem a -> b -> b) -> b -> FingerTree (Elem a) -> b)++    foldl :: forall b a. (b -> a -> b) -> b -> Seq a -> b+    foldl = coerce (foldl :: (b -> Elem a -> b) -> b -> FingerTree (Elem a) -> b)++    foldr' :: forall a b. (a -> b -> b) -> b -> Seq a -> b+    foldr' = coerce (foldr' :: (Elem a -> b -> b) -> b -> FingerTree (Elem a) -> b)++    foldl' :: forall b a. (b -> a -> b) -> b -> Seq a -> b+    foldl' = coerce (foldl' :: (b -> Elem a -> b) -> b -> FingerTree (Elem a) -> b)++    foldr1 :: forall a. (a -> a -> a) -> Seq a -> a+    foldr1 = coerce (foldr1 :: (Elem a -> Elem a -> Elem a) -> FingerTree (Elem a) -> Elem a)++    foldl1 :: forall a. (a -> a -> a) -> Seq a -> a+    foldl1 = coerce (foldl1 :: (Elem a -> Elem a -> Elem a) -> FingerTree (Elem a) -> Elem a)+#else+    foldMap f (Seq xs) = foldMap (f . getElem) xs++    foldr f z (Seq xs) = foldr (f . getElem) z xs++    foldl f z (Seq xs) = foldl (\z' x -> f z' (getElem x)) z xs++    foldr' f z (Seq xs) = foldr' (f . getElem) z xs++    foldl' f z (Seq xs) = foldl' (\z' x -> f z' (getElem x)) z xs++    foldr1 f (Seq xs) = getElem (foldr1 f' xs)+      where f' (Elem x) (Elem y) = Elem (f x y)++    foldl1 f (Seq xs) = getElem (foldl1 f' xs)+      where f' (Elem x) (Elem y) = Elem (f x y)+#endif++    length = length+    {-# INLINE length #-}+    null   = null+    {-# INLINE null #-}++instance Traversable Seq where+#if __GLASGOW_HASKELL__+    {-# INLINABLE traverse #-}+#endif+    traverse _ (Seq EmptyT) = pure (Seq EmptyT)+    traverse f' (Seq (Single (Elem x'))) =+        (\x'' -> Seq (Single (Elem x''))) <$> f' x'+    traverse f' (Seq (Deep s' pr' m' sf')) =+        liftA3+            (\pr'' m'' sf'' -> Seq (Deep s' pr'' m'' sf''))+            (traverseDigitE f' pr')+            (traverseTree (traverseNodeE f') m')+            (traverseDigitE f' sf')+      where+        traverseTree+            :: Applicative f+            => (Node a -> f (Node b))+            -> FingerTree (Node a)+            -> f (FingerTree (Node b))+        traverseTree _ EmptyT = pure EmptyT+        traverseTree f (Single x) = Single <$> f x+        traverseTree f (Deep s pr m sf) =+            liftA3+                (Deep s)+                (traverseDigitN f pr)+                (traverseTree (traverseNodeN f) m)+                (traverseDigitN f sf)+        traverseDigitE+            :: Applicative f+            => (a -> f b) -> Digit (Elem a) -> f (Digit (Elem b))+        traverseDigitE f (One (Elem a)) =+            (\a' -> One (Elem a')) <$>+            f a+        traverseDigitE f (Two (Elem a) (Elem b)) =+            liftA2+                (\a' b' -> Two (Elem a') (Elem b'))+                (f a)+                (f b)+        traverseDigitE f (Three (Elem a) (Elem b) (Elem c)) =+            liftA3+                (\a' b' c' ->+                      Three (Elem a') (Elem b') (Elem c'))+                (f a)+                (f b)+                (f c)+        traverseDigitE f (Four (Elem a) (Elem b) (Elem c) (Elem d)) =+            liftA3+                (\a' b' c' d' -> Four (Elem a') (Elem b') (Elem c') (Elem d'))+                (f a)+                (f b)+                (f c) <*>+                (f d)+        traverseDigitN+            :: Applicative f+            => (Node a -> f (Node b)) -> Digit (Node a) -> f (Digit (Node b))+        traverseDigitN f t = traverse f t+        traverseNodeE+            :: Applicative f+            => (a -> f b) -> Node (Elem a) -> f (Node (Elem b))+        traverseNodeE f (Node2 s (Elem a) (Elem b)) =+            liftA2+                (\a' b' -> Node2 s (Elem a') (Elem b'))+                (f a)+                (f b)+        traverseNodeE f (Node3 s (Elem a) (Elem b) (Elem c)) =+            liftA3+                (\a' b' c' ->+                      Node3 s (Elem a') (Elem b') (Elem c'))+                (f a)+                (f b)+                (f c)+        traverseNodeN+            :: Applicative f+            => (Node a -> f (Node b)) -> Node (Node a) -> f (Node (Node b))+        traverseNodeN f t = traverse f t++instance NFData a => NFData (Seq a) where+    rnf (Seq xs) = rnf xs++-- | @since 0.8+instance NFData1 Seq where+    liftRnf rnfx (Seq xs) = liftRnf (liftRnf rnfx) xs++instance Monad Seq where+    xs >>= f = foldl' add empty xs+      where add ys x = ys >< f x+    (>>) = (*>)++-- | @since 0.5.11+instance MonadFix Seq where+    mfix = mfixSeq++-- This is just like the instance for lists, but we can take advantage of+-- constant-time length and logarithmic-time indexing to speed things up.+-- Using fromFunction, we make this about as lazy as we can.+mfixSeq :: (a -> Seq a) -> Seq a+mfixSeq f = fromFunction (length (f err)) (\k -> fix (\xk -> f xk `index` k))+  where+    err = error "mfix for Data.Sequence.Seq applied to strict function"++-- | @since 0.5.4+instance Applicative Seq where+    pure = singleton+    xs *> ys = cycleNTimes (length xs) ys+    (<*>) = apSeq+    liftA2 = liftA2Seq+    xs <* ys = beforeSeq xs ys++apSeq :: Seq (a -> b) -> Seq a -> Seq b+apSeq fs xs@(Seq xsFT) = case viewl fs of+  EmptyL -> empty+  firstf :< fs' -> case viewr fs' of+    EmptyR -> fmap firstf xs+    Seq fs''FT :> lastf -> case rigidify xsFT of+         RigidEmpty -> empty+         RigidOne (Elem x) -> fmap ($ x) fs+         RigidTwo (Elem x1) (Elem x2) ->+            Seq $ ap2FT firstf fs''FT lastf (x1, x2)+         RigidThree (Elem x1) (Elem x2) (Elem x3) ->+            Seq $ ap3FT firstf fs''FT lastf (x1, x2, x3)+         RigidFull r@(Rigid s pr _m sf) -> Seq $+               Deep (s * length fs)+                    (fmap (fmap firstf) (nodeToDigit pr))+                    (liftA2Middle (fmap firstf) (fmap lastf) fmap fs''FT r)+                    (fmap (fmap lastf) (nodeToDigit sf))+{-# NOINLINE [1] apSeq #-}++{-# RULES+"ap/fmap1" forall f xs ys . apSeq (fmapSeq f xs) ys = liftA2Seq f xs ys+"ap/fmap2" forall f gs xs . apSeq gs (fmapSeq f xs) =+                              liftA2Seq (\g x -> g (f x)) gs xs+"fmap/ap" forall f gs xs . fmapSeq f (gs `apSeq` xs) =+                             liftA2Seq (\g x -> f (g x)) gs xs+"fmap/liftA2" forall f g m n . fmapSeq f (liftA2Seq g m n) =+                       liftA2Seq (\x y -> f (g x y)) m n+"liftA2/fmap1" forall f g m n . liftA2Seq f (fmapSeq g m) n =+                       liftA2Seq (\x y -> f (g x) y) m n+"liftA2/fmap2" forall f g m n . liftA2Seq f m (fmapSeq g n) =+                       liftA2Seq (\x y -> f x (g y)) m n+ #-}++ap2FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a) -> FingerTree (Elem b)+ap2FT firstf fs lastf (x,y) =+                 Deep (size fs * 2 + 4)+                      (Two (Elem $ firstf x) (Elem $ firstf y))+                      (mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) fs)+                      (Two (Elem $ lastf x) (Elem $ lastf y))++ap3FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a,a) -> FingerTree (Elem b)+ap3FT firstf fs lastf (x,y,z) = Deep (size fs * 3 + 6)+                        (Three (Elem $ firstf x) (Elem $ firstf y) (Elem $ firstf z))+                        (mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) fs)+                        (Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))++lift2FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b) -> FingerTree (Elem c)+lift2FT f firstx xs lastx (y1,y2) =+                 Deep (size xs * 2 + 4)+                      (Two (Elem $ f firstx y1) (Elem $ f firstx y2))+                      (mapMulFT 2 (\(Elem x) -> Node2 2 (Elem (f x y1)) (Elem (f x y2))) xs)+                      (Two (Elem $ f lastx y1) (Elem $ f lastx y2))++lift3FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b,b) -> FingerTree (Elem c)+lift3FT f firstx xs lastx (y1,y2,y3) =+                 Deep (size xs * 3 + 6)+                      (Three (Elem $ f firstx y1) (Elem $ f firstx y2) (Elem $ f firstx y3))+                      (mapMulFT 3 (\(Elem x) -> Node3 3 (Elem (f x y1)) (Elem (f x y2)) (Elem (f x y3))) xs)+                      (Three (Elem $ f lastx y1) (Elem $ f lastx y2) (Elem $ f lastx y3))++liftA2Seq :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+liftA2Seq f xs ys@(Seq ysFT) = case viewl xs of+  EmptyL -> empty+  firstx :< xs' -> case viewr xs' of+    EmptyR -> f firstx <$> ys+    Seq xs''FT :> lastx -> case rigidify ysFT of+      RigidEmpty -> empty+      RigidOne (Elem y) -> fmap (\x -> f x y) xs+      RigidTwo (Elem y1) (Elem y2) ->+        Seq $ lift2FT f firstx xs''FT lastx (y1, y2)+      RigidThree (Elem y1) (Elem y2) (Elem y3) ->+        Seq $ lift3FT f firstx xs''FT lastx (y1, y2, y3)+      RigidFull r@(Rigid s pr _m sf) -> Seq $+        Deep (s * length xs)+             (fmap (fmap (f firstx)) (nodeToDigit pr))+             (liftA2Middle (fmap (f firstx)) (fmap (f lastx)) (lift_elem f) xs''FT r)+             (fmap (fmap (f lastx)) (nodeToDigit sf))+  where+    lift_elem :: (a -> b -> c) -> a -> Elem b -> Elem c+#ifdef __GLASGOW_HASKELL__+    lift_elem = coerce+#else+    lift_elem f x (Elem y) = Elem (f x y)+#endif+{-# NOINLINE [1] liftA2Seq #-}+++data Rigidified a = RigidEmpty+                  | RigidOne a+                  | RigidTwo a a+                  | RigidThree a a a+                  | RigidFull (Rigid a)+#ifdef TESTING+                  deriving Show+#endif++-- | A finger tree whose top level has only Two and/or Three digits, and whose+-- other levels have only One and Two digits. A Rigid tree is precisely what one+-- gets by unzipping/inverting a 2-3 tree, so it is precisely what we need to+-- turn a finger tree into in order to transform it into a 2-3 tree.+data Rigid a = Rigid {-# UNPACK #-} !Int !(Digit23 a) (Thin (Node a)) !(Digit23 a)+#ifdef TESTING+             deriving Show+#endif++-- | A finger tree whose digits are all ones and twos+data Thin a = EmptyTh+            | SingleTh a+            | DeepTh {-# UNPACK #-} !Int !(Digit12 a) (Thin (Node a)) !(Digit12 a)+#ifdef TESTING+            deriving Show+#endif++data Digit12 a = One12 a | Two12 a a+#ifdef TESTING+        deriving Show+#endif++-- | Sometimes, we want to emphasize that we are viewing a node as a top-level+-- digit of a 'Rigid' tree.+type Digit23 a = Node a++-- | 'liftA2Middle' does most of the hard work of computing @liftA2 f xs ys@.  It+-- produces the center part of a finger tree, with a prefix corresponding to+-- the first element of @xs@ and a suffix corresponding to its last element omitted;+-- the missing suffix and prefix are added by the caller.  For the recursive+-- call, it squashes the prefix and the suffix into the center tree. Once it+-- gets to the bottom, it turns the tree into a 2-3 tree, applies 'mapMulFT' to+-- produce the main body, and glues all the pieces together.+--+-- @f@ itself is a bit horrifying because of the nested types involved. Its+-- job is to map over the *elements* of a 2-3 tree, rather than the subtrees.+-- If we used a higher-order nested type with MPTC, we could probably use a+-- class, but as it is we have to build up @f@ explicitly through the+-- recursion.+--+-- === Description of parameters+--+-- ==== Types+--+-- @a@ remains constant through recursive calls (in the @DeepTh@ case),+-- while @b@ and @c@ do not: 'liftAMiddle' calls itself at types @Node b@ and+-- @Node c@.+--+-- ==== Values+--+-- 'liftA2Middle' is used when the original @xs :: Sequence a@ has at+-- least two elements, so it can be decomposed by taking off the first and last+-- elements:+--+-- > xs = firstx <: midxs :> lastx+--+-- - the first two arguments @ffirstx, flastx :: b -> c@ are equal to+--   @f firstx@ and @f lastx@, where @f :: a -> b -> c@ is the third argument.+--   This ensures sharing when @f@ computes some data upon being partially+--   applied to its first argument. The way @f@ gets accumulated also ensures+--   sharing for the middle section.+--+-- - the fourth argument is the middle part @midxs@, always constant.+--+-- - the last argument, a tuple of type @Rigid b@, holds all the elements of+--   @ys@, in three parts: a middle part around which the recursion is+--   structured, surrounded by a prefix and a suffix that accumulate+--   elements on the side as we walk down the middle.+--+-- === Invariants+--+-- > 1. Viewing the various trees as the lists they represent+-- >    (the types of the toList functions are given a few paragraphs below):+-- >+-- >    toListFTN result+-- >      =  (ffirstx                    <$> (toListThinN m ++ toListD sf))+-- >      ++ (f      <$> toListFTE midxs <*> (toListD pr ++ toListThinN m ++ toListD sf))+-- >      ++ (flastx                     <$> (toListD pr ++ toListThinN m))+-- >+-- > 2. s = size m + size pr + size sf+-- >+-- > 3. size (ffirstx y) = size (flastx y) = size (f x y) = size y+-- >      for any (x :: a) (y :: b)+--+-- Projecting invariant 1 on sizes, using 2 and 3 to simplify, we have the+-- following corollary.+-- It is weaker than invariant 1, but it may be easier to keep track of.+--+-- > 1a. size result = s * (size midxs + 1) + size m+--+-- In invariant 1, the types of the auxiliary functions are as follows+-- for reference:+--+-- > toListFTE   :: FingerTree (Elem a) -> [a]+-- > toListFTN   :: FingerTree (Node c) -> [c]+-- > toListThinN :: Thin (Node b) -> [b]+-- > toListD     :: Digit12 b -> [b]+liftA2Middle+  :: (b -> c)              -- ^ @ffirstx@+  -> (b -> c)              -- ^ @flastx@+  -> (a -> b -> c)         -- ^ @f@+  -> FingerTree (Elem a)   -- ^ @midxs@+  -> Rigid b               -- ^ @Rigid s pr m sf@ (@pr@: prefix, @sf@: suffix)+  -> FingerTree (Node c)++-- Not at the bottom yet++liftA2Middle+    ffirstx+    flastx+    f+    midxs+    (Rigid s pr (DeepTh sm prm mm sfm) sf)+    -- note: size (DeepTh sm pr mm sfm) = sm = size pr + size mm + size sfm+    = Deep (sm + s * (size midxs + 1)) -- note: sm = s - size pr - size sf+           (fmap (fmap ffirstx) (digit12ToDigit prm))+           (liftA2Middle+               (fmap ffirstx)+               (fmap flastx)+               (fmap . f)+               midxs+               (Rigid s (squashL pr prm) mm (squashR sfm sf)))+           (fmap (fmap flastx) (digit12ToDigit sfm))++-- At the bottom++liftA2Middle+    ffirstx+    flastx+    f+    midxs+    (Rigid s pr EmptyTh sf)+    = deep+           (One (fmap ffirstx sf))+           (mapMulFT s (\(Elem x) -> fmap (fmap (f x)) converted) midxs)+           (One (fmap flastx pr))+   where converted = node2 pr sf++liftA2Middle+    ffirstx+    flastx+    f+    midxs+    (Rigid s pr (SingleTh q) sf)+    = deep+           (Two (fmap ffirstx q) (fmap ffirstx sf))+           (mapMulFT s (\(Elem x) -> fmap (fmap (f x)) converted) midxs)+           (Two (fmap flastx pr) (fmap flastx q))+   where converted = node3 pr q sf++digit12ToDigit :: Digit12 a -> Digit a+digit12ToDigit (One12 a) = One a+digit12ToDigit (Two12 a b) = Two a b++-- Squash the first argument down onto the left side of the second.+squashL :: Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)+squashL m (One12 n) = node2 m n+squashL m (Two12 n1 n2) = node3 m n1 n2++-- Squash the second argument down onto the right side of the first+squashR :: Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)+squashR (One12 n) m = node2 n m+squashR (Two12 n1 n2) m = node3 n1 n2 m+++-- | \(O(mn)\) (incremental) Takes an \(O(m)\) function and a finger tree of size+-- \(n\) and maps the function over the tree leaves. Unlike the usual 'fmap', the+-- function is applied to the "leaves" of the 'FingerTree' (i.e., given a+-- @FingerTree (Elem a)@, it applies the function to elements of type @Elem+-- a@), replacing the leaves with subtrees of at least the same height, e.g.,+-- @Node(Node(Elem y))@. The multiplier argument serves to make the annotations+-- match up properly.+mapMulFT :: Int -> (a -> b) -> FingerTree a -> FingerTree b+mapMulFT !_ _ EmptyT = EmptyT+mapMulFT _mul f (Single a) = Single (f a)+mapMulFT mul f (Deep s pr m sf) = Deep (mul * s) (fmap f pr) (mapMulFT mul (mapMulNode mul f) m) (fmap f sf)++mapMulNode :: Int -> (a -> b) -> Node a -> Node b+mapMulNode mul f (Node2 s a b)   = Node2 (mul * s) (f a) (f b)+mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c)++-- | \(O(\log n)\) (incremental) Takes the extra flexibility out of a 'FingerTree'+-- to make it a genuine 2-3 finger tree. The result of 'rigidify' will have+-- only two and three digits at the top level and only one and two+-- digits elsewhere. If the tree has fewer than four elements, 'rigidify'+-- will simply extract them, and will not build a tree.+rigidify :: FingerTree (Elem a) -> Rigidified (Elem a)+-- The patterns below just fix up the top level of the tree; 'rigidify'+-- delegates the hard work to 'thin'.++rigidify EmptyT = RigidEmpty++rigidify (Single q) = RigidOne q++-- The left digit is Two or Three+rigidify (Deep s (Two a b) m sf) = rigidifyRight s (node2 a b) m sf+rigidify (Deep s (Three a b c) m sf) = rigidifyRight s (node3 a b c) m sf++-- The left digit is Four+rigidify (Deep s (Four a b c d) m sf) = rigidifyRight s (node2 a b) (node2 c d `consTree` m) sf++-- The left digit is One+rigidify (Deep s (One a) m sf) = case viewLTree m of+   ConsLTree (Node2 _ b c) m' -> rigidifyRight s (node3 a b c) m' sf+   ConsLTree (Node3 _ b c d) m' -> rigidifyRight s (node2 a b) (node2 c d `consTree` m') sf+   EmptyLTree -> case sf of+     One b -> RigidTwo a b+     Two b c -> RigidThree a b c+     Three b c d -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c d)+     Four b c d e -> RigidFull $ Rigid s (node3 a b c) EmptyTh (node2 d e)++-- | \(O(\log n)\) (incremental) Takes a tree whose left side has been rigidified+-- and finishes the job.+rigidifyRight :: Int -> Digit23 (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> Rigidified (Elem a)++-- The right digit is Two, Three, or Four+rigidifyRight s pr m (Two a b) = RigidFull $ Rigid s pr (thin m) (node2 a b)+rigidifyRight s pr m (Three a b c) = RigidFull $ Rigid s pr (thin m) (node3 a b c)+rigidifyRight s pr m (Four a b c d) = RigidFull $ Rigid s pr (thin $ m `snocTree` node2 a b) (node2 c d)++-- The right digit is One+rigidifyRight s pr m (One e) = case viewRTree m of+    SnocRTree m' (Node2 _ a b) -> RigidFull $ Rigid s pr (thin m') (node3 a b e)+    SnocRTree m' (Node3 _ a b c) -> RigidFull $ Rigid s pr (thin $ m' `snocTree` node2 a b) (node2 c e)+    EmptyRTree -> case pr of+      Node2 _ a b -> RigidThree a b e+      Node3 _ a b c -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c e)++-- | \(O(\log n)\) (incremental) Rejigger a finger tree so the digits are all ones+-- and twos.+thin :: Sized a => FingerTree a -> Thin a+-- Note that 'thin12' will produce a 'DeepTh' constructor immediately before+-- recursively calling 'thin'.+thin EmptyT = EmptyTh+thin (Single a) = SingleTh a+thin (Deep s pr m sf) =+  case pr of+    One a -> thin12 s (One12 a) m sf+    Two a b -> thin12 s (Two12 a b) m sf+    Three a b c  -> thin12 s (One12 a) (node2 b c `consTree` m) sf+    Four a b c d -> thin12 s (Two12 a b) (node2 c d `consTree` m) sf++thin12 :: Sized a => Int -> Digit12 a -> FingerTree (Node a) -> Digit a -> Thin a+thin12 s pr m (One a) = DeepTh s pr (thin m) (One12 a)+thin12 s pr m (Two a b) = DeepTh s pr (thin m) (Two12 a b)+thin12 s pr m (Three a b c) = DeepTh s pr (thin $ m `snocTree` node2 a b) (One12 c)+thin12 s pr m (Four a b c d) = DeepTh s pr (thin $ m `snocTree` node2 a b) (Two12 c d)++-- | \( O(n) \). Intersperse an element between the elements of a sequence.+--+-- @+-- intersperse a empty = empty+-- intersperse a (singleton x) = singleton x+-- intersperse a (fromList [x,y]) = fromList [x,a,y]+-- intersperse a (fromList [x,y,z]) = fromList [x,a,y,a,z]+-- @+--+-- @since 0.5.8+intersperse :: a -> Seq a -> Seq a+intersperse y xs = case viewl xs of+  EmptyL -> empty+  p :< ps -> p <| (ps <**> (const y <| singleton id))+-- We used to use+--+-- intersperse y xs = drop 1 $ xs <**> (const y <| singleton id)+--+-- but if length xs = ((maxBound :: Int) `quot` 2) + 1 then+--+-- length (xs <**> (const y <| singleton id)) will wrap around to negative+-- and the drop won't work. The new implementation can produce a result+-- right up to maxBound :: Int++instance MonadPlus Seq where+    mzero = empty+    mplus = (><)++-- | @since 0.5.4+instance Alternative Seq where+    empty = empty+    (<|>) = (><)++instance Eq a => Eq (Seq a) where+  xs == ys = liftEq (==) xs ys+  {-# INLINABLE (==) #-}++instance Ord a => Ord (Seq a) where+  compare xs ys = liftCompare compare xs ys+  {-# INLINABLE compare #-}++#ifdef TESTING+instance Show a => Show (Seq a) where+    showsPrec p (Seq x) = showsPrec p x+#else+instance Show a => Show (Seq a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (toList xs)+#endif++-- | @since 0.5.9+instance Show1 Seq where+  liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $+        showString "fromList " . shwList (toList xs)++-- | @since 0.5.9+instance Eq1 Seq where+  liftEq eq xs ys =+    sameSize xs ys && sameSizeLiftEqLists eq (toList xs) (toList ys)+  {-# INLINE liftEq #-}++-- | @since 0.5.9+instance Ord1 Seq where+  liftCompare f xs ys = liftCmpLists f (toList xs) (toList ys)+  {-# INLINE liftCompare #-}++-- Note [Eq and Ord]+-- ~~~~~~~~~~~~~~~~~+-- Eq and Ord for Seq are implemented by converting to lists, which turns out+-- to be quite efficient.+-- However, we define our own functions to work with lists because the relevant+-- list functions in base have performance issues (liftEq and liftCompare are+-- recursive and cannot inline, (==) and compare are not INLINABLE and cannot+-- specialize).++-- Same as `length xs == length ys` but uses the structure invariants to skip+-- unnecessary cases.+sameSize :: Seq a -> Seq b -> Bool+sameSize (Seq t1) (Seq t2) = case (t1, t2) of+  (EmptyT, EmptyT) -> True+  (Single _, Single _) -> True+  (Deep v1 _ _ _, Deep v2 _ _ _) -> v1 == v2+  _ -> False++-- Assumes the lists are of equal size to skip some cases.+sameSizeLiftEqLists :: (a -> b -> Bool) -> [a] -> [b] -> Bool+sameSizeLiftEqLists eq = go+  where+    go (x:xs) (y:ys) = eq x y && go xs ys+    go _ _ = True+{-# INLINE sameSizeLiftEqLists #-}++liftCmpLists :: (a -> b -> Ordering) -> [a] -> [b] -> Ordering+liftCmpLists cmp = go+  where+    go [] [] = EQ+    go [] (_:_) = LT+    go (_:_) [] = GT+    go (x:xs) (y:ys) = cmp x y <> go xs ys+{-# INLINE liftCmpLists #-}++instance Read a => Read (Seq a) where+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+    readPrec = parens $ prec 10 $ do+        Ident "fromList" <- lexP+        xs <- readPrec+        return (fromList xs)++    readListPrec = readListPrecDefault+#else+    readsPrec p = readParen (p > 10) $ \ r -> do+        ("fromList",s) <- lex r+        (xs,t) <- reads s+        return (fromList xs,t)+#endif++-- | @since 0.5.9+instance Read1 Seq where+  liftReadsPrec _rp readLst p = readParen (p > 10) $ \r -> do+    ("fromList",s) <- lex r+    (xs,t) <- readLst s+    pure (fromList xs, t)++-- | @mempty@ = 'empty'+instance Monoid (Seq a) where+    mempty = empty+    mappend = (Semigroup.<>)++-- | @(<>)@ = '(><)'+--+-- @since 0.5.7+instance Semigroup.Semigroup (Seq a) where+    (<>)    = (><)+    stimes = cycleNTimes . fromIntegral++#if __GLASGOW_HASKELL__+instance Data a => Data (Seq a) where+    gfoldl f z s    = case viewl s of+        EmptyL  -> z empty+        x :< xs -> z (<|) `f` x `f` xs++    gunfold k z c   = case constrIndex c of+        1 -> z empty+        2 -> k (k (z (<|)))+        _ -> error "gunfold"++    toConstr xs+      | null xs     = emptyConstr+      | otherwise   = consConstr++    dataTypeOf _    = seqDataType++    dataCast1 f     = gcast1 f++emptyConstr, consConstr :: Constr+emptyConstr = mkConstr seqDataType "empty" [] Prefix+consConstr  = mkConstr seqDataType "<|" [] Infix++seqDataType :: DataType+seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]+#endif++-- Finger trees++data FingerTree a+    = EmptyT+    | Single a+    | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)+#ifdef TESTING+    deriving Show+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.1+deriving instance Generic1 FingerTree++-- | @since 0.6.1+deriving instance Generic (FingerTree a)++-- | @since 0.6.6+deriving instance TH.Lift a => TH.Lift (FingerTree a)+#endif++instance Sized a => Sized (FingerTree a) where+    {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}+    {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}+    size EmptyT             = 0+    size (Single x)         = size x+    size (Deep v _ _ _)     = v++instance Foldable FingerTree where+    foldMap _ EmptyT = mempty+    foldMap f' (Single x') = f' x'+    foldMap f' (Deep _ pr' m' sf') =+        foldMapDigit f' pr' <>+        foldMapTree (foldMapNode f') m' <>+        foldMapDigit f' sf'+      where+        foldMapTree :: Monoid m => (Node a -> m) -> FingerTree (Node a) -> m+        foldMapTree _ EmptyT = mempty+        foldMapTree f (Single x) = f x+        foldMapTree f (Deep _ pr m sf) =+            foldMapDigitN f pr <>+            foldMapTree (foldMapNodeN f) m <>+            foldMapDigitN f sf++        foldMapDigit :: Monoid m => (a -> m) -> Digit a -> m+        foldMapDigit f t = foldDigit (<>) f t++        foldMapDigitN :: Monoid m => (Node a -> m) -> Digit (Node a) -> m+        foldMapDigitN f t = foldDigit (<>) f t++        foldMapNode :: Monoid m => (a -> m) -> Node a -> m+        foldMapNode f t = foldNode (<>) f t++        foldMapNodeN :: Monoid m => (Node a -> m) -> Node (Node a) -> m+        foldMapNodeN f t = foldNode (<>) f t+#if __GLASGOW_HASKELL__+    {-# INLINABLE foldMap #-}+#endif++    foldr _ z' EmptyT = z'+    foldr f' z' (Single x') = x' `f'` z'+    foldr f' z' (Deep _ pr' m' sf') =+        foldrDigit f' (foldrTree (foldrNode f') (foldrDigit f' z' sf') m') pr'+      where+        foldrTree :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b+        foldrTree _ z EmptyT = z+        foldrTree f z (Single x) = x `f` z+        foldrTree f z (Deep _ pr m sf) =+            foldrDigitN f (foldrTree (foldrNodeN f) (foldrDigitN f z sf) m) pr++        foldrDigit :: (a -> b -> b) -> b -> Digit a -> b+        foldrDigit f z t = foldr f z t++        foldrDigitN :: (Node a -> b -> b) -> b -> Digit (Node a) -> b+        foldrDigitN f z t = foldr f z t++        foldrNode :: (a -> b -> b) -> Node a -> b -> b+        foldrNode f t z = foldr f z t++        foldrNodeN :: (Node a -> b -> b) -> Node (Node a) -> b -> b+        foldrNodeN f t z = foldr f z t+    {-# INLINE foldr #-}+++    foldl _ z' EmptyT = z'+    foldl f' z' (Single x') = z' `f'` x'+    foldl f' z' (Deep _ pr' m' sf') =+        foldlDigit f' (foldlTree (foldlNode f') (foldlDigit f' z' pr') m') sf'+      where+        foldlTree :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b+        foldlTree _ z EmptyT = z+        foldlTree f z (Single x) = z `f` x+        foldlTree f z (Deep _ pr m sf) =+            foldlDigitN f (foldlTree (foldlNodeN f) (foldlDigitN f z pr) m) sf++        foldlDigit :: (b -> a -> b) -> b -> Digit a -> b+        foldlDigit f z t = foldl f z t++        foldlDigitN :: (b -> Node a -> b) -> b -> Digit (Node a) -> b+        foldlDigitN f z t = foldl f z t++        foldlNode :: (b -> a -> b) -> b -> Node a -> b+        foldlNode f z t = foldl f z t++        foldlNodeN :: (b -> Node a -> b) -> b -> Node (Node a) -> b+        foldlNodeN f z t = foldl f z t+    {-# INLINE foldl #-}++    foldr' _  !z' EmptyT = z'+    foldr' f' !z' (Single x') = f' x' z'+    foldr' f' !z' (Deep _ pr' m' sf') =+        (foldrDigit' f' $! (foldrTree' (foldrNode' f') $! (foldrDigit' f' z') sf') m') pr'+      where+        foldrTree' :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b+        foldrTree' _ !z EmptyT = z+        foldrTree' f !z (Single x) = f x z+        foldrTree' f !z (Deep _ pr m sf) =+            (foldr' f $! (foldrTree' (foldrNodeN' f) $! foldr' f z sf) m) pr++        foldrDigit' :: (a -> b -> b) -> b -> Digit a -> b+        foldrDigit' f z t = foldr' f z t++        foldrNode' :: (a -> b -> b) -> Node a -> b -> b+        foldrNode' f t z = foldr' f z t++        foldrNodeN' :: (Node a -> b -> b) -> Node (Node a) -> b -> b+        foldrNodeN' f t z = foldr' f z t+    {-# INLINE foldr' #-}++    foldl' _  !z' EmptyT = z'+    foldl' f' !z' (Single x') = f' z' x'+    foldl' f' !z' (Deep _ pr' m' sf') =+        (foldlDigit' f' $!+         (foldlTree' (foldlNode' f') $! (foldlDigit' f' z') pr') m')+            sf'+      where+        foldlTree' :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b+        foldlTree' _ !z EmptyT = z+        foldlTree' f !z (Single xs) = f z xs+        foldlTree' f !z (Deep _ pr m sf) =+            (foldl' f $! (foldlTree' (foldl' f) $! foldl' f z pr) m) sf++        foldlDigit' :: (b -> a -> b) -> b -> Digit a -> b+        foldlDigit' f z t = foldl' f z t++        foldlNode' :: (b -> a -> b) -> b -> Node a -> b+        foldlNode' f z t = foldl' f z t+    {-# INLINE foldl' #-}++    foldr1 _ EmptyT = error "foldr1: empty sequence"+    foldr1 _ (Single x) = x+    foldr1 f (Deep _ pr m sf) =+        foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr++    foldl1 _ EmptyT = error "foldl1: empty sequence"+    foldl1 _ (Single x) = x+    foldl1 f (Deep _ pr m sf) =+        foldl f (foldl (foldl f) (foldl1 f pr) m) sf++instance Functor FingerTree where+    fmap _ EmptyT = EmptyT+    fmap f (Single x) = Single (f x)+    fmap f (Deep v pr m sf) =+        Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)++instance Traversable FingerTree where+    traverse _ EmptyT = pure EmptyT+    traverse f (Single x) = Single <$> f x+    traverse f (Deep v pr m sf) =+        liftA3 (Deep v) (traverse f pr) (traverse (traverse f) m)+            (traverse f sf)++instance NFData a => NFData (FingerTree a) where+    rnf EmptyT = ()+    rnf (Single x) = rnf x+    rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m++-- | @since 0.8+instance NFData1 FingerTree where+    liftRnf _ EmptyT = ()+    liftRnf rnfx (Single x) = rnfx x+    liftRnf rnfx (Deep _ pr m sf) = liftRnf rnfx pr `seq` liftRnf (liftRnf rnfx) m `seq` liftRnf rnfx sf++{-# INLINE deep #-}+deep            :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a+deep pr m sf    =  Deep (size pr + size m + size sf) pr m sf++{-# INLINE pullL #-}+pullL :: Int -> FingerTree (Node a) -> Digit a -> FingerTree a+pullL s m sf = case viewLTree m of+    EmptyLTree          -> digitToTree' s sf+    ConsLTree pr m'     -> Deep s (nodeToDigit pr) m' sf++{-# INLINE pullR #-}+pullR :: Int -> Digit a -> FingerTree (Node a) -> FingerTree a+pullR s pr m = case viewRTree m of+    EmptyRTree          -> digitToTree' s pr+    SnocRTree m' sf     -> Deep s pr m' (nodeToDigit sf)++-- Digits++data Digit a+    = One a+    | Two a a+    | Three a a a+    | Four a a a a+#ifdef TESTING+    deriving Show+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.1+deriving instance Generic1 Digit++-- | @since 0.6.1+deriving instance Generic (Digit a)++-- | @since 0.6.6+deriving instance TH.Lift a => TH.Lift (Digit a)+#endif++foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b+foldDigit _     f (One a) = f a+foldDigit (<+>) f (Two a b) = f a <+> f b+foldDigit (<+>) f (Three a b c) = f a <+> f b <+> f c+foldDigit (<+>) f (Four a b c d) = f a <+> f b <+> f c <+> f d+{-# INLINE foldDigit #-}++instance Foldable Digit where+    foldMap = foldDigit mappend++    foldr f z (One a) = a `f` z+    foldr f z (Two a b) = a `f` (b `f` z)+    foldr f z (Three a b c) = a `f` (b `f` (c `f` z))+    foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))+    {-# INLINE foldr #-}++    foldl f z (One a) = z `f` a+    foldl f z (Two a b) = (z `f` a) `f` b+    foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c+    foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d+    {-# INLINE foldl #-}++    foldr' f !z (One a) = f a z+    foldr' f !z (Two a b) = f a $! f b z+    foldr' f !z (Three a b c) = f a $! f b $! f c z+    foldr' f !z (Four a b c d) = f a $! f b $! f c $! f d z+    {-# INLINE foldr' #-}++    foldl' f !z (One a) = f z a+    foldl' f !z (Two a b) = (f $! f z a) b+    foldl' f !z (Three a b c) = (f $! (f $! f z a) b) c+    foldl' f !z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d+    {-# INLINE foldl' #-}++    foldr1 _ (One a) = a+    foldr1 f (Two a b) = a `f` b+    foldr1 f (Three a b c) = a `f` (b `f` c)+    foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))++    foldl1 _ (One a) = a+    foldl1 f (Two a b) = a `f` b+    foldl1 f (Three a b c) = (a `f` b) `f` c+    foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d++instance Functor Digit where+    {-# INLINE fmap #-}+    fmap f (One a) = One (f a)+    fmap f (Two a b) = Two (f a) (f b)+    fmap f (Three a b c) = Three (f a) (f b) (f c)+    fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)++instance Traversable Digit where+    {-# INLINE traverse #-}+    traverse f (One a) = One <$> f a+    traverse f (Two a b) = liftA2 Two (f a) (f b)+    traverse f (Three a b c) = liftA3 Three (f a) (f b) (f c)+    traverse f (Four a b c d) = liftA3 Four (f a) (f b) (f c) <*> f d++instance NFData a => NFData (Digit a) where+    rnf (One a) = rnf a+    rnf (Two a b) = rnf a `seq` rnf b+    rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c+    rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d++-- | @since 0.8+instance NFData1 Digit where+    liftRnf rnfx (One a) = rnfx a+    liftRnf rnfx (Two a b) = rnfx a `seq` rnfx b+    liftRnf rnfx (Three a b c) = rnfx a `seq` rnfx b `seq` rnfx c+    liftRnf rnfx (Four a b c d) = rnfx a `seq` rnfx b `seq` rnfx c `seq` rnfx d++instance Sized a => Sized (Digit a) where+    {-# INLINE size #-}+    size = foldl1 (+) . fmap size++{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}+digitToTree     :: Sized a => Digit a -> FingerTree a+digitToTree (One a) = Single a+digitToTree (Two a b) = deep (One a) EmptyT (One b)+digitToTree (Three a b c) = deep (Two a b) EmptyT (One c)+digitToTree (Four a b c d) = deep (Two a b) EmptyT (Two c d)++-- | Given the size of a digit and the digit itself, efficiently converts+-- it to a FingerTree.+digitToTree' :: Int -> Digit a -> FingerTree a+digitToTree' n (Four a b c d) = Deep n (Two a b) EmptyT (Two c d)+digitToTree' n (Three a b c) = Deep n (Two a b) EmptyT (One c)+digitToTree' n (Two a b) = Deep n (One a) EmptyT (One b)+digitToTree' !_n (One a) = Single a++-- Nodes++data Node a+    = Node2 {-# UNPACK #-} !Int a a+    | Node3 {-# UNPACK #-} !Int a a a+#ifdef TESTING+    deriving Show+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.1+deriving instance Generic1 Node++-- | @since 0.6.1+deriving instance Generic (Node a)++-- | @since 0.6.6+deriving instance TH.Lift a => TH.Lift (Node a)+#endif++foldNode :: (b -> b -> b) -> (a -> b) -> Node a -> b+foldNode (<+>) f (Node2 _ a b) = f a <+> f b+foldNode (<+>) f (Node3 _ a b c) = f a <+> f b <+> f c+{-# INLINE foldNode #-}++instance Foldable Node where+    foldMap = foldNode mappend++    foldr f z (Node2 _ a b) = a `f` (b `f` z)+    foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))+    {-# INLINE foldr #-}++    foldl f z (Node2 _ a b) = (z `f` a) `f` b+    foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c+    {-# INLINE foldl #-}++    foldr' f !z (Node2 _ a b) = f a $! f b z+    foldr' f !z (Node3 _ a b c) = f a $! f b $! f c z+    {-# INLINE foldr' #-}++    foldl' f !z (Node2 _ a b) = (f $! f z a) b+    foldl' f !z (Node3 _ a b c) = (f $! (f $! f z a) b) c+    {-# INLINE foldl' #-}++instance Functor Node where+    {-# INLINE fmap #-}+    fmap f (Node2 v a b) = Node2 v (f a) (f b)+    fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)++instance Traversable Node where+    {-# INLINE traverse #-}+    traverse f (Node2 v a b) = liftA2 (Node2 v) (f a) (f b)+    traverse f (Node3 v a b c) = liftA3 (Node3 v) (f a) (f b) (f c)++instance NFData a => NFData (Node a) where+    rnf (Node2 _ a b) = rnf a `seq` rnf b+    rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c++-- | @since 0.8+instance NFData1 Node where+    liftRnf rnfx (Node2 _ a b) = rnfx a `seq` rnfx b+    liftRnf rnfx (Node3 _ a b c) = rnfx a `seq` rnfx b `seq` rnfx c++instance Sized (Node a) where+    size (Node2 v _ _)      = v+    size (Node3 v _ _ _)    = v++{-# INLINE node2 #-}+node2           :: Sized a => a -> a -> Node a+node2 a b       =  Node2 (size a + size b) a b++{-# INLINE node3 #-}+node3           :: Sized a => a -> a -> a -> Node a+node3 a b c     =  Node3 (size a + size b + size c) a b c++nodeToDigit :: Node a -> Digit a+nodeToDigit (Node2 _ a b) = Two a b+nodeToDigit (Node3 _ a b c) = Three a b c++-- Elements++newtype Elem a  =  Elem { getElem :: a }+#ifdef TESTING+    deriving Show+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.6.1+deriving instance Generic1 Elem++-- | @since 0.6.1+deriving instance Generic (Elem a)+#endif++instance Sized (Elem a) where+    size _ = 1++instance Functor Elem where+#ifdef __GLASGOW_HASKELL__+-- This cuts the time for <*> by around a fifth.+    fmap = coerce+#else+    fmap f (Elem x) = Elem (f x)+#endif++instance Foldable Elem where+    foldr f z (Elem x) = f x z+#ifdef __GLASGOW_HASKELL__+    foldMap = coerce+    foldl = coerce+    foldl' = coerce+#else+    foldMap f (Elem x) = f x+    foldl f z (Elem x) = f z x+    foldl' f z (Elem x) = f z x+#endif++instance Traversable Elem where+    traverse f (Elem x) = Elem <$> f x++instance NFData a => NFData (Elem a) where+    rnf (Elem x) = rnf x++-- | @since 0.8+instance NFData1 Elem where+    liftRnf rnfx (Elem x) = rnfx x++-------------------------------------------------------+-- Applicative construction+-------------------------------------------------------++-- | 'applicativeTree' takes an Applicative-wrapped construction of a+-- piece of a FingerTree, assumed to always have the same size (which+-- is put in the second argument), and replicates it as many times as+-- specified.  This is a generalization of 'replicateA', which itself+-- is a generalization of many Data.Sequence methods.+{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}+{-# SPECIALIZE applicativeTree :: Int -> Int -> Identity a -> Identity (FingerTree a) #-}+-- Special note: the Identity specialization automatically does node sharing,+-- reducing memory usage of the resulting tree to \(O(\log n)\).+applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)+applicativeTree n !mSize m = case n of+    0 -> pure EmptyT+    1 -> fmap Single m+    2 -> deepA one emptyTree one+    3 -> deepA two emptyTree one+    4 -> deepA two emptyTree two+    5 -> deepA three emptyTree two+    6 -> deepA three emptyTree three+    _ -> case n `quotRem` 3 of+           (q,0) -> deepA three (applicativeTree (q - 2) mSize' n3) three+           (q,1) -> deepA two (applicativeTree (q - 1) mSize' n3) two+           (q,_) -> deepA three (applicativeTree (q - 1) mSize' n3) two+      where !mSize' = 3 * mSize+            n3 = liftA3 (Node3 mSize') m m m+  where+    one = fmap One m+    two = liftA2 Two m m+    three = liftA3 Three m m m+    deepA = liftA3 (Deep (n * mSize))+    emptyTree = pure EmptyT++data RCountMid a = RCountMid+  !(Node a)  -- End of the first+  !Int -- Number of units in the middle+  !(Node a)  -- Beginning of the last++{-+We could generalize beforeSeq quite easily to++  beforeSeq :: (a -> c) -> Seq a -> Seq b -> Seq c++This would let us add a rewrite rule++  fmap f xs <* ys  ==>  beforeSeq f xs ys++We don't currently bother because I don't yet know of a practical use for (<*)+for sequences; a rewrite rule to optimize it seems like extreme overkill.+-}++beforeSeq :: Seq a -> Seq b -> Seq a+beforeSeq xs ys = replicateEach (length ys) xs++-- | Replicate each element of a sequence the given number of times.+--+-- @replicateEach 3 [1,2] = [1,1,1,2,2,2]@+-- @replicateEach n xs = xs >>= replicate n@+replicateEach :: Int -> Seq a -> Seq a+-- The main idea is that we construct a function that takes an element and+-- produces a 2-3 tree representing that element replicated lenys times. We map+-- that function over the sequence to (mostly) produce the desired fingertree. But+-- if we *just* did that, we'd end up with a fingertree of 2-3 trees of the given+-- size, not of elements. So we need to work our way down to the appropriate+-- level by building the left side of the fingertree corresponding to the first+-- 2-3 tree and the right side corresponding to the last one, along with the+-- 2-3 trees corresponding to the right side of the first and the left side of+-- the last.+replicateEach lenys xs = case viewl xs of+  EmptyL -> empty+  firstx :< xs' -> case viewr xs' of+    EmptyR -> replicate lenys firstx+    Seq midxs :> lastx -> case lenys of+      0 -> empty+      1 -> xs+      2 ->+        Seq $ rep2EachFT fxE midxs lxE+      3 ->+        Seq $ rep3EachFT fxE midxs lxE+      _ -> Seq $ case lenys `quotRem` 3 of  -- lenys > 3+             (q,0) -> Deep (lenys * length xs) fd3+               (repEachMiddle_ lift_elem (RCountMid fn3 (q - 2) ln3))+               ld3+                   where+                    lift_elem a = let n3a = n3 a in (n3a, n3a, n3a)+             (q,1) -> Deep (lenys * length xs) fd2+               (repEachMiddle_ lift_elem (RCountMid fn2 (q - 1) ln2))+               ld2+                   where+                    lift_elem a = let n2a = n2 a in (n2a, n3 a, n2a)+             (q,_) -> Deep (lenys * length xs) fd3+               (repEachMiddle_ lift_elem (RCountMid fn2 (q - 1) ln3))+               ld2+                   where+                    lift_elem a = let n3a = n3 a in (n3a, n3a, n2 a)+        where+          repEachMiddle_ = repEachMiddle midxs lenys 3 fn3 ln3+          fd2 = Two fxE fxE+          fd3 = Three fxE fxE fxE+          ld2 = Two lxE lxE+          ld3 = Three lxE lxE lxE+          fn2 = Node2 2 fxE fxE+          fn3 = Node3 3 fxE fxE fxE+          ln2 = Node2 2 lxE lxE+          ln3 = Node3 3 lxE lxE lxE+          n3 a = Node3 3 (Elem a) (Elem a) (Elem a)+          n2 a = Node2 2 (Elem a) (Elem a)+      where+          fxE = Elem firstx+          lxE = Elem lastx++rep2EachFT :: Elem a -> FingerTree (Elem a) -> Elem a -> FingerTree (Elem a)+rep2EachFT firstx xs lastx =+                 Deep (size xs * 2 + 4)+                      (Two firstx firstx)+                      (mapMulFT 2 (\ex -> Node2 2 ex ex) xs)+                      (Two lastx lastx)++rep3EachFT :: Elem a -> FingerTree (Elem a) -> Elem a -> FingerTree (Elem a)+rep3EachFT firstx xs lastx =+                 Deep (size xs * 3 + 6)+                      (Three firstx firstx firstx)+                      (mapMulFT 3 (\ex -> Node3 3 ex ex ex) xs)+                      (Three lastx lastx lastx)++-- Invariants for repEachMiddle:+--+-- 1. midxs is constant: the middle bit in the original sequence (xs = (first <: Seq midxs :> last))+-- 2. lenys is constant: the length of ys+-- 3. firstx and pr repeat the same element: the first one in the original sequence xs+-- 4. lastx  and sf repeat the same element: the last  one in the original sequence xs+-- 5. sizec = size firstx = size lastx+-- 6. lenys = deep_count * sizec + size pr + size pf+-- 7. let (lft, fill, rght) = fill23 x, for any x:+--      7a. All three sequences repeat the element x+--      7b. size fill = sizec+--      7c. size lft  = size sf+--      7d. size rght = size pr+-- 8. size result = deep_count * sizec + lenys * (size midxs + 1)+repEachMiddle+  :: FingerTree (Elem a)  -- midxs+  -> Int                  -- lenys+  -> Int                  -- sizec+  -> Node c               -- firstx+  -> Node c               -- lastx+  -> (a -> (Node c, Node c, Node c))  -- fill23+  -> RCountMid c          -- (RCountMid pr deep_count sf)+  -> FingerTree (Node c)  -- result++-- At the bottom++repEachMiddle midxs lenys+            !_sizec+            _firstx+            _lastx+            fill23+            (RCountMid pr 0 sf)+     = Deep (lenys * (size midxs + 1))+            (One pr)+            (mapMulFT lenys fill23_final midxs)+            (One sf)+   where+     -- fill23_final ::  Elem a -> Node (Node c)+     fill23_final (Elem a) = case fill23 a of+        -- See the note on lift_fill23 for an explanation of this+        -- lazy pattern.+        ~(lft, _fill, rght) -> Node2 (size pr + size sf) lft rght++repEachMiddle midxs lenys+            !sizec+            firstx+            lastx+            fill23+            (RCountMid pr 1 sf)+     = Deep (sizec + lenys * (size midxs + 1))+            (Two pr firstx)+            (mapMulFT lenys fill23_final midxs)+            (Two lastx sf)+   where+     -- fill23_final ::  Elem a -> Node (Node c)+     fill23_final (Elem a) = case fill23 a of+        -- See the note on lift_fill23 for an explanation of this+        -- lazy pattern.+        ~(lft, fill, rght) -> Node3 (size pr + size sf + sizec) lft fill rght++-- Not at the bottom yet++repEachMiddle midxs lenys+            !sizec+            firstx+            lastx+            fill23+            (RCountMid pr deep_count sf)  -- deep_count > 1+  = case deep_count `quotRem` 3 of+      (q,0)+       -> deep'+        (Two firstx firstx)+        (repEachMiddle_+           (lift_fill23 TOT3 TOT2 fill23)+           (RCountMid pr' (q - 1) sf'))+        (One lastx)+       where+        pr' = node2 firstx pr+        sf' = node3 lastx lastx sf+      (q,1)+       -> deep'+        (Two firstx firstx)+        (repEachMiddle_+           (lift_fill23 TOT3 TOT3 fill23)+           (RCountMid pr' (q - 1) sf'))+        (Two lastx lastx)+       where+        pr' = node3 firstx firstx pr+        sf' = node3 lastx lastx sf+      (q,_) -- the remainder is 2+       -> deep'+        (One firstx)+        (repEachMiddle_+           (lift_fill23 TOT2 TOT2 fill23)+           (RCountMid pr' q sf'))+        (One lastx)+       where+        pr' = node2 firstx pr+        sf' = node2 lastx sf++  where+    deep' = Deep (deep_count * sizec + lenys * (size midxs + 1))+    repEachMiddle_ = repEachMiddle midxs lenys sizec' fn3 ln3+    sizec' = 3 * sizec+    fn3 = Node3 sizec' firstx firstx firstx+    ln3 = Node3 sizec' lastx lastx lastx+    spr = size pr+    ssf = size sf+    lift_fill23+      :: TwoOrThree+      -> TwoOrThree+      -> (a -> (b, b, b))+      -> a -> (Node b, Node b, Node b)+    lift_fill23 !tl !tr f a = (lft', fill', rght')+      where+        -- We use a strict pattern match on the recursive call.  This means+        -- that we build the 2-3 trees from the *bottom up* instead of from the+        -- *top down*. We do it this way for two reasons:+        --+        -- 1. The trees are never very deep, so we don't get much locality+        -- benefit from building them lazily.+        --+        -- 2. Building the trees lazily would require us to build four thunks+        -- at each level of each tree, which seems just a bit pricy.+        --+        -- Does this break the incremental optimality? I don't believe it does.+        -- As far as I can tell, each sequence operation that inspects one of+        -- these trees either inspects only its root (to get its size for+        -- indexing purposes) or descends all the way to the bottom. So we're+        -- strict here, and lazy in the construction of+        -- the root in fill23_final.+        !(lft, fill, rght) = f a+        !fill' = Node3 (3 * sizec) fill fill fill+        !lft' = case tl of+          TOT2 -> Node2 (ssf + sizec) lft fill+          TOT3 -> Node3 (ssf + 2 * sizec) lft fill fill+        !rght' = case tr of+          TOT2 -> Node2 (spr + sizec) rght fill+          TOT3 -> Node3 (spr + 2 * sizec) rght fill fill++data TwoOrThree = TOT2 | TOT3++------------------------------------------------------------------------+-- Construction+------------------------------------------------------------------------++-- | \( O(1) \). The empty sequence.+empty           :: Seq a+empty           =  Seq EmptyT++-- | \( O(1) \). A singleton sequence.+singleton       :: a -> Seq a+singleton x     =  Seq (Single (Elem x))++-- | \( O(\log n) \). @replicate n x@ is a sequence consisting of @n@ copies of @x@.+replicate       :: Int -> a -> Seq a+replicate n x+  | n >= 0      = runIdentity (replicateA n (Identity x))+  | otherwise   = error "replicate takes a nonnegative integer argument"++-- | 'replicateA' is an 'Applicative' version of 'replicate', and makes+-- \( O(\log n) \) calls to 'liftA2' and 'pure'.+--+-- > replicateA n x = sequenceA (replicate n x)+replicateA :: Applicative f => Int -> f a -> f (Seq a)+replicateA n x+  | n >= 0      = Seq <$> applicativeTree n 1 (Elem <$> x)+  | otherwise   = error "replicateA takes a nonnegative integer argument"+{-# SPECIALIZE replicateA :: Int -> State a b -> State a (Seq b) #-}++-- | 'replicateM' is the @Seq@ counterpart of+-- @Control.Monad.'Control.Monad.replicateM'@.+--+-- > replicateM n x = sequence (replicate n x)+--+-- For @base >= 4.8.0@ and @containers >= 0.5.11@, 'replicateM'+-- is a synonym for 'replicateA'.+replicateM :: Applicative m => Int -> m a -> m (Seq a)+replicateM = replicateA++-- | \(O(\log k)\). @'cycleTaking' k xs@ forms a sequence of length @k@ by+-- repeatedly concatenating @xs@ with itself. @xs@ may only be empty if+-- @k@ is 0.+--+-- prop> cycleTaking k = fromList . take k . cycle . toList++-- If you wish to concatenate a possibly empty sequence @xs@ with+-- itself precisely @k@ times, use @'stimes' k xs@ instead of this+-- function.+--+-- @since 0.5.8+cycleTaking :: Int -> Seq a -> Seq a+cycleTaking n !_xs | n <= 0 = empty+cycleTaking _n xs  | null xs = error "cycleTaking cannot take a positive number of elements from an empty cycle."+cycleTaking n xs = cycleNTimes reps xs >< take final xs+  where+    (reps, final) = n `quotRem` length xs++-- \( O(\log(kn)) \). @'cycleNTimes' k xs@ concatenates @k@ copies of @xs@. This+-- operation uses time and additional space logarithmic in the size of its+-- result.+cycleNTimes :: Int -> Seq a -> Seq a+cycleNTimes n !xs+  | n <= 0    = empty+  | n == 1    = xs+cycleNTimes n (Seq xsFT) = case rigidify xsFT of+             RigidEmpty -> empty+             RigidOne (Elem x) -> replicate n x+             RigidTwo x1 x2 -> Seq $+               Deep (n*2) pair+                    (runIdentity $ applicativeTree (n-2) 2 (Identity (node2 x1 x2)))+                    pair+               where pair = Two x1 x2+             RigidThree x1 x2 x3 -> Seq $+               Deep (n*3) triple+                    (runIdentity $ applicativeTree (n-2) 3 (Identity (node3 x1 x2 x3)))+                    triple+               where triple = Three x1 x2 x3+             RigidFull r@(Rigid s pr _m sf) -> Seq $+                   Deep (n*s)+                        (nodeToDigit pr)+                        (cycleNMiddle (n-2) r)+                        (nodeToDigit sf)++cycleNMiddle+  :: Int+     -> Rigid c+     -> FingerTree (Node c)++-- Not at the bottom yet++cycleNMiddle !n+           (Rigid s pr (DeepTh sm prm mm sfm) sf)+    = Deep (sm + s * (n + 1)) -- note: sm = s - size pr - size sf+           (digit12ToDigit prm)+           (cycleNMiddle n+                       (Rigid s (squashL pr prm) mm (squashR sfm sf)))+           (digit12ToDigit sfm)++-- At the bottom++cycleNMiddle n+           (Rigid s pr EmptyTh sf)+     = deep+            (One sf)+            (runIdentity $ applicativeTree n s (Identity converted))+            (One pr)+   where converted = node2 pr sf++cycleNMiddle n+           (Rigid s pr (SingleTh q) sf)+     = deep+            (Two q sf)+            (runIdentity $ applicativeTree n s (Identity converted))+            (Two pr q)+   where converted = node3 pr q sf+++-- | \( O(1) \). Add an element to the left end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(<|)            :: a -> Seq a -> Seq a+x <| Seq xs     =  Seq (Elem x `consTree` xs)++{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}+consTree        :: Sized a => a -> FingerTree a -> FingerTree a+consTree a EmptyT       = Single a+consTree a (Single b)   = deep (One a) EmptyT (One b)+-- As described in the paper, we force the middle of a tree+-- *before* consing onto it; this preserves the amortized+-- bounds but prevents repeated consing from building up+-- gigantic suspensions.+consTree a (Deep s (Four b c d e) m sf) = m `seq`+    Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf+consTree a (Deep s (Three b c d) m sf) =+    Deep (size a + s) (Four a b c d) m sf+consTree a (Deep s (Two b c) m sf) =+    Deep (size a + s) (Three a b c) m sf+consTree a (Deep s (One b) m sf) =+    Deep (size a + s) (Two a b) m sf++cons' :: a -> Seq a -> Seq a+cons' x (Seq xs) = Seq (Elem x `consTree'` xs)++snoc' :: Seq a -> a -> Seq a+snoc' (Seq xs) x = Seq (xs `snocTree'` Elem x)++{-# SPECIALIZE consTree' :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE consTree' :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}+consTree'        :: Sized a => a -> FingerTree a -> FingerTree a+consTree' a EmptyT       = Single a+consTree' a (Single b)   = deep (One a) EmptyT (One b)+-- As described in the paper, we force the middle of a tree+-- *before* consing onto it; this preserves the amortized+-- bounds but prevents repeated consing from building up+-- gigantic suspensions.+consTree' a (Deep s (Four b c d e) m sf) =+    Deep (size a + s) (Two a b) m' sf+  where !m' = abc `consTree'` m+        !abc = node3 c d e+consTree' a (Deep s (Three b c d) m sf) =+    Deep (size a + s) (Four a b c d) m sf+consTree' a (Deep s (Two b c) m sf) =+    Deep (size a + s) (Three a b c) m sf+consTree' a (Deep s (One b) m sf) =+    Deep (size a + s) (Two a b) m sf++-- | \( O(1) \). Add an element to the right end of a sequence.+-- Mnemonic: a triangle with the single element at the pointy end.+(|>)            :: Seq a -> a -> Seq a+Seq xs |> x     =  Seq (xs `snocTree` Elem x)++{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}+{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}+snocTree        :: Sized a => FingerTree a -> a -> FingerTree a+snocTree EmptyT a       =  Single a+snocTree (Single a) b   =  deep (One a) EmptyT (One b)+-- See note on `seq` in `consTree`.+snocTree (Deep s pr m (Four a b c d)) e = m `seq`+    Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)+snocTree (Deep s pr m (Three a b c)) d =+    Deep (s + size d) pr m (Four a b c d)+snocTree (Deep s pr m (Two a b)) c =+    Deep (s + size c) pr m (Three a b c)+snocTree (Deep s pr m (One a)) b =+    Deep (s + size b) pr m (Two a b)++{-# SPECIALIZE snocTree' :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}+{-# SPECIALIZE snocTree' :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}+snocTree'        :: Sized a => FingerTree a -> a -> FingerTree a+snocTree' EmptyT a       =  Single a+snocTree' (Single a) b   =  deep (One a) EmptyT (One b)+-- See note on `seq` in `consTree`.+snocTree' (Deep s pr m (Four a b c d)) e =+    Deep (s + size e) pr m' (Two d e)+  where !m' = m `snocTree'` abc+        !abc = node3 a b c+snocTree' (Deep s pr m (Three a b c)) d =+    Deep (s + size d) pr m (Four a b c d)+snocTree' (Deep s pr m (Two a b)) c =+    Deep (s + size c) pr m (Three a b c)+snocTree' (Deep s pr m (One a)) b =+    Deep (s + size b) pr m (Two a b)++-- | \( O(\log(\min(n_1,n_2))) \). Concatenate two sequences.+(><)            :: Seq a -> Seq a -> Seq a+Seq xs >< Seq ys = Seq (appendTree0 xs ys)++-- The appendTree/addDigits gunk below was originally machine generated via mkappend.hs,+-- but has since been manually edited to include strictness annotations.++appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)+appendTree0 EmptyT xs =+    xs+appendTree0 xs EmptyT =+    xs+appendTree0 (Single x) xs =+    x `consTree` xs+appendTree0 xs (Single x) =+    xs `snocTree` x+appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =+    Deep (s1 + s2) pr1 m sf2+  where !m = addDigits0 m1 sf1 pr2 m2++addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))+addDigits0 m1 (One a) (One b) m2 =+    appendTree1 m1 (node2 a b) m2+addDigits0 m1 (One a) (Two b c) m2 =+    appendTree1 m1 (node3 a b c) m2+addDigits0 m1 (One a) (Three b c d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (One a) (Four b c d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Two a b) (One c) m2 =+    appendTree1 m1 (node3 a b c) m2+addDigits0 m1 (Two a b) (Two c d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (Two a b) (Three c d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Two a b) (Four c d e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Three a b c) (One d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits0 m1 (Three a b c) (Two d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Three a b c) (Three d e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Three a b c) (Four d e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits0 m1 (Four a b c d) (One e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits0 m1 (Four a b c d) (Two e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits0 m1 (Four a b c d) (Three e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits0 m1 (Four a b c d) (Four e f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2++appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree1 EmptyT !a xs =+    a `consTree` xs+appendTree1 xs !a EmptyT =+    xs `snocTree` a+appendTree1 (Single x) !a xs =+    x `consTree` a `consTree` xs+appendTree1 xs !a (Single x) =+    xs `snocTree` a `snocTree` x+appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =+    Deep (s1 + size a + s2) pr1 m sf2+  where !m = addDigits1 m1 sf1 a pr2 m2++addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits1 m1 (One a) b (One c) m2 =+    appendTree1 m1 (node3 a b c) m2+addDigits1 m1 (One a) b (Two c d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits1 m1 (One a) b (Three c d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (One a) b (Four c d e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Two a b) c (One d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits1 m1 (Two a b) c (Two d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (Two a b) c (Three d e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Two a b) c (Four d e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Three a b c) d (One e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits1 m1 (Three a b c) d (Two e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Three a b c) d (Three e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Three a b c) d (Four e f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits1 m1 (Four a b c d) e (One f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits1 m1 (Four a b c d) e (Two f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits1 m1 (Four a b c d) e (Three f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2++appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree2 EmptyT !a !b xs =+    a `consTree` b `consTree` xs+appendTree2 xs !a !b EmptyT =+    xs `snocTree` a `snocTree` b+appendTree2 (Single x) a b xs =+    x `consTree` a `consTree` b `consTree` xs+appendTree2 xs a b (Single x) =+    xs `snocTree` a `snocTree` b `snocTree` x+appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =+    Deep (s1 + size a + size b + s2) pr1 m sf2+  where !m = addDigits2 m1 sf1 a b pr2 m2++addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits2 m1 (One a) b c (One d) m2 =+    appendTree2 m1 (node2 a b) (node2 c d) m2+addDigits2 m1 (One a) b c (Two d e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits2 m1 (One a) b c (Three d e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (One a) b c (Four d e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Two a b) c d (One e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits2 m1 (Two a b) c d (Two e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (Two a b) c d (Three e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Two a b) c d (Four e f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Three a b c) d e (One f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits2 m1 (Three a b c) d e (Two f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Three a b c) d e (Three f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits2 m1 (Four a b c d) e f (One g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits2 m1 (Four a b c d) e f (Two g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2++appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree3 EmptyT !a !b !c xs =+    a `consTree` b `consTree` c `consTree` xs+appendTree3 xs !a !b !c EmptyT =+    xs `snocTree` a `snocTree` b `snocTree` c+appendTree3 (Single x) a b c xs =+    x `consTree` a `consTree` b `consTree` c `consTree` xs+appendTree3 xs a b c (Single x) =+    xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x+appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =+    Deep (s1 + size a + size b + size c + s2) pr1 m sf2+  where !m = addDigits3 m1 sf1 a b c pr2 m2++addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits3 m1 (One a) !b !c !d (One e) m2 =+    appendTree2 m1 (node3 a b c) (node2 d e) m2+addDigits3 m1 (One a) b c d (Two e f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits3 m1 (One a) b c d (Three e f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (One a) b c d (Four e f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Two a b) !c !d !e (One f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits3 m1 (Two a b) c d e (Two f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (Two a b) c d e (Three f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Three a b c) !d !e !f (One g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits3 m1 (Three a b c) d e f (Two g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits3 m1 (Four a b c d) !e !f !g (One h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2++appendTree4 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)+appendTree4 EmptyT !a !b !c !d xs =+    a `consTree` b `consTree` c `consTree` d `consTree` xs+appendTree4 xs !a !b !c !d EmptyT =+    xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d+appendTree4 (Single x) a b c d xs =+    x `consTree` a `consTree` b `consTree` c `consTree` d `consTree` xs+appendTree4 xs a b c d (Single x) =+    xs `snocTree` a `snocTree` b `snocTree` c `snocTree` d `snocTree` x+appendTree4 (Deep s1 pr1 m1 sf1) a b c d (Deep s2 pr2 m2 sf2) =+    Deep (s1 + size a + size b + size c + size d + s2) pr1 m sf2+  where !m = addDigits4 m1 sf1 a b c d pr2 m2++addDigits4 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))+addDigits4 m1 (One a) !b !c !d !e (One f) m2 =+    appendTree2 m1 (node3 a b c) (node3 d e f) m2+addDigits4 m1 (One a) b c d e (Two f g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits4 m1 (One a) b c d e (Three f g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (One a) b c d e (Four f g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Two a b) !c !d !e !f (One g) m2 =+    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2+addDigits4 m1 (Two a b) c d e f (Two g h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Three a b c) !d !e !f !g (One h) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2+addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2+addDigits4 m1 (Four a b c d) !e !f !g !h (One i) m2 =+    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2+addDigits4 m1 (Four a b c d) !e !f !g !h (Two i j) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2+addDigits4 m1 (Four a b c d) !e !f !g !h (Three i j k) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2+addDigits4 m1 (Four a b c d) !e !f !g !h (Four i j k l) m2 =+    appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2++-- | Builds a sequence from a seed value.  Takes time linear in the+-- number of generated elements.  /WARNING:/ If the number of generated+-- elements is infinite, this method will not terminate.+unfoldr :: (b -> Maybe (a, b)) -> b -> Seq a+unfoldr f = unfoldr' empty+  -- uses tail recursion rather than, for instance, the List implementation.+  where unfoldr' !as b = maybe as (\ (a, b') -> unfoldr' (as `snoc'` a) b') (f b)++-- | @'unfoldl' f x@ is equivalent to @'reverse' ('unfoldr' ('fmap' swap . f) x)@.+unfoldl :: (b -> Maybe (b, a)) -> b -> Seq a+unfoldl f = unfoldl' empty+  where unfoldl' !as b = maybe as (\ (b', a) -> unfoldl' (a `cons'` as) b') (f b)++-- | \( O(n) \).  Constructs a sequence by repeated application of a function+-- to a seed value.+--+-- > iterateN n f x = fromList (Prelude.take n (Prelude.iterate f x))+iterateN :: Int -> (a -> a) -> a -> Seq a+iterateN n f x+  | n >= 0      = replicateA n (State (\ y -> (f y, y))) `execState` x+  | otherwise   = error "iterateN takes a nonnegative integer argument"++------------------------------------------------------------------------+-- Deconstruction+------------------------------------------------------------------------++-- | \( O(1) \). Is this the empty sequence?+null            :: Seq a -> Bool+null (Seq EmptyT) = True+null _            =  False++-- | \( O(1) \). The number of elements in the sequence.+length          :: Seq a -> Int+length (Seq xs) =  size xs++-- Views++data ViewLTree a = ConsLTree a (FingerTree a) | EmptyLTree+data ViewRTree a = SnocRTree (FingerTree a) a | EmptyRTree++-- | View of the left end of a sequence.+data ViewL a+    = EmptyL        -- ^ empty sequence+    | a :< Seq a    -- ^ leftmost element and the rest of the sequence+    deriving (Eq, Ord, Show, Read)++#ifdef __GLASGOW_HASKELL__+deriving instance Data a => Data (ViewL a)++-- | @since 0.5.8+deriving instance Generic1 ViewL++-- | @since 0.5.8+deriving instance Generic (ViewL a)++-- | @since 0.6.6+deriving instance TH.Lift a => TH.Lift (ViewL a)+#endif++instance Functor ViewL where+    {-# INLINE fmap #-}+    fmap _ EmptyL       = EmptyL+    fmap f (x :< xs)    = f x :< fmap f xs++instance Foldable ViewL where+    foldMap _ EmptyL = mempty+    foldMap f (x :< xs) = f x <> foldMap f xs++    foldr _ z EmptyL = z+    foldr f z (x :< xs) = f x (foldr f z xs)++    foldl _ z EmptyL = z+    foldl f z (x :< xs) = foldl f (f z x) xs++    foldl1 _ EmptyL = error "foldl1: empty view"+    foldl1 f (x :< xs) = foldl f x xs++    null EmptyL = True+    null (_ :< _) = False++    length EmptyL = 0+    length (_ :< xs) = 1 + length xs++instance Traversable ViewL where+    traverse _ EmptyL       = pure EmptyL+    traverse f (x :< xs)    = liftA2 (:<) (f x) (traverse f xs)++-- | \( O(1) \). Analyse the left end of a sequence.+viewl           ::  Seq a -> ViewL a+viewl (Seq xs)  =  case viewLTree xs of+    EmptyLTree -> EmptyL+    ConsLTree (Elem x) xs' -> x :< Seq xs'++{-# SPECIALIZE viewLTree :: FingerTree (Elem a) -> ViewLTree (Elem a) #-}+{-# SPECIALIZE viewLTree :: FingerTree (Node a) -> ViewLTree (Node a) #-}+viewLTree       :: Sized a => FingerTree a -> ViewLTree a+viewLTree EmptyT                = EmptyLTree+viewLTree (Single a)            = ConsLTree a EmptyT+viewLTree (Deep s (One a) m sf) = ConsLTree a (pullL (s - size a) m sf)+viewLTree (Deep s (Two a b) m sf) =+    ConsLTree a (Deep (s - size a) (One b) m sf)+viewLTree (Deep s (Three a b c) m sf) =+    ConsLTree a (Deep (s - size a) (Two b c) m sf)+viewLTree (Deep s (Four a b c d) m sf) =+    ConsLTree a (Deep (s - size a) (Three b c d) m sf)++-- | View of the right end of a sequence.+data ViewR a+    = EmptyR        -- ^ empty sequence+    | Seq a :> a    -- ^ the sequence minus the rightmost element,+            -- and the rightmost element+    deriving (Eq, Ord, Show, Read)++#ifdef __GLASGOW_HASKELL__+deriving instance Data a => Data (ViewR a)++-- | @since 0.5.8+deriving instance Generic1 ViewR++-- | @since 0.5.8+deriving instance Generic (ViewR a)++-- | @since 0.6.6+deriving instance TH.Lift a => TH.Lift (ViewR a)+#endif++instance Functor ViewR where+    {-# INLINE fmap #-}+    fmap _ EmptyR       = EmptyR+    fmap f (xs :> x)    = fmap f xs :> f x++instance Foldable ViewR where+    foldMap _ EmptyR = mempty+    foldMap f (xs :> x) = foldMap f xs <> f x++    foldr _ z EmptyR = z+    foldr f z (xs :> x) = foldr f (f x z) xs++    foldl _ z EmptyR = z+    foldl f z (xs :> x) = foldl f z xs `f` x++    foldr1 _ EmptyR = error "foldr1: empty view"+    foldr1 f (xs :> x) = foldr f x xs++    null EmptyR = True+    null (_ :> _) = False++    length EmptyR = 0+    length (xs :> _) = length xs + 1++instance Traversable ViewR where+    traverse _ EmptyR       = pure EmptyR+    traverse f (xs :> x)    = liftA2 (:>) (traverse f xs) (f x)++-- | \( O(1) \). Analyse the right end of a sequence.+viewr           ::  Seq a -> ViewR a+viewr (Seq xs)  =  case viewRTree xs of+    EmptyRTree -> EmptyR+    SnocRTree xs' (Elem x) -> Seq xs' :> x++{-# SPECIALIZE viewRTree :: FingerTree (Elem a) -> ViewRTree (Elem a) #-}+{-# SPECIALIZE viewRTree :: FingerTree (Node a) -> ViewRTree (Node a) #-}+viewRTree       :: Sized a => FingerTree a -> ViewRTree a+viewRTree EmptyT                = EmptyRTree+viewRTree (Single z)            = SnocRTree EmptyT z+viewRTree (Deep s pr m (One z)) = SnocRTree (pullR (s - size z) pr m) z+viewRTree (Deep s pr m (Two y z)) =+    SnocRTree (Deep (s - size z) pr m (One y)) z+viewRTree (Deep s pr m (Three x y z)) =+    SnocRTree (Deep (s - size z) pr m (Two x y)) z+viewRTree (Deep s pr m (Four w x y z)) =+    SnocRTree (Deep (s - size z) pr m (Three w x y)) z++------------------------------------------------------------------------+-- Scans+--+-- These are not particularly complex applications of the Traversable+-- functor, though making the correspondence with Data.List exact+-- requires the use of (<|) and (|>).+--+-- Note that save for the single (<|) or (|>), we maintain the original+-- structure of the Seq, not having to do any restructuring of our own.+--+-- wasserman.louis@gmail.com, 5/23/09+------------------------------------------------------------------------++-- | 'scanl' is similar to 'foldl', but returns a sequence of reduced+-- values from the left:+--+-- > scanl f z (fromList [x1, x2, ...]) = fromList [z, z `f` x1, (z `f` x1) `f` x2, ...]+scanl :: (a -> b -> a) -> a -> Seq b -> Seq a+scanl f z0 xs = z0 <| snd (mapAccumL (\ x z -> let x' = f x z in (x', x')) z0 xs)++-- | 'scanl1' is a variant of 'scanl' that has no starting value argument:+--+-- > scanl1 f (fromList [x1, x2, ...]) = fromList [x1, x1 `f` x2, ...]+scanl1 :: (a -> a -> a) -> Seq a -> Seq a+scanl1 f xs = case viewl xs of+    EmptyL          -> error "scanl1 takes a nonempty sequence as an argument"+    x :< xs'        -> scanl f x xs'++-- | 'scanr' is the right-to-left dual of 'scanl'.+scanr :: (a -> b -> b) -> b -> Seq a -> Seq b+scanr f z0 xs = snd (mapAccumR (\ z x -> let z' = f x z in (z', z')) z0 xs) |> z0++-- | 'scanr1' is a variant of 'scanr' that has no starting value argument.+scanr1 :: (a -> a -> a) -> Seq a -> Seq a+scanr1 f xs = case viewr xs of+    EmptyR          -> error "scanr1 takes a nonempty sequence as an argument"+    xs' :> x        -> scanr f x xs'++-- Indexing++-- | \( O(\log(\min(i,n-i))) \). The element at the specified position,+-- counting from 0.  The argument should thus be a non-negative+-- integer less than the size of the sequence.+-- If the position is out of range, 'index' fails with an error.+--+-- prop> xs `index` i = toList xs !! i+--+-- Caution: 'index' necessarily delays retrieving the requested+-- element until the result is forced. It can therefore lead to a space+-- leak if the result is stored, unforced, in another structure. To retrieve+-- an element immediately without forcing it, use 'lookup' or '(!?)'.+index           :: Seq a -> Int -> a+index (Seq xs) i+  -- See note on unsigned arithmetic in splitAt+  | fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of+                Place _ (Elem x) -> x+  | otherwise   =+      error $ "index out of bounds in call to: Data.Sequence.index " ++ show i++-- | \( O(\log(\min(i,n-i))) \). The element at the specified position,+-- counting from 0. If the specified position is negative or at+-- least the length of the sequence, 'lookup' returns 'Nothing'.+--+-- prop> 0 <= i < length xs ==> lookup i xs == Just (toList xs !! i)+-- prop> i < 0 || i >= length xs ==> lookup i xs = Nothing+--+-- Unlike 'index', this can be used to retrieve an element without+-- forcing it. For example, to insert the fifth element of a sequence+-- @xs@ into a 'Data.Map.Lazy.Map' @m@ at key @k@, you could use+--+-- @+-- case lookup 5 xs of+--   Nothing -> m+--   Just x -> 'Data.Map.Lazy.insert' k x m+-- @+--+-- @since 0.5.8+lookup            :: Int -> Seq a -> Maybe a+lookup i (Seq xs)+  -- Note: we perform the lookup *before* applying the Just constructor+  -- to ensure that we don't hold a reference to the whole sequence in+  -- a thunk. If we applied the Just constructor around the case, the+  -- actual lookup wouldn't be performed unless and until the value was+  -- forced.+  | fromIntegral i < (fromIntegral (size xs) :: Word) = case lookupTree i xs of+                Place _ (Elem x) -> Just x+  | otherwise = Nothing++-- | \( O(\log(\min(i,n-i))) \). A flipped, infix version of `lookup`.+--+-- @since 0.5.8+(!?) ::           Seq a -> Int -> Maybe a+(!?) = flip lookup++data Place a = Place {-# UNPACK #-} !Int a+#ifdef TESTING+    deriving Show+#endif++{-# SPECIALIZE lookupTree :: Int -> FingerTree (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupTree :: Int -> FingerTree (Node a) -> Place (Node a) #-}+lookupTree :: Sized a => Int -> FingerTree a -> Place a+lookupTree !_ EmptyT = error "lookupTree of empty tree"+lookupTree i (Single x) = Place i x+lookupTree i (Deep _ pr m sf)+  | i < spr     =  lookupDigit i pr+  | i < spm     =  case lookupTree (i - spr) m of+                   Place i' xs -> lookupNode i' xs+  | otherwise   =  lookupDigit (i - spm) sf+  where+    spr     = size pr+    spm     = spr + size m++{-# SPECIALIZE lookupNode :: Int -> Node (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupNode :: Int -> Node (Node a) -> Place (Node a) #-}+lookupNode :: Sized a => Int -> Node a -> Place a+lookupNode i (Node2 _ a b)+  | i < sa      = Place i a+  | otherwise   = Place (i - sa) b+  where+    sa      = size a+lookupNode i (Node3 _ a b c)+  | i < sa      = Place i a+  | i < sab     = Place (i - sa) b+  | otherwise   = Place (i - sab) c+  where+    sa      = size a+    sab     = sa + size b++{-# SPECIALIZE lookupDigit :: Int -> Digit (Elem a) -> Place (Elem a) #-}+{-# SPECIALIZE lookupDigit :: Int -> Digit (Node a) -> Place (Node a) #-}+lookupDigit :: Sized a => Int -> Digit a -> Place a+lookupDigit i (One a) = Place i a+lookupDigit i (Two a b)+  | i < sa      = Place i a+  | otherwise   = Place (i - sa) b+  where+    sa      = size a+lookupDigit i (Three a b c)+  | i < sa      = Place i a+  | i < sab     = Place (i - sa) b+  | otherwise   = Place (i - sab) c+  where+    sa      = size a+    sab     = sa + size b+lookupDigit i (Four a b c d)+  | i < sa      = Place i a+  | i < sab     = Place (i - sa) b+  | i < sabc    = Place (i - sab) c+  | otherwise   = Place (i - sabc) d+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c++-- | \( O(\log(\min(i,n-i))) \). Replace the element at the specified position.+-- If the position is out of range, the original sequence is returned.+update          :: Int -> a -> Seq a -> Seq a+update i x (Seq xs)+  -- See note on unsigned arithmetic in splitAt+  | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq (updateTree (Elem x) i xs)+  | otherwise   = Seq xs++-- It seems a shame to copy the implementation of the top layer of+-- `adjust` instead of just using `update i x = adjust (const x) i`.+-- With the latter implementation, updating the same position many+-- times could lead to silly thunks building up around that position.+-- The thunks will each look like @const v a@, where @v@ is the new+-- value and @a@ the old.+updateTree      :: Elem a -> Int -> FingerTree (Elem a) -> FingerTree (Elem a)+updateTree _ !_ EmptyT = EmptyT -- Unreachable+updateTree v _i (Single _) = Single v+updateTree v i (Deep s pr m sf)+  | i < spr     = Deep s (updateDigit v i pr) m sf+  | i < spm     = let !m' = adjustTree (updateNode v) (i - spr) m+                  in Deep s pr m' sf+  | otherwise   = Deep s pr m (updateDigit v (i - spm) sf)+  where+    spr     = size pr+    spm     = spr + size m++updateNode      :: Elem a -> Int -> Node (Elem a) -> Node (Elem a)+updateNode v i (Node2 s a b)+  | i < sa      = Node2 s v b+  | otherwise   = Node2 s a v+  where+    sa      = size a+updateNode v i (Node3 s a b c)+  | i < sa      = Node3 s v b c+  | i < sab     = Node3 s a v c+  | otherwise   = Node3 s a b v+  where+    sa      = size a+    sab     = sa + size b++updateDigit     :: Elem a -> Int -> Digit (Elem a) -> Digit (Elem a)+updateDigit v !_i (One _) = One v+updateDigit v i (Two a b)+  | i < sa      = Two v b+  | otherwise   = Two a v+  where+    sa      = size a+updateDigit v i (Three a b c)+  | i < sa      = Three v b c+  | i < sab     = Three a v c+  | otherwise   = Three a b v+  where+    sa      = size a+    sab     = sa + size b+updateDigit v i (Four a b c d)+  | i < sa      = Four v b c d+  | i < sab     = Four a v c d+  | i < sabc    = Four a b v d+  | otherwise   = Four a b c v+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c++-- | \( O(\log(\min(i,n-i))) \). Update the element at the specified position.  If+-- the position is out of range, the original sequence is returned.  'adjust'+-- can lead to poor performance and even memory leaks, because it does not+-- force the new value before installing it in the sequence. 'adjust'' should+-- usually be preferred.+--+-- @since 0.5.8+adjust          :: (a -> a) -> Int -> Seq a -> Seq a+adjust f i (Seq xs)+  -- See note on unsigned arithmetic in splitAt+  | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq (adjustTree (`seq` fmap f) i xs)+  | otherwise   = Seq xs++-- | \( O(\log(\min(i,n-i))) \). Update the element at the specified position.+-- If the position is out of range, the original sequence is returned.+-- The new value is forced before it is installed in the sequence.+--+-- @+-- adjust' f i xs =+--  case xs !? i of+--    Nothing -> xs+--    Just x -> let !x' = f x+--              in update i x' xs+-- @+--+-- @since 0.5.8+adjust'          :: forall a . (a -> a) -> Int -> Seq a -> Seq a+#ifdef __GLASGOW_HASKELL__+adjust' f i xs+  -- See note on unsigned arithmetic in splitAt+  | fromIntegral i < (fromIntegral (length xs) :: Word) =+      coerce $ adjustTree (\ !_k (ForceBox a) -> ForceBox (f a)) i (coerce xs)+  | otherwise   = xs+#else+-- This is inefficient, but fixing it would take a lot of fuss and bother+-- for little immediate gain. We can deal with that when we have another+-- Haskell implementation to worry about.+adjust' f i xs =+  case xs !? i of+    Nothing -> xs+    Just x -> let !x' = f x+              in update i x' xs+#endif++{-# SPECIALIZE adjustTree :: (Int -> ForceBox a -> ForceBox a) -> Int -> FingerTree (ForceBox a) -> FingerTree (ForceBox a) #-}+{-# SPECIALIZE adjustTree :: (Int -> Elem a -> Elem a) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE adjustTree :: (Int -> Node a -> Node a) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}+adjustTree      :: (Sized a, MaybeForce a) => (Int -> a -> a) ->+             Int -> FingerTree a -> FingerTree a+adjustTree _ !_ EmptyT = EmptyT -- Unreachable+adjustTree f i (Single x) = Single $!? f i x+adjustTree f i (Deep s pr m sf)+  | i < spr     = Deep s (adjustDigit f i pr) m sf+  | i < spm     = let !m' = adjustTree (adjustNode f) (i - spr) m+                  in Deep s pr m' sf+  | otherwise   = Deep s pr m (adjustDigit f (i - spm) sf)+  where+    spr     = size pr+    spm     = spr + size m++{-# SPECIALIZE adjustNode :: (Int -> Elem a -> Elem a) -> Int -> Node (Elem a) -> Node (Elem a) #-}+{-# SPECIALIZE adjustNode :: (Int -> Node a -> Node a) -> Int -> Node (Node a) -> Node (Node a) #-}+adjustNode      :: (Sized a, MaybeForce a) => (Int -> a -> a) -> Int -> Node a -> Node a+adjustNode f i (Node2 s a b)+  | i < sa      = let fia = f i a in fia `mseq` Node2 s fia b+  | otherwise   = let fisab = f (i - sa) b in fisab `mseq` Node2 s a fisab+  where+    sa      = size a+adjustNode f i (Node3 s a b c)+  | i < sa      = let fia = f i a in fia `mseq` Node3 s fia b c+  | i < sab     = let fisab = f (i - sa) b in fisab `mseq` Node3 s a fisab c+  | otherwise   = let fisabc = f (i - sab) c in fisabc `mseq` Node3 s a b fisabc+  where+    sa      = size a+    sab     = sa + size b++{-# SPECIALIZE adjustDigit :: (Int -> Elem a -> Elem a) -> Int -> Digit (Elem a) -> Digit (Elem a) #-}+{-# SPECIALIZE adjustDigit :: (Int -> Node a -> Node a) -> Int -> Digit (Node a) -> Digit (Node a) #-}+adjustDigit     :: (Sized a, MaybeForce a) => (Int -> a -> a) -> Int -> Digit a -> Digit a+adjustDigit f !i (One a) = One $!? f i a+adjustDigit f i (Two a b)+  | i < sa      = let fia = f i a in fia `mseq` Two fia b+  | otherwise   = let fisab = f (i - sa) b in fisab `mseq` Two a fisab+  where+    sa      = size a+adjustDigit f i (Three a b c)+  | i < sa      = let fia = f i a in fia `mseq` Three fia b c+  | i < sab     = let fisab = f (i - sa) b in fisab `mseq` Three a fisab c+  | otherwise   = let fisabc = f (i - sab) c in fisabc `mseq` Three a b fisabc+  where+    sa      = size a+    sab     = sa + size b+adjustDigit f i (Four a b c d)+  | i < sa      = let fia = f i a in fia `mseq` Four fia b c d+  | i < sab     = let fisab = f (i - sa) b in fisab `mseq` Four a fisab c d+  | i < sabc    = let fisabc = f (i - sab) c in fisabc `mseq` Four a b fisabc d+  | otherwise   = let fisabcd = f (i - sabc) d in fisabcd `mseq` Four a b c fisabcd+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c++-- | \( O(\log(\min(i,n-i))) \). @'insertAt' i x xs@ inserts @x@ into @xs@+-- at the index @i@, shifting the rest of the sequence over.+--+-- @+-- insertAt 2 x (fromList [a,b,c,d]) = fromList [a,b,x,c,d]+-- insertAt 4 x (fromList [a,b,c,d]) = insertAt 10 x (fromList [a,b,c,d])+--                                   = fromList [a,b,c,d,x]+-- @+--+-- prop> insertAt i x xs = take i xs >< singleton x >< drop i xs+--+-- @since 0.5.8+insertAt :: Int -> a -> Seq a -> Seq a+insertAt i a s@(Seq xs)+  | fromIntegral i < (fromIntegral (size xs) :: Word)+      = Seq (insTree (`seq` InsTwo (Elem a)) i xs)+  | i <= 0 = a <| s+  | otherwise = s |> a++data Ins a = InsOne a | InsTwo a a++{-# SPECIALIZE insTree :: (Int -> Elem a -> Ins (Elem a)) -> Int -> FingerTree (Elem a) -> FingerTree (Elem a) #-}+{-# SPECIALIZE insTree :: (Int -> Node a -> Ins (Node a)) -> Int -> FingerTree (Node a) -> FingerTree (Node a) #-}+insTree      :: Sized a => (Int -> a -> Ins a) ->+             Int -> FingerTree a -> FingerTree a+insTree _ !_ EmptyT = EmptyT -- Unreachable+insTree f i (Single x) = case f i x of+  InsOne x' -> Single x'+  InsTwo m n -> deep (One m) EmptyT (One n)+insTree f i (Deep s pr m sf)+  | i < spr     = case insLeftDigit f i pr of+     InsLeftDig pr' -> Deep (s + 1) pr' m sf+     InsDigNode pr' n -> m `seq` Deep (s + 1) pr' (n `consTree` m) sf+  | i < spm     = let !m' = insTree (insNode f) (i - spr) m+                  in Deep (s + 1) pr m' sf+  | otherwise   = case insRightDigit f (i - spm) sf of+     InsRightDig sf' -> Deep (s + 1) pr m sf'+     InsNodeDig n sf' -> m `seq` Deep (s + 1) pr (m `snocTree` n) sf'+  where+    spr     = size pr+    spm     = spr + size m++{-# SPECIALIZE insNode :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Node (Elem a) -> Ins (Node (Elem a)) #-}+{-# SPECIALIZE insNode :: (Int -> Node a -> Ins (Node a)) -> Int -> Node (Node a) -> Ins (Node (Node a)) #-}+insNode :: Sized a => (Int -> a -> Ins a) -> Int -> Node a -> Ins (Node a)+insNode f i (Node2 s a b)+  | i < sa = case f i a of+      InsOne n -> InsOne $ Node2 (s + 1) n b+      InsTwo m n -> InsOne $ Node3 (s + 1) m n b+  | otherwise = case f (i - sa) b of+      InsOne n -> InsOne $ Node2 (s + 1) a n+      InsTwo m n -> InsOne $ Node3 (s + 1) a m n+  where sa = size a+insNode f i (Node3 s a b c)+  | i < sa = case f i a of+      InsOne n -> InsOne $ Node3 (s + 1) n b c+      InsTwo m n -> InsTwo (Node2 (sa + 1) m n) (Node2 (s - sa) b c)+  | i < sab = case f (i - sa) b of+      InsOne n -> InsOne $ Node3 (s + 1) a n c+      InsTwo m n -> InsTwo am nc+        where !am = node2 a m+              !nc = node2 n c+  | otherwise = case f (i - sab) c of+      InsOne n -> InsOne $ Node3 (s + 1) a b n+      InsTwo m n -> InsTwo (Node2 sab a b) (Node2 (s - sab + 1) m n)+  where sa = size a+        sab = sa + size b++data InsDigNode a = InsLeftDig !(Digit a) | InsDigNode !(Digit a) !(Node a)+{-# SPECIALIZE insLeftDigit :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Digit (Elem a) -> InsDigNode (Elem a) #-}+{-# SPECIALIZE insLeftDigit :: (Int -> Node a -> Ins (Node a)) -> Int -> Digit (Node a) -> InsDigNode (Node a) #-}+insLeftDigit :: Sized a => (Int -> a -> Ins a) -> Int -> Digit a -> InsDigNode a+insLeftDigit f !i (One a) = case f i a of+  InsOne a' -> InsLeftDig $ One a'+  InsTwo a1 a2 -> InsLeftDig $ Two a1 a2+insLeftDigit f i (Two a b)+  | i < sa = case f i a of+     InsOne a' -> InsLeftDig $ Two a' b+     InsTwo a1 a2 -> InsLeftDig $ Three a1 a2 b+  | otherwise = case f (i - sa) b of+     InsOne b' -> InsLeftDig $ Two a b'+     InsTwo b1 b2 -> InsLeftDig $ Three a b1 b2+  where sa = size a+insLeftDigit f i (Three a b c)+  | i < sa = case f i a of+     InsOne a' -> InsLeftDig $ Three a' b c+     InsTwo a1 a2 -> InsLeftDig $ Four a1 a2 b c+  | i < sab = case f (i - sa) b of+     InsOne b' -> InsLeftDig $ Three a b' c+     InsTwo b1 b2 -> InsLeftDig $ Four a b1 b2 c+  | otherwise = case f (i - sab) c of+     InsOne c' -> InsLeftDig $ Three a b c'+     InsTwo c1 c2 -> InsLeftDig $ Four a b c1 c2+  where sa = size a+        sab = sa + size b+insLeftDigit f i (Four a b c d)+  | i < sa = case f i a of+     InsOne a' -> InsLeftDig $ Four a' b c d+     InsTwo a1 a2 -> InsDigNode (Two a1 a2) (node3 b c d)+  | i < sab = case f (i - sa) b of+     InsOne b' -> InsLeftDig $ Four a b' c d+     InsTwo b1 b2 -> InsDigNode (Two a b1) (node3 b2 c d)+  | i < sabc = case f (i - sab) c of+     InsOne c' -> InsLeftDig $ Four a b c' d+     InsTwo c1 c2 -> InsDigNode (Two a b) (node3 c1 c2 d)+  | otherwise = case f (i - sabc) d of+     InsOne d' -> InsLeftDig $ Four a b c d'+     InsTwo d1 d2 -> InsDigNode (Two a b) (node3 c d1 d2)+  where sa = size a+        sab = sa + size b+        sabc = sab + size c++data InsNodeDig a = InsRightDig !(Digit a) | InsNodeDig !(Node a) !(Digit a)+{-# SPECIALIZE insRightDigit :: (Int -> Elem a -> Ins (Elem a)) -> Int -> Digit (Elem a) -> InsNodeDig (Elem a) #-}+{-# SPECIALIZE insRightDigit :: (Int -> Node a -> Ins (Node a)) -> Int -> Digit (Node a) -> InsNodeDig (Node a) #-}+insRightDigit :: Sized a => (Int -> a -> Ins a) -> Int -> Digit a -> InsNodeDig a+insRightDigit f !i (One a) = case f i a of+  InsOne a' -> InsRightDig $ One a'+  InsTwo a1 a2 -> InsRightDig $ Two a1 a2+insRightDigit f i (Two a b)+  | i < sa = case f i a of+     InsOne a' -> InsRightDig $ Two a' b+     InsTwo a1 a2 -> InsRightDig $ Three a1 a2 b+  | otherwise = case f (i - sa) b of+     InsOne b' -> InsRightDig $ Two a b'+     InsTwo b1 b2 -> InsRightDig $ Three a b1 b2+  where sa = size a+insRightDigit f i (Three a b c)+  | i < sa = case f i a of+     InsOne a' -> InsRightDig $ Three a' b c+     InsTwo a1 a2 -> InsRightDig $ Four a1 a2 b c+  | i < sab = case f (i - sa) b of+     InsOne b' -> InsRightDig $ Three a b' c+     InsTwo b1 b2 -> InsRightDig $ Four a b1 b2 c+  | otherwise = case f (i - sab) c of+     InsOne c' -> InsRightDig $ Three a b c'+     InsTwo c1 c2 -> InsRightDig $ Four a b c1 c2+  where sa = size a+        sab = sa + size b+insRightDigit f i (Four a b c d)+  | i < sa = case f i a of+     InsOne a' -> InsRightDig $ Four a' b c d+     InsTwo a1 a2 -> InsNodeDig (node3 a1 a2 b) (Two c d)+  | i < sab = case f (i - sa) b of+     InsOne b' -> InsRightDig $ Four a b' c d+     InsTwo b1 b2 -> InsNodeDig (node3 a b1 b2) (Two c d)+  | i < sabc = case f (i - sab) c of+     InsOne c' -> InsRightDig $ Four a b c' d+     InsTwo c1 c2 -> InsNodeDig (node3 a b c1) (Two c2 d)+  | otherwise = case f (i - sabc) d of+     InsOne d' -> InsRightDig $ Four a b c d'+     InsTwo d1 d2 -> InsNodeDig (node3 a b c) (Two d1 d2)+  where sa = size a+        sab = sa + size b+        sabc = sab + size c++-- | \( O(\log(\min(i,n-i))) \). Delete the element of a sequence at a given+-- index. Return the original sequence if the index is out of range.+--+-- @+-- deleteAt 2 [a,b,c,d] = [a,b,d]+-- deleteAt 4 [a,b,c,d] = deleteAt (-1) [a,b,c,d] = [a,b,c,d]+-- @+--+-- @since 0.5.8+deleteAt :: Int -> Seq a -> Seq a+deleteAt i (Seq xs)+  | fromIntegral i < (fromIntegral (size xs) :: Word) = Seq $ delTreeE i xs+  | otherwise = Seq xs++delTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)+delTreeE !_i EmptyT = EmptyT -- Unreachable+delTreeE _i Single{} = EmptyT+delTreeE i (Deep s pr m sf)+  | i < spr = delLeftDigitE i s pr m sf+  | i < spm = case delTree delNodeE (i - spr) m of+     FullTree m' -> Deep (s - 1) pr m' sf+     DefectTree e -> delRebuildMiddle (s - 1) pr e sf+  | otherwise = delRightDigitE (i - spm) s pr m sf+  where spr = size pr+        spm = spr + size m++delNodeE :: Int -> Node (Elem a) -> Del (Elem a)+delNodeE i (Node3 _ a b c) = case i of+  0 -> Full $ Node2 2 b c+  1 -> Full $ Node2 2 a c+  _ -> Full $ Node2 2 a b+delNodeE i (Node2 _ a b) = case i of+  0 -> Defect b+  _ -> Defect a+++delLeftDigitE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a)+delLeftDigitE !_i s One{} m sf = pullL (s - 1) m sf+delLeftDigitE i s (Two a b) m sf+  | i == 0 = Deep (s - 1) (One b) m sf+  | otherwise = Deep (s - 1) (One a) m sf+delLeftDigitE i s (Three a b c) m sf+  | i == 0 = Deep (s - 1) (Two b c) m sf+  | i == 1 = Deep (s - 1) (Two a c) m sf+  | otherwise = Deep (s - 1) (Two a b) m sf+delLeftDigitE i s (Four a b c d) m sf+  | i == 0 = Deep (s - 1) (Three b c d) m sf+  | i == 1 = Deep (s - 1) (Three a c d) m sf+  | i == 2 = Deep (s - 1) (Three a b d) m sf+  | otherwise = Deep (s - 1) (Three a b c) m sf++delRightDigitE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> FingerTree (Elem a)+delRightDigitE !_i s pr m One{} = pullR (s - 1) pr m+delRightDigitE i s pr m (Two a b)+  | i == 0 = Deep (s - 1) pr m (One b)+  | otherwise = Deep (s - 1) pr m (One a)+delRightDigitE i s pr m (Three a b c)+  | i == 0 = Deep (s - 1) pr m (Two b c)+  | i == 1 = Deep (s - 1) pr m (Two a c)+  | otherwise = deep pr m (Two a b)+delRightDigitE i s pr m (Four a b c d)+  | i == 0 = Deep (s - 1) pr m (Three b c d)+  | i == 1 = Deep (s - 1) pr m (Three a c d)+  | i == 2 = Deep (s - 1) pr m (Three a b d)+  | otherwise = Deep (s - 1) pr m (Three a b c)++data DelTree a = FullTree !(FingerTree (Node a)) | DefectTree a++{-# SPECIALIZE delTree :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> FingerTree (Node (Elem a)) -> DelTree (Elem a) #-}+{-# SPECIALIZE delTree :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> FingerTree (Node (Node a)) -> DelTree (Node a) #-}+delTree :: Sized a => (Int -> Node a -> Del a) -> Int -> FingerTree (Node a) -> DelTree a+delTree _f !_i EmptyT = FullTree EmptyT -- Unreachable+delTree f i (Single a) = case f i a of+  Full a' -> FullTree (Single a')+  Defect e -> DefectTree e+delTree f i (Deep s pr m sf)+  | i < spr = case delDigit f i pr of+     FullDig pr' -> FullTree $ Deep (s - 1) pr' m sf+     DefectDig e -> case viewLTree m of+                      EmptyLTree -> FullTree $ delRebuildRightDigit (s - 1) e sf+                      ConsLTree n m' -> FullTree $ delRebuildLeftSide (s - 1) e n m' sf+  | i < spm = case delTree (delNode f) (i - spr) m of+     FullTree m' -> FullTree (Deep (s - 1) pr m' sf)+     DefectTree e -> FullTree $ delRebuildMiddle (s - 1) pr e sf+  | otherwise = case delDigit f (i - spm) sf of+     FullDig sf' -> FullTree $ Deep (s - 1) pr m sf'+     DefectDig e -> case viewRTree m of+                      EmptyRTree -> FullTree $ delRebuildLeftDigit (s - 1) pr e+                      SnocRTree m' n -> FullTree $ delRebuildRightSide (s - 1) pr m' n e+  where spr = size pr+        spm = spr + size m++data Del a = Full !(Node a) | Defect a++{-# SPECIALIZE delNode :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> Node (Node (Elem a)) -> Del (Node (Elem a)) #-}+{-# SPECIALIZE delNode :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> Node (Node (Node a)) -> Del (Node (Node a)) #-}+delNode :: Sized a => (Int -> Node a -> Del a) -> Int -> Node (Node a) -> Del (Node a)+delNode f i (Node3 s a b c)+  | i < sa = case f i a of+     Full a' -> Full $ Node3 (s - 1) a' b c+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> Full $ Node3 (s - 1) (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c+         where !sx = size x+       Node2 sxy x y -> Full $ Node2 (s - 1) (Node3 (sxy + se) e x y) c+  | i < sab = case f (i - sa) b of+     Full b' -> Full $ Node3 (s - 1) a b' c+     Defect e -> let !se = size e in case a of+       Node3 sxyz x y z -> Full $ Node3 (s - 1) (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c+         where !sz = size z+       Node2 sxy x y -> Full $ Node2 (s - 1) (Node3 (sxy + se) x y e) c+  | otherwise = case f (i - sab) c of+     Full c' -> Full $ Node3 (s - 1) a b c'+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> Full $ Node3 (s - 1) a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)+         where !sz = size z+       Node2 sxy x y -> Full $ Node2 (s - 1) a (Node3 (sxy + se) x y e)+  where sa = size a+        sab = sa + size b+delNode f i (Node2 s a b)+  | i < sa = case f i a of+     Full a' -> Full $ Node2 (s - 1) a' b+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> Full $ Node2 (s - 1) (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z)+        where !sx = size x+       Node2 _ x y -> Defect $ Node3 (s - 1) e x y+  | otherwise = case f (i - sa) b of+     Full b' -> Full $ Node2 (s - 1) a b'+     Defect e -> let !se = size e in case a of+       Node3 sxyz x y z -> Full $ Node2 (s - 1) (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)+         where !sz = size z+       Node2 _ x y -> Defect $ Node3 (s - 1) x y e+  where sa = size a++{-# SPECIALIZE delRebuildRightDigit :: Int -> Elem a -> Digit (Node (Elem a)) -> FingerTree (Node (Elem a)) #-}+{-# SPECIALIZE delRebuildRightDigit :: Int -> Node a -> Digit (Node (Node a)) -> FingerTree (Node (Node a)) #-}+delRebuildRightDigit :: Sized a => Int -> a -> Digit (Node a) -> FingerTree (Node a)+delRebuildRightDigit s p (One a) = let !sp = size p in case a of+  Node3 sxyz x y z -> Deep s (One (Node2 (sp + sx) p x)) EmptyT (One (Node2 (sxyz - sx) y z))+    where !sx = size x+  Node2 sxy x y -> Single (Node3 (sp + sxy) p x y)+delRebuildRightDigit s p (Two a b) = let !sp = size p in case a of+  Node3 sxyz x y z -> Deep s (Two (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z)) EmptyT (One b)+    where !sx = size x+  Node2 sxy x y -> Deep s (One (Node3 (sp + sxy) p x y)) EmptyT (One b)+delRebuildRightDigit s p (Three a b c) = let !sp = size p in case a of+  Node3 sxyz x y z -> Deep s (Two (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z)) EmptyT (Two b c)+    where !sx = size x+  Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) EmptyT (One c)+delRebuildRightDigit s p (Four a b c d) = let !sp = size p in case a of+  Node3 sxyz x y z -> Deep s (Three (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b) EmptyT (Two c d)+    where !sx = size x+  Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) EmptyT (Two c d)++{-# SPECIALIZE delRebuildLeftDigit :: Int -> Digit (Node (Elem a)) -> Elem a -> FingerTree (Node (Elem a)) #-}+{-# SPECIALIZE delRebuildLeftDigit :: Int -> Digit (Node (Node a)) -> Node a -> FingerTree (Node (Node a)) #-}+delRebuildLeftDigit :: Sized a => Int -> Digit (Node a) -> a -> FingerTree (Node a)+delRebuildLeftDigit s (One a) p = let !sp = size p in case a of+  Node3 sxyz x y z -> Deep s (One (Node2 (sxyz - sz) x y)) EmptyT (One (Node2 (sz + sp) z p))+    where !sz = size z+  Node2 sxy x y -> Single (Node3 (sxy + sp) x y p)+delRebuildLeftDigit s (Two a b) p = let !sp = size p in case b of+  Node3 sxyz x y z -> Deep s (Two a (Node2 (sxyz - sz) x y)) EmptyT (One (Node2 (sz + sp) z p))+    where !sz = size z+  Node2 sxy x y -> Deep s (One a) EmptyT (One (Node3 (sxy + sp) x y p))+delRebuildLeftDigit s (Three a b c) p = let !sp = size p in case c of+  Node3 sxyz x y z -> Deep s (Two a b) EmptyT (Two (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))+    where !sz = size z+  Node2 sxy x y -> Deep s (Two a b) EmptyT (One (Node3 (sxy + sp) x y p))+delRebuildLeftDigit s (Four a b c d) p = let !sp = size p in case d of+  Node3 sxyz x y z -> Deep s (Three a b c) EmptyT (Two (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))+    where !sz = size z+  Node2 sxy x y -> Deep s (Two a b) EmptyT (Two c (Node3 (sxy + sp) x y p))++delRebuildLeftSide :: Sized a+                   => Int -> a -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)+                   -> FingerTree (Node a)+delRebuildLeftSide s p (Node2 _ a b) m sf = let !sp = size p in case a of+  Node2 sxy x y -> Deep s (Two (Node3 (sp + sxy) p x y) b) m sf+  Node3 sxyz x y z -> Deep s (Three (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b) m sf+    where !sx = size x+delRebuildLeftSide s p (Node3 _ a b c) m sf = let !sp = size p in case a of+  Node2 sxy x y -> Deep s (Three (Node3 (sp + sxy) p x y) b c) m sf+  Node3 sxyz x y z -> Deep s (Four (Node2 (sp + sx) p x) (Node2 (sxyz - sx) y z) b c) m sf+    where !sx = size x++delRebuildRightSide :: Sized a+                    => Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a) -> a+                    -> FingerTree (Node a)+delRebuildRightSide s pr m (Node2 _ a b) p = let !sp = size p in case b of+  Node2 sxy x y -> Deep s pr m (Two a (Node3 (sxy + sp) x y p))+  Node3 sxyz x y z -> Deep s pr m (Three a (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))+    where !sz = size z+delRebuildRightSide s pr m (Node3 _ a b c) p = let !sp = size p in case c of+  Node2 sxy x y -> Deep s pr m (Three a b (Node3 (sxy + sp) x y p))+  Node3 sxyz x y z -> Deep s pr m (Four a b (Node2 (sxyz - sz) x y) (Node2 (sz + sp) z p))+    where !sz = size z++delRebuildMiddle :: Sized a+                 => Int -> Digit a -> a -> Digit a+                 -> FingerTree a+delRebuildMiddle s (One a) e sf = Deep s (Two a e) EmptyT sf+delRebuildMiddle s (Two a b) e sf = Deep s (Three a b e) EmptyT sf+delRebuildMiddle s (Three a b c) e sf = Deep s (Four a b c e) EmptyT sf+delRebuildMiddle s (Four a b c d) e sf = Deep s (Two a b) (Single (node3 c d e)) sf++data DelDig a = FullDig !(Digit (Node a)) | DefectDig a++{-# SPECIALIZE delDigit :: (Int -> Node (Elem a) -> Del (Elem a)) -> Int -> Digit (Node (Elem a)) -> DelDig (Elem a) #-}+{-# SPECIALIZE delDigit :: (Int -> Node (Node a) -> Del (Node a)) -> Int -> Digit (Node (Node a)) -> DelDig (Node a) #-}+delDigit :: Sized a => (Int -> Node a -> Del a) -> Int -> Digit (Node a) -> DelDig a+delDigit f !i (One a) = case f i a of+  Full a' -> FullDig $ One a'+  Defect e -> DefectDig e+delDigit f i (Two a b)+  | i < sa = case f i a of+     Full a' -> FullDig $ Two a' b+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> FullDig $ Two (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z)+         where !sx = size x+       Node2 sxy x y -> FullDig $ One (Node3 (se + sxy) e x y)+  | otherwise = case f (i - sa) b of+     Full b' -> FullDig $ Two a b'+     Defect e -> let !se = size e in case a of+       Node3 sxyz x y z -> FullDig $ Two (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)+         where !sz = size z+       Node2 sxy x y -> FullDig $ One (Node3 (sxy + se) x y e)+  where sa = size a+delDigit f i (Three a b c)+  | i < sa = case f i a of+     Full a' -> FullDig $ Three a' b c+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> FullDig $ Three (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c+         where !sx = size x+       Node2 sxy x y -> FullDig $ Two (Node3 (se + sxy) e x y) c+  | i < sab = case f (i - sa) b of+     Full b' -> FullDig $ Three a b' c+     Defect e -> let !se = size e in case a of+       Node3 sxyz x y z -> FullDig $ Three (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c+         where !sz = size z+       Node2 sxy x y -> FullDig $ Two (Node3 (sxy + se) x y e) c+  | otherwise = case f (i - sab) c of+     Full c' -> FullDig $ Three a b c'+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> FullDig $ Three a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)+         where !sz = size z+       Node2 sxy x y -> FullDig $ Two a (Node3 (sxy + se) x y e)+  where sa = size a+        sab = sa + size b+delDigit f i (Four a b c d)+  | i < sa = case f i a of+     Full a' -> FullDig $ Four a' b c d+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> FullDig $ Four (Node2 (se + sx) e x) (Node2 (sxyz - sx) y z) c d+         where !sx = size x+       Node2 sxy x y -> FullDig $ Three (Node3 (se + sxy) e x y) c d+  | i < sab = case f (i - sa) b of+     Full b' -> FullDig $ Four a b' c d+     Defect e -> let !se = size e in case a of+       Node3 sxyz x y z -> FullDig $ Four (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) c d+         where !sz = size z+       Node2 sxy x y -> FullDig $ Three (Node3 (sxy + se) x y e) c d+  | i < sabc = case f (i - sab) c of+     Full c' -> FullDig $ Four a b c' d+     Defect e -> let !se = size e in case b of+       Node3 sxyz x y z -> FullDig $ Four a (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e) d+         where !sz = size z+       Node2 sxy x y -> FullDig $ Three a (Node3 (sxy + se) x y e) d+  | otherwise = case f (i - sabc) d of+     Full d' -> FullDig $ Four a b c d'+     Defect e -> let !se = size e in case c of+       Node3 sxyz x y z -> FullDig $ Four a b (Node2 (sxyz - sz) x y) (Node2 (sz + se) z e)+         where !sz = size z+       Node2 sxy x y -> FullDig $ Three a b (Node3 (sxy + se) x y e)+  where sa = size a+        sab = sa + size b+        sabc = sab + size c+++-- | A generalization of 'fmap', 'mapWithIndex' takes a mapping+-- function that also depends on the element's index, and applies it to every+-- element in the sequence.+mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b+mapWithIndex f' (Seq xs') = Seq $ mapWithIndexTree (\s (Elem a) -> Elem (f' s a)) 0 xs'+ where+  {-# SPECIALIZE mapWithIndexTree :: (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> FingerTree b #-}+  {-# SPECIALIZE mapWithIndexTree :: (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> FingerTree b #-}+  mapWithIndexTree :: Sized a => (Int -> a -> b) -> Int -> FingerTree a -> FingerTree b+  mapWithIndexTree _ !_s EmptyT = EmptyT+  mapWithIndexTree f s (Single xs) = Single $ f s xs+  mapWithIndexTree f s (Deep n pr m sf) =+          Deep n+               (mapWithIndexDigit f s pr)+               (mapWithIndexTree (mapWithIndexNode f) sPspr m)+               (mapWithIndexDigit f sPsprm sf)+    where+      !sPspr = s + size pr+      !sPsprm = sPspr + size m++  {-# SPECIALIZE mapWithIndexDigit :: (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> Digit b #-}+  {-# SPECIALIZE mapWithIndexDigit :: (Int -> Node y -> b) -> Int -> Digit (Node y) -> Digit b #-}+  mapWithIndexDigit :: Sized a => (Int -> a -> b) -> Int -> Digit a -> Digit b+  mapWithIndexDigit f !s (One a) = One (f s a)+  mapWithIndexDigit f s (Two a b) = Two (f s a) (f sPsa b)+    where+      !sPsa = s + size a+  mapWithIndexDigit f s (Three a b c) =+                                      Three (f s a) (f sPsa b) (f sPsab c)+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b+  mapWithIndexDigit f s (Four a b c d) =+                          Four (f s a) (f sPsa b) (f sPsab c) (f sPsabc d)+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b+      !sPsabc = sPsab + size c++  {-# SPECIALIZE mapWithIndexNode :: (Int -> Elem y -> b) -> Int -> Node (Elem y) -> Node b #-}+  {-# SPECIALIZE mapWithIndexNode :: (Int -> Node y -> b) -> Int -> Node (Node y) -> Node b #-}+  mapWithIndexNode :: Sized a => (Int -> a -> b) -> Int -> Node a -> Node b+  mapWithIndexNode f s (Node2 ns a b) = Node2 ns (f s a) (f sPsa b)+    where+      !sPsa = s + size a+  mapWithIndexNode f s (Node3 ns a b c) =+                                     Node3 ns (f s a) (f sPsa b) (f sPsab c)+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] mapWithIndex #-}+{-# RULES+"mapWithIndex/mapWithIndex" forall f g xs . mapWithIndex f (mapWithIndex g xs) =+  mapWithIndex (\k a -> f k (g k a)) xs+"mapWithIndex/fmapSeq" forall f g xs . mapWithIndex f (fmapSeq g xs) =+  mapWithIndex (\k a -> f k (g a)) xs+"fmapSeq/mapWithIndex" forall f g xs . fmapSeq f (mapWithIndex g xs) =+  mapWithIndex (\k a -> f (g k a)) xs+ #-}+#endif++{-# INLINE foldWithIndexDigit #-}+foldWithIndexDigit :: Sized a => (b -> b -> b) -> (Int -> a -> b) -> Int -> Digit a -> b+foldWithIndexDigit _ f !s (One a) = f s a+foldWithIndexDigit (<+>) f s (Two a b) = f s a <+> f sPsa b+  where+    !sPsa = s + size a+foldWithIndexDigit (<+>) f s (Three a b c) = f s a <+> f sPsa b <+> f sPsab c+  where+    !sPsa = s + size a+    !sPsab = sPsa + size b+foldWithIndexDigit (<+>) f s (Four a b c d) =+    f s a <+> f sPsa b <+> f sPsab c <+> f sPsabc d+  where+    !sPsa = s + size a+    !sPsab = sPsa + size b+    !sPsabc = sPsab + size c++{-# INLINE foldWithIndexNode #-}+foldWithIndexNode :: Sized a => (m -> m -> m) -> (Int -> a -> m) -> Int -> Node a -> m+foldWithIndexNode (<+>) f !s (Node2 _ a b) = f s a <+> f sPsa b+  where+    !sPsa = s + size a+foldWithIndexNode (<+>) f s (Node3 _ a b c) = f s a <+> f sPsa b <+> f sPsab c+  where+    !sPsa = s + size a+    !sPsab = sPsa + size b++-- A generalization of 'foldMap', 'foldMapWithIndex' takes a folding+-- function that also depends on the element's index, and applies it to every+-- element in the sequence.+--+-- @since 0.5.8+foldMapWithIndex :: Monoid m => (Int -> a -> m) -> Seq a -> m+foldMapWithIndex f' (Seq xs') = foldMapWithIndexTreeE (lift_elem f') 0 xs'+ where+  lift_elem :: (Int -> a -> m) -> (Int -> Elem a -> m)+#ifdef __GLASGOW_HASKELL__+  lift_elem g = coerce g+#else+  lift_elem g = \s (Elem a) -> g s a+#endif+  {-# INLINE lift_elem #-}+-- We have to specialize these functions by hand, unfortunately, because+-- GHC does not specialize until *all* instances are determined.+-- Although the Sized instance is known at compile time, the Monoid+-- instance generally is not.+  foldMapWithIndexTreeE :: Monoid m => (Int -> Elem a -> m) -> Int -> FingerTree (Elem a) -> m+  foldMapWithIndexTreeE _ !_s EmptyT = mempty+  foldMapWithIndexTreeE f s (Single xs) = f s xs+  foldMapWithIndexTreeE f s (Deep _ pr m sf) =+               foldMapWithIndexDigitE f s pr <>+               foldMapWithIndexTreeN (foldMapWithIndexNodeE f) sPspr m <>+               foldMapWithIndexDigitE f sPsprm sf+    where+      !sPspr = s + size pr+      !sPsprm = sPspr + size m++  foldMapWithIndexTreeN :: Monoid m => (Int -> Node a -> m) -> Int -> FingerTree (Node a) -> m+  foldMapWithIndexTreeN _ !_s EmptyT = mempty+  foldMapWithIndexTreeN f s (Single xs) = f s xs+  foldMapWithIndexTreeN f s (Deep _ pr m sf) =+               foldMapWithIndexDigitN f s pr <>+               foldMapWithIndexTreeN (foldMapWithIndexNodeN f) sPspr m <>+               foldMapWithIndexDigitN f sPsprm sf+    where+      !sPspr = s + size pr+      !sPsprm = sPspr + size m++  foldMapWithIndexDigitE :: Monoid m => (Int -> Elem a -> m) -> Int -> Digit (Elem a) -> m+  foldMapWithIndexDigitE f i t = foldWithIndexDigit (<>) f i t++  foldMapWithIndexDigitN :: Monoid m => (Int -> Node a -> m) -> Int -> Digit (Node a) -> m+  foldMapWithIndexDigitN f i t = foldWithIndexDigit (<>) f i t++  foldMapWithIndexNodeE :: Monoid m => (Int -> Elem a -> m) -> Int -> Node (Elem a) -> m+  foldMapWithIndexNodeE f i t = foldWithIndexNode (<>) f i t++  foldMapWithIndexNodeN :: Monoid m => (Int -> Node a -> m) -> Int -> Node (Node a) -> m+  foldMapWithIndexNodeN f i t = foldWithIndexNode (<>) f i t++#if __GLASGOW_HASKELL__+{-# INLINABLE foldMapWithIndex #-}+#endif++-- | 'traverseWithIndex' is a version of 'traverse' that also offers+-- access to the index of each element.+--+-- @since 0.5.8+traverseWithIndex :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)+traverseWithIndex f' (Seq xs') = Seq <$> traverseWithIndexTreeE (\s (Elem a) -> Elem <$> f' s a) 0 xs'+ where+-- We have to specialize these functions by hand, unfortunately, because+-- GHC does not specialize until *all* instances are determined.+-- Although the Sized instance is known at compile time, the Applicative+-- instance generally is not.+  traverseWithIndexTreeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> FingerTree (Elem a) -> f (FingerTree b)+  traverseWithIndexTreeE _ !_s EmptyT = pure EmptyT+  traverseWithIndexTreeE f s (Single xs) = Single <$> f s xs+  traverseWithIndexTreeE f s (Deep n pr m sf) =+          liftA3 (Deep n)+               (traverseWithIndexDigitE f s pr)+               (traverseWithIndexTreeN (traverseWithIndexNodeE f) sPspr m)+               (traverseWithIndexDigitE f sPsprm sf)+    where+      !sPspr = s + size pr+      !sPsprm = sPspr + size m++  traverseWithIndexTreeN :: Applicative f => (Int -> Node a -> f b) -> Int -> FingerTree (Node a) -> f (FingerTree b)+  traverseWithIndexTreeN _ !_s EmptyT = pure EmptyT+  traverseWithIndexTreeN f s (Single xs) = Single <$> f s xs+  traverseWithIndexTreeN f s (Deep n pr m sf) =+          liftA3 (Deep n)+               (traverseWithIndexDigitN f s pr)+               (traverseWithIndexTreeN (traverseWithIndexNodeN f) sPspr m)+               (traverseWithIndexDigitN f sPsprm sf)+    where+      !sPspr = s + size pr+      !sPsprm = sPspr + size m++  traverseWithIndexDigitE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Digit (Elem a) -> f (Digit b)+  traverseWithIndexDigitE f i t = traverseWithIndexDigit f i t++  traverseWithIndexDigitN :: Applicative f => (Int -> Node a -> f b) -> Int -> Digit (Node a) -> f (Digit b)+  traverseWithIndexDigitN f i t = traverseWithIndexDigit f i t++  {-# INLINE traverseWithIndexDigit #-}+  traverseWithIndexDigit :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Digit a -> f (Digit b)+  traverseWithIndexDigit f !s (One a) = One <$> f s a+  traverseWithIndexDigit f s (Two a b) = liftA2 Two (f s a) (f sPsa b)+    where+      !sPsa = s + size a+  traverseWithIndexDigit f s (Three a b c) =+                                      liftA3 Three (f s a) (f sPsa b) (f sPsab c)+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b+  traverseWithIndexDigit f s (Four a b c d) =+                          liftA3 Four (f s a) (f sPsa b) (f sPsab c) <*> f sPsabc d+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b+      !sPsabc = sPsab + size c++  traverseWithIndexNodeE :: Applicative f => (Int -> Elem a -> f b) -> Int -> Node (Elem a) -> f (Node b)+  traverseWithIndexNodeE f i t = traverseWithIndexNode f i t++  traverseWithIndexNodeN :: Applicative f => (Int -> Node a -> f b) -> Int -> Node (Node a) -> f (Node b)+  traverseWithIndexNodeN f i t = traverseWithIndexNode f i t++  {-# INLINE traverseWithIndexNode #-}+  traverseWithIndexNode :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Node a -> f (Node b)+  traverseWithIndexNode f !s (Node2 ns a b) = liftA2 (Node2 ns) (f s a) (f sPsa b)+    where+      !sPsa = s + size a+  traverseWithIndexNode f s (Node3 ns a b c) =+                           liftA3 (Node3 ns) (f s a) (f sPsa b) (f sPsab c)+    where+      !sPsa = s + size a+      !sPsab = sPsa + size b+++#ifdef __GLASGOW_HASKELL__+{-# INLINABLE [1] traverseWithIndex #-}+#else+{-# INLINE [1] traverseWithIndex #-}+#endif++#ifdef __GLASGOW_HASKELL__+{-# RULES+"travWithIndex/mapWithIndex" forall f g xs . traverseWithIndex f (mapWithIndex g xs) =+  traverseWithIndex (\k a -> f k (g k a)) xs+"travWithIndex/fmapSeq" forall f g xs . traverseWithIndex f (fmapSeq g xs) =+  traverseWithIndex (\k a -> f k (g a)) xs+ #-}+#endif+{-+It might be nice to be able to rewrite++traverseWithIndex f (fromFunction i g)+to+replicateAWithIndex i (\k -> f k (g k))+and+traverse f (fromFunction i g)+to+replicateAWithIndex i (f . g)++but we don't have replicateAWithIndex as yet.++We might wish for a rule like+"fmapSeq/travWithIndex" forall f g xs . fmapSeq f <$> traverseWithIndex g xs =+  traverseWithIndex (\k a -> f <$> g k a) xs+Unfortunately, this rule could screw up the inliner's treatment of+fmap in general, and it also relies on the arbitrary Functor being+valid.+-}+++-- | \( O(n) \). Convert a given sequence length and a function representing that+-- sequence into a sequence.+--+-- @since 0.5.6.2+fromFunction :: Int -> (Int -> a) -> Seq a+fromFunction len f | len < 0 = error "Data.Sequence.fromFunction called with negative len"+                   | len == 0 = empty+                   | otherwise = Seq $ create (lift_elem f) 1 0 len+  where+    create :: (Int -> a) -> Int -> Int -> Int -> FingerTree a+    create b{-tree_builder-} !s{-tree_size-} !i{-start_index-} trees = case trees of+       1 -> Single $ b i+       2 -> Deep (2*s) (One (b i)) EmptyT (One (b (i+s)))+       3 -> Deep (3*s) (createTwo i) EmptyT (One (b (i+2*s)))+       4 -> Deep (4*s) (createTwo i) EmptyT (createTwo (i+2*s))+       5 -> Deep (5*s) (createThree i) EmptyT (createTwo (i+3*s))+       6 -> Deep (6*s) (createThree i) EmptyT (createThree (i+3*s))+       _ -> case trees `quotRem` 3 of+           (trees', 1) -> Deep (trees*s) (createTwo i)+                              (create mb (3*s) (i+2*s) (trees'-1))+                              (createTwo (i+(2+3*(trees'-1))*s))+           (trees', 2) -> Deep (trees*s) (createThree i)+                              (create mb (3*s) (i+3*s) (trees'-1))+                              (createTwo (i+(3+3*(trees'-1))*s))+           (trees', _) -> Deep (trees*s) (createThree i)+                              (create mb (3*s) (i+3*s) (trees'-2))+                              (createThree (i+(3+3*(trees'-2))*s))+      where+        createTwo j = Two (b j) (b (j + s))+        {-# INLINE createTwo #-}+        createThree j = Three (b j) (b (j + s)) (b (j + 2*s))+        {-# INLINE createThree #-}+        mb j = Node3 (3*s) (b j) (b (j + s)) (b (j + 2*s))+        {-# INLINE mb #-}++    lift_elem :: (Int -> a) -> (Int -> Elem a)+#ifdef __GLASGOW_HASKELL__+    lift_elem g = coerce g+#else+    lift_elem g = Elem . g+#endif+    {-# INLINE lift_elem #-}++-- | \( O(n) \). Create a sequence consisting of the elements of an 'Array'.+-- Note that the resulting sequence elements may be evaluated lazily (as on GHC),+-- so you must force the entire structure to be sure that the original array+-- can be garbage-collected.+--+-- @since 0.5.6.2+fromArray :: Ix i => Array i a -> Seq a+#ifdef __GLASGOW_HASKELL__+fromArray a = fromFunction (GHC.Arr.numElements a) (GHC.Arr.unsafeAt a)+ where+  -- The following definition uses an (Ix i) constraint, which is needed for+  -- the other fromArray definition.+  _ = Data.Array.rangeSize (Data.Array.bounds a)+#else+fromArray a = fromList2 (Data.Array.rangeSize (Data.Array.bounds a)) (Data.Array.elems a)+#endif++-- Splitting++-- | \( O(\log(\min(i,n-i))) \). The first @i@ elements of a sequence.+-- If @i@ is negative, @'take' i s@ yields the empty sequence.+-- If the sequence contains fewer than @i@ elements, the whole sequence+-- is returned.+take :: Int -> Seq a -> Seq a+take i xs@(Seq t)+    -- See note on unsigned arithmetic in splitAt+  | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =+      Seq (takeTreeE i t)+  | i <= 0 = empty+  | otherwise = xs++takeTreeE :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)+takeTreeE !_i EmptyT = EmptyT+takeTreeE i t@(Single _)+   | i <= 0 = EmptyT+   | otherwise = t+takeTreeE i (Deep s pr m sf)+  | i < spr     = takePrefixE i pr+  | i < spm     = case takeTreeN im m of+            ml :*: xs -> takeMiddleE (im - size ml) spr pr ml xs+  | otherwise   = takeSuffixE (i - spm) s pr m sf+  where+    spr     = size pr+    spm     = spr + size m+    im      = i - spr++takeTreeN :: Int -> FingerTree (Node a) -> StrictPair (FingerTree (Node a)) (Node a)+takeTreeN !_i EmptyT = error "takeTreeN of empty tree"+takeTreeN _i (Single x) = EmptyT :*: x+takeTreeN i (Deep s pr m sf)+  | i < spr     = takePrefixN i pr+  | i < spm     = case takeTreeN im m of+            ml :*: xs -> takeMiddleN (im - size ml) spr pr ml xs+  | otherwise   = takeSuffixN (i - spm) s pr m sf  where+    spr     = size pr+    spm     = spr + size m+    im      = i - spr++takeMiddleN :: Int -> Int+             -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a)+             -> StrictPair (FingerTree (Node a)) (Node a)+takeMiddleN i spr pr ml (Node2 _ a b)+  | i < sa      = pullR sprml pr ml :*: a+  | otherwise   = Deep sprmla pr ml (One a) :*: b+  where+    sa      = size a+    sprml   = spr + size ml+    sprmla  = sa + sprml+takeMiddleN i spr pr ml (Node3 _ a b c)+  | i < sa      = pullR sprml pr ml :*: a+  | i < sab     = Deep sprmla pr ml (One a) :*: b+  | otherwise   = Deep sprmlab pr ml (Two a b) :*: c+  where+    sa      = size a+    sab     = sa + size b+    sprml   = spr + size ml+    sprmla  = sa + sprml+    sprmlab = sprmla + size b++takeMiddleE :: Int -> Int+             -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Node (Elem a)+             -> FingerTree (Elem a)+takeMiddleE i spr pr ml (Node2 _ a _)+  | i < 1       = pullR sprml pr ml+  | otherwise   = Deep sprmla pr ml (One a)+  where+    sprml   = spr + size ml+    sprmla  = 1 + sprml+takeMiddleE i spr pr ml (Node3 _ a b _)+  | i < 1       = pullR sprml pr ml+  | i < 2       = Deep sprmla pr ml (One a)+  | otherwise   = Deep sprmlab pr ml (Two a b)+  where+    sprml   = spr + size ml+    sprmla  = 1 + sprml+    sprmlab = sprmla + 1++takePrefixE :: Int -> Digit (Elem a) -> FingerTree (Elem a)+takePrefixE !_i (One _) = EmptyT+takePrefixE i (Two a _)+  | i < 1       = EmptyT+  | otherwise   = Single a+takePrefixE i (Three a b _)+  | i < 1       = EmptyT+  | i < 2       = Single a+  | otherwise   = Deep 2 (One a) EmptyT (One b)+takePrefixE i (Four a b c _)+  | i < 1       = EmptyT+  | i < 2       = Single a+  | i < 3       = Deep 2 (One a) EmptyT (One b)+  | otherwise   = Deep 3 (Two a b) EmptyT (One c)++takePrefixN :: Int -> Digit (Node a)+                    -> StrictPair (FingerTree (Node a)) (Node a)+takePrefixN !_i (One a) = EmptyT :*: a+takePrefixN i (Two a b)+  | i < sa      = EmptyT :*: a+  | otherwise   = Single a :*: b+  where+    sa      = size a+takePrefixN i (Three a b c)+  | i < sa      = EmptyT :*: a+  | i < sab     = Single a :*: b+  | otherwise   = Deep sab (One a) EmptyT (One b) :*: c+  where+    sa      = size a+    sab     = sa + size b+takePrefixN i (Four a b c d)+  | i < sa      = EmptyT :*: a+  | i < sab     = Single a :*: b+  | i < sabc    = Deep sab (One a) EmptyT (One b) :*: c+  | otherwise   = Deep sabc (Two a b) EmptyT (One c) :*: d+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c++takeSuffixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->+   FingerTree (Elem a)+takeSuffixE !_i !s pr m (One _) = pullR (s - 1) pr m+takeSuffixE i s pr m (Two a _)+  | i < 1      = pullR (s - 2) pr m+  | otherwise  = Deep (s - 1) pr m (One a)+takeSuffixE i s pr m (Three a b _)+  | i < 1      = pullR (s - 3) pr m+  | i < 2      = Deep (s - 2) pr m (One a)+  | otherwise  = Deep (s - 1) pr m (Two a b)+takeSuffixE i s pr m (Four a b c _)+  | i < 1      = pullR (s - 4) pr m+  | i < 2      = Deep (s - 3) pr m (One a)+  | i < 3      = Deep (s - 2) pr m (Two a b)+  | otherwise  = Deep (s - 1) pr m (Three a b c)++takeSuffixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->+   StrictPair (FingerTree (Node a)) (Node a)+takeSuffixN !_i !s pr m (One a) = pullR (s - size a) pr m :*: a+takeSuffixN i s pr m (Two a b)+  | i < sa      = pullR (s - sa - size b) pr m :*: a+  | otherwise   = Deep (s - size b) pr m (One a) :*: b+  where+    sa      = size a+takeSuffixN i s pr m (Three a b c)+  | i < sa      = pullR (s - sab - size c) pr m :*: a+  | i < sab     = Deep (s - size b - size c) pr m (One a) :*: b+  | otherwise   = Deep (s - size c) pr m (Two a b) :*: c+  where+    sa      = size a+    sab     = sa + size b+takeSuffixN i s pr m (Four a b c d)+  | i < sa      = pullR (s - sa - sbcd) pr m :*: a+  | i < sab     = Deep (s - sbcd) pr m (One a) :*: b+  | i < sabc    = Deep (s - scd) pr m (Two a b) :*: c+  | otherwise   = Deep (s - sd) pr m (Three a b c) :*: d+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c+    sd      = size d+    scd     = size c + sd+    sbcd    = size b + scd++-- | \( O(\log(\min(i,n-i))) \). Elements of a sequence after the first @i@.+-- If @i@ is negative, @'drop' i s@ yields the whole sequence.+-- If the sequence contains fewer than @i@ elements, the empty sequence+-- is returned.+drop            :: Int -> Seq a -> Seq a+drop i xs@(Seq t)+    -- See note on unsigned arithmetic in splitAt+  | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =+      Seq (takeTreeER (length xs - i) t)+  | i <= 0 = xs+  | otherwise = empty++-- We implement `drop` using a "take from the rear" strategy.  There's no+-- particular technical reason for this; it just lets us reuse the arithmetic+-- from `take` (which itself reuses the arithmetic from `splitAt`) instead of+-- figuring it out from scratch and ending up with lots of off-by-one errors.+takeTreeER :: Int -> FingerTree (Elem a) -> FingerTree (Elem a)+takeTreeER !_i EmptyT = EmptyT+takeTreeER i t@(Single _)+   | i <= 0 = EmptyT+   | otherwise = t+takeTreeER i (Deep s pr m sf)+  | i < ssf     = takeSuffixER i sf+  | i < ssm     = case takeTreeNR im m of+            xs :*: mr -> takeMiddleER (im - size mr) ssf xs mr sf+  | otherwise   = takePrefixER (i - ssm) s pr m sf+  where+    ssf     = size sf+    ssm     = ssf + size m+    im      = i - ssf++takeTreeNR :: Int -> FingerTree (Node a) -> StrictPair (Node a) (FingerTree (Node a))+takeTreeNR !_i EmptyT = error "takeTreeNR of empty tree"+takeTreeNR _i (Single x) = x :*: EmptyT+takeTreeNR i (Deep s pr m sf)+  | i < ssf     = takeSuffixNR i sf+  | i < ssm     = case takeTreeNR im m of+            xs :*: mr -> takeMiddleNR (im - size mr) ssf xs mr sf+  | otherwise   = takePrefixNR (i - ssm) s pr m sf  where+    ssf     = size sf+    ssm     = ssf + size m+    im      = i - ssf++takeMiddleNR :: Int -> Int+             -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)+             -> StrictPair (Node a) (FingerTree (Node a))+takeMiddleNR i ssf (Node2 _ a b) mr sf+  | i < sb      = b :*: pullL ssfmr mr sf+  | otherwise   = a :*: Deep ssfmrb (One b) mr sf+  where+    sb      = size b+    ssfmr   = ssf + size mr+    ssfmrb  = sb + ssfmr+takeMiddleNR i ssf (Node3 _ a b c) mr sf+  | i < sc      = c :*: pullL ssfmr mr sf+  | i < sbc     = b :*: Deep ssfmrc (One c) mr sf+  | otherwise   = a :*: Deep ssfmrbc (Two b c) mr sf+  where+    sc      = size c+    sbc     = sc + size b+    ssfmr   = ssf + size mr+    ssfmrc  = sc + ssfmr+    ssfmrbc = ssfmrc + size b++takeMiddleER :: Int -> Int+             -> Node (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a)+             -> FingerTree (Elem a)+takeMiddleER i ssf (Node2 _ _ b) mr sf+  | i < 1       = pullL ssfmr mr sf+  | otherwise   = Deep ssfmrb (One b) mr sf+  where+    ssfmr   = ssf + size mr+    ssfmrb  = 1 + ssfmr+takeMiddleER i ssf (Node3 _ _ b c) mr sf+  | i < 1       = pullL ssfmr mr sf+  | i < 2       = Deep ssfmrc (One c) mr sf+  | otherwise   = Deep ssfmrbc (Two b c) mr sf+  where+    ssfmr   = ssf + size mr+    ssfmrc  = 1 + ssfmr+    ssfmrbc = ssfmr + 2++takeSuffixER :: Int -> Digit (Elem a) -> FingerTree (Elem a)+takeSuffixER !_i (One _) = EmptyT+takeSuffixER i (Two _ b)+  | i < 1       = EmptyT+  | otherwise   = Single b+takeSuffixER i (Three _ b c)+  | i < 1       = EmptyT+  | i < 2       = Single c+  | otherwise   = Deep 2 (One b) EmptyT (One c)+takeSuffixER i (Four _ b c d)+  | i < 1       = EmptyT+  | i < 2       = Single d+  | i < 3       = Deep 2 (One c) EmptyT (One d)+  | otherwise   = Deep 3 (Two b c) EmptyT (One d)++takeSuffixNR :: Int -> Digit (Node a)+                    -> StrictPair (Node a) (FingerTree (Node a))+takeSuffixNR !_i (One a) = a :*: EmptyT+takeSuffixNR i (Two a b)+  | i < sb      = b :*: EmptyT+  | otherwise   = a :*: Single b+  where+    sb      = size b+takeSuffixNR i (Three a b c)+  | i < sc      = c :*: EmptyT+  | i < sbc     = b :*: Single c+  | otherwise   = a :*: Deep sbc (One b) EmptyT (One c)+  where+    sc      = size c+    sbc     = sc + size b+takeSuffixNR i (Four a b c d)+  | i < sd      = d :*: EmptyT+  | i < scd     = c :*: Single d+  | i < sbcd    = b :*: Deep scd (One c) EmptyT (One d)+  | otherwise   = a :*: Deep sbcd (Two b c) EmptyT (One d)+  where+    sd      = size d+    scd     = sd + size c+    sbcd    = scd + size b++takePrefixER :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->+   FingerTree (Elem a)+takePrefixER !_i !s (One _) m sf = pullL (s - 1) m sf+takePrefixER i s (Two _ b) m sf+  | i < 1      = pullL (s - 2) m sf+  | otherwise  = Deep (s - 1) (One b) m sf+takePrefixER i s (Three _ b c) m sf+  | i < 1      = pullL (s - 3) m sf+  | i < 2      = Deep (s - 2) (One c) m sf+  | otherwise  = Deep (s - 1) (Two b c) m sf+takePrefixER i s (Four _ b c d) m sf+  | i < 1      = pullL (s - 4) m sf+  | i < 2      = Deep (s - 3) (One d) m sf+  | i < 3      = Deep (s - 2) (Two c d) m sf+  | otherwise  = Deep (s - 1) (Three b c d) m sf++takePrefixNR :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->+   StrictPair (Node a) (FingerTree (Node a))+takePrefixNR !_i !s (One a) m sf = a :*: pullL (s - size a) m sf+takePrefixNR i s (Two a b) m sf+  | i < sb      = b :*: pullL (s - sb - size a) m sf+  | otherwise   = a :*: Deep (s - size a) (One b) m sf+  where+    sb      = size b+takePrefixNR i s (Three a b c) m sf+  | i < sc      = c :*: pullL (s - sbc - size a) m sf+  | i < sbc     = b :*: Deep (s - size b - size a) (One c) m sf+  | otherwise   = a :*: Deep (s - size a) (Two b c) m sf+  where+    sc      = size c+    sbc     = sc + size b+takePrefixNR i s (Four a b c d) m sf+  | i < sd      = d :*: pullL (s - sd - sabc) m sf+  | i < scd     = c :*: Deep (s - sabc) (One d) m sf+  | i < sbcd    = b :*: Deep (s - sab) (Two c d) m sf+  | otherwise   = a :*: Deep (s - sa) (Three b c d) m sf+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c+    sd      = size d+    scd     = size c + sd+    sbcd    = size b + scd++-- | \( O(\log(\min(i,n-i))) \). Split a sequence at a given position.+-- @'splitAt' i s = ('take' i s, 'drop' i s)@.+splitAt                  :: Int -> Seq a -> (Seq a, Seq a)+splitAt i xs@(Seq t)+  -- We use an unsigned comparison to make the common case+  -- faster. This only works because our representation of+  -- sizes as (signed) Ints gives us a free high bit to play+  -- with. Note also that there's no sharing to lose in the+  -- case that the length is 0.+  | fromIntegral i - 1 < (fromIntegral (length xs) - 1 :: Word) =+      case splitTreeE i t of+        l :*: r -> (Seq l, Seq r)+  | i <= 0 = (empty, xs)+  | otherwise = (xs, empty)++-- | \( O(\log(\min(i,n-i))) \) A version of 'splitAt' that does not attempt to+-- enhance sharing when the split point is less than or equal to 0, and that+-- gives completely wrong answers when the split point is at least the length+-- of the sequence, unless the sequence is a singleton. This is used to+-- implement zipWith and chunksOf, which are extremely sensitive to the cost of+-- splitting very short sequences. There is just enough of a speed increase to+-- make this worth the trouble.+uncheckedSplitAt :: Int -> Seq a -> (Seq a, Seq a)+uncheckedSplitAt i (Seq xs) = case splitTreeE i xs of+  l :*: r -> (Seq l, Seq r)++data Split a = Split !(FingerTree (Node a)) !(Node a) !(FingerTree (Node a))+#ifdef TESTING+    deriving Show+#endif++splitTreeE :: Int -> FingerTree (Elem a) -> StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))+splitTreeE !_i EmptyT = EmptyT :*: EmptyT+splitTreeE i t@(Single _)+   | i <= 0 = EmptyT :*: t+   | otherwise = t :*: EmptyT+splitTreeE i (Deep s pr m sf)+  | i < spr     = splitPrefixE i s pr m sf+  | i < spm     = case splitTreeN im m of+            Split ml xs mr -> splitMiddleE (im - size ml) s spr pr ml xs mr sf+  | otherwise   = splitSuffixE (i - spm) s pr m sf+  where+    spr     = size pr+    spm     = spr + size m+    im      = i - spr++splitTreeN :: Int -> FingerTree (Node a) -> Split a+splitTreeN !_i EmptyT = error "splitTreeN of empty tree"+splitTreeN _i (Single x) = Split EmptyT x EmptyT+splitTreeN i (Deep s pr m sf)+  | i < spr     = splitPrefixN i s pr m sf+  | i < spm     = case splitTreeN im m of+            Split ml xs mr -> splitMiddleN (im - size ml) s spr pr ml xs mr sf+  | otherwise   = splitSuffixN (i - spm) s pr m sf  where+    spr     = size pr+    spm     = spr + size m+    im      = i - spr++splitMiddleN :: Int -> Int -> Int+             -> Digit (Node a) -> FingerTree (Node (Node a)) -> Node (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a)+             -> Split a+splitMiddleN i s spr pr ml (Node2 _ a b) mr sf+  | i < sa      = Split (pullR sprml pr ml) a (Deep (s - sprmla) (One b) mr sf)+  | otherwise   = Split (Deep sprmla pr ml (One a)) b (pullL (s - sprmla - size b) mr sf)+  where+    sa      = size a+    sprml   = spr + size ml+    sprmla  = sa + sprml+splitMiddleN i s spr pr ml (Node3 _ a b c) mr sf+  | i < sa      = Split (pullR sprml pr ml) a (Deep (s - sprmla) (Two b c) mr sf)+  | i < sab     = Split (Deep sprmla pr ml (One a)) b (Deep (s - sprmlab) (One c) mr sf)+  | otherwise   = Split (Deep sprmlab pr ml (Two a b)) c (pullL (s - sprmlab - size c) mr sf)+  where+    sa      = size a+    sab     = sa + size b+    sprml   = spr + size ml+    sprmla  = sa + sprml+    sprmlab = sprmla + size b++splitMiddleE :: Int -> Int -> Int+             -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Node (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a)+             -> StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))+splitMiddleE i s spr pr ml (Node2 _ a b) mr sf+  | i < 1       = pullR sprml pr ml :*: Deep (s - sprml) (Two a b) mr sf+  | otherwise   = Deep sprmla pr ml (One a) :*: Deep (s - sprmla) (One b) mr sf+  where+    sprml   = spr + size ml+    sprmla  = 1 + sprml+splitMiddleE i s spr pr ml (Node3 _ a b c) mr sf = case i of+  0 -> pullR sprml pr ml :*: Deep (s - sprml) (Three a b c) mr sf+  1 -> Deep sprmla pr ml (One a) :*: Deep (s - sprmla) (Two b c) mr sf+  _ -> Deep sprmlab pr ml (Two a b) :*: Deep (s - sprmlab) (One c) mr sf+  where+    sprml   = spr + size ml+    sprmla  = 1 + sprml+    sprmlab = sprmla + 1++splitPrefixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->+                    StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))+splitPrefixE !_i !s (One a) m sf = EmptyT :*: Deep s (One a) m sf+splitPrefixE i s (Two a b) m sf = case i of+  0 -> EmptyT :*: Deep s (Two a b) m sf+  _ -> Single a :*: Deep (s - 1) (One b) m sf+splitPrefixE i s (Three a b c) m sf = case i of+  0 -> EmptyT :*: Deep s (Three a b c) m sf+  1 -> Single a :*: Deep (s - 1) (Two b c) m sf+  _ -> Deep 2 (One a) EmptyT (One b) :*: Deep (s - 2) (One c) m sf+splitPrefixE i s (Four a b c d) m sf = case i of+  0 -> EmptyT :*: Deep s (Four a b c d) m sf+  1 -> Single a :*: Deep (s - 1) (Three b c d) m sf+  2 -> Deep 2 (One a) EmptyT (One b) :*: Deep (s - 2) (Two c d) m sf+  _ -> Deep 3 (Two a b) EmptyT (One c) :*: Deep (s - 3) (One d) m sf++splitPrefixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->+                    Split a+splitPrefixN !_i !s (One a) m sf = Split EmptyT a (pullL (s - size a) m sf)+splitPrefixN i s (Two a b) m sf+  | i < sa      = Split EmptyT a (Deep (s - sa) (One b) m sf)+  | otherwise   = Split (Single a) b (pullL (s - sa - size b) m sf)+  where+    sa      = size a+splitPrefixN i s (Three a b c) m sf+  | i < sa      = Split EmptyT a (Deep (s - sa) (Two b c) m sf)+  | i < sab     = Split (Single a) b (Deep (s - sab) (One c) m sf)+  | otherwise   = Split (Deep sab (One a) EmptyT (One b)) c (pullL (s - sab - size c) m sf)+  where+    sa      = size a+    sab     = sa + size b+splitPrefixN i s (Four a b c d) m sf+  | i < sa      = Split EmptyT a $ Deep (s - sa) (Three b c d) m sf+  | i < sab     = Split (Single a) b $ Deep (s - sab) (Two c d) m sf+  | i < sabc    = Split (Deep sab (One a) EmptyT (One b)) c $ Deep (s - sabc) (One d) m sf+  | otherwise   = Split (Deep sabc (Two a b) EmptyT (One c)) d $ pullL (s - sabc - size d) m sf+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c++splitSuffixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) ->+   StrictPair (FingerTree (Elem a)) (FingerTree (Elem a))+splitSuffixE !_i !s pr m (One a) = pullR (s - 1) pr m :*: Single a+splitSuffixE i s pr m (Two a b) = case i of+  0 -> pullR (s - 2) pr m :*: Deep 2 (One a) EmptyT (One b)+  _ -> Deep (s - 1) pr m (One a) :*: Single b+splitSuffixE i s pr m (Three a b c) = case i of+  0 -> pullR (s - 3) pr m :*: Deep 3 (Two a b) EmptyT (One c)+  1 -> Deep (s - 2) pr m (One a) :*: Deep 2 (One b) EmptyT (One c)+  _ -> Deep (s - 1) pr m (Two a b) :*: Single c+splitSuffixE i s pr m (Four a b c d) = case i of+  0 -> pullR (s - 4) pr m :*: Deep 4 (Two a b) EmptyT (Two c d)+  1 -> Deep (s - 3) pr m (One a) :*: Deep 3 (Two b c) EmptyT (One d)+  2 -> Deep (s - 2) pr m (Two a b) :*: Deep 2 (One c) EmptyT (One d)+  _ -> Deep (s - 1) pr m (Three a b c) :*: Single d++splitSuffixN :: Int -> Int -> Digit (Node a) -> FingerTree (Node (Node a)) -> Digit (Node a) ->+   Split a+splitSuffixN !_i !s pr m (One a) = Split (pullR (s - size a) pr m) a EmptyT+splitSuffixN i s pr m (Two a b)+  | i < sa      = Split (pullR (s - sa - size b) pr m) a (Single b)+  | otherwise   = Split (Deep (s - size b) pr m (One a)) b EmptyT+  where+    sa      = size a+splitSuffixN i s pr m (Three a b c)+  | i < sa      = Split (pullR (s - sab - size c) pr m) a (deep (One b) EmptyT (One c))+  | i < sab     = Split (Deep (s - size b - size c) pr m (One a)) b (Single c)+  | otherwise   = Split (Deep (s - size c) pr m (Two a b)) c EmptyT+  where+    sa      = size a+    sab     = sa + size b+splitSuffixN i s pr m (Four a b c d)+  | i < sa      = Split (pullR (s - sa - sbcd) pr m) a (Deep sbcd (Two b c) EmptyT (One d))+  | i < sab     = Split (Deep (s - sbcd) pr m (One a)) b (Deep scd (One c) EmptyT (One d))+  | i < sabc    = Split (Deep (s - scd) pr m (Two a b)) c (Single d)+  | otherwise   = Split (Deep (s - sd) pr m (Three a b c)) d EmptyT+  where+    sa      = size a+    sab     = sa + size b+    sabc    = sab + size c+    sd      = size d+    scd     = size c + sd+    sbcd    = size b + scd++-- | \(O \Bigl(\bigl(\frac{n}{c}\bigr) \log c\Bigr)\). @chunksOf c xs@ splits @xs@ into chunks of size @c>0@.+-- If @c@ does not divide the length of @xs@ evenly, then the last element+-- of the result will be short.+--+-- Side note: the given performance bound is missing some messy terms that only+-- really affect edge cases. Performance degrades smoothly from \( O(1) \) (for+-- \( c = n \)) to \( O(n) \) (for \( c = 1 \)). The true bound is more like+-- \( O \Bigl( \bigl(\frac{n}{c} - 1\bigr) (\log (c + 1)) + 1 \Bigr) \)+--+-- @since 0.5.8+chunksOf :: Int -> Seq a -> Seq (Seq a)+chunksOf n xs | n <= 0 =+  if null xs+    then empty+    else error "chunksOf: A non-empty sequence can only be broken up into positively-sized chunks."+chunksOf 1 s = fmap singleton s+chunksOf n s = splitMap (uncheckedSplitAt . (*n)) const most (replicate numReps ())+                 >< if null end then empty else singleton end+  where+    (numReps, endLength) = length s `quotRem` n+    (most, end) = splitAt (length s - endLength) s++-- | \( O(n) \).  Returns a sequence of all suffixes of this sequence,+-- longest first.  For example,+--+-- > tails (fromList "abc") = fromList [fromList "abc", fromList "bc", fromList "c", fromList ""]+--+-- Evaluating the \( i \)th suffix takes \( O(\log(\min(i, n-i))) \), but evaluating+-- every suffix in the sequence takes \( O(n) \) due to sharing.+tails                   :: Seq a -> Seq (Seq a)+tails (Seq xs)          = Seq (tailsTree (Elem . Seq) xs) |> empty++-- | \( O(n) \).  Returns a sequence of all prefixes of this sequence,+-- shortest first.  For example,+--+-- > inits (fromList "abc") = fromList [fromList "", fromList "a", fromList "ab", fromList "abc"]+--+-- Evaluating the \( i \)th prefix takes \( O(\log(\min(i, n-i))) \), but evaluating+-- every prefix in the sequence takes \( O(n) \) due to sharing.+inits                   :: Seq a -> Seq (Seq a)+inits (Seq xs)          = empty <| Seq (initsTree (Elem . Seq) xs)++-- This implementation of tails (and, analogously, inits) has the+-- following algorithmic advantages:+--      Evaluating each tail in the sequence takes linear total time,+--      which is better than we could say for+--              @fromList [drop n xs | n <- [0..length xs]]@.+--      Evaluating any individual tail takes logarithmic time, which is+--      better than we can say for either+--              @scanr (<|) empty xs@ or @iterateN (length xs + 1) (\ xs -> let _ :< xs' = viewl xs in xs') xs@.+--+-- Moreover, if we actually look at every tail in the sequence, the+-- following benchmarks demonstrate that this implementation is modestly+-- faster than any of the above:+--+-- Times (ms)+--               min      mean    +/-sd    median    max+-- Seq.tails:   21.986   24.961   10.169   22.417   86.485+-- scanr:       85.392   87.942    2.488   87.425  100.217+-- iterateN:       29.952   31.245    1.574   30.412   37.268+--+-- The algorithm for tails (and, analogously, inits) is as follows:+--+-- A Node in the FingerTree of tails is constructed by evaluating the+-- corresponding tail of the FingerTree of Nodes, considering the first+-- Node in this tail, and constructing a Node in which each tail of this+-- Node is made to be the prefix of the remaining tree.  This ends up+-- working quite elegantly, as the remainder of the tail of the FingerTree+-- of Nodes becomes the middle of a new tail, the suffix of the Node is+-- the prefix, and the suffix of the original tree is retained.+--+-- In particular, evaluating the /i/th tail involves making as+-- many partial evaluations as the Node depth of the /i/th element.+-- In addition, when we evaluate the /i/th tail, and we also evaluate+-- the /j/th tail, and /m/ Nodes are on the path to both /i/ and /j/,+-- each of those /m/ evaluations are shared between the computation of+-- the /i/th and /j/th tails.+--+-- wasserman.louis@gmail.com, 7/16/09++tailsDigit :: Digit a -> Digit (Digit a)+tailsDigit (One a) = One (One a)+tailsDigit (Two a b) = Two (Two a b) (One b)+tailsDigit (Three a b c) = Three (Three a b c) (Two b c) (One c)+tailsDigit (Four a b c d) = Four (Four a b c d) (Three b c d) (Two c d) (One d)++initsDigit :: Digit a -> Digit (Digit a)+initsDigit (One a) = One (One a)+initsDigit (Two a b) = Two (One a) (Two a b)+initsDigit (Three a b c) = Three (One a) (Two a b) (Three a b c)+initsDigit (Four a b c d) = Four (One a) (Two a b) (Three a b c) (Four a b c d)++tailsNode :: Node a -> Node (Digit a)+tailsNode (Node2 s a b) = Node2 s (Two a b) (One b)+tailsNode (Node3 s a b c) = Node3 s (Three a b c) (Two b c) (One c)++initsNode :: Node a -> Node (Digit a)+initsNode (Node2 s a b) = Node2 s (One a) (Two a b)+initsNode (Node3 s a b c) = Node3 s (One a) (Two a b) (Three a b c)++{-# SPECIALIZE tailsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}+{-# SPECIALIZE tailsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}+-- | Given a function to apply to tails of a tree, applies that function+-- to every tail of the specified tree.+tailsTree :: Sized a => (FingerTree a -> b) -> FingerTree a -> FingerTree b+tailsTree _ EmptyT = EmptyT+tailsTree f (Single x) = Single (f (Single x))+tailsTree f (Deep n pr m sf) =+    Deep n (fmap (\ pr' -> f (deep pr' m sf)) (tailsDigit pr))+        (tailsTree f' m)+        (fmap (f . digitToTree) (tailsDigit sf))+  where+    f' ms = let ConsLTree node m' = viewLTree ms in+        fmap (\ pr' -> f (deep pr' m' sf)) (tailsNode node)++{-# SPECIALIZE initsTree :: (FingerTree (Elem a) -> Elem b) -> FingerTree (Elem a) -> FingerTree (Elem b) #-}+{-# SPECIALIZE initsTree :: (FingerTree (Node a) -> Node b) -> FingerTree (Node a) -> FingerTree (Node b) #-}+-- | Given a function to apply to inits of a tree, applies that function+-- to every init of the specified tree.+initsTree :: Sized a => (FingerTree a -> b) -> FingerTree a -> FingerTree b+initsTree _ EmptyT = EmptyT+initsTree f (Single x) = Single (f (Single x))+initsTree f (Deep n pr m sf) =+    Deep n (fmap (f . digitToTree) (initsDigit pr))+        (initsTree f' m)+        (fmap (f . deep pr m) (initsDigit sf))+  where+    f' ms =  let SnocRTree m' node = viewRTree ms in+             fmap (\ sf' -> f (deep pr m' sf')) (initsNode node)++{-# INLINE foldlWithIndex #-}+-- | 'foldlWithIndex' is a version of 'foldl' that also provides access+-- to the index of each element.+foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b+foldlWithIndex f z xs = foldl (\ g x !i -> f (g (i - 1)) i x) (const z) xs (length xs - 1)++{-# INLINE foldrWithIndex #-}+-- | 'foldrWithIndex' is a version of 'foldr' that also provides access+-- to the index of each element.+foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b+foldrWithIndex f z xs = foldr (\ x g !i -> f i x (g (i+1))) (const z) xs 0++{-# INLINE listToMaybe' #-}+-- 'listToMaybe\'' is a good consumer version of 'listToMaybe'.+listToMaybe' :: [a] -> Maybe a+listToMaybe' = foldr (\ x _ -> Just x) Nothing++-- | \( O(i) \) where \( i \) is the prefix length. 'takeWhileL', applied+-- to a predicate @p@ and a sequence @xs@, returns the longest prefix+-- (possibly empty) of @xs@ of elements that satisfy @p@.+takeWhileL :: (a -> Bool) -> Seq a -> Seq a+takeWhileL p = fst . spanl p++-- | \( O(i) \) where \( i \) is the suffix length.  'takeWhileR', applied+-- to a predicate @p@ and a sequence @xs@, returns the longest suffix+-- (possibly empty) of @xs@ of elements that satisfy @p@.+--+-- @'takeWhileR' p xs@ is equivalent to @'reverse' ('takeWhileL' p ('reverse' xs))@.+takeWhileR :: (a -> Bool) -> Seq a -> Seq a+takeWhileR p = fst . spanr p++-- | \( O(i) \) where \( i \) is the prefix length.  @'dropWhileL' p xs@ returns+-- the suffix remaining after @'takeWhileL' p xs@.+dropWhileL :: (a -> Bool) -> Seq a -> Seq a+dropWhileL p = snd . spanl p++-- | \( O(i) \) where \( i \) is the suffix length.  @'dropWhileR' p xs@ returns+-- the prefix remaining after @'takeWhileR' p xs@.+--+-- @'dropWhileR' p xs@ is equivalent to @'reverse' ('dropWhileL' p ('reverse' xs))@.+dropWhileR :: (a -> Bool) -> Seq a -> Seq a+dropWhileR p = snd . spanr p++-- | \( O(i) \) where \( i \) is the prefix length.  'spanl', applied to+-- a predicate @p@ and a sequence @xs@, returns a pair whose first+-- element is the longest prefix (possibly empty) of @xs@ of elements that+-- satisfy @p@ and the second element is the remainder of the sequence.+spanl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+spanl p = breakl (not . p)++-- | \( O(i) \) where \( i \) is the suffix length.  'spanr', applied to a+-- predicate @p@ and a sequence @xs@, returns a pair whose /first/ element+-- is the longest /suffix/ (possibly empty) of @xs@ of elements that+-- satisfy @p@ and the second element is the remainder of the sequence.+spanr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+spanr p = breakr (not . p)++{-# INLINE breakl #-}+-- | \( O(i) \) where \( i \) is the breakpoint index.  'breakl', applied to a+-- predicate @p@ and a sequence @xs@, returns a pair whose first element+-- is the longest prefix (possibly empty) of @xs@ of elements that+-- /do not satisfy/ @p@ and the second element is the remainder of+-- the sequence.+--+-- @'breakl' p@ is equivalent to @'spanl' (not . p)@.+breakl :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+breakl p xs = foldr (\ i _ -> splitAt i xs) (xs, empty) (findIndicesL p xs)++{-# INLINE breakr #-}+-- | @'breakr' p@ is equivalent to @'spanr' (not . p)@.+breakr :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+breakr p xs = foldr (\ i _ -> flipPair (splitAt (i + 1) xs)) (xs, empty) (findIndicesR p xs)+  where flipPair (x, y) = (y, x)++-- | \( O(n) \).  The 'partition' function takes a predicate @p@ and a+-- sequence @xs@ and returns sequences of those elements which do and+-- do not satisfy the predicate.+partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)+partition p = toPair . foldl' part (empty :*: empty)+  where+    part (xs :*: ys) x+      | p x         = (xs `snoc'` x) :*: ys+      | otherwise   = xs :*: (ys `snoc'` x)++-- | \( O(n) \).  The 'filter' function takes a predicate @p@ and a sequence+-- @xs@ and returns a sequence of those elements which satisfy the+-- predicate.+filter :: (a -> Bool) -> Seq a -> Seq a+filter p = foldl' (\ xs x -> if p x then xs `snoc'` x else xs) empty++-- Indexing sequences++-- | 'elemIndexL' finds the leftmost index of the specified element,+-- if it is present, and otherwise 'Nothing'.+elemIndexL :: Eq a => a -> Seq a -> Maybe Int+elemIndexL x = findIndexL (x ==)++-- | 'elemIndexR' finds the rightmost index of the specified element,+-- if it is present, and otherwise 'Nothing'.+elemIndexR :: Eq a => a -> Seq a -> Maybe Int+elemIndexR x = findIndexR (x ==)++-- | 'elemIndicesL' finds the indices of the specified element, from+-- left to right (i.e. in ascending order).+elemIndicesL :: Eq a => a -> Seq a -> [Int]+elemIndicesL x = findIndicesL (x ==)++-- | 'elemIndicesR' finds the indices of the specified element, from+-- right to left (i.e. in descending order).+elemIndicesR :: Eq a => a -> Seq a -> [Int]+elemIndicesR x = findIndicesR (x ==)++-- | @'findIndexL' p xs@ finds the index of the leftmost element that+-- satisfies @p@, if any exist.+findIndexL :: (a -> Bool) -> Seq a -> Maybe Int+findIndexL p = listToMaybe' . findIndicesL p++-- | @'findIndexR' p xs@ finds the index of the rightmost element that+-- satisfies @p@, if any exist.+findIndexR :: (a -> Bool) -> Seq a -> Maybe Int+findIndexR p = listToMaybe' . findIndicesR p++{-# INLINE findIndicesL #-}+-- | @'findIndicesL' p@ finds all indices of elements that satisfy @p@,+-- in ascending order.+findIndicesL :: (a -> Bool) -> Seq a -> [Int]+#if __GLASGOW_HASKELL__+findIndicesL p xs = build (\ c n -> let g i x z = if p x then c i z else z in+                foldrWithIndex g n xs)+#else+findIndicesL p xs = foldrWithIndex g [] xs+  where g i x is = if p x then i:is else is+#endif++{-# INLINE findIndicesR #-}+-- | @'findIndicesR' p@ finds all indices of elements that satisfy @p@,+-- in descending order.+findIndicesR :: (a -> Bool) -> Seq a -> [Int]+#if __GLASGOW_HASKELL__+findIndicesR p xs = build (\ c n ->+    let g z i x = if p x then c i z else z in foldlWithIndex g n xs)+#else+findIndicesR p xs = foldlWithIndex g [] xs+  where g is i x = if p x then i:is else is+#endif++------------------------------------------------------------------------+-- Lists+------------------------------------------------------------------------++-- The implementation below is based on an idea by Ross Paterson and+-- implemented by Lennart Spitzner. It avoids the rebuilding the original+-- (|>)-based implementation suffered from. It also avoids the excessive pair+-- allocations Paterson's implementation suffered from.+--+-- David Feuer suggested building in nine-element chunks, which reduces+-- intermediate conses from around (1/2)*n to around (1/8)*n with a concomitant+-- improvement in benchmark constant factors. In fact, it should be even+-- better to work in chunks of 27 `Elem`s and chunks of three `Node`s, rather+-- than nine of each, but it seems hard to avoid a code explosion with+-- such large chunks.+--+-- Paterson's code can be seen, for example, in+-- https://github.com/haskell/containers/blob/74034b3244fa4817c7bef1202e639b887a975d9e/Data/Sequence.hs#L3532+--+-- Given a list+--+-- [1..302]+--+-- the original code forms Three 1 2 3 | [node3 4 5 6, node3 7 8 9, node3 10 11+-- 12, ...] | Two 301 302+--+-- Then it recurses on the middle list. The middle lists become successively+-- shorter as their elements become successively deeper nodes.+--+-- The original implementation of the list shortener, getNodes, included the+-- recursive step++--     getNodes s x1 (x2:x3:x4:xs) = (Node3 s x1 x2 x3:ns, d)+--            where (ns, d) = getNodes s x4 xs++-- This allocates a cons and a lazy pair at each 3-element step. It relies on+-- the Haskell implementation using Wadler's technique, described in "Fixing+-- some space leaks with a garbage collector"+-- http://homepages.inf.ed.ac.uk/wadler/papers/leak/leak.ps.gz, to repeatedly+-- simplify the `d` thunk. Although GHC uses this GC trick, heap profiling at+-- least appears to indicate that the pair constructors and conses build up+-- with this implementation.+--+-- Spitzner's implementation uses a similar approach, but replaces the middle+-- list, in each level, with a customized stream type that finishes off with+-- the final digit in that level and (since it works in nines) in the one+-- above. To work around the nested tree structure, the overall computation is+-- structured using continuation-passing style, with a function that, at the+-- bottom of the tree, deals with a stream that terminates in a nested-pair+-- representation of the entire right side of the tree. Perhaps someone will+-- eventually find a less mind-bending way to accomplish this.++-- | \( O(n) \). Create a sequence from a finite list of elements.+-- There is a function 'toList' in the opposite direction for all+-- instances of the 'Foldable' class, including 'Seq'.+fromList        :: [a] -> Seq a+-- Note: we can avoid map_elem if we wish by scattering+-- Elem applications throughout mkTreeE and getNodesE, but+-- it gets a bit hard to read.+fromList = Seq . mkTree . map_elem+  where+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+    mkTree :: forall a' . [Elem a'] -> FingerTree (Elem a')+#else+    mkTree :: [Elem a] -> FingerTree (Elem a)+#endif+    mkTree [] = EmptyT+    mkTree [x1] = Single x1+    mkTree [x1, x2] = Deep 2 (One x1) EmptyT (One x2)+    mkTree [x1, x2, x3] = Deep 3 (Two x1 x2) EmptyT (One x3)+    mkTree [x1, x2, x3, x4] = Deep 4 (Two x1 x2) EmptyT (Two x3 x4)+    mkTree [x1, x2, x3, x4, x5] = Deep 5 (Three x1 x2 x3) EmptyT (Two x4 x5)+    mkTree [x1, x2, x3, x4, x5, x6] =+      Deep 6 (Three x1 x2 x3) EmptyT (Three x4 x5 x6)+    mkTree [x1, x2, x3, x4, x5, x6, x7] =+      Deep 7 (Two x1 x2) (Single (Node3 3 x3 x4 x5)) (Two x6 x7)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8] =+      Deep 8 (Three x1 x2 x3) (Single (Node3 3 x4 x5 x6)) (Two x7 x8)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9] =+      Deep 9 (Three x1 x2 x3) (Single (Node3 3 x4 x5 x6)) (Three x7 x8 x9)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, y0, y1] =+      Deep 10 (Two x1 x2)+              (Deep 6 (One (Node3 3 x3 x4 x5)) EmptyT (One (Node3 3 x6 x7 x8)))+              (Two y0 y1)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1] =+      Deep 11 (Three x1 x2 x3)+              (Deep 6 (One (Node3 3 x4 x5 x6)) EmptyT (One (Node3 3 x7 x8 x9)))+              (Two y0 y1)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2] =+      Deep 12 (Three x1 x2 x3)+              (Deep 6 (One (Node3 3 x4 x5 x6)) EmptyT (One (Node3 3 x7 x8 x9)))+              (Three y0 y1 y2)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, y0, y1, y2, y3, y4] =+      Deep 13 (Two x1 x2)+              (Deep 9 (Two (Node3 3 x3 x4 x5) (Node3 3 x6 x7 x8)) EmptyT (One (Node3 3 y0 y1 y2)))+              (Two y3 y4)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2, y3, y4] =+      Deep 14 (Three x1 x2 x3)+              (Deep 9 (Two (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9)) EmptyT (One (Node3 3 y0 y1 y2)))+              (Two y3 y4)+    mkTree [x1, x2, x3, x4, x5, x6, x7, x8, x9, y0, y1, y2, y3, y4, y5] =+      Deep 15 (Three x1 x2 x3)+              (Deep 9 (Two (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9)) EmptyT (One (Node3 3 y0 y1 y2)))+              (Three y3 y4 y5)+    mkTree (x1:x2:x3:x4:x5:x6:x7:x8:x9:y0:y1:y2:y3:y4:y5:y6:xs) =+        mkTreeC cont 9 (getNodes 3 (Node3 3 y3 y4 y5) y6 xs)+      where+        d2 = Three x1 x2 x3+        d1 = Three (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9) (Node3 3 y0 y1 y2)+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+        cont :: (Digit (Node (Elem a')), Digit (Elem a')) -> FingerTree (Node (Node (Elem a'))) -> FingerTree (Elem a')+#endif+        cont (!r1, !r2) !sub =+          let !sub1 = Deep (9 + size r1 + size sub) d1 sub r1+          in Deep (3 + size r2 + size sub1) d2 sub1 r2++    getNodes :: forall a . Int+             -> Node a+             -> a+             -> [a]+             -> ListFinal (Node (Node a)) (Digit (Node a), Digit a)+    getNodes !_ n1 x1 [] = LFinal (One n1, One x1)+    getNodes _ n1 x1 [x2] = LFinal (One n1, Two x1 x2)+    getNodes _ n1 x1 [x2, x3] = LFinal (One n1, Three x1 x2 x3)+    getNodes s n1 x1 [x2, x3, x4] = LFinal (Two n1 (Node3 s x1 x2 x3), One x4)+    getNodes s n1 x1 [x2, x3, x4, x5] = LFinal (Two n1 (Node3 s x1 x2 x3), Two x4 x5)+    getNodes s n1 x1 [x2, x3, x4, x5, x6] = LFinal (Two n1 (Node3 s x1 x2 x3), Three x4 x5 x6)+    getNodes s n1 x1 [x2, x3, x4, x5, x6, x7] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), One x7)+    getNodes s n1 x1 [x2, x3, x4, x5, x6, x7, x8] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), Two x7 x8)+    getNodes s n1 x1 [x2, x3, x4, x5, x6, x7, x8, x9] = LFinal (Three n1 (Node3 s x1 x2 x3) (Node3 s x4 x5 x6), Three x7 x8 x9)+    getNodes s n1 x1 (x2:x3:x4:x5:x6:x7:x8:x9:x10:xs) = LCons n10 (getNodes s (Node3 s x7 x8 x9) x10 xs)+      where !n2 = Node3 s x1 x2 x3+            !n3 = Node3 s x4 x5 x6+            !n10 = Node3 (3*s) n1 n2 n3++    mkTreeC ::+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+               forall a b c .+#endif+               (b -> FingerTree (Node a) -> c)+            -> Int+            -> ListFinal (Node a) b+            -> c+    mkTreeC cont !_ (LFinal b) =+      cont b EmptyT+    mkTreeC cont _ (LCons x1 (LFinal b)) =+      cont b (Single x1)+    mkTreeC cont s (LCons x1 (LCons x2 (LFinal b))) =+      cont b (Deep (2*s) (One x1) EmptyT (One x2))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LFinal b)))) =+      cont b (Deep (3*s) (Two x1 x2) EmptyT (One x3))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LFinal b))))) =+      cont b (Deep (4*s) (Two x1 x2) EmptyT (Two x3 x4))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LFinal b)))))) =+      cont b (Deep (5*s) (Three x1 x2 x3) EmptyT (Two x4 x5))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LFinal b))))))) =+      cont b (Deep (6*s) (Three x1 x2 x3) EmptyT (Three x4 x5 x6))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LFinal b)))))))) =+      cont b (Deep (7*s) (Two x1 x2) (Single (Node3 (3*s) x3 x4 x5)) (Two x6 x7))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LFinal b))))))))) =+      cont b (Deep (8*s) (Three x1 x2 x3) (Single (Node3 (3*s) x4 x5 x6)) (Two x7 x8))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LFinal b)))))))))) =+      cont b (Deep (9*s) (Three x1 x2 x3) (Single (Node3 (3*s) x4 x5 x6)) (Three x7 x8 x9))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons y0 (LCons y1 (LFinal b))))))))))) =+      cont b (Deep (10*s) (Two x1 x2) (Deep (6*s) (One (Node3 (3*s) x3 x4 x5)) EmptyT (One (Node3 (3*s) x6 x7 x8))) (Two y0 y1))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LFinal b)))))))))))) =+      cont b (Deep (11*s) (Three x1 x2 x3) (Deep (6*s) (One (Node3 (3*s) x4 x5 x6)) EmptyT (One (Node3 (3*s) x7 x8 x9))) (Two y0 y1))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LFinal b))))))))))))) =+      cont b (Deep (12*s) (Three x1 x2 x3) (Deep (6*s) (One (Node3 (3*s) x4 x5 x6)) EmptyT (One (Node3 (3*s) x7 x8 x9))) (Three y0 y1 y2))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LFinal b)))))))))))))) =+      cont b (Deep (13*s) (Two x1 x2) (Deep (9*s) (Two (Node3 (3*s) x3 x4 x5) (Node3 (3*s) x6 x7 x8)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Two y3 y4))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LFinal b))))))))))))))) =+      cont b (Deep (14*s) (Three x1 x2 x3) (Deep (9*s) (Two (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Two y3 y4))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LFinal b)))))))))))))))) =+      cont b (Deep (15*s) (Three x1 x2 x3) (Deep (9*s) (Two (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9)) EmptyT (One (Node3 (3*s) y0 y1 y2))) (Three y3 y4 y5))+    mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LCons y6 xs)))))))))))))))) =+      mkTreeC cont2 (9*s) (getNodesC (3*s) (Node3 (3*s) y3 y4 y5) y6 xs)+      where+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+        cont2 :: (b, Digit (Node (Node a)), Digit (Node a)) -> FingerTree (Node (Node (Node a))) -> c+#endif+        cont2 (b, r1, r2) !sub =+          let d2 = Three x1 x2 x3+              d1 = Three (Node3 (3*s) x4 x5 x6) (Node3 (3*s) x7 x8 x9) (Node3 (3*s) y0 y1 y2)+              !sub1 = Deep (9*s + size r1 + size sub) d1 sub r1+          in cont b $! Deep (3*s + size r2 + size sub1) d2 sub1 r2++    getNodesC :: Int+              -> Node a+              -> a+              -> ListFinal a b+              -> ListFinal (Node (Node a)) (b, Digit (Node a), Digit a)+    getNodesC !_ n1 x1 (LFinal b) = LFinal $ (b, One n1, One x1)+    getNodesC _  n1  x1 (LCons x2 (LFinal b)) = LFinal $ (b, One n1, Two x1 x2)+    getNodesC _  n1  x1 (LCons x2 (LCons x3 (LFinal b))) = LFinal $ (b, One n1, Three x1 x2 x3)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LFinal b)))) =+      let !n2 = Node3 s x1 x2 x3+      in LFinal $ (b, Two n1 n2, One x4)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LFinal b))))) =+      let !n2 = Node3 s x1 x2 x3+      in LFinal $ (b, Two n1 n2, Two x4 x5)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LFinal b)))))) =+      let !n2 = Node3 s x1 x2 x3+      in LFinal $ (b, Two n1 n2, Three x4 x5 x6)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LFinal b))))))) =+      let !n2 = Node3 s x1 x2 x3+          !n3 = Node3 s x4 x5 x6+      in LFinal $ (b, Three n1 n2 n3, One x7)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LFinal b)))))))) =+      let !n2 = Node3 s x1 x2 x3+          !n3 = Node3 s x4 x5 x6+      in LFinal $ (b, Three n1 n2 n3, Two x7 x8)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LFinal b))))))))) =+      let !n2 = Node3 s x1 x2 x3+          !n3 = Node3 s x4 x5 x6+      in LFinal $ (b, Three n1 n2 n3, Three x7 x8 x9)+    getNodesC s  n1  x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons x10 xs))))))))) =+        LCons n10 $ getNodesC s (Node3 s x7 x8 x9) x10 xs+      where !n2 = Node3 s x1 x2 x3+            !n3 = Node3 s x4 x5 x6+            !n10 = Node3 (3*s) n1 n2 n3++    map_elem :: [a] -> [Elem a]+#ifdef __GLASGOW_HASKELL__+    map_elem xs = coerce xs+#else+    map_elem xs = Data.List.map Elem xs+#endif+    {-# INLINE map_elem #-}++-- essentially: Free ((,) a) b.+data ListFinal a cont = LFinal !cont | LCons !a (ListFinal a cont)++#ifdef __GLASGOW_HASKELL__+instance GHC.Exts.IsList (Seq a) where+    type Item (Seq a) = a+    fromList = fromList+    fromListN = fromList2+    toList = toList+#endif++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.7+instance a ~ Char => IsString (Seq a) where+    fromString = fromList+#endif++------------------------------------------------------------------------+-- Reverse+------------------------------------------------------------------------++-- | \( O(n) \). The reverse of a sequence.+reverse :: Seq a -> Seq a+reverse (Seq xs) = Seq (fmapReverseTree id xs)++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] reverse #-}++-- | \( O(n) \). Reverse a sequence while mapping over it. This is not+-- currently exported, but is used in rewrite rules.+fmapReverse :: (a -> b) -> Seq a -> Seq b+fmapReverse f (Seq xs) = Seq (fmapReverseTree (lift_elem f) xs)+  where+    lift_elem :: (a -> b) -> (Elem a -> Elem b)+#ifdef __GLASGOW_HASKELL__+    lift_elem = coerce+#else+    lift_elem g (Elem a) = Elem (g a)+#endif++-- If we're mapping over a sequence, we can reverse it at the same time+-- at no extra charge.+{-# RULES+"fmapSeq/reverse" forall f xs . fmapSeq f (reverse xs) = fmapReverse f xs+"reverse/fmapSeq" forall f xs . reverse (fmapSeq f xs) = fmapReverse f xs+ #-}+#endif++fmapReverseTree :: (a -> b) -> FingerTree a -> FingerTree b+fmapReverseTree _ EmptyT = EmptyT+fmapReverseTree f (Single x) = Single (f x)+fmapReverseTree f (Deep s pr m sf) =+    Deep s (reverseDigit f sf)+        (fmapReverseTree (reverseNode f) m)+        (reverseDigit f pr)++{-# INLINE reverseDigit #-}+reverseDigit :: (a -> b) -> Digit a -> Digit b+reverseDigit f (One a) = One (f a)+reverseDigit f (Two a b) = Two (f b) (f a)+reverseDigit f (Three a b c) = Three (f c) (f b) (f a)+reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)++reverseNode :: (a -> b) -> Node a -> Node b+reverseNode f (Node2 s a b) = Node2 s (f b) (f a)+reverseNode f (Node3 s a b c) = Node3 s (f c) (f b) (f a)++------------------------------------------------------------------------+-- Mapping with a splittable value+------------------------------------------------------------------------++-- For zipping, it is useful to build a result by+-- traversing a sequence while splitting up something else.  For zipping, we+-- traverse the first sequence while splitting up the second.+--+-- What makes all this crazy code a good idea:+--+-- Suppose we zip together two sequences of the same length:+--+-- zs = zip xs ys+--+-- We want to get reasonably fast indexing into zs immediately, rather than+-- needing to construct the entire thing first, as the previous implementation+-- required. The first aspect is that we build the result "outside-in" or+-- "top-down", rather than left to right. That gives us access to both ends+-- quickly. But that's not enough, by itself, to give immediate access to the+-- center of zs. For that, we need to be able to skip over larger segments of+-- zs, delaying their construction until we actually need them. The way we do+-- this is to traverse xs, while splitting up ys according to the structure of+-- xs. If we have a Deep _ pr m sf, we split ys into three pieces, and hand off+-- one piece to the prefix, one to the middle, and one to the suffix of the+-- result. The key point is that we don't need to actually do anything further+-- with those pieces until we actually need them; the computations to split+-- them up further and zip them with their matching pieces can be delayed until+-- they're actually needed. We do the same thing for Digits (splitting into+-- between one and four pieces) and Nodes (splitting into two or three). The+-- ultimate result is that we can index into, or split at, any location in zs+-- in polylogarithmic time *immediately*, while still being able to force all+-- the thunks in O(n) time.+--+-- Benchmark info, and alternatives:+--+-- The old zipping code used mapAccumL to traverse the first sequence while+-- cutting down the second sequence one piece at a time.+--+-- An alternative way to express that basic idea is to convert both sequences+-- to lists, zip the lists, and then convert the result back to a sequence.+-- I'll call this the "listy" implementation.+--+-- I benchmarked two operations: Each started by zipping two sequences+-- constructed with replicate and/or fromList. The first would then immediately+-- index into the result. The second would apply deepseq to force the entire+-- result.  The new implementation worked much better than either of the others+-- on the immediate indexing test, as expected. It also worked better than the+-- old implementation for all the deepseq tests. For short sequences, the listy+-- implementation outperformed all the others on the deepseq test. However, the+-- splitting implementation caught up and surpassed it once the sequences grew+-- long enough. It seems likely that by avoiding rebuilding, it interacts+-- better with the cache hierarchy.+--+-- David Feuer, with some guidance from Carter Schonwald, December 2014++-- | \( O(n) \). Constructs a new sequence with the same structure as an existing+-- sequence using a user-supplied mapping function along with a splittable+-- value and a way to split it. The value is split up lazily according to the+-- structure of the sequence, so one piece of the value is distributed to each+-- element of the sequence. The caller should provide a splitter function that+-- takes a number, @n@, and a splittable value, breaks off a chunk of size @n@+-- from the value, and returns that chunk and the remainder as a pair. The+-- following examples will hopefully make the usage clear:+--+-- > zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+-- > zipWith f s1 s2 = splitMap splitAt (\b a -> f a (b `index` 0)) s2' s1'+-- >   where+-- >     minLen = min (length s1) (length s2)+-- >     s1' = take minLen s1+-- >     s2' = take minLen s2+--+-- > mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b+-- > mapWithIndex f = splitMap (\n i -> (i, n+i)) f 0+#ifdef __GLASGOW_HASKELL__+-- We use ScopedTypeVariables to improve performance and make+-- performance less sensitive to minor changes.++-- We INLINE this so GHC can see that the function passed in is+-- strict in its Int argument.+{-# INLINE splitMap #-}+splitMap :: forall s a' b' . (Int -> s -> (s,s)) -> (s -> a' -> b') -> s -> Seq a' -> Seq b'+splitMap splt f0 s0 (Seq xs0) = Seq $ splitMapTreeE (\s' (Elem a) -> Elem (f0 s' a)) s0 xs0+  where+    {-# INLINE splitMapTreeE #-}+    splitMapTreeE :: (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b+    splitMapTreeE  _ _ EmptyT = EmptyT+    splitMapTreeE  f s (Single xs) = Single $ f s xs+    splitMapTreeE  f s (Deep n pr m sf) = Deep n (splitMapDigit f prs pr) (splitMapTreeN (\eta1 eta2 -> splitMapNode f eta1 eta2) ms m) (splitMapDigit f sfs sf)+          where+            !spr = size pr+            !sm = n - spr - size sf+            (prs, r) = splt spr s+            (ms, sfs) = splt sm r++    splitMapTreeN :: (s -> Node a -> b) -> s -> FingerTree (Node a) -> FingerTree b+    splitMapTreeN _ _ EmptyT = EmptyT+    splitMapTreeN f s (Single xs) = Single $ f s xs+    splitMapTreeN f s (Deep n pr m sf) = Deep n (splitMapDigit f prs pr) (splitMapTreeN (\eta1 eta2 -> splitMapNode f eta1 eta2) ms m) (splitMapDigit f sfs sf)+          where+            (prs, r) = splt (size pr) s+            (ms, sfs) = splt (size m) r++    {-# INLINE splitMapDigit #-}+    splitMapDigit :: Sized a => (s -> a -> b) -> s -> Digit a -> Digit b+    splitMapDigit f s (One a) = One (f s a)+    splitMapDigit f s (Two a b) = Two (f first a) (f second b)+      where+        (first, second) = splt (size a) s+    splitMapDigit f s (Three a b c) = Three (f first a) (f second b) (f third c)+      where+        (first, r) = splt (size a) s+        (second, third) = splt (size b) r+    splitMapDigit f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)+      where+        (first, s') = splt (size a) s+        (middle, fourth) = splt (size b + size c) s'+        (second, third) = splt (size b) middle++    {-# INLINE splitMapNode #-}+    splitMapNode :: Sized a => (s -> a -> b) -> s -> Node a -> Node b+    splitMapNode f s (Node2 ns a b) = Node2 ns (f first a) (f second b)+      where+        (first, second) = splt (size a) s+    splitMapNode f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)+      where+        (first, r) = splt (size a) s+        (second, third) = splt (size b) r++#else+-- Implementation without ScopedTypeVariables--somewhat slower,+-- and much more sensitive to minor changes in various places.++{-# INLINE splitMap #-}+splitMap :: (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Seq a -> Seq b+splitMap splt' f0 s0 (Seq xs0) = Seq $ splitMapTreeE splt' (\s' (Elem a) -> Elem (f0 s' a)) s0 xs0++{-# INLINE splitMapTreeE #-}+splitMapTreeE :: (Int -> s -> (s,s)) -> (s -> Elem y -> b) -> s -> FingerTree (Elem y) -> FingerTree b+splitMapTreeE _    _ _ EmptyT = EmptyT+splitMapTreeE _    f s (Single xs) = Single $ f s xs+splitMapTreeE splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTreeN splt (\eta1 eta2 -> splitMapNode splt f eta1 eta2) ms m) (splitMapDigit splt f sfs sf)+      where+        !spr = size pr+        sm = n - spr - size sf+        (prs, r) = splt spr s+        (ms, sfs) = splt sm r++splitMapTreeN :: (Int -> s -> (s,s)) -> (s -> Node a -> b) -> s -> FingerTree (Node a) -> FingerTree b+splitMapTreeN _    _ _ EmptyT = EmptyT+splitMapTreeN _    f s (Single xs) = Single $ f s xs+splitMapTreeN splt f s (Deep n pr m sf) = Deep n (splitMapDigit splt f prs pr) (splitMapTreeN splt (\eta1 eta2 -> splitMapNode splt f eta1 eta2) ms m) (splitMapDigit splt f sfs sf)+      where+        (prs, r) = splt (size pr) s+        (ms, sfs) = splt (size m) r++{-# INLINE splitMapDigit #-}+splitMapDigit :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Digit a -> Digit b+splitMapDigit _    f s (One a) = One (f s a)+splitMapDigit splt f s (Two a b) = Two (f first a) (f second b)+  where+    (first, second) = splt (size a) s+splitMapDigit splt f s (Three a b c) = Three (f first a) (f second b) (f third c)+  where+    (first, r) = splt (size a) s+    (second, third) = splt (size b) r+splitMapDigit splt f s (Four a b c d) = Four (f first a) (f second b) (f third c) (f fourth d)+  where+    (first, s') = splt (size a) s+    (middle, fourth) = splt (size b + size c) s'+    (second, third) = splt (size b) middle++{-# INLINE splitMapNode #-}+splitMapNode :: Sized a => (Int -> s -> (s,s)) -> (s -> a -> b) -> s -> Node a -> Node b+splitMapNode splt f s (Node2 ns a b) = Node2 ns (f first a) (f second b)+  where+    (first, second) = splt (size a) s+splitMapNode splt f s (Node3 ns a b c) = Node3 ns (f first a) (f second b) (f third c)+  where+    (first, r) = splt (size a) s+    (second, third) = splt (size b) r+#endif++------------------------------------------------------------------------+-- Zipping+------------------------------------------------------------------------++-- We use a custom definition of munzip to avoid retaining+-- memory longer than necessary. Using the default definition, if+-- we write+--+-- let (xs,ys) = munzip zs+-- in xs `deepseq` (... ys ...)+--+-- then ys will retain the entire zs sequence until ys itself is fully forced.+-- This implementation uses the selector thunk optimization to prevent that.+-- Unfortunately, that optimization is fragile, so we can't actually guarantee+-- anything.++-- | @ 'mzipWith' = 'zipWith' @+--+-- @ 'munzip' = 'unzip' @+--+-- @since 0.5.10.1+instance MonadZip Seq where+  mzipWith = zipWith+  munzip = unzip++-- | Unzip a sequence of pairs.+--+-- @+-- unzip ps = ps ``seq`` ('fmap' 'fst' ps) ('fmap' 'snd' ps)+-- @+--+-- Example:+--+-- @+-- unzip $ fromList [(1,"a"), (2,"b"), (3,"c")] =+--   (fromList [1,2,3], fromList ["a", "b", "c"])+-- @+--+-- See the note about efficiency at 'unzipWith'.+--+-- @since 0.5.11+unzip :: Seq (a, b) -> (Seq a, Seq b)+unzip xs = unzipWith id xs++-- | \( O(n) \). Unzip a sequence using a function to divide elements.+--+-- @ unzipWith f xs == 'unzip' ('fmap' f xs) @+--+-- Efficiency note:+--+-- @unzipWith@ produces its two results in lockstep. If you calculate+-- @ unzipWith f xs @ and fully force /either/ of the results, then the+-- entire structure of the /other/ one will be built as well. This+-- behavior allows the garbage collector to collect each calculated+-- pair component as soon as it dies, without having to wait for its mate+-- to die. If you do not need this behavior, you may be better off simply+-- calculating the sequence of pairs and using 'fmap' to extract each+-- component sequence.+--+-- @since 0.5.11+unzipWith :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)+unzipWith f = unzipWith' (\x ->+  let+    {-# NOINLINE fx #-}+    fx = f x+    (y,z) = fx+  in (y,z))+-- Why do we lazify `f`? Because we don't want the strictness to depend+-- on exactly how the sequence is balanced. For example, what do we want+-- from+--+-- unzip [(1,2), undefined, (5,6)]?+--+-- The argument could be represented as+--+-- Seq $ Deep 3 (One (Elem (1,2))) EmptyT (Two undefined (Elem (5,6)))+--+-- or as+--+-- Seq $ Deep 3 (Two (Elem (1,2)) undefined) EmptyT (One (Elem (5,6)))+--+-- We don't want the tree balance to determine whether we get+--+-- ([1, undefined, undefined], [2, undefined, undefined])+--+-- or+--+-- ([undefined, undefined, 5], [undefined, undefined, 6])+--+-- so we pretty much have to be completely lazy in the elements.++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] unzipWith #-}++-- We don't need a special rule for unzip:+--+-- unzip (fmap f xs) = unzipWith id f xs,+--+-- which rewrites to unzipWith (id . f) xs+--+-- It's true that if GHC doesn't know the arity of `f` then+-- it won't reduce further, but that doesn't seem like too+-- big a deal here.+{-# RULES+"unzipWith/fmapSeq" forall f g xs. unzipWith f (fmapSeq g xs) =+                                     unzipWith (f . g) xs+ #-}+#endif++class UnzipWith f where+  unzipWith' :: (x -> (a, b)) -> f x -> (f a, f b)++-- This instance is only used at the very top of the tree;+-- the rest of the elements are handled by unzipWithNodeElem+instance UnzipWith Elem where+#ifdef __GLASGOW_HASKELL__+  unzipWith' = coerce+#else+  unzipWith' f (Elem a) = case f a of (x, y) -> (Elem x, Elem y)+#endif++-- We're very lazy here for the sake of efficiency. We want to be able to+-- reach any element of either result in logarithmic time. If we pattern+-- match strictly, we'll end up building entire 2-3 trees at once, which+-- would take linear time.+--+-- However, we're not *entirely* lazy! We are careful to build pieces+-- of each sequence as the corresponding pieces of the *other* sequence+-- are demanded. This allows the garbage collector to get rid of each+-- *component* of each result pair as soon as it is dead.+--+-- Note that this instance is used only for *internal* nodes. Nodes+-- containing elements are handled by 'unzipWithNodeElem'+instance UnzipWith Node where+  unzipWith' f (Node2 s x y) =+    ( Node2 s x1 y1+    , Node2 s x2 y2)+    where+      {-# NOINLINE fx #-}+      {-# NOINLINE fy #-}+      fx = strictifyPair (f x)+      fy = strictifyPair (f y)+      (x1, x2) = fx+      (y1, y2) = fy+  unzipWith' f (Node3 s x y z) =+    ( Node3 s x1 y1 z1+    , Node3 s x2 y2 z2)+    where+      {-# NOINLINE fx #-}+      {-# NOINLINE fy #-}+      {-# NOINLINE fz #-}+      fx = strictifyPair (f x)+      fy = strictifyPair (f y)+      fz = strictifyPair (f z)+      (x1, x2) = fx+      (y1, y2) = fy+      (z1, z2) = fz++-- Force both elements of a pair+strictifyPair :: (a, b) -> (a, b)+strictifyPair (!x, !y) = (x, y)++-- We're strict here for the sake of efficiency. The Node instance+-- is lazy, so we don't particularly need to add an extra thunk on top+-- of each node.+instance UnzipWith Digit where+  unzipWith' f (One x)+    | (x1, x2) <- f x+    = (One x1, One x2)+  unzipWith' f (Two x y)+    | (x1, x2) <- f x+    , (y1, y2) <- f y+    = ( Two x1 y1+      , Two x2 y2)+  unzipWith' f (Three x y z)+    | (x1, x2) <- f x+    , (y1, y2) <- f y+    , (z1, z2) <- f z+    = ( Three x1 y1 z1+      , Three x2 y2 z2)+  unzipWith' f (Four x y z w)+    | (x1, x2) <- f x+    , (y1, y2) <- f y+    , (z1, z2) <- f z+    , (w1, w2) <- f w+    = ( Four x1 y1 z1 w1+      , Four x2 y2 z2 w2)++instance UnzipWith FingerTree where+  unzipWith' _ EmptyT = (EmptyT, EmptyT)+  unzipWith' f (Single x)+    | (x1, x2) <- f x+    = (Single x1, Single x2)+  unzipWith' f (Deep s pr m sf)+    | (!pr1, !pr2) <- unzipWith' f pr+    , (!sf1, !sf2) <- unzipWith' f sf+    = (Deep s pr1 m1 sf1, Deep s pr2 m2 sf2)+    where+      {-# NOINLINE m1m2 #-}+      m1m2 = strictifyPair $ unzipWith' (unzipWith' f) m+      (m1, m2) = m1m2++instance UnzipWith Seq where+  unzipWith' _ (Seq EmptyT) = (empty, empty)+  unzipWith' f (Seq (Single (Elem x)))+    | (x1, x2) <- f x+    = (singleton x1, singleton x2)+  unzipWith' f (Seq (Deep s pr m sf))+    | (!pr1, !pr2) <- unzipWith' (unzipWith' f) pr+    , (!sf1, !sf2) <- unzipWith' (unzipWith' f) sf+    = (Seq (Deep s pr1 m1 sf1), Seq (Deep s pr2 m2 sf2))+    where+      {-# NOINLINE m1m2 #-}+      m1m2 = strictifyPair $ unzipWith' (unzipWithNodeElem f) m+      (m1, m2) = m1m2++-- Here we need to be lazy in the children (because they're+-- Elems), but we can afford to be strict in the results+-- of `f` because it's sure to return a pair immediately+-- (unzipWith lazifies the function it's passed).+unzipWithNodeElem :: (x -> (a, b))+       -> Node (Elem x) -> (Node (Elem a), Node (Elem b))+unzipWithNodeElem f (Node2 s (Elem x) (Elem y))+  | (x1, x2) <- f x+  , (y1, y2) <- f y+  = ( Node2 s (Elem x1) (Elem y1)+    , Node2 s (Elem x2) (Elem y2))+unzipWithNodeElem f (Node3 s (Elem x) (Elem y) (Elem z))+  | (x1, x2) <- f x+  , (y1, y2) <- f y+  , (z1, z2) <- f z+  = ( Node3 s (Elem x1) (Elem y1) (Elem z1)+    , Node3 s (Elem x2) (Elem y2) (Elem z2))++-- | \( O(\min(n_1,n_2)) \).  'zip' takes two sequences and returns a sequence+-- of corresponding pairs.  If one input is short, excess elements are+-- discarded from the right end of the longer sequence.+zip :: Seq a -> Seq b -> Seq (a, b)+zip = zipWith (,)++-- | \( O(\min(n_1,n_2)) \).  'zipWith' generalizes 'zip' by zipping with the+-- function given as the first argument, instead of a tupling function.+-- For example, @zipWith (+)@ is applied to two sequences to take the+-- sequence of corresponding sums.+zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith f s1 s2 = zipWith' f s1' s2'+  where+    minLen = min (length s1) (length s2)+    s1' = take minLen s1+    s2' = take minLen s2++-- | A version of zipWith that assumes the sequences have the same length.+zipWith' :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+zipWith' f s1 s2 = splitMap uncheckedSplitAt goLeaf s2 s1+  where+    goLeaf (Seq (Single (Elem b))) a = f a b+    goLeaf _ _ = error "Data.Sequence.zipWith'.goLeaf internal error: not a singleton"++-- | \( O(\min(n_1,n_2,n_3)) \).  'zip3' takes three sequences and returns a+-- sequence of triples, analogous to 'zip'.+zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)+zip3 = zipWith3 (,,)++-- | \( O(\min(n_1,n_2,n_3)) \).  'zipWith3' takes a function which combines+-- three elements, as well as three sequences and returns a sequence of+-- their point-wise combinations, analogous to 'zipWith'.+zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+zipWith3 f s1 s2 s3 = zipWith' ($) (zipWith' f s1' s2') s3'+  where+    minLen = minimum [length s1, length s2, length s3]+    s1' = take minLen s1+    s2' = take minLen s2+    s3' = take minLen s3++zipWith3' :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d+zipWith3' f s1 s2 s3 = zipWith' ($) (zipWith' f s1 s2) s3++-- | \( O(\min(n_1,n_2,n_3,n_4)) \).  'zip4' takes four sequences and returns a+-- sequence of quadruples, analogous to 'zip'.+zip4 :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a,b,c,d)+zip4 = zipWith4 (,,,)++-- | \( O(\min(n_1,n_2,n_3,n_4)) \).  'zipWith4' takes a function which combines+-- four elements, as well as four sequences and returns a sequence of+-- their point-wise combinations, analogous to 'zipWith'.+zipWith4 :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e+zipWith4 f s1 s2 s3 s4 = zipWith' ($) (zipWith3' f s1' s2' s3') s4'+  where+    minLen = minimum [length s1, length s2, length s3, length s4]+    s1' = take minLen s1+    s2' = take minLen s2+    s3' = take minLen s3+    s4' = take minLen s4++-- | fromList2, given a list and its length, constructs a completely+-- balanced Seq whose elements are that list using the replicateA+-- generalization.+fromList2 :: Int -> [a] -> Seq a+fromList2 n = execState (replicateA n (State ht))+  where+    ht (x:xs) = (xs, x)+    ht []     = error "fromList2: short list"
+ src/Data/Sequence/Internal/Sorting.hs view
@@ -0,0 +1,437 @@+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_HADDOCK not-home #-}++-- |+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- This module provides the various sorting implementations for+-- "Data.Sequence". Further notes are available in the file sorting.md+-- (in this directory).++module Data.Sequence.Internal.Sorting+  (+   -- * Sort Functions+   sort+  ,sortBy+  ,sortOn+  ,unstableSort+  ,unstableSortBy+  ,unstableSortOn+  ,+   -- * Heaps+   -- $heaps+   Queue(..)+  ,QList(..)+  ,IndexedQueue(..)+  ,IQList(..)+  ,TaggedQueue(..)+  ,TQList(..)+  ,IndexedTaggedQueue(..)+  ,ITQList(..)+  ,+   -- * Merges+   -- $merges+   mergeQ+  ,mergeIQ+  ,mergeTQ+  ,mergeITQ+  ,+   -- * popMin+   -- $popMin+   popMinQ+  ,popMinIQ+  ,popMinTQ+  ,popMinITQ+  ,+   -- * Building+   -- $building+   buildQ+  ,buildIQ+  ,buildTQ+  ,buildITQ+  ,+   -- * Special folds+   -- $folds+   foldToMaybeTree+  ,foldToMaybeWithIndexTree)+  where++import Data.Sequence.Internal+       (Elem(..), Seq(..), Node(..), Digit(..), Sized(..), FingerTree(..),+        replicateA, foldDigit, foldNode, foldWithIndexDigit,+        foldWithIndexNode)+import Utils.Containers.Internal.State (State(..), execState)+-- | \( O(n \log n) \).  'sort' sorts the specified 'Seq' by the natural+-- ordering of its elements.  The sort is stable, meaning the order of equal+-- elements is preserved.  If stability is not+-- required, 'unstableSort' can be slightly faster.+--+-- @since 0.3.0+sort :: Ord a => Seq a -> Seq a+sort = sortBy compare++-- | \( O(n \log n) \).  'sortBy' sorts the specified 'Seq' according to the+-- specified comparator.  The sort is stable, meaning the order of equal+-- elements is preserved.  If stability is not required,+-- 'unstableSortBy' can be slightly faster.+--+-- @since 0.3.0+sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a+sortBy cmp (Seq xs) =+    maybe+        (Seq EmptyT)+        (execState (replicateA (size xs) (State (popMinIQ cmp))))+        (buildIQ cmp (\s (Elem x) -> IQ s x IQNil) 0 xs)++-- | \( O(n \log n) \). 'sortOn' sorts the specified 'Seq' by comparing+-- the results of a key function applied to each element. The sort is stable,+-- meaning the order of equal elements is preserved. @'sortOn' f@ is+-- equivalent to @'sortBy' ('compare' ``Data.Function.on`` f)@, but has the+-- performance advantage of only evaluating @f@ once for each element in the+-- input 'Seq'.+--+-- An example of using 'sortOn' might be to sort a 'Seq' of strings+-- according to their length:+--+-- > sortOn length (fromList ["alligator", "monkey", "zebra"]) == fromList ["zebra", "monkey", "alligator"]+--+-- If, instead, 'sortBy' had been used, 'length' would be evaluated on+-- every comparison, giving \( O(n \log n) \) evaluations, rather than+-- \( O(n) \).+--+-- If @f@ is very cheap (for example a record selector, or 'fst'),+-- @'sortBy' ('compare' ``Data.Function.on`` f)@ will be faster than+-- @'sortOn' f@.+--+-- @since 0.5.11+sortOn :: Ord b => (a -> b) -> Seq a -> Seq a+sortOn f (Seq xs) =+    maybe+       (Seq EmptyT)+       (execState (replicateA (size xs) (State (popMinITQ compare))))+       (buildITQ compare (\s (Elem x) -> ITQ s (f x) x ITQNil) 0 xs)++-- | \( O(n \log n) \).  'unstableSort' sorts the specified 'Seq' by+-- the natural ordering of its elements, but the sort is not stable.+-- This algorithm is frequently faster and uses less memory than 'sort'.++-- Notes on the implementation and choice of heap are available in+-- the file sorting.md (in this directory).+--+-- @since 0.3.0+unstableSort :: Ord a => Seq a -> Seq a+unstableSort = unstableSortBy compare++-- | \( O(n \log n) \).  A generalization of 'unstableSort', 'unstableSortBy'+-- takes an arbitrary comparator and sorts the specified sequence.+-- The sort is not stable.  This algorithm is frequently faster and+-- uses less memory than 'sortBy'.+--+-- @since 0.3.0+unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a+unstableSortBy cmp (Seq xs) =+    maybe+        (Seq EmptyT)+        (execState (replicateA (size xs) (State (popMinQ cmp))))+        (buildQ cmp (\(Elem x) -> Q x Nil) xs)++-- | \( O(n \log n) \). 'unstableSortOn' sorts the specified 'Seq' by+-- comparing the results of a key function applied to each element.+-- @'unstableSortOn' f@ is equivalent to @'unstableSortBy' ('compare' ``Data.Function.on`` f)@,+-- but has the performance advantage of only evaluating @f@ once for each+-- element in the input 'Seq'.+--+-- An example of using 'unstableSortOn' might be to sort a 'Seq' of strings+-- according to their length:+--+-- > unstableSortOn length (fromList ["alligator", "monkey", "zebra"]) == fromList ["zebra", "monkey", "alligator"]+--+-- If, instead, 'unstableSortBy' had been used, 'length' would be evaluated on+-- every comparison, giving \( O(n \log n) \) evaluations, rather than+-- \( O(n) \).+--+-- If @f@ is very cheap (for example a record selector, or 'fst'),+-- @'unstableSortBy' ('compare' ``Data.Function.on`` f)@ will be faster than+-- @'unstableSortOn' f@.+--+-- @since 0.5.11+unstableSortOn :: Ord b => (a -> b) -> Seq a -> Seq a+unstableSortOn f (Seq xs) =+    maybe+       (Seq EmptyT)+       (execState (replicateA (size xs) (State (popMinTQ compare))))+       (buildTQ compare (\(Elem x) -> TQ (f x) x TQNil) xs)++------------------------------------------------------------------------+-- $heaps+--+-- The following are definitions for various specialized pairing heaps.+--+-- All of the heaps are defined to be non-empty, which speeds up the+-- merge functions.+------------------------------------------------------------------------++-- | A simple pairing heap.+data Queue e = Q !e (QList e)+data QList e+    = Nil+    | QCons {-# UNPACK #-} !(Queue e)+            (QList e)++-- | A pairing heap tagged with the original position of elements,+-- to allow for stable sorting.+data IndexedQueue e =+    IQ {-# UNPACK #-} !Int !e (IQList e)+data IQList e+    = IQNil+    | IQCons {-# UNPACK #-} !(IndexedQueue e)+             (IQList e)++-- | A pairing heap tagged with some key for sorting elements, for use+-- in 'unstableSortOn'.+data TaggedQueue a b =+    TQ !a b (TQList a b)+data TQList a b+    = TQNil+    | TQCons {-# UNPACK #-} !(TaggedQueue a b)+             (TQList a b)++-- | A pairing heap tagged with both a key and the original position+-- of its elements, for use in 'sortOn'.+data IndexedTaggedQueue e a =+    ITQ {-# UNPACK #-} !Int !e a (ITQList e a)+data ITQList e a+    = ITQNil+    | ITQCons {-# UNPACK #-} !(IndexedTaggedQueue e a)+              (ITQList e a)++infixr 8 `ITQCons`, `TQCons`, `QCons`, `IQCons`++------------------------------------------------------------------------+-- $merges+--+-- The following are definitions for "merge" for each of the heaps+-- above. Each takes a comparison function which is used to order the+-- elements.+------------------------------------------------------------------------++-- | 'mergeQ' merges two 'Queue's.+mergeQ :: (a -> a -> Ordering) -> Queue a -> Queue a -> Queue a+mergeQ cmp q1@(Q x1 ts1) q2@(Q x2 ts2)+  | cmp x1 x2 == GT = Q x2 (q1 `QCons` ts2)+  | otherwise       = Q x1 (q2 `QCons` ts1)++-- | 'mergeTQ' merges two 'TaggedQueue's, based on the tag value.+mergeTQ :: (a -> a -> Ordering)+        -> TaggedQueue a b+        -> TaggedQueue a b+        -> TaggedQueue a b+mergeTQ cmp q1@(TQ x1 y1 ts1) q2@(TQ x2 y2 ts2)+  | cmp x1 x2 == GT = TQ x2 y2 (q1 `TQCons` ts2)+  | otherwise       = TQ x1 y1 (q2 `TQCons` ts1)++-- | 'mergeIQ' merges two 'IndexedQueue's, taking into account the+-- original position of the elements.+mergeIQ :: (a -> a -> Ordering)+        -> IndexedQueue a+        -> IndexedQueue a+        -> IndexedQueue a+mergeIQ cmp q1@(IQ i1 x1 ts1) q2@(IQ i2 x2 ts2) =+    case cmp x1 x2 of+        LT -> IQ i1 x1 (q2 `IQCons` ts1)+        EQ | i1 <= i2 -> IQ i1 x1 (q2 `IQCons` ts1)+        _ -> IQ i2 x2 (q1 `IQCons` ts2)++-- | 'mergeITQ' merges two 'IndexedTaggedQueue's, based on the tag+-- value, taking into account the original position of the elements.+mergeITQ+    :: (a -> a -> Ordering)+    -> IndexedTaggedQueue a b+    -> IndexedTaggedQueue a b+    -> IndexedTaggedQueue a b+mergeITQ cmp q1@(ITQ i1 x1 y1 ts1) q2@(ITQ i2 x2 y2 ts2) =+    case cmp x1 x2 of+        LT -> ITQ i1 x1 y1 (q2 `ITQCons` ts1)+        EQ | i1 <= i2 -> ITQ i1 x1 y1 (q2 `ITQCons` ts1)+        _ -> ITQ i2 x2 y2 (q1 `ITQCons` ts2)++------------------------------------------------------------------------+-- $popMin+--+-- The following are definitions for @popMin@, a function which+-- constructs a stateful action which pops the smallest element from the+-- queue, where "smallest" is according to the supplied comparison+-- function.+--+-- All of the functions fail on an empty queue.+--+-- Each of these functions is structured something like this:+--+-- @popMinQ cmp (Q x ts) = (mergeQs ts, x)@+--+-- The reason the call to @mergeQs@ is lazy is that it will be bottom+-- for the last element in the queue, preventing us from evaluating the+-- fully sorted sequence.+------------------------------------------------------------------------++-- | Pop the smallest element from the queue, using the supplied+-- comparator.+popMinQ :: (e -> e -> Ordering) -> Queue e -> (Queue e, e)+popMinQ cmp (Q x xs) = (mergeQs xs, x)+  where+    mergeQs (t `QCons` Nil) = t+    mergeQs (t1 `QCons` t2 `QCons` Nil) = t1 <+> t2+    mergeQs (t1 `QCons` t2 `QCons` ts) = (t1 <+> t2) <+> mergeQs ts+    mergeQs Nil = error "popMinQ: tried to pop from empty queue"+    (<+>) = mergeQ cmp++-- | Pop the smallest element from the queue, using the supplied+-- comparator, deferring to the item's original position when the+-- comparator returns 'EQ'.+popMinIQ :: (e -> e -> Ordering) -> IndexedQueue e -> (IndexedQueue e, e)+popMinIQ cmp (IQ _ x xs) = (mergeQs xs, x)+  where+    mergeQs (t `IQCons` IQNil) = t+    mergeQs (t1 `IQCons` t2 `IQCons` IQNil) = t1 <+> t2+    mergeQs (t1 `IQCons` t2 `IQCons` ts) = (t1 <+> t2) <+> mergeQs ts+    mergeQs IQNil = error "popMinQ: tried to pop from empty queue"+    (<+>) = mergeIQ cmp++-- | Pop the smallest element from the queue, using the supplied+-- comparator on the tag.+popMinTQ :: (a -> a -> Ordering) -> TaggedQueue a b -> (TaggedQueue a b, b)+popMinTQ cmp (TQ _ x xs) = (mergeQs xs, x)+  where+    mergeQs (t `TQCons` TQNil) = t+    mergeQs (t1 `TQCons` t2 `TQCons` TQNil) = t1 <+> t2+    mergeQs (t1 `TQCons` t2 `TQCons` ts) = (t1 <+> t2) <+> mergeQs ts+    mergeQs TQNil = error "popMinQ: tried to pop from empty queue"+    (<+>) = mergeTQ cmp++-- | Pop the smallest element from the queue, using the supplied+-- comparator on the tag, deferring to the item's original position+-- when the comparator returns 'EQ'.+popMinITQ :: (e -> e -> Ordering)+          -> IndexedTaggedQueue e b+          -> (IndexedTaggedQueue e b, b)+popMinITQ cmp (ITQ _ _ x xs) = (mergeQs xs, x)+  where+    mergeQs (t `ITQCons` ITQNil) = t+    mergeQs (t1 `ITQCons` t2 `ITQCons` ITQNil) = t1 <+> t2+    mergeQs (t1 `ITQCons` t2 `ITQCons` ts) = (t1 <+> t2) <+> mergeQs ts+    mergeQs ITQNil = error "popMinQ: tried to pop from empty queue"+    (<+>) = mergeITQ cmp++------------------------------------------------------------------------+-- $building+--+-- The following are definitions for functions to build queues, given a+-- comparison function.+------------------------------------------------------------------------++buildQ :: (b -> b -> Ordering) -> (a -> Queue b) -> FingerTree a -> Maybe (Queue b)+buildQ cmp = foldToMaybeTree (mergeQ cmp)++buildIQ+    :: (b -> b -> Ordering)+    -> (Int -> Elem y -> IndexedQueue b)+    -> Int+    -> FingerTree (Elem y)+    -> Maybe (IndexedQueue b)+buildIQ cmp = foldToMaybeWithIndexTree (mergeIQ cmp)++buildTQ+    :: (b -> b -> Ordering)+    -> (a -> TaggedQueue b c)+    -> FingerTree a+    -> Maybe (TaggedQueue b c)+buildTQ cmp = foldToMaybeTree (mergeTQ cmp)++buildITQ+    :: (b -> b -> Ordering)+    -> (Int -> Elem y -> IndexedTaggedQueue b c)+    -> Int+    -> FingerTree (Elem y)+    -> Maybe (IndexedTaggedQueue b c)+buildITQ cmp = foldToMaybeWithIndexTree (mergeITQ cmp)++------------------------------------------------------------------------+-- $folds+--+-- A big part of what makes the heaps fast is that they're non empty,+-- so the merge function can avoid an extra case match. To take+-- advantage of this, though, we need specialized versions of 'foldMap'+-- and 'Data.Sequence.foldMapWithIndex', which can alternate between+-- calling the faster semigroup-like merge when folding over non empty+-- structures (like 'Node' and 'Digit'), and the+-- 'Data.Semirgroup.Option'-like mappend, when folding over structures+-- which can be empty (like 'FingerTree').+------------------------------------------------------------------------++-- | A 'foldMap'-like function, specialized to the+-- 'Data.Semigroup.Option' monoid, which takes advantage of the+-- internal structure of 'Seq' to avoid wrapping in 'Maybe' at certain+-- points.+foldToMaybeTree :: (b -> b -> b) -> (a -> b) -> FingerTree a -> Maybe b+foldToMaybeTree _ _ EmptyT = Nothing+foldToMaybeTree _ f (Single xs) = Just (f xs)+foldToMaybeTree (<+>) f (Deep _ pr m sf) =+    Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) m')+  where+    pr' = foldDigit (<+>) f pr+    sf' = foldDigit (<+>) f sf+    m' = foldToMaybeTree (<+>) (foldNode (<+>) f) m++-- | A 'Data.Sequence.foldMapWithIndex'-like function, specialized to the+-- 'Data.Semigroup.Option' monoid, which takes advantage of the+-- internal structure of 'Seq' to avoid wrapping in 'Maybe' at certain+-- points.+foldToMaybeWithIndexTree :: (b -> b -> b)+                         -> (Int -> Elem y -> b)+                         -> Int+                         -> FingerTree (Elem y)+                         -> Maybe b+foldToMaybeWithIndexTree = foldToMaybeWithIndexTree'+  where+    {-# SPECIALISE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> FingerTree (Elem y) -> Maybe b #-}+    {-# SPECIALISE foldToMaybeWithIndexTree' :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> FingerTree (Node y) -> Maybe b #-}+    foldToMaybeWithIndexTree'+        :: Sized a+        => (b -> b -> b) -> (Int -> a -> b) -> Int -> FingerTree a -> Maybe b+    foldToMaybeWithIndexTree' _ _ !_s EmptyT = Nothing+    foldToMaybeWithIndexTree' _ f s (Single xs) = Just (f s xs)+    foldToMaybeWithIndexTree' (<+>) f s (Deep _ pr m sf) =+        Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) m')+      where+        pr' = digit (<+>) f s pr+        sf' = digit (<+>) f sPsprm sf+        m' = foldToMaybeWithIndexTree' (<+>) (node (<+>) f) sPspr m+        !sPspr = s + size pr+        !sPsprm = sPspr + size m+    {-# SPECIALISE digit :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Digit (Elem y) -> b #-}+    {-# SPECIALISE digit :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Digit (Node y) -> b #-}+    digit+        :: Sized a+        => (b -> b -> b) -> (Int -> a -> b) -> Int -> Digit a -> b+    digit = foldWithIndexDigit+    {-# SPECIALISE node :: (b -> b -> b) -> (Int -> Elem y -> b) -> Int -> Node (Elem y) -> b #-}+    {-# SPECIALISE node :: (b -> b -> b) -> (Int -> Node y -> b) -> Int -> Node (Node y) -> b #-}+    node+        :: Sized a+        => (b -> b -> b) -> (Int -> a -> b) -> Int -> Node a -> b+    node = foldWithIndexNode+{-# INLINE foldToMaybeWithIndexTree #-}
+ src/Data/Set.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Safe #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Set+-- Copyright   :  (c) Daan Leijen 2002+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Sets+--+-- The @'Set' e@ type represents a set of elements of type @e@. Most operations+-- require that @e@ be an instance of the 'Ord' class. A 'Set' is strict in its+-- elements.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions, e.g.+--+-- >  import Data.Set (Set)+-- >  import qualified Data.Set as Set+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two sets as arguments and combine them, such as `union` and `intersection`,+-- prefer the entries in the first argument to those in the second. Of course,+-- this bias can only be observed when equality is an equivalence relation+-- instead of structural equality.+--+--+-- == Warning+--+-- The size of the set must not exceed @maxBound::Int@. Violation of+-- this condition is not detected and if the size limit is exceeded, its+-- behaviour is undefined.+--+--+-- == Implementation+--+-- The implementation of 'Set' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104>+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>.+--+--+-- == Performance information+--+-- The time complexity is given for each operation in+-- [big-O notation](http://en.wikipedia.org/wiki/Big_O_notation), with \(n\)+-- referring to the number of entries in the set.+--+-- Operations like 'member', 'insert', and 'delete' take \(O(\log n)\) time.+--+-- Binary set operations like 'union' and 'intersection' take+-- \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr)\) time, where \(m\) and \(n\)+-- are the sizes of the smaller and larger input sets respectively.+--+-----------------------------------------------------------------------------++module Data.Set (+            -- * Set type+              Set          -- instance Eq,Ord,Show,Read,Data++            -- * Construction+            , empty+            , singleton+            , fromList+            , fromAscList+            , fromDescList+            , fromDistinctAscList+            , fromDistinctDescList+            , powerSet++            -- * Insertion+            , insert++            -- * Deletion+            , delete++            -- * Generalized insertion/deletion++            , alterF++            -- * Query+            , member+            , notMember+            , lookupLT+            , lookupGT+            , lookupLE+            , lookupGE+            , S.null+            , size+            , isSubsetOf+            , isProperSubsetOf+            , disjoint++            -- * Combine+            , union+            , unions+            , difference+            , (\\)+            , intersection+            , intersections+            , symmetricDifference+            , cartesianProduct+            , disjointUnion+            , Intersection(..)++            -- * Filter+            , S.filter+            , takeWhileAntitone+            , dropWhileAntitone+            , spanAntitone+            , partition+            , split+            , splitMember+            , splitRoot++            -- * Indexed+            , lookupIndex+            , findIndex+            , elemAt+            , deleteAt+            , S.take+            , S.drop+            , S.splitAt++            -- * Map+            , S.map+            , mapMonotonic++            -- * Folds+            , S.foldr+            , S.foldl+            -- ** Strict folds+            , S.foldr'+            , S.foldl'+            -- ** Legacy folds+            , fold++            -- * Min\/Max+            , lookupMin+            , lookupMax+            , findMin+            , findMax+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , maxView+            , minView++            -- * Conversion++            -- ** List+            , elems+            , toList+            , toAscList+            , toDescList++            -- * Debugging+            , showTree+            , showTreeWith+            , valid+            ) where++import Data.Set.Internal as S
+ src/Data/Set/Internal.hs view
@@ -0,0 +1,2288 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+#endif++{-# OPTIONS_HADDOCK not-home #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Set.Internal+-- Copyright   :  (c) Daan Leijen 2002+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+--+-- = Finite Sets (internals)+--+-- The @'Set' e@ type represents a set of elements of type @e@. Most operations+-- require that @e@ be an instance of the 'Ord' class. A 'Set' is strict in its+-- elements.+--+--+-- == Implementation+--+-- The implementation of 'Set' is based on /size balanced/ binary trees (or+-- trees of /bounded balance/) as described by:+--+--    * Stephen Adams, \"/Efficient sets—a balancing act/\",+--      Journal of Functional Programming 3(4):553-562, October 1993,+--      <https://doi.org/10.1017/S0956796800000885>,+--      <https://groups.csail.mit.edu/mac/users/adams/BB/index.html>.+--    * J. Nievergelt and E.M. Reingold,+--      \"/Binary search trees of bounded balance/\",+--      SIAM journal of computing 2(1), March 1973.+--      <https://doi.org/10.1137/0202005>.+--    * Yoichi Hirai and Kazuhiko Yamamoto,+--      \"/Balancing weight-balanced trees/\",+--      Journal of Functional Programming 21(3):287-307, 2011,+--      <https://doi.org/10.1017/S0956796811000104>+--+--  Bounds for 'union', 'intersection', and 'difference' are as given+--  by+--+--    * Guy Blelloch, Daniel Ferizovic, and Yihan Sun,+--      \"/Parallel Ordered Sets Using Join/\",+--      <https://arxiv.org/abs/1602.02120v4>.+--+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: Using INLINABLE]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- It is crucial to the performance that the functions specialize on the Ord+-- type when possible. GHC 7.0 and higher does this by itself when it sees th+-- unfolding of a function -- that is why all public functions are marked+-- INLINABLE (that exposes the unfolding).+++-- [Note: Using INLINE]+-- ~~~~~~~~~~~~~~~~~~~~+-- For other compilers and GHC pre 7.0, we mark some of the functions INLINE.+-- We mark the functions that just navigate down the tree (lookup, insert,+-- delete and similar). That navigation code gets inlined and thus specialized+-- when possible. There is a price to pay -- code growth. The code INLINED is+-- therefore only the tree navigation, all the real work (rebalancing) is not+-- INLINED by using a NOINLINE.+--+-- All methods marked INLINE have to be nonrecursive -- a 'go' function doing+-- the real work is provided.+++-- [Note: Type of local 'go' function]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- If the local 'go' function uses an Ord class, it sometimes heap-allocates+-- the Ord dictionary when the 'go' function does not have explicit type.+-- In that case we give 'go' explicit type. But this slightly decrease+-- performance, as the resulting 'go' function can float out to top level.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- As opposed to IntSet, when 'go' function captures an argument, increased+-- heap-allocation can occur: sometimes in a polymorphic function, the 'go'+-- floats out of its enclosing function and then it heap-allocates the+-- dictionary and the argument. Maybe it floats out too late and strictness+-- analyzer cannot see that these could be passed on stack.++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of Set matters when considering performance.+-- Currently in GHC 7.0, when type has 2 constructors, a forward conditional+-- jump is made when successfully matching second constructor. Successful match+-- of first constructor results in the forward jump not taken.+-- On GHC 7.0, reordering constructors from Tip | Bin to Bin | Tip+-- improves the benchmark by up to 10% on x86.++module Data.Set.Internal (+            -- * Set type+              Set(..)       -- instance Eq,Ord,Show,Read,Data+            , Size++            -- * Operators+            , (\\)++            -- * Query+            , null+            , size+            , member+            , notMember+            , lookupLT+            , lookupGT+            , lookupLE+            , lookupGE+            , isSubsetOf+            , isProperSubsetOf+            , disjoint++            -- * Construction+            , empty+            , singleton+            , insert+            , delete+            , alterF+            , powerSet++            -- * Combine+            , union+            , unions+            , difference+            , intersection+            , intersections+            , symmetricDifference+            , cartesianProduct+            , disjointUnion+            , Intersection(..)+++            -- * Filter+            , filter+            , takeWhileAntitone+            , dropWhileAntitone+            , spanAntitone+            , partition+            , split+            , splitMember+            , splitRoot++            -- * Indexed+            , lookupIndex+            , findIndex+            , elemAt+            , deleteAt+            , take+            , drop+            , splitAt++            -- * Map+            , map+            , mapMonotonic++            -- * Folds+            , foldr+            , foldl+            -- ** Strict folds+            , foldr'+            , foldl'+            -- ** Legacy folds+            , fold++            -- * Min\/Max+            , lookupMin+            , lookupMax+            , findMin+            , findMax+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , maxView+            , minView++            -- * Conversion++            -- ** List+            , elems+            , toList+            , fromList++            -- ** Ordered list+            , toAscList+            , toDescList+            , fromAscList+            , fromDistinctAscList+            , fromDescList+            , fromDistinctDescList++            -- * Debugging+            , showTree+            , showTreeWith+            , valid++            -- Internals (for testing)+            , bin+            , balanced+            , link+            , merge+            ) where++import Utils.Containers.Internal.Prelude hiding+  (filter,foldl,foldl',foldr,null,map,take,drop,splitAt)+import Prelude ()+import Control.Applicative (Const(..))+import qualified Data.List as List+import Data.Semigroup (Semigroup(..), stimesIdempotentMonoid, stimesIdempotent)+import Data.Functor.Classes+import Data.Functor.Identity (Identity)+import qualified Data.Foldable as Foldable+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf))+import Data.List.NonEmpty (NonEmpty(..))++import Utils.Containers.Internal.StrictPair+import Utils.Containers.Internal.PtrEquality+import Utils.Containers.Internal.EqOrdUtil (EqM(..), OrdM(..))++#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+import Text.Read ( readPrec, Read (..), Lexeme (..), parens, prec+                 , lexP, readListPrecDefault )+#endif+#if __GLASGOW_HASKELL__+import GHC.Exts ( build, lazy )+import qualified GHC.Exts as GHCExts+import Data.Data+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+import Data.Coerce (coerce)+#endif+++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+infixl 9 \\ --++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). See 'difference'.+(\\) :: Ord a => Set a -> Set a -> Set a+m1 \\ m2 = difference m1 m2+#if __GLASGOW_HASKELL__+{-# INLINABLE (\\) #-}+#endif++{--------------------------------------------------------------------+  Sets are size balanced trees+--------------------------------------------------------------------}+-- | A set of values @a@.++-- See Note: Order of constructors+data Set a    = Bin {-# UNPACK #-} !Size !a !(Set a) !(Set a)+              | Tip++type Size     = Int++#ifdef __GLASGOW_HASKELL__+type role Set nominal++-- | @since 0.6.6+deriving instance Lift a => Lift (Set a)+#endif++-- | @mempty@ = 'empty'+instance Ord a => Monoid (Set a) where+    mempty  = empty+    mconcat = unions+    mappend = (<>)++-- | @(<>)@ = 'union'+--+-- @since 0.5.7+instance Ord a => Semigroup (Set a) where+    (<>)    = union+    stimes  = stimesIdempotentMonoid++-- | Folds in order of increasing key.+instance Foldable.Foldable Set where+    fold = go+      where go Tip = mempty+            go (Bin 1 k _ _) = k+            go (Bin _ k l r) = go l `mappend` (k `mappend` go r)+    {-# INLINABLE fold #-}+    foldr = foldr+    {-# INLINE foldr #-}+    foldl = foldl+    {-# INLINE foldl #-}+    foldMap f t = go t+      where go Tip = mempty+            go (Bin 1 k _ _) = f k+            go (Bin _ k l r) = go l `mappend` (f k `mappend` go r)+    {-# INLINE foldMap #-}+    foldl' = foldl'+    {-# INLINE foldl' #-}+    foldr' = foldr'+    {-# INLINE foldr' #-}+    length = size+    {-# INLINE length #-}+    null   = null+    {-# INLINE null #-}+    toList = toList+    {-# INLINE toList #-}+    elem = go+      where go !_ Tip = False+            go x (Bin _ y l r) = x == y || go x l || go x r+    {-# INLINABLE elem #-}+    minimum = findMin+    {-# INLINE minimum #-}+    maximum = findMax+    {-# INLINE maximum #-}+    sum = foldl' (+) 0+    {-# INLINABLE sum #-}+    product = foldl' (*) 1+    {-# INLINABLE product #-}++#if __GLASGOW_HASKELL__++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance (Data a, Ord a) => Data (Set a) where+  gfoldl f z set = z fromList `f` (toList set)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = setDataType+  dataCast1 f    = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr setDataType "fromList" [] Prefix++setDataType :: DataType+setDataType = mkDataType "Data.Set.Internal.Set" [fromListConstr]++#endif++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is this the empty set?+null :: Set a -> Bool+null Tip      = True+null (Bin {}) = False+{-# INLINE null #-}++-- | \(O(1)\). The number of elements in the set.+size :: Set a -> Int+size Tip = 0+size (Bin sz _ _ _) = sz+{-# INLINE size #-}++-- | \(O(\log n)\). Is the element in the set?+member :: Ord a => a -> Set a -> Bool+member = go+  where+    go !_ Tip = False+    go x (Bin _ y l r) = case compare x y of+      LT -> go x l+      GT -> go x r+      EQ -> True+#if __GLASGOW_HASKELL__+{-# INLINABLE member #-}+#else+{-# INLINE member #-}+#endif++-- | \(O(\log n)\). Is the element not in the set?+notMember :: Ord a => a -> Set a -> Bool+notMember a t = not $ member a t+#if __GLASGOW_HASKELL__+{-# INLINABLE notMember #-}+#else+{-# INLINE notMember #-}+#endif++-- | \(O(\log n)\). Find largest element smaller than the given one.+--+-- > lookupLT 3 (fromList [3, 5]) == Nothing+-- > lookupLT 5 (fromList [3, 5]) == Just 3+lookupLT :: Ord a => a -> Set a -> Maybe a+lookupLT = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing x (Bin _ y l r) | x <= y = goNothing x l+                              | otherwise = goJust x y r++    goJust !_ best Tip = Just best+    goJust x best (Bin _ y l r) | x <= y = goJust x best l+                                | otherwise = goJust x y r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupLT #-}+#else+{-# INLINE lookupLT #-}+#endif++-- | \(O(\log n)\). Find smallest element greater than the given one.+--+-- > lookupGT 4 (fromList [3, 5]) == Just 5+-- > lookupGT 5 (fromList [3, 5]) == Nothing+lookupGT :: Ord a => a -> Set a -> Maybe a+lookupGT = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing x (Bin _ y l r) | x < y = goJust x y l+                              | otherwise = goNothing x r++    goJust !_ best Tip = Just best+    goJust x best (Bin _ y l r) | x < y = goJust x y l+                                | otherwise = goJust x best r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupGT #-}+#else+{-# INLINE lookupGT #-}+#endif++-- | \(O(\log n)\). Find largest element smaller or equal to the given one.+--+-- > lookupLE 2 (fromList [3, 5]) == Nothing+-- > lookupLE 4 (fromList [3, 5]) == Just 3+-- > lookupLE 5 (fromList [3, 5]) == Just 5+lookupLE :: Ord a => a -> Set a -> Maybe a+lookupLE = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing x (Bin _ y l r) = case compare x y of LT -> goNothing x l+                                                    EQ -> Just y+                                                    GT -> goJust x y r++    goJust !_ best Tip = Just best+    goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x best l+                                                      EQ -> Just y+                                                      GT -> goJust x y r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupLE #-}+#else+{-# INLINE lookupLE #-}+#endif++-- | \(O(\log n)\). Find smallest element greater or equal to the given one.+--+-- > lookupGE 3 (fromList [3, 5]) == Just 3+-- > lookupGE 4 (fromList [3, 5]) == Just 5+-- > lookupGE 6 (fromList [3, 5]) == Nothing+lookupGE :: Ord a => a -> Set a -> Maybe a+lookupGE = goNothing+  where+    goNothing !_ Tip = Nothing+    goNothing x (Bin _ y l r) = case compare x y of LT -> goJust x y l+                                                    EQ -> Just y+                                                    GT -> goNothing x r++    goJust !_ best Tip = Just best+    goJust x best (Bin _ y l r) = case compare x y of LT -> goJust x y l+                                                      EQ -> Just y+                                                      GT -> goJust x best r+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupGE #-}+#else+{-# INLINE lookupGE #-}+#endif++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty set.+empty  :: Set a+empty = Tip+{-# INLINE empty #-}++-- | \(O(1)\). Create a singleton set.+singleton :: a -> Set a+singleton x = Bin 1 x Tip Tip+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insertion, Deletion+--------------------------------------------------------------------}+-- | \(O(\log n)\). Insert an element in a set.+-- If the set already contains an element equal to the given value,+-- it is replaced with the new value.++-- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper (in Data.Map.Internal)+insert :: Ord a => a -> Set a -> Set a+insert x0 = go x0 x0+  where+    go :: Ord a => a -> a -> Set a -> Set a+    go orig !_ Tip = singleton (lazy orig)+    go orig !x t@(Bin sz y l r) = case compare x y of+        LT | l' `ptrEq` l -> t+           | otherwise -> balanceL y l' r+           where !l' = go orig x l+        GT | r' `ptrEq` r -> t+           | otherwise -> balanceR y l r'+           where !r' = go orig x r+        EQ | lazy orig `seq` (orig `ptrEq` y) -> t+           | otherwise -> Bin sz (lazy orig) l r+#if __GLASGOW_HASKELL__+{-# INLINABLE insert #-}+#else+{-# INLINE insert #-}+#endif++#ifndef __GLASGOW_HASKELL__+lazy :: a -> a+lazy a = a+#endif++-- Insert an element to the set only if it is not in the set.+-- Used by `union`.++-- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper (in Data.Map.Internal)+insertR :: Ord a => a -> Set a -> Set a+insertR x0 = go x0 x0+  where+    go :: Ord a => a -> a -> Set a -> Set a+    go orig !_ Tip = singleton (lazy orig)+    go orig !x t@(Bin _ y l r) = case compare x y of+        LT | l' `ptrEq` l -> t+           | otherwise -> balanceL y l' r+           where !l' = go orig x l+        GT | r' `ptrEq` r -> t+           | otherwise -> balanceR y l r'+           where !r' = go orig x r+        EQ -> t+#if __GLASGOW_HASKELL__+{-# INLINABLE insertR #-}+#else+{-# INLINE insertR #-}+#endif++-- | \(O(\log n)\). Delete an element from a set.++-- See Note: Type of local 'go' function+delete :: Ord a => a -> Set a -> Set a+delete = go+  where+    go :: Ord a => a -> Set a -> Set a+    go !_ Tip = Tip+    go x t@(Bin _ y l r) = case compare x y of+        LT | l' `ptrEq` l -> t+           | otherwise -> balanceR y l' r+           where !l' = go x l+        GT | r' `ptrEq` r -> t+           | otherwise -> balanceL y l r'+           where !r' = go x r+        EQ -> glue l r+#if __GLASGOW_HASKELL__+{-# INLINABLE delete #-}+#else+{-# INLINE delete #-}+#endif++-- | \(O(\log n)\) @('alterF' f x s)@ can delete or insert @x@ in @s@ depending on+-- whether an equal element is found in @s@.+--+-- In short:+--+-- @+-- 'member' x \<$\> 'alterF' f x s = f ('member' x s)+-- @+--+-- Note that unlike 'insert', 'alterF' will /not/ replace an element equal to+-- the given value.+--+-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".+--+-- @since 0.6.3.1+alterF :: (Ord a, Functor f) => (Bool -> f Bool) -> a -> Set a -> f (Set a)+alterF f k s = fmap choose (f member_)+  where+    (member_, inserted, deleted) = case alteredSet k s of+        Deleted d           -> (True , s, d)+        Inserted i          -> (False, i, s)++    choose True  = inserted+    choose False = deleted+#ifndef __GLASGOW_HASKELL__+{-# INLINE alterF #-}+#else+{-# INLINABLE [2] alterF #-}++{-# RULES+"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s+ #-}+#endif++{-# SPECIALIZE alterF :: Ord a => (Bool -> Identity Bool) -> a -> Set a -> Identity (Set a) #-}++data AlteredSet a+      -- | The needle is present in the original set.+      -- We return the set where the needle is deleted.+    = Deleted !(Set a)++      -- | The needle is not present in the original set.+      -- We return the set with the needle inserted.+    | Inserted !(Set a)++alteredSet :: Ord a => a -> Set a -> AlteredSet a+alteredSet x0 s0 = go x0 s0+  where+    go :: Ord a => a -> Set a -> AlteredSet a+    go x Tip           = Inserted (singleton x)+    go x (Bin _ y l r) = case compare x y of+        LT -> case go x l of+            Deleted d           -> Deleted (balanceR y d r)+            Inserted i          -> Inserted (balanceL y i r)+        GT -> case go x r of+            Deleted d           -> Deleted (balanceL y l d)+            Inserted i          -> Inserted (balanceR y l i)+        EQ -> Deleted (glue l r)+#if __GLASGOW_HASKELL__+{-# INLINABLE alteredSet #-}+#else+{-# INLINE alteredSet #-}+#endif++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- @(s1 \`isProperSubsetOf\` s2)@ indicates whether @s1@ is a+-- proper subset of @s2@.+--+-- @+-- s1 \`isProperSubsetOf\` s2 = s1 ``isSubsetOf`` s2 && s1 /= s2+-- @+isProperSubsetOf :: Ord a => Set a -> Set a -> Bool+isProperSubsetOf s1 s2+    = size s1 < size s2 && isSubsetOfX s1 s2+#if __GLASGOW_HASKELL__+{-# INLINABLE isProperSubsetOf #-}+#endif+++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- @(s1 \`isSubsetOf\` s2)@ indicates whether @s1@ is a subset of @s2@.+--+-- @+-- s1 \`isSubsetOf\` s2 = all (``member`` s2) s1+-- s1 \`isSubsetOf\` s2 = null (s1 ``difference`` s2)+-- s1 \`isSubsetOf\` s2 = s1 ``union`` s2 == s2+-- s1 \`isSubsetOf\` s2 = s1 ``intersection`` s2 == s1+-- @+isSubsetOf :: Ord a => Set a -> Set a -> Bool+isSubsetOf t1 t2+  = size t1 <= size t2 && isSubsetOfX t1 t2+#if __GLASGOW_HASKELL__+{-# INLINABLE isSubsetOf #-}+#endif++-- Test whether a set is a subset of another without the *initial*+-- size test.+--+-- This function is structured very much like `difference`, `union`,+-- and `intersection`. Whereas the bounds proofs for those in Blelloch+-- et al needed to account for both "split work" and "merge work", we+-- only have to worry about split work here, which is the same as in+-- those functions.+isSubsetOfX :: Ord a => Set a -> Set a -> Bool+isSubsetOfX Tip _ = True+isSubsetOfX _ Tip = False+-- Skip the final split when we hit a singleton.+isSubsetOfX (Bin 1 x _ _) t = member x t+isSubsetOfX (Bin _ x l r) t+  = found &&+    -- Cheap size checks can sometimes save expensive recursive calls when the+    -- result will be False. Suppose we check whether [1..10] (with root 4) is+    -- a subset of [0..9]. After the first split, we have to check if [1..3] is+    -- a subset of [0..3] and if [5..10] is a subset of [5..9]. But we can bail+    -- immediately because size [5..10] > size [5..9].+    --+    -- Why not just call `isSubsetOf` on each side to do the size checks?+    -- Because that could make a recursive call on the left even though the+    -- size check would fail on the right. In principle, we could take this to+    -- extremes by maintaining a queue of pairs of sets to be checked, working+    -- through the tree level-wise. But that would impose higher administrative+    -- costs without obvious benefits. It might be worth considering if we find+    -- a way to use it to tighten the bounds in some useful/comprehensible way.+    size l <= size lt && size r <= size gt &&+    isSubsetOfX l lt && isSubsetOfX r gt+  where+    (lt,found,gt) = splitMember x t+#if __GLASGOW_HASKELL__+{-# INLINABLE isSubsetOfX #-}+#endif++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Check whether two sets are disjoint+-- (i.e., their intersection is empty).+--+-- > disjoint (fromList [2,4,6])   (fromList [1,3])     == True+-- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False+-- > disjoint (fromList [1,2])     (fromList [1,2,3,4]) == False+-- > disjoint (fromList [])        (fromList [])        == True+--+-- @+-- xs ``disjoint`` ys = null (xs ``intersection`` ys)+-- @+--+-- @since 0.5.11++disjoint :: Ord a => Set a -> Set a -> Bool+disjoint Tip _ = True+disjoint _ Tip = True+-- Avoid a split for the singleton case.+disjoint (Bin 1 x _ _) t = x `notMember` t+disjoint (Bin _ x l r) t+  -- Analogous implementation to `subsetOfX`+  = not found && disjoint l lt && disjoint r gt+  where+    (lt,found,gt) = splitMember x t++{--------------------------------------------------------------------+  Minimal, Maximal+--------------------------------------------------------------------}++-- Note [Inline lookupMin]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- The core of lookupMin is implemented as lookupMinSure, a recursive function+-- that does not involve Maybes. lookupMin wraps the result of lookupMinSure in+-- a Just. We inline lookupMin so that GHC optimizations can eliminate the Maybe+-- if it is matched on at the call site.++lookupMinSure :: a -> Set a -> a+lookupMinSure x Tip = x+lookupMinSure _ (Bin _ x l _) = lookupMinSure x l++-- | \(O(\log n)\). The minimal element of the set. Returns 'Nothing' if the set+-- is empty.+--+-- @since 0.5.9++lookupMin :: Set a -> Maybe a+lookupMin Tip = Nothing+lookupMin (Bin _ x l _) = Just $! lookupMinSure x l+{-# INLINE lookupMin #-} -- See Note [Inline lookupMin]++-- | \(O(\log n)\). The minimal element of the set. Calls 'error' if the set is+-- empty.+findMin :: Set a -> a+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "Set.findMin: empty set has no minimal element"++lookupMaxSure :: a -> Set a -> a+lookupMaxSure x Tip = x+lookupMaxSure _ (Bin _ x _ r) = lookupMaxSure x r++-- | \(O(\log n)\). The maximal element of the set. Returns 'Nothing' if the set+-- is empty.+--+-- @since 0.5.9++lookupMax :: Set a -> Maybe a+lookupMax Tip = Nothing+lookupMax (Bin _ x _ r) = Just $! lookupMaxSure x r+{-# INLINE lookupMax #-} -- See Note [Inline lookupMin]++-- | \(O(\log n)\). The maximal element of the set. Calls 'error' if the set is+-- empty.+findMax :: Set a -> a+findMax t+  | Just r <- lookupMax t = r+  | otherwise = error "Set.findMax: empty set has no maximal element"++-- | \(O(\log n)\). Delete the minimal element. Returns an empty set if the set is empty.+deleteMin :: Set a -> Set a+deleteMin (Bin _ _ Tip r) = r+deleteMin (Bin _ x l r)   = balanceR x (deleteMin l) r+deleteMin Tip             = Tip++-- | \(O(\log n)\). Delete the maximal element. Returns an empty set if the set is empty.+deleteMax :: Set a -> Set a+deleteMax (Bin _ _ l Tip) = l+deleteMax (Bin _ x l r)   = balanceL x l (deleteMax r)+deleteMax Tip             = Tip++{--------------------------------------------------------------------+  Union.+--------------------------------------------------------------------}+-- | The union of the sets in a Foldable structure : (@'unions' == 'foldl' 'union' 'empty'@).+unions :: (Foldable f, Ord a) => f (Set a) -> Set a+unions = Foldable.foldl' union empty+#if __GLASGOW_HASKELL__+{-# INLINABLE unions #-}+#endif++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). The union of two sets, preferring the first set when+-- equal elements are encountered.+union :: Ord a => Set a -> Set a -> Set a+union t1 Tip  = t1+union t1 (Bin 1 x _ _) = insertR x t1+union (Bin 1 x _ _) t2 = insert x t2+union Tip t2  = t2+union t1@(Bin _ x l1 r1) t2 = case splitS x t2 of+  (l2 :*: r2)+    | l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1 -> t1+    | otherwise -> link x l1l2 r1r2+    where !l1l2 = union l1 l2+          !r1r2 = union r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE union #-}+#endif++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). Difference of two sets.+--+-- Return elements of the first set not existing in the second set.+--+-- > difference (fromList [5, 3]) (fromList [5, 7]) == singleton 3+difference :: Ord a => Set a -> Set a -> Set a+difference Tip _   = Tip+difference t1 Tip  = t1+difference t1 (Bin _ x l2 r2) = case split x t1 of+   (l1, r1)+     | size l1l2 + size r1r2 == size t1 -> t1+     | otherwise -> merge l1l2 r1r2+     where !l1l2 = difference l1 l2+           !r1r2 = difference r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE difference #-}+#endif++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\). The intersection of two sets.+-- Elements of the result come from the first set, so for example+--+-- > import qualified Data.Set as S+-- > data AB = A | B deriving Show+-- > instance Ord AB where compare _ _ = EQ+-- > instance Eq AB where _ == _ = True+-- > main = print (S.singleton A `S.intersection` S.singleton B,+-- >               S.singleton B `S.intersection` S.singleton A)+--+-- prints @(fromList [A],fromList [B])@.+intersection :: Ord a => Set a -> Set a -> Set a+intersection Tip _ = Tip+intersection _ Tip = Tip+intersection t1@(Bin _ x l1 r1) t2+  | b = if l1l2 `ptrEq` l1 && r1r2 `ptrEq` r1+        then t1+        else link x l1l2 r1r2+  | otherwise = merge l1l2 r1r2+  where+    !(l2, b, r2) = splitMember x t2+    !l1l2 = intersection l1 l2+    !r1r2 = intersection r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE intersection #-}+#endif++-- | The intersection of a series of sets. Intersections are performed+-- left-to-right.+--+-- @since 0.8+intersections :: Ord a => NonEmpty (Set a) -> Set a+intersections (s0 :| ss)+  | null s0 = empty+  | otherwise = List.foldr go id ss s0+  where+    go s r acc+      | null acc' = empty+      | otherwise = r acc'+      where+        acc' = intersection acc s+{-# INLINABLE intersections #-}++-- | @Set@s form a 'Semigroup' under 'intersection'.+--+-- @since 0.8+newtype Intersection a = Intersection { getIntersection :: Set a }+    deriving (Show, Eq, Ord)++instance (Ord a) => Semigroup (Intersection a) where+    (Intersection a) <> (Intersection b) = Intersection $ intersection a b+    {-# INLINABLE (<>) #-}++    stimes = stimesIdempotent+    {-# INLINABLE stimes #-}++    sconcat =+#ifdef __GLASGOW_HASKELL__+      coerce intersections+#else+      Intersection . intersections . fmap getIntersection+#endif+    {-# INLINABLE sconcat #-}++{--------------------------------------------------------------------+  Symmetric difference+--------------------------------------------------------------------}++-- | \(O\bigl(m \log\bigl(\frac{n}{m}+1\bigr)\bigr), \; 0 < m \leq n\).+-- The symmetric difference of two sets.+--+-- The result contains elements that appear in exactly one of the two sets.+--+-- @+-- symmetricDifference (fromList [0,2,4,6]) (fromList [0,3,6,9]) == fromList [2,3,4,9]+-- @+--+-- @since 0.8+symmetricDifference :: Ord a => Set a -> Set a -> Set a+symmetricDifference Tip t2 = t2+symmetricDifference t1 Tip = t1+symmetricDifference (Bin _ x l1 r1) t2+  | found = merge l1l2 r1r2+  | otherwise = link x l1l2 r1r2+  where+    !(l2, found, r2) = splitMember x t2+    !l1l2 = symmetricDifference l1 l2+    !r1r2 = symmetricDifference r1 r2+#if __GLASGOW_HASKELL__+{-# INLINABLE symmetricDifference #-}+#endif++{--------------------------------------------------------------------+  Filter and partition+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all elements that satisfy the predicate.+filter :: (a -> Bool) -> Set a -> Set a+filter _ Tip = Tip+filter p t@(Bin _ x l r)+    | p x = if l `ptrEq` l' && r `ptrEq` r'+            then t+            else link x l' r'+    | otherwise = merge l' r'+    where+      !l' = filter p l+      !r' = filter p r++-- | \(O(n)\). Partition the set into two sets, one with all elements that satisfy+-- the predicate and one with all elements that don't satisfy the predicate.+-- See also 'split'.+partition :: (a -> Bool) -> Set a -> (Set a,Set a)+partition p0 t0 = toPair $ go p0 t0+  where+    go _ Tip = (Tip :*: Tip)+    go p t@(Bin _ x l r) = case (go p l, go p r) of+      ((l1 :*: l2), (r1 :*: r2))+        | p x       -> (if l1 `ptrEq` l && r1 `ptrEq` r+                        then t+                        else link x l1 r1) :*: merge l2 r2+        | otherwise -> merge l1 r1 :*:+                       (if l2 `ptrEq` l && r2 `ptrEq` r+                        then t+                        else link x l2 r2)++{----------------------------------------------------------------------+  Map+----------------------------------------------------------------------}++-- | \(O(n \log n)\).+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.+--+-- If `f` is monotonically non-decreasing, this function takes \(O(n)\) time.+--+-- It's worth noting that the size of the result may be smaller if,+-- for some @(x,y)@, @x \/= y && f x == f y@++map :: Ord b => (a->b) -> Set a -> Set b+map f t = finishB (foldl' (\b x -> insertB (f x) b) emptyB t)+#if __GLASGOW_HASKELL__+{-# INLINABLE map #-}+#endif++-- | \(O(n)\).+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapMonotonic f s == map f s+-- >     where ls = toList s+--+-- __Warning__: This function should be used only if @f@ is monotonically+-- strictly increasing. This precondition is not checked. Use 'map' if the+-- precondition may not hold.++mapMonotonic :: (a->b) -> Set a -> Set b+mapMonotonic _ Tip = Tip+mapMonotonic f (Bin sz x l r) = Bin sz (f x) (mapMonotonic f l) (mapMonotonic f r)++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator.+--+{-# DEPRECATED fold "Use Data.Set.foldr instead" #-}+fold :: (a -> b -> b) -> b -> Set a -> b+fold = foldr+{-# INLINE fold #-}++-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.+--+-- For example,+--+-- > toAscList set = foldr (:) [] set+foldr :: (a -> b -> b) -> b -> Set a -> b+foldr f z = go z+  where+    go z' Tip           = z'+    go z' (Bin _ x l r) = go (f x (go z' r)) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> Set a -> b+foldr' f z = go z+  where+    go !z' Tip           = z'+    go z' (Bin _ x l r) = go (f x $! go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the elements in the set using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.+--+-- For example,+--+-- > toDescList set = foldl (flip (:)) [] set+foldl :: (a -> b -> a) -> a -> Set b -> a+foldl f z = go z+  where+    go z' Tip           = z'+    go z' (Bin _ x l r) = go (f (go z' l) x) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> Set b -> a+foldl' f z = go z+  where+    go !z' Tip           = z'+    go z' (Bin _ x l r) =+      let !z'' = go z' l+      in go (f z'' x) r+{-# INLINE foldl' #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order.+-- Subject to list fusion.+elems :: Set a -> [a]+elems = toAscList++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++#ifdef __GLASGOW_HASKELL__+-- | @since 0.5.6.2+instance (Ord a) => GHCExts.IsList (Set a) where+  type Item (Set a) = a+  fromList = fromList+  toList   = toList+#endif++-- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion.+toList :: Set a -> [a]+toList = toAscList++-- | \(O(n)\). Convert the set to an ascending list of elements. Subject to list fusion.+toAscList :: Set a -> [a]+toAscList = foldr (:) []++-- | \(O(n)\). Convert the set to a descending list of elements. Subject to list+-- fusion.+toDescList :: Set a -> [a]+toDescList = foldl (flip (:)) []++-- List fusion for the list generating functions.+#if __GLASGOW_HASKELL__+-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.+-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.+foldrFB :: (a -> b -> b) -> b -> Set a -> b+foldrFB = foldr+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> b -> a) -> a -> Set b -> a+foldlFB = foldl+{-# INLINE[0] foldlFB #-}++-- Inline elems and toList, so that we need to fuse only toAscList.+{-# INLINE elems #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded to{Asc,Desc}List calls back to+-- to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were used in+-- a list fusion, otherwise it would go away in phase 1), and let compiler do+-- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it+-- before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "Set.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-}+{-# RULES "Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-}+{-# RULES "Set.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}+{-# RULES "Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}+#endif++-- | \(O(n \log n)\). Create a set from a list of elements.+--+-- If the elements are in non-decreasing order, this function takes \(O(n)\)+-- time.+fromList :: Ord a => [a] -> Set a+fromList xs = finishB (Foldable.foldl' (flip insertB) emptyB xs)+{-# INLINE fromList #-}  -- INLINE for fusion++{--------------------------------------------------------------------+  Building trees from ascending/descending lists can be done in linear time.++  Note that if [xs] is ascending that:+    fromAscList xs == fromList xs+--------------------------------------------------------------------}+-- | \(O(n)\). Build a set from an ascending list in linear time.+--+-- __Warning__: This function should be used only if the elements are in+-- non-decreasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+fromAscList :: Eq a => [a] -> Set a+fromAscList xs = ascLinkAll (Foldable.foldl' next Nada xs)+  where+    next stk !y = case stk of+      Push x l stk'+        | y == x -> Push y l stk'+        | Tip <- l -> ascLinkTop stk' 1 (singleton x) y+        | otherwise -> Push y Tip stk+      Nada -> Push y Tip stk+{-# INLINE fromAscList #-}  -- INLINE for fusion++-- | \(O(n)\). Build a set from a descending list in linear time.+--+-- __Warning__: This function should be used only if the elements are in+-- non-increasing order. This precondition is not checked. Use 'fromList' if the+-- precondition may not hold.+--+-- @since 0.5.8+fromDescList :: Eq a => [a] -> Set a+fromDescList xs = descLinkAll (Foldable.foldl' next Nada xs)+  where+    next stk !y = case stk of+      Push x r stk'+        | y == x -> Push y r stk'+        | Tip <- r -> descLinkTop y 1 (singleton x) stk'+        | otherwise -> Push y Tip stk+      Nada -> Push y Tip stk+{-# INLINE fromDescList #-}  -- INLINE for fusion++-- | \(O(n)\). Build a set from an ascending list of distinct elements in linear time.+--+-- __Warning__: This function should be used only if the elements are in+-- strictly increasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.++-- See Note [fromDistinctAscList implementation]+fromDistinctAscList :: [a] -> Set a+fromDistinctAscList xs = ascLinkAll (Foldable.foldl' next Nada xs)+  where+    next :: Stack a -> a -> Stack a+    next (Push x Tip stk) !y = ascLinkTop stk 1 (singleton x) y+    next stk !x = Push x Tip stk+{-# INLINE fromDistinctAscList #-}  -- INLINE for fusion++ascLinkTop :: Stack a -> Int -> Set a -> a -> Stack a+ascLinkTop (Push x l@(Bin lsz _ _ _) stk) !rsz r y+  | lsz == rsz = ascLinkTop stk sz (Bin sz x l r) y+  where+    sz = lsz + rsz + 1+ascLinkTop stk !_ r y = Push y r stk++ascLinkAll :: Stack a -> Set a+ascLinkAll stk = foldl'Stack (\r x l -> link x l r) Tip stk+{-# INLINABLE ascLinkAll #-}++-- | \(O(n)\). Build a set from a descending list of distinct elements in linear time.+--+-- __Warning__: This function should be used only if the elements are in+-- strictly decreasing order. This precondition is not checked. Use 'fromList'+-- if the precondition may not hold.+--+-- @since 0.5.8++-- See Note [fromDistinctAscList implementation]+fromDistinctDescList :: [a] -> Set a+fromDistinctDescList xs = descLinkAll (Foldable.foldl' next Nada xs)+  where+    next :: Stack a -> a -> Stack a+    next (Push y Tip stk) !x = descLinkTop x 1 (singleton y) stk+    next stk !y = Push y Tip stk+{-# INLINE fromDistinctDescList #-}  -- INLINE for fusion++descLinkTop :: a -> Int -> Set a -> Stack a -> Stack a+descLinkTop x !lsz l (Push y r@(Bin rsz _ _ _) stk)+  | lsz == rsz = descLinkTop x sz (Bin sz y l r) stk+  where+    sz = lsz + rsz + 1+descLinkTop y !_ r stk = Push y r stk++descLinkAll :: Stack a -> Set a+descLinkAll stk = foldl'Stack (\l x r -> link x l r) Tip stk+{-# INLINABLE descLinkAll #-}++data Stack a = Push !a !(Set a) !(Stack a) | Nada++foldl'Stack :: (b -> a -> Set a -> b) -> b -> Stack a -> b+foldl'Stack f = go+  where+    go !z Nada = z+    go z (Push x t stk) = go (f z x t) stk+{-# INLINE foldl'Stack #-}++{--------------------------------------------------------------------+  Iterator+--------------------------------------------------------------------}++-- Note [Iterator]+-- ~~~~~~~~~~~~~~~+-- Iteration, using a Stack as an iterator, is an efficient way to consume a Set+-- one element at a time. Alternately, this may be done by toAscList. toAscList+-- when consumed via List.foldr will rewrite to Set.foldr (thanks to rewrite+-- rules), which is quite efficient. However, sometimes that is not possible,+-- such as in the second arg of '==' or 'compare', where manifesting the list+-- cons cells is unavoidable and makes things slower.+--+-- Concretely, compare on Set Int using toAscList takes ~21% more time compared+-- to using Iterator, on GHC 9.6.3.+--+-- The heart of this implementation is the `iterDown` function. It walks down+-- the left spine of the tree, pushing the value and right child on the stack,+-- until a Tip is reached. The next value is now at the top of the stack. To get+-- to the value after that, `iterDown` is called again with the right child and+-- the remaining stack.++iterDown :: Set a -> Stack a -> Stack a+iterDown (Bin _ x l r) stk = iterDown l (Push x r stk)+iterDown Tip stk = stk++-- Create an iterator from a Set, starting at the smallest element.+iterator :: Set a -> Stack a+iterator s = iterDown s Nada++-- Get the next element and the remaining iterator.+iterNext :: Stack a -> Maybe (StrictPair a (Stack a))+iterNext (Push x r stk) = Just $! x :*: iterDown r stk+iterNext Nada = Nothing+{-# INLINE iterNext #-}++-- Whether there are no more elements in the iterator.+iterNull :: Stack a -> Bool+iterNull (Push _ _ _) = False+iterNull Nada = True++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}++instance Eq a => Eq (Set a) where+  s1 == s2 = liftEq (==) s1 s2+  {-# INLINABLE (==) #-}++-- | @since 0.5.9+instance Eq1 Set where+  liftEq eq s1 s2 = size s1 == size s2 && sameSizeLiftEq eq s1 s2+  {-# INLINE liftEq #-}++-- Assumes the sets are of equal size to skip the final check.+sameSizeLiftEq :: (a -> b -> Bool) -> Set a -> Set b -> Bool+sameSizeLiftEq eq s1 s2 =+  case runEqM (foldMap f s1) (iterator s2) of e :*: _ -> e+  where+    f x = EqM $ \it -> case iterNext it of+      Nothing -> False :*: it+      Just (y :*: it') -> eq x y :*: it'+{-# INLINE sameSizeLiftEq #-}++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord a => Ord (Set a) where+  compare s1 s2 = liftCmp compare s1 s2+  {-# INLINABLE compare #-}++-- | @since 0.5.9+instance Ord1 Set where+  liftCompare = liftCmp+  {-# INLINE liftCompare #-}++liftCmp :: (a -> b -> Ordering) -> Set a -> Set b -> Ordering+liftCmp cmp s1 s2 = case runOrdM (foldMap f s1) (iterator s2) of+  o :*: it -> o <> if iterNull it then EQ else LT+  where+    f x = OrdM $ \it -> case iterNext it of+      Nothing -> GT :*: it+      Just (y :*: it') -> cmp x y :*: it'+{-# INLINE liftCmp #-}++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance Show a => Show (Set a) where+  showsPrec p xs = showParen (p > 10) $+    showString "fromList " . shows (toList xs)++-- | @since 0.5.9+instance Show1 Set where+    liftShowsPrec sp sl d m =+        showsUnaryWith (liftShowsPrec sp sl) "fromList" d (toList m)++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance (Read a, Ord a) => Read (Set a) where+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault+#else+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("fromList",s) <- lex r+    (xs,t) <- reads s+    return (fromList xs,t)+#endif++{--------------------------------------------------------------------+  NFData+--------------------------------------------------------------------}++instance NFData a => NFData (Set a) where+    rnf Tip           = ()+    rnf (Bin _ y l r) = rnf y `seq` rnf l `seq` rnf r++-- | @since 0.8+instance NFData1 Set where+    liftRnf rnfx = go+      where+      go Tip           = ()+      go (Bin _ y l r) = rnfx y `seq` go l `seq` go r++{--------------------------------------------------------------------+  Split+--------------------------------------------------------------------}+-- | \(O(\log n)\). The expression (@'split' x set@) is a pair @(set1,set2)@+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@+-- comprises the elements of @set@ greater than @x@.+split :: Ord a => a -> Set a -> (Set a,Set a)+split x t = toPair $ splitS x t+{-# INLINABLE split #-}++splitS :: Ord a => a -> Set a -> StrictPair (Set a) (Set a)+splitS _ Tip = (Tip :*: Tip)+splitS x (Bin _ y l r)+      = case compare x y of+          LT -> let (lt :*: gt) = splitS x l in (lt :*: link y gt r)+          GT -> let (lt :*: gt) = splitS x r in (link y l lt :*: gt)+          EQ -> (l :*: r)+{-# INLINABLE splitS #-}++-- | \(O(\log n)\). Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Ord a => a -> Set a -> (Set a,Bool,Set a)+splitMember _ Tip = (Tip, False, Tip)+splitMember x (Bin _ y l r)+   = case compare x y of+       LT -> let (lt, found, gt) = splitMember x l+                 !gt' = link y gt r+             in (lt, found, gt')+       GT -> let (lt, found, gt) = splitMember x r+                 !lt' = link y l lt+             in (lt', found, gt)+       EQ -> (l, True, r)+#if __GLASGOW_HASKELL__+{-# INLINABLE splitMember #-}+#endif++{--------------------------------------------------------------------+  Indexing+--------------------------------------------------------------------}++-- | \(O(\log n)\). Return the /index/ of an element, which is its zero-based+-- index in the sorted sequence of elements. The index is a number from /0/ up+-- to, but not including, the 'size' of the set. Calls 'error' when the element+-- is not a 'member' of the set.+--+-- > findIndex 2 (fromList [5,3])    Error: element is not in the set+-- > findIndex 3 (fromList [5,3]) == 0+-- > findIndex 5 (fromList [5,3]) == 1+-- > findIndex 6 (fromList [5,3])    Error: element is not in the set+--+-- @since 0.5.4++-- See Note: Type of local 'go' function+findIndex :: Ord a => a -> Set a -> Int+findIndex = go 0+  where+    go :: Ord a => Int -> a -> Set a -> Int+    go !_ !_ Tip  = error "Set.findIndex: element is not in the set"+    go idx x (Bin _ kx l r) = case compare x kx of+      LT -> go idx x l+      GT -> go (idx + size l + 1) x r+      EQ -> idx + size l+#if __GLASGOW_HASKELL__+{-# INLINABLE findIndex #-}+#endif++-- | \(O(\log n)\). Look up the /index/ of an element, which is its zero-based index in+-- the sorted sequence of elements. The index is a number from /0/ up to, but not+-- including, the 'size' of the set.+--+-- > isJust   (lookupIndex 2 (fromList [5,3])) == False+-- > fromJust (lookupIndex 3 (fromList [5,3])) == 0+-- > fromJust (lookupIndex 5 (fromList [5,3])) == 1+-- > isJust   (lookupIndex 6 (fromList [5,3])) == False+--+-- @since 0.5.4++-- See Note: Type of local 'go' function+lookupIndex :: Ord a => a -> Set a -> Maybe Int+lookupIndex = go 0+  where+    go :: Ord a => Int -> a -> Set a -> Maybe Int+    go !_ !_ Tip  = Nothing+    go idx x (Bin _ kx l r) = case compare x kx of+      LT -> go idx x l+      GT -> go (idx + size l + 1) x r+      EQ -> Just $! idx + size l+#if __GLASGOW_HASKELL__+{-# INLINABLE lookupIndex #-}+#endif++-- | \(O(\log n)\). Retrieve an element by its /index/, i.e. by its zero-based+-- index in the sorted sequence of elements. If the /index/ is out of range (less+-- than zero, greater or equal to 'size' of the set), 'error' is called.+--+-- > elemAt 0 (fromList [5,3]) == 3+-- > elemAt 1 (fromList [5,3]) == 5+-- > elemAt 2 (fromList [5,3])    Error: index out of range+--+-- @since 0.5.4++elemAt :: Int -> Set a -> a+elemAt !_ Tip = error "Set.elemAt: index out of range"+elemAt i (Bin _ x l r)+  = case compare i sizeL of+      LT -> elemAt i l+      GT -> elemAt (i-sizeL-1) r+      EQ -> x+  where+    sizeL = size l++-- | \(O(\log n)\). Delete the element at /index/, i.e. by its zero-based index in+-- the sorted sequence of elements. If the /index/ is out of range (less than zero,+-- greater or equal to 'size' of the set), 'error' is called.+--+-- > deleteAt 0    (fromList [5,3]) == singleton 5+-- > deleteAt 1    (fromList [5,3]) == singleton 3+-- > deleteAt 2    (fromList [5,3])    Error: index out of range+-- > deleteAt (-1) (fromList [5,3])    Error: index out of range+--+-- @since 0.5.4++deleteAt :: Int -> Set a -> Set a+deleteAt !i t =+  case t of+    Tip -> error "Set.deleteAt: index out of range"+    Bin _ x l r -> case compare i sizeL of+      LT -> balanceR x (deleteAt i l) r+      GT -> balanceL x l (deleteAt (i-sizeL-1) r)+      EQ -> glue l r+      where+        sizeL = size l++-- | \(O(\log n)\). Take a given number of elements in order, beginning+-- with the smallest ones.+--+-- @+-- take n = 'fromDistinctAscList' . 'Prelude.take' n . 'toAscList'+-- @+--+-- @since 0.5.8+take :: Int -> Set a -> Set a+take i m | i >= size m = m+take i0 m0 = go i0 m0+  where+    go i !_ | i <= 0 = Tip+    go !_ Tip = Tip+    go i (Bin _ x l r) =+      case compare i sizeL of+        LT -> go i l+        GT -> link x l (go (i - sizeL - 1) r)+        EQ -> l+      where sizeL = size l++-- | \(O(\log n)\). Drop a given number of elements in order, beginning+-- with the smallest ones.+--+-- @+-- drop n = 'fromDistinctAscList' . 'Prelude.drop' n . 'toAscList'+-- @+--+-- @since 0.5.8+drop :: Int -> Set a -> Set a+drop i m | i >= size m = Tip+drop i0 m0 = go i0 m0+  where+    go i m | i <= 0 = m+    go !_ Tip = Tip+    go i (Bin _ x l r) =+      case compare i sizeL of+        LT -> link x (go i l) r+        GT -> go (i - sizeL - 1) r+        EQ -> insertMin x r+      where sizeL = size l++-- | \(O(\log n)\). Split a set at a particular index.+--+-- @+-- splitAt !n !xs = ('take' n xs, 'drop' n xs)+-- @+splitAt :: Int -> Set a -> (Set a, Set a)+splitAt i0 m0+  | i0 >= size m0 = (m0, Tip)+  | otherwise = toPair $ go i0 m0+  where+    go i m | i <= 0 = Tip :*: m+    go !_ Tip = Tip :*: Tip+    go i (Bin _ x l r)+      = case compare i sizeL of+          LT -> case go i l of+                  ll :*: lr -> ll :*: link x lr r+          GT -> case go (i - sizeL - 1) r of+                  rl :*: rr -> link x l rl :*: rr+          EQ -> l :*: insertMin x r+      where sizeL = size l++-- | \(O(\log n)\). Take while a predicate on the elements holds.+-- The user is responsible for ensuring that for all elements @j@ and @k@ in the set,+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'+-- takeWhileAntitone p = 'filter' p+-- @+--+-- @since 0.5.8++takeWhileAntitone :: (a -> Bool) -> Set a -> Set a+takeWhileAntitone _ Tip = Tip+takeWhileAntitone p (Bin _ x l r)+  | p x = link x l (takeWhileAntitone p r)+  | otherwise = takeWhileAntitone p l++-- | \(O(\log n)\). Drop while a predicate on the elements holds.+-- The user is responsible for ensuring that for all elements @j@ and @k@ in the set,+-- @j \< k ==\> p j \>= p k@. See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'+-- dropWhileAntitone p = 'filter' (not . p)+-- @+--+-- @since 0.5.8++dropWhileAntitone :: (a -> Bool) -> Set a -> Set a+dropWhileAntitone _ Tip = Tip+dropWhileAntitone p (Bin _ x l r)+  | p x = dropWhileAntitone p r+  | otherwise = link x (dropWhileAntitone p l) r++-- | \(O(\log n)\). Divide a set at the point where a predicate on the elements stops holding.+-- The user is responsible for ensuring that for all elements @j@ and @k@ in the set,+-- @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = partition p xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set+-- at some /unspecified/ point where the predicate switches from holding to not+-- holding (where the predicate is seen to hold before the first element and to fail+-- after the last element).+--+-- @since 0.5.8++spanAntitone :: (a -> Bool) -> Set a -> (Set a, Set a)+spanAntitone p0 m = toPair (go p0 m)+  where+    go _ Tip = Tip :*: Tip+    go p (Bin _ x l r)+      | p x = let u :*: v = go p r in link x l u :*: v+      | otherwise = let u :*: v = go p l in u :*: link x v r++{--------------------------------------------------------------------+  SetBuilder+--------------------------------------------------------------------}++-- Note [SetBuilder]+-- ~~~~~~~~~~~~~~~~~+-- SetBuilder serves as an accumulator for element-by-element construction of+-- a Set. It can be used in folds to construct sets. This plays nicely with list+-- fusion if the structure folded over is a list, as in fromList and friends.+--+-- As long as the elements are in non-decreasing order, insertB accumulates them+-- in a Stack, just as fromDistinctAscList does. On encountering an element out+-- of order, it builds a Set from the Stack and switches to using insert for all+-- future elements. This gives us construction in O(n) if the elements are+-- already sorted. If not, the worst case remains O(n log n).+--+-- More complicated implementations are possible, such as repeatedly+-- accumulating runs of increasing elements in Stacks (not just once) and+-- union-ing with an accumulated Set, but this makes the worst case somewhat+-- slower (~10%).++data SetBuilder a+  = BAsc !(Stack a)+  | BSet !(Set a)++-- Empty builder.+emptyB :: SetBuilder a+emptyB = BAsc Nada++-- Insert an element. Replaces the old element if an equal element already+-- exists.+insertB :: Ord a => a -> SetBuilder a -> SetBuilder a+insertB !y b = case b of+  BAsc stk -> case stk of+    Push x l stk' -> case compare y x of+      LT -> BSet (insert y (ascLinkAll stk))+      EQ -> BAsc (Push y l stk')+      GT -> case l of+        Tip -> BAsc (ascLinkTop stk' 1 (singleton x) y)+        Bin{} -> BAsc (Push y Tip stk)+    Nada -> BAsc (Push y Tip Nada)+  BSet m -> BSet (insert y m)+{-# INLINE insertB #-}++-- Finalize the builder into a Set.+finishB :: SetBuilder a -> Set a+finishB (BAsc stk) = ascLinkAll stk+finishB (BSet s) = s+{-# INLINABLE finishB #-}++{--------------------------------------------------------------------+  Utility functions that maintain the balance properties of the tree.+  All constructors assume that all values in [l] < [x] and all values+  in [r] > [x], and that [l] and [r] are valid trees.++  In order of sophistication:+    [Bin sz x l r]    The type constructor.+    [bin x l r]       Maintains the correct size, assumes that both [l]+                      and [r] are balanced with respect to each other.+    [balance x l r]   Restores the balance and size.+                      Assumes that the original tree was balanced and+                      that [l] or [r] has changed by at most one element.+    [link x l r]      Restores balance and size.++  Furthermore, we can construct a new tree from two trees. Both operations+  assume that all values in [l] < all values in [r] and that [l] and [r]+  are valid:+    [glue l r]        Glues [l] and [r] together. Assumes that [l] and+                      [r] are already balanced with respect to each other.+    [merge l r]       Merges two trees and restores balance.+--------------------------------------------------------------------}++{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}+link :: a -> Set a -> Set a -> Set a+link x Tip r  = insertMin x r+link x l Tip  = insertMax x l+link x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)+  | delta*sizeL < sizeR  = balanceL z (link x l lz) rz+  | delta*sizeR < sizeL  = balanceR y ly (link x ry r)+  | otherwise            = bin x l r+++-- insertMin and insertMax don't perform potentially expensive comparisons.+insertMax,insertMin :: a -> Set a -> Set a+insertMax x t+  = case t of+      Tip -> singleton x+      Bin _ y l r+          -> balanceR y l (insertMax x r)++insertMin x t+  = case t of+      Tip -> singleton x+      Bin _ y l r+          -> balanceL y (insertMin x l) r++{--------------------------------------------------------------------+  [merge l r]: merges two trees.+--------------------------------------------------------------------}+merge :: Set a -> Set a -> Set a+merge Tip r   = r+merge l Tip   = l+merge l@(Bin sizeL x lx rx) r@(Bin sizeR y ly ry)+  | delta*sizeL < sizeR = balanceL y (merge l ly) ry+  | delta*sizeR < sizeL = balanceR x lx (merge rx r)+  | otherwise           = glue l r++{--------------------------------------------------------------------+  [glue l r]: glues two trees together.+  Assumes that [l] and [r] are already balanced with respect to each other.+--------------------------------------------------------------------}+glue :: Set a -> Set a -> Set a+glue Tip r = r+glue l Tip = l+glue l@(Bin sl xl ll lr) r@(Bin sr xr rl rr)+  | sl > sr = let !(m :*: l') = maxViewSure xl ll lr in Bin (sl+sr) m l' r+  | otherwise = let !(m :*: r') = minViewSure xr rl rr in Bin (sl+sr) m l r'++-- | \(O(\log n)\). Delete and find the minimal element.+--+-- > deleteFindMin set = (findMin set, deleteMin set)++deleteFindMin :: Set a -> (a,Set a)+deleteFindMin t+  | Just r <- minView t = r+  | otherwise = (error "Set.deleteFindMin: can not return the minimal element of an empty set", Tip)++-- | \(O(\log n)\). Delete and find the maximal element.+--+-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: Set a -> (a,Set a)+deleteFindMax t+  | Just r <- maxView t = r+  | otherwise = (error "Set.deleteFindMax: can not return the maximal element of an empty set", Tip)++minViewSure :: a -> Set a -> Set a -> StrictPair a (Set a)+minViewSure = go+  where+    go x Tip r = x :*: r+    go x (Bin _ xl ll lr) r =+      case go xl ll lr of+        xm :*: l' -> xm :*: balanceR x l' r++-- | \(O(\log n)\). Retrieves the minimal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+minView :: Set a -> Maybe (a, Set a)+minView Tip = Nothing+minView (Bin _ x l r) = Just $! toPair $ minViewSure x l r++maxViewSure :: a -> Set a -> Set a -> StrictPair a (Set a)+maxViewSure = go+  where+    go x l Tip = x :*: l+    go x l (Bin _ xr rl rr) =+      case go xr rl rr of+        xm :*: r' -> xm :*: balanceL x l r'++-- | \(O(\log n)\). Retrieves the maximal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+maxView :: Set a -> Maybe (a, Set a)+maxView Tip = Nothing+maxView (Bin _ x l r) = Just $! toPair $ maxViewSure x l r++{--------------------------------------------------------------------+  [balance x l r] balances two trees with value x.+  The sizes of the trees should balance after decreasing the+  size of one of them. (a rotation).++  [delta] is the maximal relative difference between the sizes of+          two trees, it corresponds with the [w] in Adams' paper.+  [ratio] is the ratio between an outer and inner sibling of the+          heavier subtree in an unbalanced setting. It determines+          whether a double or single rotation should be performed+          to restore balance. It is corresponds with the inverse+          of $\alpha$ in Adam's article.++  Note that according to the Adam's paper:+  - [delta] should be larger than 4.646 with a [ratio] of 2.+  - [delta] should be larger than 3.745 with a [ratio] of 1.534.++  But the Adam's paper is erroneous:+  - it can be proved that for delta=2 and delta>=5 there does+    not exist any ratio that would work+  - delta=4.5 and ratio=2 does not work++  That leaves two reasonable variants, delta=3 and delta=4,+  both with ratio=2.++  - A lower [delta] leads to a more 'perfectly' balanced tree.+  - A higher [delta] performs less rebalancing.++  In the benchmarks, delta=3 is faster on insert operations,+  and delta=4 has slightly better deletes. As the insert speedup+  is larger, we currently use delta=3.++--------------------------------------------------------------------}+delta,ratio :: Int+delta = 3+ratio = 2++-- The balance function is equivalent to the following:+--+--   balance :: a -> Set a -> Set a -> Set a+--   balance x l r+--     | sizeL + sizeR <= 1   = Bin sizeX x l r+--     | sizeR > delta*sizeL  = rotateL x l r+--     | sizeL > delta*sizeR  = rotateR x l r+--     | otherwise            = Bin sizeX x l r+--     where+--       sizeL = size l+--       sizeR = size r+--       sizeX = sizeL + sizeR + 1+--+--   rotateL :: a -> Set a -> Set a -> Set a+--   rotateL x l r@(Bin _ _ ly ry) | size ly < ratio*size ry = singleL x l r+--                                 | otherwise               = doubleL x l r+--   rotateR :: a -> Set a -> Set a -> Set a+--   rotateR x l@(Bin _ _ ly ry) r | size ry < ratio*size ly = singleR x l r+--                                 | otherwise               = doubleR x l r+--+--   singleL, singleR :: a -> Set a -> Set a -> Set a+--   singleL x1 t1 (Bin _ x2 t2 t3)  = bin x2 (bin x1 t1 t2) t3+--   singleR x1 (Bin _ x2 t1 t2) t3  = bin x2 t1 (bin x1 t2 t3)+--+--   doubleL, doubleR :: a -> Set a -> Set a -> Set a+--   doubleL x1 t1 (Bin _ x2 (Bin _ x3 t2 t3) t4) = bin x3 (bin x1 t1 t2) (bin x2 t3 t4)+--   doubleR x1 (Bin _ x2 t1 (Bin _ x3 t2 t3)) t4 = bin x3 (bin x2 t1 t2) (bin x1 t3 t4)+--+-- It is only written in such a way that every node is pattern-matched only once.+--+-- Only balanceL and balanceR are needed at the moment, so balance is not here anymore.+-- In case it is needed, it can be found in Data.Map.++-- Functions balanceL and balanceR are specialised versions of balance.+-- balanceL only checks whether the left subtree is too big,+-- balanceR only checks whether the right subtree is too big.++-- Note [Inlining balance]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- Benchmarks show that we benefit from inlining balanceL and balanceR, but+-- we don't want to cause code bloat from inlining these large functions.+-- As a compromise, we inline only one case: that of two Bins already balanced+-- with respect to each other.+--+-- This is the most common case for typical scenarios. For instance, for n+-- inserts there may be O(n log n) calls to balanceL/balanceR but at most O(n)+-- of them actually require rebalancing. So, inlining this common case provides+-- most of the potential benefits of inlining the full function.++-- balanceL is called when left subtree might have been inserted to or when+-- right subtree might have been deleted from.+balanceL :: a -> Set a -> Set a -> Set a+balanceL x l r = case (l, r) of+  (Bin ls _ _ _, Bin rs _ _ _)+    | ls <= delta*rs -> Bin (1+ls+rs) x l r+  _ -> balanceL_ x l r+{-# INLINE balanceL #-} -- See Note [Inlining balance]++balanceL_ :: a -> Set a -> Set a -> Set a+balanceL_ x l r = case r of+  Tip -> case l of+           Tip -> Bin 1 x Tip Tip+           (Bin _ _ Tip Tip) -> Bin 2 x l Tip+           (Bin _ lx Tip (Bin _ lrx _ _)) -> Bin 3 lrx (Bin 1 lx Tip Tip) (Bin 1 x Tip Tip)+           (Bin _ lx ll@(Bin _ _ _ _) Tip) -> Bin 3 lx ll (Bin 1 x Tip Tip)+           (Bin ls lx ll@(Bin lls _ _ _) lr@(Bin lrs lrx lrl lrr))+             | lrs < ratio*lls -> Bin (1+ls) lx ll (Bin (1+lrs) x lr Tip)+             | otherwise -> Bin (1+ls) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+size lrr) x lrr Tip)++  (Bin rs _ _ _) -> case l of+           Tip -> Bin (1+rs) x Tip r++           (Bin ls lx ll lr) -> case (ll, lr) of+                   (Bin lls _ _ _, Bin lrs lrx lrl lrr)+                     | lrs < ratio*lls -> Bin (1+ls+rs) lx ll (Bin (1+rs+lrs) x lr r)+                     | otherwise -> Bin (1+ls+rs) lrx (Bin (1+lls+size lrl) lx ll lrl) (Bin (1+rs+size lrr) x lrr r)+                   (_, _) -> error "Failure in Data.Set.balanceL_"+{-# NOINLINE balanceL_ #-}++-- balanceR is called when right subtree might have been inserted to or when+-- left subtree might have been deleted from.+balanceR :: a -> Set a -> Set a -> Set a+balanceR x l r = case (l, r) of+  (Bin ls _ _ _, Bin rs _ _ _)+    | rs <= delta*ls -> Bin (1+ls+rs) x l r+  _ -> balanceR_ x l r+{-# INLINE balanceR #-} -- See Note [Inlining balance]++balanceR_ :: a -> Set a -> Set a -> Set a+balanceR_ x l r = case l of+  Tip -> case r of+           Tip -> Bin 1 x Tip Tip+           (Bin _ _ Tip Tip) -> Bin 2 x Tip r+           (Bin _ rx Tip rr@(Bin _ _ _ _)) -> Bin 3 rx (Bin 1 x Tip Tip) rr+           (Bin _ rx (Bin _ rlx _ _) Tip) -> Bin 3 rlx (Bin 1 x Tip Tip) (Bin 1 rx Tip Tip)+           (Bin rs rx rl@(Bin rls rlx rll rlr) rr@(Bin rrs _ _ _))+             | rls < ratio*rrs -> Bin (1+rs) rx (Bin (1+rls) x Tip rl) rr+             | otherwise -> Bin (1+rs) rlx (Bin (1+size rll) x Tip rll) (Bin (1+rrs+size rlr) rx rlr rr)++  (Bin ls _ _ _) -> case r of+           Tip -> Bin (1+ls) x l Tip++           (Bin rs rx rl rr) -> case (rl, rr) of+                   (Bin rls rlx rll rlr, Bin rrs _ _ _)+                     | rls < ratio*rrs -> Bin (1+ls+rs) rx (Bin (1+ls+rls) x l rl) rr+                     | otherwise -> Bin (1+ls+rs) rlx (Bin (1+ls+size rll) x l rll) (Bin (1+rrs+size rlr) rx rlr rr)+                   (_, _) -> error "Failure in Data.Set.balanceR_"+{-# NOINLINE balanceR_ #-}++{--------------------------------------------------------------------+  The bin constructor maintains the size of the tree+--------------------------------------------------------------------}+bin :: a -> Set a -> Set a -> Set a+bin x l r+  = Bin (size l + size r + 1) x l r+{-# INLINE bin #-}+++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | \(O(1)\).  Decompose a set into pieces based on the structure of the underlying+-- tree.  This function is useful for consuming a set in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the pieces+-- returned will be in ascending order (all elements in the first subset less than all+-- elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList [1..6]) ==+-- >   [fromList [1,2,3],fromList [4],fromList [5,6]]+--+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than three subsets,+--  but you should not depend on this behaviour because it can change in the+--  future without notice.+--+-- @since 0.5.4+splitRoot :: Set a -> [Set a]+splitRoot orig =+  case orig of+    Tip           -> []+    Bin _ v l r -> [l, singleton v, r]+{-# INLINE splitRoot #-}+++-- | \(O(2^n \log n)\). Calculate the power set of a set: the set of all its subsets.+--+-- @+-- t ``member`` powerSet s == t ``isSubsetOf`` s+-- @+--+-- Example:+--+-- @+-- powerSet (fromList [1,2,3]) =+--   fromList $ map fromList [[],[1],[1,2],[1,2,3],[1,3],[2],[2,3],[3]]+-- @+--+-- @since 0.5.11++-- Proof of complexity: step executes n times. At the ith step,+-- "insertMin x `mapMonotonic` pxs" takes O(2^i log i) time since pxs has size+-- 2^i - 1 and we insertMin into its elements which are sets of size <= i.+-- "insertMin (singleton x)" and "`glue` pxs" are cheaper operations that both+-- take O(i) time. Over n steps, we have a total cost of+--+--   O(\sum_{i=1}^{n-1} 2^i log i)+-- = O(log n * \sum_{i=1}^{n-1} 2^i)+-- = O(2^n log n)++powerSet :: Set a -> Set (Set a)+powerSet xs0 = insertMin empty (foldr' step Tip xs0) where+  step x pxs = insertMin (singleton x) (insertMin x `mapMonotonic` pxs) `glue` pxs++-- | \(O(nm)\). Calculate the Cartesian product of two sets.+--+-- @+-- cartesianProduct xs ys = fromList $ liftA2 (,) (toList xs) (toList ys)+-- @+--+-- Example:+--+-- @+-- cartesianProduct (fromList [1,2]) (fromList [\'a\',\'b\']) =+--   fromList [(1,\'a\'), (1,\'b\'), (2,\'a\'), (2,\'b\')]+-- @+--+-- @since 0.5.11+cartesianProduct :: Set a -> Set b -> Set (a, b)+-- The obvious big-O optimal (O(nm)) implementation would be+--+--   cartesianProduct _as Tip = Tip+--   cartesianProduct as bs = fromDistinctAscList+--     [(a,b) | a <- toList as, b <- toList bs]+--+-- Unfortunately, this is much slower in practice, at least when the sets are+-- constructed from ascending lists. I tried doing the same thing using a+-- known-length (perfect balancing) variant of fromDistinctAscList, but it+-- still didn't come close to the performance of the implementation we use in my+-- very informal tests.+--+-- The implementation we use (slightly modified from one that Edward Kmett+-- hacked together) is also optimal but performs better in practice. We map+-- each element a in as to a set made up of (a,b) for every element b in bs,+-- taking O(nm) overall. Then we merge these sets up the tree of as, which takes+-- O(n log m). A brief sketch of proof for the latter:+--+-- Consider all nodes in the tree at the same distance from the root to be at+-- the same "level". The nodes farthest from the root are at level 0, with+-- levels increasing by 1 towards the root. Being a balanced tree, there are+-- O(n/2^i) nodes at level i. At every node at level i, we merge the merged left+-- set, current set, and merged right set into a set of size O(2^i*m) in+-- O(log (2^i*m)) = O(i + log m) time. Over all levels, we do a total work of+--+--   O(\sum_{i=0}^{root_level} n * (i + log m) / 2^i)+-- = O(  \sum_{i=0}^{root_level} n * i / 2^i+--     + \sum_{i=0}^{root_level} n * log m / 2^i)+-- = O(  n * \sum_{i=0}^{root_level} i/2^i+--     + n * log m * \sum_{i=0}^{root_level} 1/2^i)+-- = O(  n * \sum_{i=0}^{inf} i/2^i+--     + n * log m * \sum_{i=0}^{inf} 1/2^i)+--+-- The sum terms converge, and we get O(n log m).++-- When the second argument has at most one element, we can be a little+-- clever.+cartesianProduct !_as Tip = Tip+cartesianProduct as (Bin 1 b _ _) = mapMonotonic (flip (,) b) as+cartesianProduct as bs =+  getMergeSet $ foldMap (\a -> MergeSet $ mapMonotonic ((,) a) bs) as++-- A version of Set with peculiar Semigroup and Monoid instances.+-- The result of xs <> ys will only be a valid set if the greatest+-- element of xs is strictly less than the least element of ys.+-- This is used to define cartesianProduct.+newtype MergeSet a = MergeSet { getMergeSet :: Set a }++instance Semigroup (MergeSet a) where+  MergeSet xs <> MergeSet ys = MergeSet (merge xs ys)++instance Monoid (MergeSet a) where+  mempty = MergeSet empty++  mappend = (<>)++-- | \(O(n+m)\). Calculate the disjoint union of two sets.+--+-- @ disjointUnion xs ys = map Left xs ``union`` map Right ys @+--+-- Example:+--+-- @+-- disjointUnion (fromList [1,2]) (fromList ["hi", "bye"]) =+--   fromList [Left 1, Left 2, Right "hi", Right "bye"]+-- @+--+-- @since 0.5.11+disjointUnion :: Set a -> Set b -> Set (Either a b)+disjointUnion as bs = merge (mapMonotonic Left as) (mapMonotonic Right bs)++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | \(O(n \log n)\). Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => Set a -> String+showTree s+  = showTreeWith True False s+++{- | \(O(n \log n)\). The expression (@showTreeWith hang wide map@) shows+ the tree that implements the set. If @hang@ is+ @True@, a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.++> Set> putStrLn $ showTreeWith True False $ fromDistinctAscList [1..5]+> 4+> +--2+> |  +--1+> |  +--3+> +--5+>+> Set> putStrLn $ showTreeWith True True $ fromDistinctAscList [1..5]+> 4+> |+> +--2+> |  |+> |  +--1+> |  |+> |  +--3+> |+> +--5+>+> Set> putStrLn $ showTreeWith False True $ fromDistinctAscList [1..5]+> +--5+> |+> 4+> |+> |  +--3+> |  |+> +--2+>    |+>    +--1++-}+showTreeWith :: Show a => Bool -> Bool -> Set a -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> Set a -> ShowS+showsTree wide lbars rbars t+  = case t of+      Tip -> showsBars lbars . showString "|\n"+      Bin _ x Tip Tip+          -> showsBars lbars . shows x . showString "\n"+      Bin _ x l r+          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . shows x . showString "\n" .+             showWide wide lbars .+             showsTree wide (withEmpty lbars) (withBar lbars) l++showsTreeHang :: Show a => Bool -> [String] -> Set a -> ShowS+showsTreeHang wide bars t+  = case t of+      Tip -> showsBars bars . showString "|\n"+      Bin _ x Tip Tip+          -> showsBars bars . shows x . showString "\n"+      Bin _ x l r+          -> showsBars bars . shows x . showString "\n" .+             showWide wide bars .+             showsTreeHang wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang wide (withEmpty bars) r++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _ : tl -> showString (concat (reverse tl)) . showString node++node :: String+node           = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars++{--------------------------------------------------------------------+  Assertions+--------------------------------------------------------------------}+-- | \(O(n)\). Test if the internal set structure is valid.+valid :: Ord a => Set a -> Bool+valid t+  = balanced t && ordered t && validsize t++ordered :: Ord a => Set a -> Bool+ordered t+  = bounded (const True) (const True) t+  where+    bounded lo hi t'+      = case t' of+          Tip         -> True+          Bin _ x l r -> (lo x) && (hi x) && bounded lo (<x) l && bounded (>x) hi r++balanced :: Set a -> Bool+balanced t+  = case t of+      Tip         -> True+      Bin _ _ l r -> (size l + size r <= 1 || (size l <= delta*size r && size r <= delta*size l)) &&+                     balanced l && balanced r++validsize :: Set a -> Bool+validsize t+  = (realsize t == Just (size t))+  where+    realsize t'+      = case t' of+          Tip          -> Just 0+          Bin sz _ l r -> case (realsize l,realsize r) of+                            (Just n,Just m)  | n+m+1 == sz  -> Just sz+                            _                -> Nothing++--------------------------------------------------------------------++-- Note [fromDistinctAscList implementation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- fromDistinctAscList is implemented by building up perfectly balanced trees+-- while we consume elements from the list one by one. A stack of+-- (root, perfectly balanced left branch) pairs is maintained, in increasing+-- order of size from top to bottom. The stack reflects the binary+-- representation of the total number of elements in it, with every level having+-- a power of 2 number of elements.+--+-- When we get an element from the list, we check the (root, left branch) at the+-- top of the stack.+-- If the tree there is not empty, we push the element with an empty left child+-- on the stack.+-- If the tree is empty, the root is packed into a singleton tree to act as a+-- right branch for trees higher up the stack. It is linked with left branches+-- in the stack, but only when they have equal size. This preserves the+-- perfectly balanced property. When there is a size mismatch, the tree is+-- too small to link. It is pushed on the stack as a left branch with the new+-- element as root, awaiting a right branch which will make it large enough to+-- be linked further.+--+-- When we are out of elements, we link the (root, left branch)s in the stack+-- top to bottom to get the final tree.+--+-- How long does this take? We do O(1) work per element excluding the links.+-- Over n elements, we build trees with at most n nodes total, and each link is+-- done in O(1) using `Bin`. The final linking of the stack is done in O(log n)+-- using `link` (proof below). The total time is thus O(n).+--+-- Additionally, the implemention is written using foldl' over the input list,+-- which makes it participate as a good consumer in list fusion.+--+-- fromDistinctDescList is implemented similarly, adapted for left and right+-- sides being swapped.+--+-- ~~~+--+-- A `link` operation links trees L and R with a root in+-- O(|log(size(L)) - log(size(R))|). Let's say there are m (root, tree) in the+-- stack, the size of the ith tree being 2^{k_i} - 1. We also know that+-- k_i > k_j for i > j, and n = \sum_{i=1}^m 2^{k_i}. With this information, we+-- can calculate the total time to link everything on the stack:+--+--   O(\sum_{i=2}^m |log(2^{k_i} - 1) - log(\sum_{j=1}^{i-1} 2^{k_j})|)+-- = O(\sum_{i=2}^m log(2^{k_i} - 1) - log(\sum_{j=1}^{i-1} 2^{k_j}))+-- = O(\sum_{i=2}^m log(2^{k_i} - 1) - log(2^{k_{i-1}}))+-- = O(\sum_{i=2}^m k_i - k_{i-1})+-- = O(k_m - k_1)+-- = O(log n)
+ src/Data/Tree.hs view
@@ -0,0 +1,886 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE Trustworthy #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Tree+-- Copyright   :  (c) The University of Glasgow 2002+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = Multi-way Trees and Forests+--+-- The @'Tree' a@ type represents a lazy, possibly infinite, multi-way tree+-- (also known as a /rose tree/).+--+-- The @'Forest' a@ type represents a forest of @'Tree' a@s.+--+-----------------------------------------------------------------------------++module Data.Tree(++    -- * Trees and Forests+      Tree(..)+    , Forest+    , PostOrder(..)++    -- * Construction+    , unfoldTree+    , unfoldForest+    , unfoldTreeM+    , unfoldForestM+    , unfoldTreeM_BF+    , unfoldForestM_BF++    -- * Elimination+    , foldTree+    , flatten+    , levels+    , leaves+    , edges+    , pathsToRoot+    , pathsFromRoot++    -- * Ascii Drawings+    , drawTree+    , drawForest++    ) where++import Utils.Containers.Internal.Prelude as Prelude+import Prelude ()+import Data.Bits ((.&.))+import Data.Foldable (toList)+import qualified Data.Foldable as Foldable+import Data.List.NonEmpty (NonEmpty(..))+import Data.Traversable (foldMapDefault)+import Control.Monad (liftM)+import Control.Monad.Fix (MonadFix (..), fix)+import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList,+            ViewL(..), ViewR(..), viewl, viewr)+import Control.DeepSeq (NFData(rnf),NFData1(liftRnf))++#ifdef __GLASGOW_HASKELL__+import Data.Data (Data)+import GHC.Generics (Generic, Generic1)+import qualified GHC.Exts+import Language.Haskell.TH.Syntax (Lift)+-- See Note [ Template Haskell Dependencies ]+import Language.Haskell.TH ()+#endif++import Control.Monad.Zip (MonadZip (..))++#ifdef __GLASGOW_HASKELL__+import Data.Coerce (coerce)+#endif+import Data.Functor.Classes++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup (..))+#endif++#if MIN_VERSION_base(4,18,0)+import qualified Data.Foldable1 as Foldable1+#endif++-- | Non-empty, possibly infinite, multi-way trees; also known as /rose trees/.+data Tree a = Node {+        rootLabel :: a,         -- ^ label value+        subForest :: [Tree a]   -- ^ zero or more child trees+    }+#ifdef __GLASGOW_HASKELL__+  deriving ( Eq+           , Ord -- ^ @since 0.6.5+           , Read+           , Show+           , Data+           , Generic  -- ^ @since 0.5.8+           , Generic1 -- ^ @since 0.5.8+           , Lift -- ^ @since 0.6.6+           )+#else+  deriving (Eq, Ord, Read, Show)+#endif++-- | This type synonym exists primarily for historical+-- reasons.+type Forest a = [Tree a]++-- | @since 0.5.9+instance Eq1 Tree where+  liftEq eq = leq+    where+      leq (Node a fr) (Node a' fr') = eq a a' && liftEq leq fr fr'++-- | @since 0.5.9+instance Ord1 Tree where+  liftCompare cmp = lcomp+    where+      lcomp (Node a fr) (Node a' fr') = cmp a a' <> liftCompare lcomp fr fr'++-- | @since 0.5.9+instance Show1 Tree where+  liftShowsPrec shw shwl p (Node a fr) = showParen (p > 10) $+        showString "Node {rootLabel = " . shw 0 a . showString ", " .+          showString "subForest = " . liftShowList shw shwl fr .+          showString "}"++-- | @since 0.5.9+instance Read1 Tree where+  liftReadsPrec rd rdl p = readParen (p > 10) $+    \s -> do+      ("Node", s1) <- lex s+      ("{", s2) <- lex s1+      ("rootLabel", s3) <- lex s2+      ("=", s4) <- lex s3+      (a, s5) <- rd 0 s4+      (",", s6) <- lex s5+      ("subForest", s7) <- lex s6+      ("=", s8) <- lex s7+      (fr, s9) <- liftReadList rd rdl s8+      ("}", s10) <- lex s9+      pure (Node a fr, s10)++instance Functor Tree where+    fmap = fmapTree+    x <$ Node _ ts = Node x (map (x <$) ts)++fmapTree :: (a -> b) -> Tree a -> Tree b+fmapTree f (Node x ts) = Node (f x) (map (fmapTree f) ts)++#ifdef __GLASGOW_HASKELL__+{-# NOINLINE [1] fmapTree #-}+{-# RULES+"fmapTree/coerce" fmapTree coerce = coerce+ #-}+#endif++instance Applicative Tree where+    pure x = Node x []+    Node f tfs <*> tx@(Node x txs) =+        Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs)+    liftA2 f (Node x txs) ty@(Node y tys) =+        Node (f x y) (map (f x <$>) tys ++ map (\tx -> liftA2 f tx ty) txs)+    Node x txs <* ty@(Node _ tys) =+        Node x (map (x <$) tys ++ map (<* ty) txs)+    Node _ txs *> ty@(Node y tys) =+        Node y (tys ++ map (*> ty) txs)++instance Monad Tree where+    Node x ts >>= f = case f x of+        Node x' ts' -> Node x' (ts' ++ map (>>= f) ts)++-- | @since 0.5.11+instance MonadFix Tree where+  mfix = mfixTree++mfixTree :: (a -> Tree a) -> Tree a+mfixTree f+  | Node a children <- fix (f . rootLabel)+  = Node a (zipWith (\i _ -> mfixTree ((!! i) . subForest . f))+                    [0..] children)++-- | Traverses in pre-order.+instance Traversable Tree where+  traverse f = go+    where go (Node x ts) = liftA2 Node (f x) (traverse go ts)+  {-# INLINE traverse #-}++-- | Folds in pre-order.++-- See Note [Implemented Foldable Tree functions]+instance Foldable Tree where+    fold = foldMap id+    {-# INLINABLE fold #-}++    foldMap = foldMapDefault+    {-# INLINE foldMap #-}++    foldr f z = \t -> go t z  -- Use a lambda to allow inlining with two arguments+      where+        go (Node x ts) = f x . foldr (\t k -> go t . k) id ts+        -- This is equivalent to the following simpler definition, but has been found to optimize+        -- better in benchmarks:+        -- go (Node x ts) z' = f x (foldr go z' ts)+    {-# INLINE foldr #-}++    foldl' f = go+      where go !z (Node x ts) = foldl' go (f z x) ts+    {-# INLINE foldl' #-}++    foldr1 = foldrMap1 id++    foldl1 = foldlMap1 id++    null _ = False+    {-# INLINE null #-}++    elem = any . (==)+    {-# INLINABLE elem #-}++    maximum = foldlMap1' id max+    {-# INLINABLE maximum #-}++    minimum = foldlMap1' id min+    {-# INLINABLE minimum #-}++    sum = foldlMap1' id (+)+    {-# INLINABLE sum #-}++    product = foldlMap1' id (*)+    {-# INLINABLE product #-}++#if MIN_VERSION_base(4,18,0)+-- | Folds in pre-order.+--+-- @since 0.6.7++-- See Note [Implemented Foldable1 Tree functions]+instance Foldable1.Foldable1 Tree where+  foldMap1 f = go+    where+      -- We'd like to write+      --+      -- go (Node x (t : ts)) = f x <> Foldable1.foldMap1 go (t :| ts)+      --+      -- but foldMap1 for NonEmpty isn't very good, so we don't. See+      -- https://github.com/haskell/containers/pull/921#issuecomment-1410398618+      go (Node x []) = f x+      go (Node x (t : ts)) =+        f x <> Foldable1.foldrMap1 go (\t' z -> go t' <> z) (t :| ts)+  {-# INLINE foldMap1 #-}++  foldMap1' f = foldlMap1' f (\z x -> z <> f x)+  {-# INLINE foldMap1' #-}++  toNonEmpty (Node x ts) = x :| concatMap toList ts++  maximum = Foldable.maximum+  {-# INLINABLE maximum #-}++  minimum = Foldable.minimum+  {-# INLINABLE minimum #-}++  foldrMap1 = foldrMap1++  foldlMap1' = foldlMap1'++  foldlMap1 = foldlMap1+#endif++foldrMap1 :: (a -> b) -> (a -> b -> b) -> Tree a -> b+foldrMap1 f g = go+  where+    go (Node x [])     = f x+    go (Node x (t:ts)) = g x (foldrMap1NE go (\t' z -> foldr g z t') t ts)+{-# INLINE foldrMap1 #-}++-- This is foldrMap1 for Data.List.NonEmpty, but is not available before+-- base 4.18.+foldrMap1NE :: (a -> b) -> (a -> b -> b) -> a -> [a] -> b+foldrMap1NE f g = go+  where+    go x []      = f x+    go x (x':xs) = g x (go x' xs)+{-# INLINE foldrMap1NE #-}++foldlMap1' :: (a -> b) -> (b -> a -> b) -> Tree a -> b+foldlMap1' f g =  -- Use a lambda to allow inlining with two arguments+  \(Node x ts) -> foldl' (foldl' g) (f x) ts+{-# INLINE foldlMap1' #-}++foldlMap1 :: (a -> b) -> (b -> a -> b) -> Tree a -> b+foldlMap1 f g =  -- Use a lambda to allow inlining with two arguments+  \(Node x ts) -> foldl (foldl g) (f x) ts+{-# INLINE foldlMap1 #-}++instance NFData a => NFData (Tree a) where+    rnf (Node x ts) = rnf x `seq` rnf ts++-- | @since 0.8+instance NFData1 Tree where+    liftRnf rnfx = go+      where+      go (Node x ts) = rnfx x `seq` liftRnf go ts++-- | @since 0.5.10.1+instance MonadZip Tree where+  mzipWith f (Node a as) (Node b bs)+    = Node (f a b) (mzipWith (mzipWith f) as bs)++  munzip (Node (a, b) ts) = (Node a as, Node b bs)+    where (as, bs) = munzip (map munzip ts)++-- | 2-dimensional ASCII drawing of a tree.+--+-- ==== __Examples__+--+-- > putStr $ drawTree $ fmap show (Node 1 [Node 2 [], Node 3 []])+--+-- @+-- 1+-- |+-- +- 2+-- |+-- `- 3+-- @+--+drawTree :: Tree String -> String+drawTree  = unlines . draw++-- | 2-dimensional ASCII drawing of a forest.+--+-- ==== __Examples__+--+-- > putStr $ drawForest $ map (fmap show) [(Node 1 [Node 2 [], Node 3 []]), (Node 10 [Node 20 []])]+--+-- @+-- 1+-- |+-- +- 2+-- |+-- `- 3+--+-- 10+-- |+-- `- 20+-- @+--+drawForest :: [Tree String] -> String+drawForest  = unlines . map drawTree++draw :: Tree String -> [String]+draw (Node x ts0) = lines x ++ drawSubTrees ts0+  where+    drawSubTrees [] = []+    drawSubTrees [t] =+        "|" : shift "`- " "   " (draw t)+    drawSubTrees (t:ts) =+        "|" : shift "+- " "|  " (draw t) ++ drawSubTrees ts++    shift first other = zipWith (++) (first : repeat other)++-- | Returns the elements of a tree in pre-order.+--+-- @flatten == Data.Foldable.'toList'@+--+-- @+--+--   a+--  / \\    => [a,b,c]+-- b   c+-- @+--+-- ==== __Examples__+--+-- > flatten (Node 1 [Node 2 [], Node 3 []]) == [1,2,3]+flatten :: Tree a -> [a]+flatten = toList++-- | Returns the list of nodes at each level of the tree.+--+-- @+--+--   a+--  / \\    => [[a], [b,c]]+-- b   c+-- @+--+-- ==== __Examples__+--+-- > levels (Node 1 [Node 2 [], Node 3 []]) == [[1],[2,3]]+--+levels :: Tree a -> [[a]]+levels t =+    map (map rootLabel) $+        takeWhile (not . null) $+        iterate (concatMap subForest) [t]++-- | Fold a tree into a "summary" value.+--+-- For each node in the tree, apply @f@ to the @rootLabel@ and the result+-- of applying @f@ to each @subForest@.+--+-- This is also known as the catamorphism on trees.+--+-- ==== __Examples__+--+-- Sum the values in a tree:+--+-- > foldTree (\x xs -> sum (x:xs)) (Node 1 [Node 2 [], Node 3 []]) == 6+--+-- Find the maximum value in the tree:+--+-- > foldTree (\x xs -> maximum (x:xs)) (Node 1 [Node 2 [], Node 3 []]) == 3+--+-- Count the number of leaves in the tree:+--+-- > foldTree (\_ xs -> if null xs then 1 else sum xs) (Node 1 [Node 2 [], Node 3 []]) == 2+--+-- Find depth of the tree; i.e. the number of branches from the root of the tree to the furthest leaf:+--+-- > foldTree (\_ xs -> if null xs then 0 else 1 + maximum xs) (Node 1 [Node 2 [], Node 3 []]) == 1+--+-- You can even implement traverse using foldTree:+--+-- > traverse' f = foldTree (\x xs -> liftA2 Node (f x) (sequenceA xs))+--+--+-- @since 0.5.8+foldTree :: (a -> [b] -> b) -> Tree a -> b+foldTree f = go where+    go (Node x ts) = f x (map go ts)++-- | Build a (possibly infinite) tree from a seed value.+--+-- @unfoldTree f b@ constructs a tree by starting with the tree+-- @Node { rootLabel=b, subForest=[] }@ and repeatedly applying @f@ to each+-- 'rootLabel' value in the tree's leaves to generate its 'subForest'.+--+-- For a monadic version, see 'unfoldTreeM' (depth-first) and+-- 'unfoldTreeM_BF' (breadth-first).+--+-- ==== __Examples__+--+-- Construct the tree of @Integer@s where each node has two children:+-- @left = 2*x@ and @right = 2*x + 1@, where @x@ is the 'rootLabel' of the node.+-- Stop when the values exceed 7.+--+-- > let buildNode x = if 2*x + 1 > 7 then (x, []) else (x, [2*x, 2*x+1])+-- > putStr $ drawTree $ fmap show $ unfoldTree buildNode 1+--+-- @+--+-- 1+-- |+-- +- 2+-- |  |+-- |  +- 4+-- |  |+-- |  `- 5+-- |+-- `- 3+--    |+--    +- 6+--    |+--    `- 7+-- @+--+unfoldTree :: (b -> (a, [b])) -> b -> Tree a+unfoldTree f b = let (a, bs) = f b in Node a (unfoldForest f bs)++-- | Build a (possibly infinite) forest from a list of seed values.+--+-- @unfoldForest f seeds@ invokes 'unfoldTree' on each seed value.+--+-- For a monadic version, see 'unfoldForestM' (depth-first) and+-- 'unfoldForestM_BF' (breadth-first).+--+unfoldForest :: (b -> (a, [b])) -> [b] -> [Tree a]+unfoldForest f = map (unfoldTree f)++-- | Monadic tree builder, in depth-first order.+unfoldTreeM :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)+unfoldTreeM f b = do+    (a, bs) <- f b+    ts <- unfoldForestM f bs+    return (Node a ts)++-- | Monadic forest builder, in depth-first order.+unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m ([Tree a])+unfoldForestM f = Prelude.mapM (unfoldTreeM f)++-- | Monadic tree builder, in breadth-first order.+--+-- See 'unfoldTree' for more info.+--+-- Implemented using an algorithm adapted from+-- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/,+-- by Chris Okasaki, /ICFP'00/.+unfoldTreeM_BF :: Monad m => (b -> m (a, [b])) -> b -> m (Tree a)+unfoldTreeM_BF f b = liftM getElement $ unfoldForestQ f (singleton b)+  where+    getElement xs = case viewl xs of+        x :< _ -> x+        EmptyL -> error "unfoldTreeM_BF"++-- | Monadic forest builder, in breadth-first order.+--+-- See 'unfoldForest' for more info.+--+-- Implemented using an algorithm adapted from+-- /Breadth-First Numbering: Lessons from a Small Exercise in Algorithm Design/,+-- by Chris Okasaki, /ICFP'00/.+unfoldForestM_BF :: Monad m => (b -> m (a, [b])) -> [b] -> m ([Tree a])+unfoldForestM_BF f = liftM toList . unfoldForestQ f . fromList++-- Takes a sequence (queue) of seeds and produces a sequence (reversed queue) of+-- trees of the same length.+unfoldForestQ :: Monad m => (b -> m (a, [b])) -> Seq b -> m (Seq (Tree a))+unfoldForestQ f aQ = case viewl aQ of+    EmptyL -> return empty+    a :< aQ' -> do+        (b, as) <- f a+        tQ <- unfoldForestQ f (Prelude.foldl (|>) aQ' as)+        let (tQ', ts) = splitOnto [] as tQ+        return (Node b ts <| tQ')+  where+    splitOnto :: [a'] -> [b'] -> Seq a' -> (Seq a', [a'])+    splitOnto as [] q = (q, as)+    splitOnto as (_:bs) q = case viewr q of+        q' :> a -> splitOnto (a:as) bs q'+        EmptyR -> error "unfoldForestQ"++-- | \(O(n)\). The leaves of the tree in left-to-right order.+--+-- A leaf is a node with no children.+--+-- ==== __Examples__+--+-- >>> :{+-- leaves $+--   Node 1+--     [ Node 2+--         [ Node 4 []+--         , Node 5 []+--         ]+--     , Node 3+--         [ Node 6 []+--         ]+--     ]+-- :}+-- [4,5,6]+-- >>> leaves (Node "root" [])+-- ["root"]+--+-- @since 0.8+leaves :: Tree a -> [a]+#ifdef __GLASGOW_HASKELL__+leaves t = GHC.Exts.build $ \cons nil ->+  let go (Node x []) z = cons x z+      go (Node _ ts) z = foldr go z ts+  in go t nil+{-# INLINE leaves #-} -- Inline for list fusion+#else+leaves t =+  let go (Node x []) z = x:z+      go (Node _ ts) z = foldr go z ts+  in go t []+#endif++-- | \(O(n)\). The edges of the tree as parent-child pairs in pre-order.+--+-- A tree with \(n\) nodes has \(n-1\) edges.+--+-- ==== __Examples__+--+-- >>> :{+-- edges $+--   Node 1+--     [ Node 2+--         [ Node 4 []+--         , Node 5 []+--         ]+--     , Node 3+--         [ Node 6 []+--         ]+--     ]+-- :}+-- [(1,2),(2,4),(2,5),(1,3),(3,6)]+-- >>> edges (Node "root" [])+-- []+--+-- @since 0.8+edges :: Tree a -> [(a, a)]+#ifdef __GLASGOW_HASKELL__+edges (Node x0 ts0) = GHC.Exts.build $ \cons nil ->+  let go p = foldr (\(Node x ts) z -> cons (p, x) (go x z ts))+  in go x0 nil ts0+{-# INLINE edges #-} -- Inline for list fusion+#else+edges (Node x0 ts0) =+  let go p = foldr (\(Node x ts) z -> (p, x) : go x z ts)+  in go x0 [] ts0+#endif++-- | \(O(n)\). Labels on the paths from each node to the root.+--+-- ==== __Examples__+--+-- >>> :{+-- pathsToRoot $+--   Node 1+--     [ Node 2 []+--     , Node 3 []+--     ]+-- :}+-- Node {rootLabel = 1 :| [], subForest = [Node {rootLabel = 2 :| [1], subForest = []},Node {rootLabel = 3 :| [1], subForest = []}]}+-- >>> pathsToRoot (Node "root" [])+-- Node {rootLabel = "root" :| [], subForest = []}+--+-- @since 0.8+pathsToRoot :: Tree a -> Tree (NonEmpty a)+pathsToRoot = go []+  where+    go ps (Node x ts) = Node (x :| ps) (map (go (x:ps)) ts)++-- | Labels on the paths from the root to each node.+--+-- If the path orientation is not important, consider using 'pathsToRoot'+-- instead because it is more efficient.+--+-- ==== __Examples__+--+-- >>> :{+-- pathsFromRoot $+--   Node 1+--     [ Node 2 []+--     , Node 3 []+--     ]+-- :}+-- Node {rootLabel = 1 :| [], subForest = [Node {rootLabel = 1 :| [2], subForest = []},Node {rootLabel = 1 :| [3], subForest = []}]}+-- >>> pathsFromRoot (Node "root" [])+-- Node {rootLabel = "root" :| [], subForest = []}+--+-- @since 0.8++-- See Note [pathsFromRoot implementation]+pathsFromRoot :: Tree a -> Tree (NonEmpty a)+pathsFromRoot (Node x0 ts0) = Node (x0 :| []) (map (go (singletonBQ x0)) ts0)+  where+    go !q (Node x ts) = Node (toNonEmptyBQ q') (map (go q') ts)+      where+        !q' = snocBQ q x++-- An implementation of Chris Okasaki's banker's queue.+-- Invariant: length front >= length rear+data BQ a = BQ+  a -- head+  {-# UNPACK #-} !Word -- length front + length rear+  [a] -- front+  ![a] -- rear (reversed)++singletonBQ :: a -> BQ a+singletonBQ x = BQ x 0 [] []++snocBQ :: BQ a -> a -> BQ a+snocBQ (BQ x0 n f r) x+  | doReverse = BQ x0 (n+1) (f ++ reverse (x:r)) []+  | otherwise = BQ x0 (n+1) f (x:r)+  where+    doReverse = (n+2) .&. (n+1) == 0+    -- We reverse whenever the length of r would exceed that of f.+    -- This happens every time n+2 is a power of 2.++toNonEmptyBQ :: BQ a -> NonEmpty a+toNonEmptyBQ (BQ x0 _ f r) = case r of+  [] -> x0 :| f -- optimization, no need to rebuild f+  _ -> x0 :| (f ++ reverse r)++-- | A newtype over 'Tree' that folds and traverses in post-order.+--+-- @since 0.8+newtype PostOrder a = PostOrder { unPostOrder :: Tree a }+#ifdef __GLASGOW_HASKELL__+  deriving (Eq, Ord, Read, Show, Data, Generic, Generic1, Lift)+#else+  deriving (Eq, Ord, Read, Show)+#endif++instance Functor PostOrder where+#ifdef __GLASGOW_HASKELL__+  fmap = (coerce :: ((a -> b) -> Tree a -> Tree b)+                 -> (a -> b) -> PostOrder a -> PostOrder b)+         fmapTree+  (<$) = (coerce :: (b -> Tree a -> Tree b)+                 -> b -> PostOrder a -> PostOrder b)+         (<$)+#else+  fmap f = PostOrder . fmapTree f . unPostOrder+  (<$) x = PostOrder . (x <$) . unPostOrder+#endif++-- See Note [Implemented Foldable Tree functions]+instance Foldable PostOrder where+    fold = foldMap id+    {-# INLINABLE fold #-}++    foldMap = foldMapDefault+    {-# INLINE foldMap #-}++    foldr f z0 = \(PostOrder t) -> go t z0  -- Use a lambda to inline with two arguments+      where+        go (Node x ts) z = foldr go (f x z) ts+    {-# INLINE foldr #-}++    foldl' f z0 = \(PostOrder t) -> go z0 t  -- Use a lambda to inline with two arguments+      where+        go !z (Node x ts) =+          let !z' = foldl' go z ts+          in f z' x+    {-# INLINE foldl' #-}++    foldr1 = foldrMap1PostOrder id++    foldl1 = foldlMap1PostOrder id++    null _ = False+    {-# INLINE null #-}++    elem = any . (==)+    {-# INLINABLE elem #-}++    maximum = foldlMap1'PostOrder id max+    {-# INLINABLE maximum #-}++    minimum = foldlMap1'PostOrder id min+    {-# INLINABLE minimum #-}++    sum = foldlMap1'PostOrder id (+)+    {-# INLINABLE sum #-}++    product = foldlMap1'PostOrder id (*)+    {-# INLINABLE product #-}++instance Traversable PostOrder where+  traverse f = \(PostOrder t) -> PostOrder <$> go t+    where+      go (Node x ts) = liftA2 (flip Node) (traverse go ts) (f x)+  {-# INLINE traverse #-}++#if MIN_VERSION_base(4,18,0)+-- See Note [Implemented Foldable1 Tree functions]+instance Foldable1.Foldable1 PostOrder where+  foldMap1 f = \(PostOrder t) -> go t  -- Use a lambda to inline with one argument+    where+      go (Node x []) = f x+      go (Node x (t:ts)) =+        Foldable1.foldrMap1 go (\t' z' -> go t' <> z') (t :| ts) <> f x+  {-# INLINE foldMap1 #-}++  foldMap1' f = foldlMap1'PostOrder f (\z x -> z <> f x)+  {-# INLINE foldMap1' #-}++  toNonEmpty (PostOrder t0) = go t0 []+    where+      go (Node x []) z = x :| z+      go (Node x (t:ts)) z =+        go t (foldr (\t' z' -> foldr (:) z' (PostOrder t')) (x:z) ts)++  maximum = Foldable.maximum+  {-# INLINABLE maximum #-}++  minimum = Foldable.minimum+  {-# INLINABLE minimum #-}++  foldrMap1 = foldrMap1PostOrder++  foldlMap1' = foldlMap1'PostOrder++  foldlMap1 = foldlMap1PostOrder+#endif++foldrMap1PostOrder :: (a -> b) -> (a -> b -> b) -> PostOrder a -> b+foldrMap1PostOrder f g = \(PostOrder (Node x ts)) ->+  foldr (\t z -> foldr g z (PostOrder t)) (f x) ts+{-# INLINE foldrMap1PostOrder #-}++foldlMap1PostOrder :: (a -> b) -> (b -> a -> b) -> PostOrder a -> b+foldlMap1PostOrder f g = \(PostOrder t) -> go t+  where+    go (Node x []) = f x+    go (Node x (t:ts)) =+      g (foldl (\z t' -> foldl g z (PostOrder t')) (go t) ts) x+{-# INLINE foldlMap1PostOrder #-}++foldlMap1'PostOrder :: (a -> b) -> (b -> a -> b) -> PostOrder a -> b+foldlMap1'PostOrder f g = \(PostOrder t) -> go t+  where+    go (Node x []) = f x+    go (Node x (t:ts)) =+      let !z' = foldl' (\z t' -> foldl' g z (PostOrder t')) (go t) ts+      in g z' x+{-# INLINE foldlMap1'PostOrder #-}++--------------------------------------------------------------------------------++-- Note [Implemented Foldable Tree functions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Implemented:+--+-- foldMap, foldr, foldl': Basic functions.+-- fold, elem: Implemented same as the default definition, but INLINABLE to+-- allow specialization.+-- foldr1, foldl1, null, maximum, minimum: Implemented more efficiently than+-- defaults since trees are non-empty.+-- sum, product: Implemented as strict left folds. Defaults use the lazy foldMap+-- before base 4.15.1.+--+-- Not implemented:+--+-- foldMap', toList, length: Defaults perform well.+-- foldr', foldl: Unlikely to be used.++-- Note [Implemented Foldable1 Tree functions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Implemented:+--+-- foldMap, foldrMap1, foldlMap1': Basic functions+-- foldMap1': Implemented same as the default definition, but INLINABLE to+-- allow specialization.+-- toNonEmpty, foldlMap1: Implemented more efficiently than default.+-- maximum, minimum: Uses Foldable's implementation.+--+-- Not implemented:+--+-- fold1, head: Defaults perform well.+-- foldrMap1': Unlikely to be used.++-- Note [pathsFromRoot implementation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We use Okasaki's banker's queue for pathsFromRoot because it has some+-- desirable properties when the result is consumed lazily.+--+-- 1. Fully evaluating a node's NonEmpty takes O(d) time, where d is+--    the depth of the node. This is optimal.+-- 2. The elements in the NonEmpty are yielded lazily. Note that the worst case+--    time to yield an element is not O(1), i.e. it is only amortized O(1).+--    More than O(1) work is done when the next element requires forcing (++)+--    suspensions or reversing a rear list. For example, yielding the head has+--    to force O(log d) (++) and so takes O(log d) time.+-- 3. It builds up some beneficial sharing. It is not possible to share the+--    results since the lists have different ends, but we can share some+--    intermediate structures. Consider m sibling nodes at depth d. The front+--    list is shared between them in (front ++ rear1), (front ++ rear2), ...+--    (front + rearm). Forcing a prefix of front in one list can take arbitrary+--    amounts of time per element (total bounded by O(d)), but once it is+--    forced, front is memoized and doing the same for any of the siblings will+--    take O(1) per element.+--+-- Alternatives:+--+-- * Implement it like pathsToRoot and reverse the NonEmptys. This does satisfy+--   point 1 above. On 2 there's a trade-off, it costs a full O(d) to access the+--   head and O(1) per element after that. On 3 it compares poorly because there+--   is no sharing. Accessing the heads of m siblings will take O(dm) compared+--   to the current O(d + m).+-- * Use Okasaki's real-time queues. This would guarantee O(1) per element, but+--   has worse constant-factor overall and does not seem worth the trouble.+--+-- GHC base also uses a banker's queue for Data.List.inits. inits is similar+-- in nature to pathsFromRoot since a list is a tree where each node has one or+-- zero children.
+ src/Utils/Containers/Internal/BitQueue.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Utils.Containers.Internal.BitQueue+-- Copyright   :  (c) David Feuer 2016+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- An extremely light-weight, fast, and limited representation of a string of+-- up to (2*WORDSIZE - 2) bits. In fact, there are two representations,+-- misleadingly named bit queue builder and bit queue. The builder supports+-- only `emptyQB`, creating an empty builder, and `snocQB`, enqueueing a bit.+-- The bit queue builder is then turned into a bit queue using `buildQ`, after+-- which bits can be removed one by one using `unconsQ`. If the size limit is+-- exceeded, further operations will silently produce nonsense.+-----------------------------------------------------------------------------++module Utils.Containers.Internal.BitQueue+    ( BitQueue+    , BitQueueB+    , emptyQB+    , snocQB+    , buildQ+    , unconsQ+    , toListQ+    ) where++import Utils.Containers.Internal.BitUtil (shiftLL, shiftRL, wordSize)+import Data.Bits ((.|.), (.&.), testBit)+import Data.Bits (countTrailingZeros)++-- A bit queue builder. We represent a double word using two words+-- because we don't currently have access to proper double words.+data BitQueueB = BQB {-# UNPACK #-} !Word+                     {-# UNPACK #-} !Word++newtype BitQueue = BQ BitQueueB deriving Show++-- Intended for debugging.+instance Show BitQueueB where+  show (BQB hi lo) = "BQ"+++    show (map (testBit hi) [(wordSize - 1),(wordSize - 2)..0]+            ++ map (testBit lo) [(wordSize - 1),(wordSize - 2)..0])++-- | Create an empty bit queue builder. This is represented as a single guard+-- bit in the most significant position.+emptyQB :: BitQueueB+emptyQB = BQB (1 `shiftLL` (wordSize - 1)) 0+{-# INLINE emptyQB #-}++-- Shift the double word to the right by one bit.+shiftQBR1 :: BitQueueB -> BitQueueB+shiftQBR1 (BQB hi lo) = BQB hi' lo' where+  lo' = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))+  hi' = hi `shiftRL` 1+{-# INLINE shiftQBR1 #-}++-- | Enqueue a bit. This works by shifting the queue right one bit,+-- then setting the most significant bit as requested.+{-# INLINE snocQB #-}+snocQB :: BitQueueB -> Bool -> BitQueueB+snocQB bq b = case shiftQBR1 bq of+  BQB hi lo -> BQB (hi .|. (fromIntegral (fromEnum b) `shiftLL` (wordSize - 1))) lo++-- | Convert a bit queue builder to a bit queue. This shifts in a new+-- guard bit on the left, and shifts right until the old guard bit falls+-- off.+{-# INLINE buildQ #-}+buildQ :: BitQueueB -> BitQueue+buildQ (BQB hi 0) = BQ (BQB 0 lo') where+  zeros = countTrailingZeros hi+  lo' = ((hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))) `shiftRL` zeros+buildQ (BQB hi lo) = BQ (BQB hi' lo') where+  zeros = countTrailingZeros lo+  lo1 = (lo `shiftRL` 1) .|. (hi `shiftLL` (wordSize - 1))+  hi1 = (hi `shiftRL` 1) .|. (1 `shiftLL` (wordSize - 1))+  lo' = (lo1 `shiftRL` zeros) .|. (hi1 `shiftLL` (wordSize - zeros))+  hi' = hi1 `shiftRL` zeros++-- Test if the queue is empty, which occurs when there's+-- nothing left but a guard bit in the least significant+-- place.+nullQ :: BitQueue -> Bool+nullQ (BQ (BQB 0 1)) = True+nullQ _ = False+{-# INLINE nullQ #-}++-- | Dequeue an element, or discover the queue is empty.+unconsQ :: BitQueue -> Maybe (Bool, BitQueue)+unconsQ q | nullQ q = Nothing+unconsQ (BQ bq@(BQB _ lo)) = Just (hd, BQ tl)+  where+    !hd = (lo .&. 1) /= 0+    !tl = shiftQBR1 bq+{-# INLINE unconsQ #-}++-- | Convert a bit queue to a list of bits by unconsing.+-- This is used to test that the queue functions properly.+toListQ :: BitQueue -> [Bool]+toListQ bq = case unconsQ bq of+      Nothing -> []+      Just (hd, tl) -> hd : toListQ tl
+ src/Utils/Containers/Internal/BitUtil.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE Trustworthy #-}+#endif++#include "containers.h"++-----------------------------------------------------------------------------+-- |+-- Module      :  Utils.Containers.Internal.BitUtil+-- Copyright   :  (c) Clark Gaebel 2012+--                (c) Johan Tibel 2012+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+-----------------------------------------------------------------------------+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.++module Utils.Containers.Internal.BitUtil+    ( shiftLL+    , shiftRL+    , wordSize+    , iShiftRL+    ) where++import Data.Bits (unsafeShiftL, unsafeShiftR, finiteBitSize)+#ifdef __GLASGOW_HASKELL__+import GHC.Exts (Int(..), uncheckedIShiftRL#)+#endif++-- Right and left logical shifts.+--+-- Precondition for defined behavior: 0 <= shift amount < wordSize+shiftRL, shiftLL :: Word -> Int -> Word+shiftRL = unsafeShiftR+shiftLL = unsafeShiftL++{-# INLINE wordSize #-}+wordSize :: Int+wordSize = finiteBitSize (0 :: Word)++-- Right logical shift.+--+-- Precondition for defined behavior: 0 <= shift amount < wordSize+iShiftRL :: Int -> Int -> Int+#ifdef __GLASGOW_HASKELL__+iShiftRL (I# x#) (I# sh#) = I# (uncheckedIShiftRL# x# sh#)+#else+iShiftRL x sh = fromIntegral (unsafeShiftR (fromIntegral x :: Word) sh)+#endif
+ src/Utils/Containers/Internal/EqOrdUtil.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}+module Utils.Containers.Internal.EqOrdUtil+  ( EqM(..)+  , OrdM(..)+  ) where++#if !MIN_VERSION_base(4,11,0)+import Data.Semigroup (Semigroup(..))+#endif+import Utils.Containers.Internal.StrictPair++newtype EqM a = EqM { runEqM :: a -> StrictPair Bool a }++-- | Composes left-to-right, short-circuits on False+instance Semigroup (EqM a) where+  f <> g = EqM $ \x -> case runEqM f x of+    r@(e :*: x') -> if e then runEqM g x' else r++instance Monoid (EqM a) where+  mempty = EqM (True :*:)+#if !MIN_VERSION_base(4,11,0)+  mappend = (<>)+#endif++newtype OrdM a = OrdM { runOrdM :: a -> StrictPair Ordering a }++-- | Composes left-to-right, short-circuits on non-EQ+instance Semigroup (OrdM a) where+  f <> g = OrdM $ \x -> case runOrdM f x of+    r@(o :*: x') -> case o of+      EQ -> runOrdM g x'+      _ -> r++instance Monoid (OrdM a) where+  mempty = OrdM (EQ :*:)+#if !MIN_VERSION_base(4,11,0)+  mappend = (<>)+#endif
+ src/Utils/Containers/Internal/Prelude.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+-- | This hideous module lets us avoid dealing with the fact that+-- @liftA2@ and @foldl'@ were not previously exported from the standard prelude.+module Utils.Containers.Internal.Prelude+  ( module Prelude+  , Applicative (..)+  , Foldable (..)+#ifdef __MHS__+  , Traversable(..)+  , any, concatMap+#endif+  )+  where++#ifdef __MHS__+import Prelude hiding (elem, foldr, foldl, foldr1, foldl1, maximum, minimum, product, sum, null, length, mapM, any, concatMap)+import Data.Traversable+import Data.List.NonEmpty(NonEmpty)+import Data.Foldable(any, concatMap)+#else+import Prelude hiding (Applicative(..), Foldable(..))+#endif+import Control.Applicative(Applicative(..))+import Data.Foldable (Foldable(elem, foldMap, foldr, foldl, foldl', foldr1, foldl1, maximum, minimum, product, sum, null, length))
+ src/Utils/Containers/Internal/PtrEquality.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE MagicHash #-}+#endif++{-# OPTIONS_HADDOCK hide #-}++-- | Really unsafe pointer equality+module Utils.Containers.Internal.PtrEquality (ptrEq) where++#ifdef __GLASGOW_HASKELL__+import GHC.Exts ( isTrue#, reallyUnsafePtrEquality# )+#endif++-- | Checks if two pointers are equal. Yes means yes;+-- no means maybe. The values should be forced to at least+-- WHNF before comparison to get moderately reliable results.+ptrEq :: a -> a -> Bool++#ifdef __GLASGOW_HASKELL__+ptrEq x y = isTrue# (reallyUnsafePtrEquality# x y)+#else+-- Not GHC+ptrEq _ _ = False+#endif++{-# INLINE ptrEq #-}++infix 4 `ptrEq`
+ src/Utils/Containers/Internal/State.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}+#include "containers.h"+{-# OPTIONS_HADDOCK hide #-}++-- | A clone of Control.Monad.State.Strict.+module Utils.Containers.Internal.State where++import Control.Monad (ap, liftM2)+import Control.Applicative (liftA)+import Utils.Containers.Internal.Prelude+import Prelude ()++newtype State s a = State {runState :: s -> (s, a)}++instance Functor (State s) where+    fmap = liftA++instance Monad (State s) where+    {-# INLINE (>>=) #-}+    m >>= k = State $ \ s -> case runState m s of+        (s', x) -> runState (k x) s'++instance Applicative (State s) where+    {-# INLINE pure #-}+    pure x = State $ \ s -> (s, x)+    (<*>) = ap+    m *> n = State $ \s -> case runState m s of+      (s', _) -> runState n s'+    liftA2 = liftM2++execState :: State s a -> s -> a+execState m x = snd (runState m x)
+ src/Utils/Containers/Internal/StrictMaybe.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}++#include "containers.h"++{-# OPTIONS_HADDOCK hide #-}+-- | Strict 'Maybe'++module Utils.Containers.Internal.StrictMaybe (MaybeS (..), maybeS, toMaybe, toMaybeS) where+#ifdef __MHS__+import Data.Foldable+#endif++data MaybeS a = NothingS | JustS !a++instance Foldable MaybeS where+  foldMap _ NothingS = mempty+  foldMap f (JustS a) = f a++maybeS :: r -> (a -> r) -> MaybeS a -> r+maybeS n _ NothingS = n+maybeS _ j (JustS a) = j a++toMaybe :: MaybeS a -> Maybe a+toMaybe NothingS = Nothing+toMaybe (JustS a) = Just a++toMaybeS :: Maybe a -> MaybeS a+toMaybeS Nothing = NothingS+toMaybeS (Just a) = JustS a
+ src/Utils/Containers/Internal/StrictPair.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+{-# LANGUAGE Safe #-}+#endif++#include "containers.h"++-- | A strict pair++module Utils.Containers.Internal.StrictPair (StrictPair(..), toPair) where++-- | The same as a regular Haskell pair, but+--+-- @+-- (x :*: _|_) = (_|_ :*: y) = _|_+-- @+data StrictPair a b = !a :*: !b++infixr 1 :*:++-- | Convert a strict pair to a standard pair.+toPair :: StrictPair a b -> (a, b)+toPair (x :*: y) = (x, y)+{-# INLINE toPair #-}
− tests/IntMapValidity.hs 
@@ -1,65 +0,0 @@-module IntMapValidity (valid) where--import Data.Bits (xor, (.&.))-import Data.IntMap.Internal-import Test.QuickCheck (Property, counterexample, property, (.&&.))-import Utils.Containers.Internal.BitUtil (bitcount)--{---------------------------------------------------------------------  Assertions---------------------------------------------------------------------}--- | Returns true iff the internal structure of the IntMap is valid.-valid :: IntMap a -> Property-valid t =-  counterexample "nilNeverChildOfBin" (nilNeverChildOfBin t) .&&.-  counterexample "commonPrefix" (commonPrefix t) .&&.-  counterexample "maskRespected" (maskRespected t)---- Invariant: Nil is never found as a child of Bin.-nilNeverChildOfBin :: IntMap a  -> Bool-nilNeverChildOfBin t =-  case t of-    Nil -> True-    Tip _ _ -> True-    Bin _ _ l r -> noNilInSet l && noNilInSet r-  where-    noNilInSet t' =-      case t' of-        Nil -> False-        Tip _ _ -> True-        Bin _ _ l' r' -> noNilInSet l' && noNilInSet r'---- Invariant: The Mask is a power of 2. It is the largest bit position at which---            two keys of the map differ.-maskPowerOfTwo :: IntMap a -> Bool-maskPowerOfTwo t =-  case t of-    Nil -> True-    Tip _ _ -> True-    Bin _ m l r ->-      bitcount 0 (fromIntegral m) == 1 && maskPowerOfTwo l && maskPowerOfTwo r---- Invariant: Prefix is the common high-order bits that all elements share to---            the left of the Mask bit.-commonPrefix :: IntMap a -> Bool-commonPrefix t =-  case t of-    Nil -> True-    Tip _ _ -> True-    b@(Bin p _ l r) -> all (sharedPrefix p) (keys b) && commonPrefix l && commonPrefix r-  where-    sharedPrefix :: Prefix -> Int -> Bool-    sharedPrefix p a = p == p .&. a---- 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.-maskRespected :: IntMap a -> Bool-maskRespected t =-  case t of-    Nil -> True-    Tip _ _ -> True-    Bin _ binMask l r ->-      all (\x -> zero x binMask) (keys l) &&-      all (\x -> not (zero x binMask)) (keys r) &&-      maskRespected l &&-      maskRespected r
− tests/IntSetValidity.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE CPP #-}-module IntSetValidity (valid) where--import Data.Bits (xor, (.&.))-import Data.IntSet.Internal-import Test.QuickCheck (Property, counterexample, property, (.&&.))-import Utils.Containers.Internal.BitUtil (bitcount)--{---------------------------------------------------------------------  Assertions---------------------------------------------------------------------}--- | Returns true iff the internal structure of the IntSet is valid.-valid :: IntSet -> Property-valid t =-  counterexample "nilNeverChildOfBin" (nilNeverChildOfBin t) .&&.-  counterexample "maskPowerOfTwo" (maskPowerOfTwo t) .&&.-  counterexample "commonPrefix" (commonPrefix t) .&&.-  counterexample "markRespected" (maskRespected t) .&&.-  counterexample "tipsValid" (tipsValid t)---- Invariant: Nil is never found as a child of Bin.-nilNeverChildOfBin :: IntSet -> Bool-nilNeverChildOfBin t =-  case t of-    Nil -> True-    Tip _ _ -> True-    Bin _ _ l r -> noNilInSet l && noNilInSet r-  where-    noNilInSet t' =-      case t' of-        Nil -> False-        Tip _ _ -> True-        Bin _ _ l' r' -> noNilInSet l' && noNilInSet r'---- Invariant: The Mask is a power of 2.  It is the largest bit position at which---            two elements of the set differ.-maskPowerOfTwo :: IntSet -> Bool-maskPowerOfTwo t =-  case t of-    Nil -> True-    Tip _ _ -> True-    Bin _ m l r ->-      bitcount 0 (fromIntegral m) == 1 && maskPowerOfTwo l && maskPowerOfTwo r---- Invariant: Prefix is the common high-order bits that all elements share to---            the left of the Mask bit.-commonPrefix :: IntSet -> Bool-commonPrefix t =-  case t of-    Nil -> True-    Tip _ _ -> True-    b@(Bin p _ l r) -> all (sharedPrefix p) (elems b) && commonPrefix l && commonPrefix r-  where-    sharedPrefix :: Prefix -> Int -> Bool-    sharedPrefix p a = p == p .&. a---- 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.-maskRespected :: IntSet -> Bool-maskRespected t =-  case t of-    Nil -> True-    Tip _ _ -> True-    Bin _ binMask l r ->-      all (\x -> zero x binMask) (elems l) &&-      all (\x -> not (zero x binMask)) (elems r) &&-      maskRespected l &&-      maskRespected r---- 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.------ Note: Valid entries stored in tip omitted.-tipsValid :: IntSet -> Bool-tipsValid t =-  case t of-    Nil -> True-    tip@(Tip p b) -> validTipPrefix p-    Bin _ _ l r -> tipsValid l && tipsValid r--validTipPrefix :: Prefix -> Bool-#if WORD_SIZE_IN_BITS==32--- Last 5 bits of the prefix must be zero for 32 bit arches.-validTipPrefix p = (0x0000001F .&. p) == 0-#else--- Last 6 bits of the prefix must be zero 64 bit anches.-validTipPrefix p = (0x000000000000003F .&. p) == 0-#endif
− tests/Makefile 
@@ -1,20 +0,0 @@-# The tests should be compiled and run using cabal:-# > cabal configure --enable-tests-# > cabal build-# > cabal test-#-# This Makefile is used by developers to compile the tests manually.--all:--%-properties: %-properties.hs force-	ghc -I../include -O2 -DTESTING $< -i.. -o $@ -outputdir tmp--%-strict-properties: %-properties.hs force-	ghc -I../include -O2 -DTESTING -DSTRICT $< -o $@ -i.. -outputdir tmp--.PHONY: force clean-force:--clean:-	rm -rf tmp $(patsubst %.hs, %, $(wildcard *-properties.hs)) $(patsubst %-properties.hs, %-strict-properties, $(wildcard *-properties.hs))
− tests/bitqueue-properties.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif-import qualified Data.List as List-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck-import Utils.Containers.Internal.BitUtil (wordSize)-import Utils.Containers.Internal.BitQueue-    ( BitQueue-    , emptyQB-    , snocQB-    , buildQ-    , toListQ )--default (Int)--main :: IO ()-main = defaultMain $ map testNum [0..(wordSize - 2)]--testNum :: Int -> Test-testNum n = testProperty ("Size "++show n) (prop_n n)--prop_n :: Int -> Gen Bool-prop_n n = checkList <$> vectorOf n (arbitrary :: Gen Bool)-  where-    checkList :: [Bool] -> Bool-    checkList values = toListQ q == values-      where-        q :: BitQueue-        !q = buildQ $ List.foldl' snocQB emptyQB values
− tests/graph-properties.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE CPP #-}--import Data.Graph as G--import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>), liftA2)--import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck-import Test.QuickCheck.Function (Fun (..), apply)-import Test.QuickCheck.Poly (A, B, C)-import Control.Monad (ap)--default (Int)--main :: IO ()-main = defaultMain-         [-           testProperty "monad_id1"                prop_monad_id1-         , testProperty "monad_id2"                prop_monad_id2-         , testProperty "monad_assoc"              prop_monad_assoc-         , testProperty "ap_ap"                    prop_ap_ap-         , testProperty "ap_liftA2"                prop_ap_liftA2-         , testProperty "monadFix_ls"              prop_monadFix_ls-         ]--{---------------------------------------------------------------------  Arbitrary trees---------------------------------------------------------------------}--newtype G = G Graph---- This instance isn't balanced very well; the trees will probably tend--- to lean left. But it's better than nothing and we can fix it later.-instance Arbitrary a => Arbitrary G where-  arbitrary = sized arbgraph-    where-      arbgraph :: Arbitrary a => Int -> Gen G-      arbgraph nv = do-        lo <- arbitrary-        hi <- (lo+) <$> choose (0, nv)-{--      arbtree 0 = fmap ((,) 1) $ Node <$> arbitrary <*> pure []-      arbtree n = do-        root <- arbitrary-        num_children <- choose (0, n - 1)-        (st, tl) <- go num_children-        return (1+st, Node root tl)--}--      go 0 = pure (0, [])-      go n = do-        (sh, hd) <- arbtree n-        (st, tl) <- go (n - sh)-        pure (sh + st, hd : tl)---- genericShrink only became available when generics did, so it's--- not available under GHC 7.0.-#if __GLASGOW_HASKELL__ >= 704-  shrink = genericShrink-#endif--------------------------------------------------------------------- Unit tests-------------------------------------------------------------------------------------------------------------------------------------- QuickCheck-------------------------------------------------------------------apply2 :: Fun (a, b) c -> a -> b -> c-apply2 f a b = apply f (a, b)--prop_ap_ap :: Tree (Fun A B) -> Tree A -> Property-prop_ap_ap fs xs = (apply <$> fs <*> xs) === ((apply <$> fs) `ap` xs)--prop_ap_liftA2 :: Fun (A, B) C -> Tree A -> Tree B -> Property-prop_ap_liftA2 f as bs = (apply2 f <$> as <*> bs) === liftA2 (apply2 f) as bs--prop_monad_id1 :: Tree A -> Property-prop_monad_id1 t = (t >>= pure) === t--prop_monad_id2 :: A -> Fun A (Tree B) -> Property-prop_monad_id2 a f = (pure a >>= apply f) === apply f a--prop_monad_assoc :: Tree A -> Fun A (Tree B) -> Fun B (Tree C) -> Property-prop_monad_assoc ta atb btc =-  ((ta >>= apply atb) >>= apply btc)-  ===-  (ta >>= \a -> apply atb a >>= apply btc)---- The left shrinking law------ This test is kind of wonky and unprincipled, because it's--- rather tricky to construct test cases!--- This is the most important MonadFix law to test because it's the--- least intuitive by far, and because it's the only one that's--- sensitive to the Monad instance.-prop_monadFix_ls :: Int -> Tree Int -> Fun Int (Tree Int) -> Property-prop_monadFix_ls val ta ti =-  fmap ($val) (mfix (\x -> ta >>= \y -> f x y))-  ===-  fmap ($val) (ta >>= \y -> mfix (\x -> f x y))-  where-    fact :: Int -> (Int -> Int) -> Int -> Int-    fact x _ 0 = x + 1-    fact x f n = x + n * f ((n - 1) `mod` 23)--    f :: (Int -> Int) -> Int -> Tree (Int -> Int)-    f q y = let t = apply ti y-            in fmap (\w -> fact w q) t
− tests/intmap-properties.hs 
@@ -1,1166 +0,0 @@-{-# LANGUAGE CPP #-}--#ifdef STRICT-import Data.IntMap.Strict as Data.IntMap hiding (showTree)-#else-import Data.IntMap.Lazy as Data.IntMap hiding (showTree)-#endif-import Data.IntMap.Internal.Debug (showTree)-import IntMapValidity (valid)--import Data.Monoid-import Data.Maybe hiding (mapMaybe)-import qualified Data.Maybe as Maybe (mapMaybe)-import Data.Ord-import Data.Function-import Prelude hiding (lookup, null, map, filter, foldr, foldl)-import qualified Prelude (map)--import Data.List (nub,sort)-import qualified Data.List as List-import qualified Data.IntSet as IntSet-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit hiding (Test, Testable)-import Test.QuickCheck-import Test.QuickCheck.Function (Fun(..), apply)--default (Int)--main :: IO ()-main = defaultMain-         [-               testCase "index"      test_index-             , testCase "index_lookup" test_index_lookup-             , testCase "size"       test_size-             , testCase "size2"      test_size2-             , testCase "member"     test_member-             , testCase "notMember"  test_notMember-             , testCase "lookup"     test_lookup-             , testCase "findWithDefault"     test_findWithDefault-             , testCase "lookupLT"   test_lookupLT-             , testCase "lookupGT"   test_lookupGT-             , testCase "lookupLE"   test_lookupLE-             , testCase "lookupGE"   test_lookupGE-             , testCase "empty" test_empty-             , testCase "mempty" test_mempty-             , testCase "singleton" test_singleton-             , testCase "insert" test_insert-             , testCase "insertWith" test_insertWith-             , testCase "insertWithKey" test_insertWithKey-             , testCase "insertLookupWithKey" test_insertLookupWithKey-             , testCase "delete" test_delete-             , testCase "adjust" test_adjust-             , testCase "adjustWithKey" test_adjustWithKey-             , testCase "update" test_update-             , testCase "updateWithKey" test_updateWithKey-             , testCase "updateLookupWithKey" test_updateLookupWithKey-             , testCase "alter" test_alter-             , testCase "union" test_union-             , testCase "mappend" test_mappend-             , testCase "unionWith" test_unionWith-             , testCase "unionWithKey" test_unionWithKey-             , testCase "unions" test_unions-             , testCase "mconcat" test_mconcat-             , testCase "unionsWith" test_unionsWith-             , testCase "difference" test_difference-             , testCase "differenceWith" test_differenceWith-             , testCase "differenceWithKey" test_differenceWithKey-             , testCase "intersection" test_intersection-             , testCase "intersectionWith" test_intersectionWith-             , testCase "intersectionWithKey" test_intersectionWithKey-             , testCase "map" test_map-             , testCase "mapWithKey" test_mapWithKey-             , testCase "mapAccum" test_mapAccum-             , testCase "mapAccumWithKey" test_mapAccumWithKey-             , testCase "mapAccumRWithKey" test_mapAccumRWithKey-             , testCase "mapKeys" test_mapKeys-             , testCase "mapKeysWith" test_mapKeysWith-             , testCase "mapKeysMonotonic" test_mapKeysMonotonic-             , testCase "elems" test_elems-             , testCase "keys" test_keys-             , testCase "assocs" test_assocs-             , testCase "keysSet" test_keysSet-             , testCase "keysSet" test_fromSet-             , testCase "toList" test_toList-             , testCase "fromList" test_fromList-             , testCase "fromListWith" test_fromListWith-             , testCase "fromListWithKey" test_fromListWithKey-             , testCase "toAscList" test_toAscList-             , testCase "toDescList" test_toDescList-             , testCase "showTree" test_showTree-             , testCase "fromAscList" test_fromAscList-             , testCase "fromAscListWith" test_fromAscListWith-             , testCase "fromAscListWithKey" test_fromAscListWithKey-             , testCase "fromDistinctAscList" test_fromDistinctAscList-             , testCase "filter" test_filter-             , testCase "filterWithKey" test_filteWithKey-             , testCase "partition" test_partition-             , testCase "partitionWithKey" test_partitionWithKey-             , testCase "mapMaybe" test_mapMaybe-             , testCase "mapMaybeWithKey" test_mapMaybeWithKey-             , testCase "mapEither" test_mapEither-             , testCase "mapEitherWithKey" test_mapEitherWithKey-             , testCase "split" test_split-             , testCase "splitLookup" test_splitLookup-             , testCase "isSubmapOfBy" test_isSubmapOfBy-             , testCase "isSubmapOf" test_isSubmapOf-             , testCase "isProperSubmapOfBy" test_isProperSubmapOfBy-             , testCase "isProperSubmapOf" test_isProperSubmapOf-             , testCase "lookupMin" test_lookupMin-             , testCase "lookupMax" test_lookupMax-             , testCase "findMin" test_findMin-             , testCase "findMax" test_findMax-             , testCase "deleteMin" test_deleteMin-             , testCase "deleteMax" test_deleteMax-             , testCase "deleteFindMin" test_deleteFindMin-             , testCase "deleteFindMax" test_deleteFindMax-             , testCase "updateMin" test_updateMin-             , testCase "updateMax" test_updateMax-             , testCase "updateMinWithKey" test_updateMinWithKey-             , testCase "updateMaxWithKey" test_updateMaxWithKey-             , testCase "minView" test_minView-             , testCase "maxView" test_maxView-             , testCase "minViewWithKey" test_minViewWithKey-             , testCase "maxViewWithKey" test_maxViewWithKey-             , testProperty "valid"                prop_valid-             , testProperty "empty valid"          prop_emptyValid-             , testProperty "insert to singleton"  prop_singleton-             , testProperty "insert then lookup"   prop_insertLookup-             , testProperty "insert then delete"   prop_insertDelete-             , testProperty "delete non member"    prop_deleteNonMember-             , testProperty "union model"          prop_unionModel-             , testProperty "union singleton"      prop_unionSingleton-             , testProperty "union associative"    prop_unionAssoc-             , testProperty "union+unionWith"      prop_unionWith-             , testProperty "union sum"            prop_unionSum-             , testProperty "difference model"     prop_differenceModel-             , testProperty "intersection model"   prop_intersectionModel-             , testProperty "intersectionWith model" prop_intersectionWithModel-             , testProperty "intersectionWithKey model" prop_intersectionWithKeyModel-             , testProperty "mergeWithKey model"   prop_mergeWithKeyModel-             , testProperty "fromAscList"          prop_ordered-             , testProperty "fromList then toList" prop_list-             , testProperty "toDescList"           prop_descList-             , testProperty "toAscList+toDescList" prop_ascDescList-             , testProperty "fromList"             prop_fromList-             , testProperty "alter"                prop_alter-             , testProperty "index"                prop_index-             , testProperty "index_lookup"         prop_index_lookup-             , testProperty "null"                 prop_null-             , testProperty "size"                 prop_size-             , testProperty "member"               prop_member-             , testProperty "notmember"            prop_notmember-             , testProperty "lookup"               prop_lookup-             , testProperty "find"                 prop_find-             , testProperty "findWithDefault"      prop_findWithDefault-             , testProperty "lookupLT"             prop_lookupLT-             , testProperty "lookupGT"             prop_lookupGT-             , testProperty "lookupLE"             prop_lookupLE-             , testProperty "lookupGE"             prop_lookupGE-             , testProperty "lookupMin"            prop_lookupMin-             , testProperty "lookupMax"            prop_lookupMax-             , testProperty "findMin"              prop_findMin-             , testProperty "findMax"              prop_findMax-             , testProperty "deleteMin"            prop_deleteMinModel-             , testProperty "deleteMax"            prop_deleteMaxModel-             , testProperty "filter"               prop_filter-             , testProperty "partition"            prop_partition-             , testProperty "map"                  prop_map-             , testProperty "fmap"                 prop_fmap-             , testProperty "mapkeys"              prop_mapkeys-             , testProperty "split"                prop_splitModel-             , testProperty "splitRoot"            prop_splitRoot-             , testProperty "foldr"                prop_foldr-             , testProperty "foldr'"               prop_foldr'-             , testProperty "foldl"                prop_foldl-             , testProperty "foldl'"               prop_foldl'-             , testProperty "keysSet"              prop_keysSet-             , testProperty "fromSet"              prop_fromSet-             , testProperty "restrictKeys"         prop_restrictKeys-             , testProperty "withoutKeys"          prop_withoutKeys-             ]--apply2 :: Fun (a, b) c -> a -> b -> c-apply2 f a b = apply f (a, b)--apply3 :: Fun (a, b, c) d -> a -> b -> c -> d-apply3 f a b c = apply f (a, b, c)---{---------------------------------------------------------------------  Arbitrary, reasonably balanced trees---------------------------------------------------------------------}--instance Arbitrary a => Arbitrary (IntMap a) where-  arbitrary = do{ ks <- arbitrary-                ; xs <- arbitrary-                ; return (fromList (zip xs ks))-                }--newtype NonEmptyIntMap a = NonEmptyIntMap {getNonEmptyIntMap :: IntMap a} deriving (Eq, Show)--instance Arbitrary a => Arbitrary (NonEmptyIntMap a) where-  arbitrary = fmap (NonEmptyIntMap . fromList . getNonEmpty) arbitrary-----------------------------------------------------------------------------type UMap = IntMap ()-type IMap = IntMap Int-type SMap = IntMap String--------------------------------------------------------------------tests :: [Test]-tests = [ testGroup "Test Case" [-             ]-        , testGroup "Property Test" [-             ]-        ]---------------------------------------------------------------------- Unit tests-------------------------------------------------------------------------------------------------------------------------------------- Operators--test_index :: Assertion-test_index = fromList [(5,'a'), (3,'b')] ! 5 @?= 'a'--test_index_lookup :: Assertion-test_index_lookup = do-    fromList [(5,'a'), (3,'b')] !? 1 @?= Nothing-    fromList [(5,'a'), (3,'b')] !? 5 @?= Just 'a'--------------------------------------------------------------------- Query--test_size :: Assertion-test_size = do-    null (empty)           @?= True-    null (singleton 1 'a') @?= False--test_size2 :: Assertion-test_size2 = do-    size empty                                   @?= 0-    size (singleton 1 'a')                       @?= 1-    size (fromList([(1,'a'), (2,'c'), (3,'b')])) @?= 3--test_member :: Assertion-test_member = do-    member 5 (fromList [(5,'a'), (3,'b')]) @?= True-    member 1 (fromList [(5,'a'), (3,'b')]) @?= False--test_notMember :: Assertion-test_notMember = do-    notMember 5 (fromList [(5,'a'), (3,'b')]) @?= False-    notMember 1 (fromList [(5,'a'), (3,'b')]) @?= True--test_lookup :: Assertion-test_lookup = do-    employeeCurrency 1 @?= Just 1-    employeeCurrency 2 @?= Nothing-  where-    employeeDept = fromList([(1,2), (3,1)])-    deptCountry = fromList([(1,1), (2,2)])-    countryCurrency = fromList([(1, 2), (2, 1)])-    employeeCurrency :: Int -> Maybe Int-    employeeCurrency name = do-        dept <- lookup name employeeDept-        country <- lookup dept deptCountry-        lookup country countryCurrency--test_findWithDefault :: Assertion-test_findWithDefault = do-    findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) @?= 'x'-    findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) @?= 'a'--test_lookupLT :: Assertion-test_lookupLT = do-    lookupLT 3 (fromList [(3,'a'), (5,'b')]) @?= Nothing-    lookupLT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a')--test_lookupGT :: Assertion-test_lookupGT = do-    lookupGT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b')-    lookupGT 5 (fromList [(3,'a'), (5,'b')]) @?= Nothing--test_lookupLE :: Assertion-test_lookupLE = do-    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')--test_lookupGE :: Assertion-test_lookupGE = do-    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--------------------------------------------------------------------- Construction--test_empty :: Assertion-test_empty = do-    (empty :: UMap)  @?= fromList []-    size empty @?= 0--test_mempty :: Assertion-test_mempty = do-    (mempty :: UMap)  @?= fromList []-    size (mempty :: UMap) @?= 0--test_singleton :: Assertion-test_singleton = do-    singleton 1 'a'        @?= fromList [(1, 'a')]-    size (singleton 1 'a') @?= 1--test_insert :: Assertion-test_insert = do-    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'--test_insertWith :: Assertion-test_insertWith = do-    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"--test_insertWithKey :: Assertion-test_insertWithKey = do-    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"-  where-    f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--test_insertLookupWithKey :: Assertion-test_insertLookupWithKey = do-    insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])-    insertLookupWithKey f 2 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Nothing,fromList [(2,"xxx"),(3,"b"),(5,"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")-  where-    f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--------------------------------------------------------------------- Delete/Update--test_delete :: Assertion-test_delete = do-    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 :: IMap)--test_adjust :: Assertion-test_adjust = do-    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--test_adjustWithKey :: Assertion-test_adjustWithKey = do-    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-  where-    f key x = (show key) ++ ":new " ++ x--test_update :: Assertion-test_update = do-    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"-  where-    f x = if x == "a" then Just "new a" else Nothing--test_updateWithKey :: Assertion-test_updateWithKey = do-    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"- where-     f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--test_updateLookupWithKey :: Assertion-test_updateLookupWithKey = do-    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")-  where-    f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--test_alter :: Assertion-test_alter = do-    alter f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]-    alter f 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"-    alter g 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "c")]-    alter g 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "c")]-  where-    f _ = Nothing-    g _ = Just "c"--------------------------------------------------------------------- Combine--test_union :: Assertion-test_union = union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")]--test_mappend :: Assertion-test_mappend = mappend (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")]--test_unionWith :: Assertion-test_unionWith = unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "aA"), (7, "C")]--test_unionWithKey :: Assertion-test_unionWithKey = unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "5:a|A"), (7, "C")]-  where-    f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--test_unions :: Assertion-test_unions = do-    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")]--test_mconcat :: Assertion-test_mconcat = do-    mconcat [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]-        @?= fromList [(3, "b"), (5, "a"), (7, "C")]-    mconcat [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]-        @?= fromList [(3, "B3"), (5, "A3"), (7, "C")]--test_unionsWith :: Assertion-test_unionsWith = unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]-     @?= fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]--test_difference :: Assertion-test_difference = difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 3 "b"--test_differenceWith :: Assertion-test_differenceWith = differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])-     @?= singleton 3 "b:B"- where-   f al ar = if al== "b" then Just (al ++ ":" ++ ar) else Nothing--test_differenceWithKey :: Assertion-test_differenceWithKey = differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])-     @?= singleton 3 "3:b|B"-  where-    f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing--test_intersection :: Assertion-test_intersection = intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "a"---test_intersectionWith :: Assertion-test_intersectionWith = intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "aA"--test_intersectionWithKey :: Assertion-test_intersectionWithKey = intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "5:a|A"-  where-    f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar--------------------------------------------------------------------- Traversal--test_map :: Assertion-test_map = map (++ "x") (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "bx"), (5, "ax")]--test_mapWithKey :: Assertion-test_mapWithKey = mapWithKey f (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "3:b"), (5, "5:a")]-  where-    f key x = (show key) ++ ":" ++ x--test_mapAccum :: Assertion-test_mapAccum = mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) @?= ("Everything: ba", fromList [(3, "bX"), (5, "aX")])-  where-    f a b = (a ++ b, b ++ "X")--test_mapAccumWithKey :: Assertion-test_mapAccumWithKey = mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])-  where-    f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--test_mapAccumRWithKey :: Assertion-test_mapAccumRWithKey = mapAccumRWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 5-a 3-b", fromList [(3, "bX"), (5, "aX")])-  where-    f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--test_mapKeys :: Assertion-test_mapKeys = do-    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"--test_mapKeysWith :: Assertion-test_mapKeysWith = do-    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"--test_mapKeysMonotonic :: Assertion-test_mapKeysMonotonic = do-    mapKeysMonotonic (+ 1) (fromList [(5,"a"), (3,"b")])          @?= fromList [(4, "b"), (6, "a")]-    mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) @?= fromList [(6, "b"), (10, "a")]--------------------------------------------------------------------- Conversion--test_elems :: Assertion-test_elems = do-    elems (fromList [(5,"a"), (3,"b")]) @?= ["b","a"]-    elems (empty :: UMap) @?= []--test_keys :: Assertion-test_keys = do-    keys (fromList [(5,"a"), (3,"b")]) @?= [3,5]-    keys (empty :: UMap) @?= []--test_assocs :: Assertion-test_assocs = do-    assocs (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]-    assocs (empty :: UMap) @?= []--test_keysSet :: Assertion-test_keysSet = do-    keysSet (fromList [(5,"a"), (3,"b")]) @?= IntSet.fromList [3,5]-    keysSet (empty :: UMap) @?= IntSet.empty--test_fromSet :: Assertion-test_fromSet = do-   fromSet (\k -> replicate k 'a') (IntSet.fromList [3, 5]) @?= fromList [(5,"aaaaa"), (3,"aaa")]-   fromSet undefined IntSet.empty @?= (empty :: IMap)--------------------------------------------------------------------- Lists--test_toList :: Assertion-test_toList = do-    toList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]-    toList (empty :: SMap) @?= []--test_fromList :: Assertion-test_fromList = do-    fromList [] @?= (empty :: SMap)-    fromList [(5,"a"), (3,"b"), (5, "c")] @?= fromList [(5,"c"), (3,"b")]-    fromList [(5,"c"), (3,"b"), (5, "a")] @?= fromList [(5,"a"), (3,"b")]--test_fromListWith :: Assertion-test_fromListWith = do-    fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] @?= fromList [(3, "ab"), (5, "aba")]-    fromListWith (++) [] @?= (empty :: SMap)--test_fromListWithKey :: Assertion-test_fromListWithKey = do-    fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] @?= fromList [(3, "3ab"), (5, "5a5ba")]-    fromListWithKey f [] @?= (empty :: SMap)-  where-    f k a1 a2 = (show k) ++ a1 ++ a2--------------------------------------------------------------------- Ordered lists--test_toAscList :: Assertion-test_toAscList = toAscList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]--test_toDescList :: Assertion-test_toDescList = toDescList (fromList [(5,"a"), (3,"b")]) @?= [(5,"a"), (3,"b")]--test_showTree :: Assertion-test_showTree =-       (let t = fromDistinctAscList [(x,()) | x <- [1..5]]-        in showTree t) @?= "*\n+--*\n|  +-- 1:=()\n|  +--*\n|     +-- 2:=()\n|     +-- 3:=()\n+--*\n   +-- 4:=()\n   +-- 5:=()\n"--test_fromAscList :: Assertion-test_fromAscList = do-    fromAscList [(3,"b"), (5,"a")]          @?= fromList [(3, "b"), (5, "a")]-    fromAscList [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "b")]---test_fromAscListWith :: Assertion-test_fromAscListWith = do-    fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "ba")]--test_fromAscListWithKey :: Assertion-test_fromAscListWithKey = do-    fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] @?= fromList [(3, "b"), (5, "5:b5:ba")]-  where-    f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2--test_fromDistinctAscList :: Assertion-test_fromDistinctAscList = do-    fromDistinctAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")]--------------------------------------------------------------------- Filter--test_filter :: Assertion-test_filter = do-    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--test_filteWithKey :: Assertion-test_filteWithKey = filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"--test_partition :: Assertion-test_partition = do-    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")])--test_partitionWithKey :: Assertion-test_partitionWithKey = do-    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")])--test_mapMaybe :: Assertion-test_mapMaybe = mapMaybe f (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "new a"-  where-    f x = if x == "a" then Just "new a" else Nothing--test_mapMaybeWithKey :: Assertion-test_mapMaybeWithKey = mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "key : 3"-  where-    f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing--test_mapEither :: Assertion-test_mapEither = do-    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 :: SMap), fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])- where-   f a = if a < "c" then Left a else Right a--test_mapEitherWithKey :: Assertion-test_mapEitherWithKey = do-    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 :: SMap), fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])-  where-    f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--test_split :: Assertion-test_split = do-    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)--test_splitLookup :: Assertion-test_splitLookup = do-    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)--------------------------------------------------------------------- Submap--test_isSubmapOfBy :: Assertion-test_isSubmapOfBy = do-    isSubmapOfBy (==) (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True-    isSubmapOfBy (<=) (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True-    isSubmapOfBy (==) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True-    isSubmapOfBy (==) (fromList [(fromEnum 'a',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= False-    isSubmapOfBy (<)  (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= False-    isSubmapOfBy (==) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1)]) @?= False--test_isSubmapOf :: Assertion-test_isSubmapOf = do-    isSubmapOf (fromList [(fromEnum 'a',1)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True-    isSubmapOf (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= True-    isSubmapOf (fromList [(fromEnum 'a',2)]) (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) @?= False-    isSubmapOf (fromList [(fromEnum 'a',1),(fromEnum 'b',2)]) (fromList [(fromEnum 'a',1)]) @?= False--test_isProperSubmapOfBy :: Assertion-test_isProperSubmapOfBy = do-    isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True-    isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True-    isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False-    isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False-    isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)]) @?= False--test_isProperSubmapOf :: Assertion-test_isProperSubmapOf = do-    isProperSubmapOf (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True-    isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False-    isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False--------------------------------------------------------------------- Min/Max--test_lookupMin :: Assertion-test_lookupMin = do-  lookupMin (fromList [(5,"a"), (3,"b")]) @?= Just (3,"b")-  lookupMin (empty :: SMap) @?= Nothing--test_lookupMax :: Assertion-test_lookupMax = do-  lookupMax (fromList [(5,"a"), (3,"b")]) @?= Just (5,"a")-  lookupMax (empty :: SMap) @?= Nothing--test_findMin :: Assertion-test_findMin = findMin (fromList [(5,"a"), (3,"b")]) @?= (3,"b")--test_findMax :: Assertion-test_findMax = findMax (fromList [(5,"a"), (3,"b")]) @?= (5,"a")--test_deleteMin :: Assertion-test_deleteMin = do-    deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) @?= fromList [(5,"a"), (7,"c")]-    deleteMin (empty :: SMap) @?= empty--test_deleteMax :: Assertion-test_deleteMax = do-    deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) @?= fromList [(3,"b"), (5,"a")]-    deleteMax (empty :: SMap) @?= empty--test_deleteFindMin :: Assertion-test_deleteFindMin = deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((3,"b"), fromList[(5,"a"), (10,"c")])--test_deleteFindMax :: Assertion-test_deleteFindMax = deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((10,"c"), fromList [(3,"b"), (5,"a")])--test_updateMin :: Assertion-test_updateMin = do-    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"--test_updateMax :: Assertion-test_updateMax = do-    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"--test_updateMinWithKey :: Assertion-test_updateMinWithKey = do-    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"--test_updateMaxWithKey :: Assertion-test_updateMaxWithKey = do-    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"--test_minView :: Assertion-test_minView = do-    minView (fromList [(5,"a"), (3,"b")]) @?= Just ("b", singleton 5 "a")-    minView (empty :: SMap) @?= Nothing--test_maxView :: Assertion-test_maxView = do-    maxView (fromList [(5,"a"), (3,"b")]) @?= Just ("a", singleton 3 "b")-    maxView (empty :: SMap) @?= Nothing--test_minViewWithKey :: Assertion-test_minViewWithKey = do-    minViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((3,"b"), singleton 5 "a")-    minViewWithKey (empty :: SMap) @?= Nothing--test_maxViewWithKey :: Assertion-test_maxViewWithKey = do-    maxViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((5,"a"), singleton 3 "b")-    maxViewWithKey (empty :: SMap) @?= Nothing--------------------------------------------------------------------- Valid IntMaps-------------------------------------------------------------------forValid :: Testable b => (SMap -> b) -> Property-forValid f = forAll arbitrary $ \t ->-    classify (size t == 0) "empty" $-    classify (size t > 0 && size t <= 10) "small" $-    classify (size t > 10 && size t <= 64) "medium" $-    classify (size t > 64) "large" $ f t--forValidUnitTree :: Testable b => (SMap -> b) -> Property-forValidUnitTree f = forValid f--prop_valid :: Property-prop_valid = forValidUnitTree $ \t -> valid t--------------------------------------------------------------------- QuickCheck-------------------------------------------------------------------prop_emptyValid :: Property-prop_emptyValid = valid empty--prop_singleton :: Int -> Int -> Property-prop_singleton k x =-  case singleton k x of-    s ->-      valid s .&&.-      s === insert k x empty--prop_insertLookup :: Int -> UMap -> Bool-prop_insertLookup k t = lookup k (insert k () t) /= Nothing--prop_insertDelete :: Int -> UMap -> Property-prop_insertDelete k t =-  lookup k t == Nothing ==>-    case delete k (insert k () t) of-      t' -> valid t' .&&. t' === t--prop_deleteNonMember :: Int -> UMap -> Property-prop_deleteNonMember k t = (lookup k t == Nothing) ==> (delete k t == t)--------------------------------------------------------------------prop_unionModel :: [(Int,Int)] -> [(Int,Int)] -> Property-prop_unionModel xs ys =-  case union (fromList xs) (fromList ys) of-    t ->-      valid t .&&.-      sort (keys t) === sort (nub (Prelude.map fst xs ++ Prelude.map fst ys))--prop_unionSingleton :: IMap -> Int -> Int -> Bool-prop_unionSingleton t k x = union (singleton k x) t == insert k x t--prop_unionAssoc :: IMap -> IMap -> IMap -> Bool-prop_unionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3--prop_unionWith :: IMap -> IMap -> Bool-prop_unionWith t1 t2 = (union t1 t2 == unionWith (\_ y -> y) t2 t1)--prop_unionSum :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_unionSum xs ys-  = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))-    == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))--prop_differenceModel :: [(Int,Int)] -> [(Int,Int)] -> Property-prop_differenceModel xs ys =-  case difference (fromListWith (+) xs) (fromListWith (+) ys) of-    t ->-      valid t .&&.-      sort (keys t) === sort ((List.\\)-                                 (nub (Prelude.map fst xs))-                                 (nub (Prelude.map fst ys)))--prop_intersectionModel :: [(Int,Int)] -> [(Int,Int)] -> Property-prop_intersectionModel xs ys =-  case intersection (fromListWith (+) xs) (fromListWith (+) ys) of-    t ->-      valid t .&&.-      sort (keys t) === sort (nub ((List.intersect)-                                      (Prelude.map fst xs)-                                      (Prelude.map fst ys)))--prop_intersectionWithModel :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_intersectionWithModel xs ys-  = toList (intersectionWith f (fromList xs') (fromList ys'))-    == [(kx, f vx vy ) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky]-    where xs' = List.nubBy ((==) `on` fst) xs-          ys' = List.nubBy ((==) `on` fst) ys-          f l r = l + 2 * r--prop_intersectionWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_intersectionWithKeyModel xs ys-  = toList (intersectionWithKey f (fromList xs') (fromList ys'))-    == [(kx, f kx vx vy) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky]-    where xs' = List.nubBy ((==) `on` fst) xs-          ys' = List.nubBy ((==) `on` fst) ys-          f k l r = k + 2 * l + 3 * r---- TODO: the second argument should be simply an 'IntSet', but that--- runs afoul of our orphan instance.-prop_restrictKeys :: IMap -> IMap -> Property-prop_restrictKeys m s0 =-    m `restrictKeys` s === filterWithKey (\k _ -> k `IntSet.member` s) m-  where-    s = keysSet s0---- TODO: the second argument should be simply an 'IntSet', but that--- runs afoul of our orphan instance.-prop_withoutKeys :: IMap -> IMap -> Property-prop_withoutKeys m s0 =-    m `withoutKeys` s === filterWithKey (\k _ -> k `IntSet.notMember` s) m-  where-    s = keysSet s0--prop_mergeWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_mergeWithKeyModel xs ys-  = and [ testMergeWithKey f keep_x keep_y-        | f <- [ \_k x1  _x2 -> Just x1-               , \_k _x1 x2  -> Just x2-               , \_k _x1 _x2 -> Nothing-               , \k  x1  x2  -> if k `mod` 2 == 0 then Nothing else Just (2 * x1 + 3 * x2)-               ]-        , keep_x <- [ True, False ]-        , keep_y <- [ True, False ]-        ]--    where xs' = List.nubBy ((==) `on` fst) xs-          ys' = List.nubBy ((==) `on` fst) ys--          xm = fromList xs'-          ym = fromList ys'--          testMergeWithKey f keep_x keep_y-            = toList (mergeWithKey f (keep keep_x) (keep keep_y) xm ym) == emulateMergeWithKey f keep_x keep_y-              where keep False _ = empty-                    keep True  m = m--                    emulateMergeWithKey f keep_x keep_y-                      = Maybe.mapMaybe combine (sort $ List.union (List.map fst xs') (List.map fst ys'))-                        where combine k = case (List.lookup k xs', List.lookup k ys') of-                                            (Nothing, Just y) -> if keep_y then Just (k, y) else Nothing-                                            (Just x, Nothing) -> if keep_x then Just (k, x) else Nothing-                                            (Just x, Just y) -> (\v -> (k, v)) `fmap` f k x y--          -- We prevent inlining testMergeWithKey to disable the SpecConstr-          -- optimalization. There are too many call patterns here so several-          -- warnings are issued if testMergeWithKey gets inlined.-          {-# NOINLINE testMergeWithKey #-}--------------------------------------------------------------------prop_ordered :: Property-prop_ordered-  = forAll (choose (5,100)) $ \n ->-    let xs = [(x,()) | x <- [0..n::Int]]-    in fromAscList xs == fromList xs--prop_list :: [Int] -> Bool-prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])--prop_descList :: [Int] -> Bool-prop_descList xs = (reverse (sort (nub xs)) == [x | (x,()) <- toDescList (fromList [(x,()) | x <- xs])])--prop_ascDescList :: [Int] -> Bool-prop_ascDescList xs = toAscList m == reverse (toDescList m)-  where m = fromList $ zip xs $ repeat ()--prop_fromList :: [Int] -> Property-prop_fromList xs-  = case fromList (zip xs xs) of-      t -> valid t .&&.-           t === fromAscList (zip sort_xs sort_xs) .&&.-           t === fromDistinctAscList (zip nub_sort_xs nub_sort_xs) .&&.-           t === List.foldr (uncurry insert) empty (zip xs xs)-  where sort_xs = sort xs-        nub_sort_xs = List.map List.head $ List.group sort_xs--------------------------------------------------------------------prop_alter :: UMap -> Int -> Property-prop_alter t k = valid t' .&&. case lookup k t of-    Just _  -> (size t - 1) == size t' && lookup k t' == Nothing-    Nothing -> (size t + 1) == size t' && lookup k t' /= Nothing-  where-    t' = alter f k t-    f Nothing   = Just ()-    f (Just ()) = Nothing----------------------------------------------------------------------------- Compare against the list model (after nub on keys)--prop_index :: [Int] -> Property-prop_index xs = length xs > 0 ==>-  let m  = fromList (zip xs xs)-  in  xs == [ m ! i | i <- xs ]--prop_index_lookup :: [Int] -> Property-prop_index_lookup xs = length xs > 0 ==>-  let m  = fromList (zip xs xs)-  in  (Prelude.map Just xs) == [ m !? i | i <- xs ]--prop_null :: IMap -> Bool-prop_null m = null m == (size m == 0)--prop_size :: UMap -> Property-prop_size im = sz === foldl' (\i _ -> i + 1) (0 :: Int) im .&&.-               sz === List.length (toList im)-  where sz = size im--prop_member :: [Int] -> Int -> Bool-prop_member xs n =-  let m  = fromList (zip xs xs)-  in all (\k -> k `member` m == (k `elem` xs)) (n : xs)--prop_notmember :: [Int] -> Int -> Bool-prop_notmember xs n =-  let m  = fromList (zip xs xs)-  in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs)--prop_lookup :: [(Int, Int)] -> Int -> Bool-prop_lookup xs n =-  let xs' = List.nubBy ((==) `on` fst) xs-      m = fromList xs'-  in all (\k -> lookup k m == List.lookup k xs') (n : List.map fst xs')--prop_find :: [(Int, Int)] -> Bool-prop_find xs =-  let xs' = List.nubBy ((==) `on` fst) xs-      m = fromList xs'-  in all (\(k, v) -> m ! k == v) xs'--prop_findWithDefault :: [(Int, Int)] -> Int -> Int -> Bool-prop_findWithDefault xs n x =-  let xs' = List.nubBy ((==) `on` fst) xs-      m = fromList xs'-  in all (\k -> findWithDefault x k m == maybe x id (List.lookup k xs')) (n : List.map fst xs')--test_lookupSomething :: (Int -> IntMap Int -> Maybe (Int, Int)) -> (Int -> Int -> Bool) -> [(Int, Int)] -> Bool-test_lookupSomething lookup' cmp xs =-  let odd_sorted_xs = filter_odd $ sort $ List.nubBy ((==) `on` fst) xs-      t = fromList odd_sorted_xs-      test k = case List.filter ((`cmp` k) . fst) odd_sorted_xs of-                 []             -> lookup' k t == Nothing-                 cs | 0 `cmp` 1 -> lookup' k t == Just (last cs) -- we want largest such element-                    | otherwise -> lookup' k t == Just (head cs) -- we want smallest such element-  in all test (List.map fst xs)--  where filter_odd [] = []-        filter_odd [_] = []-        filter_odd (_ : o : xs) = o : filter_odd xs--prop_lookupLT :: [(Int, Int)] -> Bool-prop_lookupLT = test_lookupSomething lookupLT (<)--prop_lookupGT :: [(Int, Int)] -> Bool-prop_lookupGT = test_lookupSomething lookupGT (>)--prop_lookupLE :: [(Int, Int)] -> Bool-prop_lookupLE = test_lookupSomething lookupLE (<=)--prop_lookupGE :: [(Int, Int)] -> Bool-prop_lookupGE = test_lookupSomething lookupGE (>=)--prop_lookupMin :: IntMap Int -> Property-prop_lookupMin im = lookupMin im === listToMaybe (toAscList im)--prop_lookupMax :: IntMap Int -> Property-prop_lookupMax im = lookupMax im === listToMaybe (toDescList im)--prop_findMin :: NonEmptyIntMap Int -> Property-prop_findMin (NonEmptyIntMap im) = findMin im === head (toAscList im)--prop_findMax :: NonEmptyIntMap Int -> Property-prop_findMax (NonEmptyIntMap im) = findMax im === head (toDescList im)--prop_deleteMinModel :: [(Int, Int)] -> Property-prop_deleteMinModel ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  toAscList (deleteMin m) == tail (sort xs)--prop_deleteMaxModel :: [(Int, Int)] -> Property-prop_deleteMaxModel ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  toAscList (deleteMax m) == init (sort xs)--prop_filter :: Fun Int Bool -> [(Int, Int)] -> Property-prop_filter p ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = filter (apply p) (fromList xs)-  in  valid m .&&.-      m === fromList (List.filter (apply p . snd) xs)--prop_partition :: Fun Int Bool -> [(Int, Int)] -> Property-prop_partition p ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m@(l, r) = partition (apply p) (fromList xs)-  in  valid l .&&.-      valid r .&&.-      m === let (a,b) = (List.partition (apply p . snd) xs)-            in (fromList a, fromList b)--prop_map :: Fun Int Int -> [(Int, Int)] -> Property-prop_map f ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  map (apply f) m == fromList [ (a, apply f b) | (a,b) <- xs ]--prop_fmap :: Fun Int Int -> [(Int, Int)] -> Property-prop_fmap f ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  fmap (apply f) m == fromList [ (a, apply f b) | (a,b) <- xs ]--prop_mapkeys :: Fun Int Int -> [(Int, Int)] -> Property-prop_mapkeys f ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  mapKeys (apply f) m == (fromList $ List.nubBy ((==) `on` fst) $ reverse [ (apply f a, b) | (a,b) <- sort xs])--prop_splitModel :: Int -> [(Int, Int)] -> Property-prop_splitModel n ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      (l, r) = split n $ fromList xs-  in  valid l .&&.-      valid r .&&.-      toAscList l === sort [(k, v) | (k,v) <- xs, k < n] .&&.-      toAscList r === sort [(k, v) | (k,v) <- xs, k > n]--prop_splitRoot :: IMap -> Bool-prop_splitRoot s = loop ls && (s == unions ls)- where-  ls = splitRoot s-  loop [] = True-  loop (s1:rst) = List.null-                  [ (x,y) | x <- toList s1-                          , y <- toList (unions rst)-                          , x > y ]--prop_foldr :: Int -> [(Int, Int)] -> Property-prop_foldr n ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  foldr (+) n m == List.foldr (+) n (List.map snd xs) &&-      foldr (:) [] m == List.map snd (List.sort xs) &&-      foldrWithKey (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) &&-      foldrWithKey (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) &&-      foldrWithKey (\k x xs -> (k,x):xs) [] m == List.sort xs---prop_foldr' :: Int -> [(Int, Int)] -> Property-prop_foldr' n ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  foldr' (+) n m == List.foldr (+) n (List.map snd xs) &&-      foldr' (:) [] m == List.map snd (List.sort xs) &&-      foldrWithKey' (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) &&-      foldrWithKey' (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) &&-      foldrWithKey' (\k x xs -> (k,x):xs) [] m == List.sort xs--prop_foldl :: Int -> [(Int, Int)] -> Property-prop_foldl n ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  foldl (+) n m == List.foldr (+) n (List.map snd xs) &&-      foldl (flip (:)) [] m == reverse (List.map snd (List.sort xs)) &&-      foldlWithKey (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) &&-      foldlWithKey (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) &&-      foldlWithKey (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs)--prop_foldl' :: Int -> [(Int, Int)] -> Property-prop_foldl' n ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  foldl' (+) n m == List.foldr (+) n (List.map snd xs) &&-      foldl' (flip (:)) [] m == reverse (List.map snd (List.sort xs)) &&-      foldlWithKey' (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) &&-      foldlWithKey' (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) &&-      foldlWithKey' (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs)--prop_keysSet :: [(Int, Int)] -> Bool-prop_keysSet xs =-  keysSet (fromList xs) == IntSet.fromList (List.map fst xs)--prop_fromSet :: [(Int, Int)] -> Bool-prop_fromSet ys =-  let xs = List.nubBy ((==) `on` fst) ys-  in fromSet (\k -> fromJust $ List.lookup k xs) (IntSet.fromList $ List.map fst xs) == fromList xs
− tests/intmap-strictness.hs 
@@ -1,125 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main (main) where--import Test.ChasingBottoms.IsBottom-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck (Arbitrary(arbitrary))-import Test.QuickCheck.Function (Fun(..), apply)--import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as M--instance Arbitrary v => Arbitrary (IntMap v) where-    arbitrary = M.fromList `fmap` arbitrary--apply2 :: Fun (a, b) c -> a -> b -> c-apply2 f a b = apply f (a, b)--apply3 :: Fun (a, b, c) d -> a -> b -> c -> d-apply3 f a b c = apply f (a, b, c)----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Strict module--pSingletonKeyStrict :: Int -> Bool-pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v--pSingletonValueStrict :: Int -> Bool-pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))--pFindWithDefaultKeyStrict :: Int -> IntMap Int -> Bool-pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m--pFindWithDefaultValueStrict :: Int -> IntMap Int -> Bool-pFindWithDefaultValueStrict k m =-    M.member k m || (isBottom $ M.findWithDefault bottom k m)--pAdjustKeyStrict :: Fun Int Int -> IntMap Int -> Bool-pAdjustKeyStrict f m = isBottom $ M.adjust (apply f) bottom m--pAdjustValueStrict :: Int -> IntMap Int -> Bool-pAdjustValueStrict k m-    | k `M.member` m = isBottom $ M.adjust (const bottom) k m-    | otherwise       = case M.keys m of-        []     -> True-        (k':_) -> isBottom $ M.adjust (const bottom) k' m--pInsertKeyStrict :: Int -> IntMap Int -> Bool-pInsertKeyStrict v m = isBottom $ M.insert bottom v m--pInsertValueStrict :: Int -> IntMap Int -> Bool-pInsertValueStrict k m = isBottom $ M.insert k bottom m--pInsertWithKeyStrict :: Fun (Int, Int) Int -> Int -> IntMap Int -> Bool-pInsertWithKeyStrict f v m = isBottom $ M.insertWith (apply2 f) bottom v m--pInsertWithValueStrict :: Fun (Int, Int) Int -> Int -> Int -> IntMap Int-                       -> Bool-pInsertWithValueStrict f k v m-    | M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&-                     not (isBottom $ M.insertWith (const2 1) k bottom m)-    | otherwise    = isBottom $ M.insertWith (apply2 f) k bottom m--pInsertLookupWithKeyKeyStrict :: Fun (Int, Int, Int) Int -> Int -> IntMap Int-                              -> Bool-pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey (apply3 f) bottom v m--pInsertLookupWithKeyValueStrict :: Fun (Int, Int, Int) Int -> Int -> Int-                                -> IntMap Int -> Bool-pInsertLookupWithKeyValueStrict f k v m-    | M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&-                     not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)-    | otherwise    = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m----------------------------------------------------------------------------- * Test list--tests :: [Test]-tests =-    [-    -- Basic interface-      testGroup "IntMap.Strict"-      [ testProperty "singleton is key-strict" pSingletonKeyStrict-      , testProperty "singleton is value-strict" pSingletonValueStrict-      , testProperty "member is key-strict" $ keyStrict M.member-      , testProperty "lookup is key-strict" $ keyStrict M.lookup-      , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict-      , testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict-      , testProperty "! is key-strict" $ keyStrict (flip (M.!))-      , testProperty "!? is key-strict" $ keyStrict (flip (M.!?))-      , testProperty "delete is key-strict" $ keyStrict M.delete-      , testProperty "adjust is key-strict" pAdjustKeyStrict-      , testProperty "adjust is value-strict" pAdjustValueStrict-      , testProperty "insert is key-strict" pInsertKeyStrict-      , testProperty "insert is value-strict" pInsertValueStrict-      , testProperty "insertWith is key-strict" pInsertWithKeyStrict-      , testProperty "insertWith is value-strict" pInsertWithValueStrict-      , testProperty "insertLookupWithKey is key-strict"-        pInsertLookupWithKeyKeyStrict-      , testProperty "insertLookupWithKey is value-strict"-        pInsertLookupWithKeyValueStrict-      ]-    ]----------------------------------------------------------------------------- * Test harness--main :: IO ()-main = defaultMain tests----------------------------------------------------------------------------- * Utilities--keyStrict :: (Int -> IntMap Int -> a) -> IntMap Int -> Bool-keyStrict f m = isBottom $ f bottom m--const2 :: a -> b -> c -> a-const2 x _ _ = x--const3 :: a -> b -> c -> d -> a-const3 x _ _ _ = x
− tests/intset-properties.hs 
@@ -1,400 +0,0 @@-{-# LANGUAGE CPP #-}-import Data.Bits ((.&.), popCount)-import Data.Word (Word)-import Data.IntSet-import Data.List (nub,sort)-import qualified Data.List as List-import Data.Monoid (mempty)-import qualified Data.Set as Set-import IntSetValidity (valid)-import Prelude hiding (lookup, null, map, filter, foldr, foldl)-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit hiding (Test, Testable)-import Test.QuickCheck hiding ((.&.))--main :: IO ()-main = defaultMain [ testCase "lookupLT" test_lookupLT-                   , testCase "lookupGT" test_lookupGT-                   , testCase "lookupLE" test_lookupLE-                   , testCase "lookupGE" test_lookupGE-                   , testCase "split" test_split-                   , testProperty "prop_Valid" prop_Valid-                   , testProperty "prop_EmptyValid" prop_EmptyValid-                   , testProperty "prop_SingletonValid" prop_SingletonValid-                   , testProperty "prop_InsertIntoEmptyValid" prop_InsertIntoEmptyValid-                   , testProperty "prop_Single" prop_Single-                   , testProperty "prop_Member" prop_Member-                   , testProperty "prop_NotMember" prop_NotMember-                   , testProperty "prop_LookupLT" prop_LookupLT-                   , testProperty "prop_LookupGT" prop_LookupGT-                   , testProperty "prop_LookupLE" prop_LookupLE-                   , testProperty "prop_LookupGE" prop_LookupGE-                   , testProperty "prop_InsertDelete" prop_InsertDelete-                   , testProperty "prop_MemberFromList" prop_MemberFromList-                   , testProperty "prop_UnionInsert" prop_UnionInsert-                   , testProperty "prop_UnionAssoc" prop_UnionAssoc-                   , testProperty "prop_UnionComm" prop_UnionComm-                   , testProperty "prop_Diff" prop_Diff-                   , testProperty "prop_Int" prop_Int-                   , testProperty "prop_Ordered" prop_Ordered-                   , testProperty "prop_List" prop_List-                   , testProperty "prop_DescList" prop_DescList-                   , testProperty "prop_AscDescList" prop_AscDescList-                   , testProperty "prop_fromList" prop_fromList-                   , testProperty "prop_MaskPow2" prop_MaskPow2-                   , testProperty "prop_Prefix" prop_Prefix-                   , testProperty "prop_LeftRight" prop_LeftRight-                   , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf-                   , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2-                   , testProperty "prop_isSubsetOf" prop_isSubsetOf-                   , testProperty "prop_isSubsetOf2" prop_isSubsetOf2-                   , testProperty "prop_disjoint" prop_disjoint-                   , testProperty "prop_size" prop_size-                   , testProperty "prop_findMax" prop_findMax-                   , testProperty "prop_findMin" prop_findMin-                   , testProperty "prop_ord" prop_ord-                   , testProperty "prop_readShow" prop_readShow-                   , testProperty "prop_foldR" prop_foldR-                   , testProperty "prop_foldR'" prop_foldR'-                   , testProperty "prop_foldL" prop_foldL-                   , testProperty "prop_foldL'" prop_foldL'-                   , testProperty "prop_map" prop_map-                   , testProperty "prop_maxView" prop_maxView-                   , testProperty "prop_minView" prop_minView-                   , testProperty "prop_split" prop_split-                   , testProperty "prop_splitMember" prop_splitMember-                   , testProperty "prop_splitRoot" prop_splitRoot-                   , testProperty "prop_partition" prop_partition-                   , testProperty "prop_filter" prop_filter-                   , testProperty "prop_bitcount" prop_bitcount-                   ]--------------------------------------------------------------------- Unit tests-------------------------------------------------------------------test_lookupLT :: Assertion-test_lookupLT = do-    lookupLT 3 (fromList [3, 5]) @?= Nothing-    lookupLT 5 (fromList [3, 5]) @?= Just 3--test_lookupGT :: Assertion-test_lookupGT = do-   lookupGT 4 (fromList [3, 5]) @?= Just 5-   lookupGT 5 (fromList [3, 5]) @?= Nothing--test_lookupLE :: Assertion-test_lookupLE = do-   lookupLE 2 (fromList [3, 5]) @?= Nothing-   lookupLE 4 (fromList [3, 5]) @?= Just 3-   lookupLE 5 (fromList [3, 5]) @?= Just 5--test_lookupGE :: Assertion-test_lookupGE = do-   lookupGE 3 (fromList [3, 5]) @?= Just 3-   lookupGE 4 (fromList [3, 5]) @?= Just 5-   lookupGE 6 (fromList [3, 5]) @?= Nothing--test_split :: Assertion-test_split = do-   split 3 (fromList [1..5]) @?= (fromList [1,2], fromList [4,5])--{---------------------------------------------------------------------  Arbitrary, reasonably balanced trees---------------------------------------------------------------------}-instance Arbitrary IntSet where-  arbitrary = do{ xs <- arbitrary-                ; return (fromList xs)-                }--{---------------------------------------------------------------------  Valid IntMaps---------------------------------------------------------------------}-forValid :: Testable a => (IntSet -> a) -> Property-forValid f = forAll arbitrary $ \t ->-    classify (size t == 0) "empty" $-    classify (size t > 0 && size t <= 10) "small" $-    classify (size t > 10 && size t <= 64) "medium" $-    classify (size t > 64) "large" $ f t--forValidUnitTree :: Testable a => (IntSet -> a) -> Property-forValidUnitTree f = forValid f--prop_Valid :: Property-prop_Valid = forValidUnitTree $ \t -> valid t--{---------------------------------------------------------------------  Construction validity---------------------------------------------------------------------}--prop_EmptyValid :: Property-prop_EmptyValid =-    valid empty--prop_SingletonValid :: Int -> Property-prop_SingletonValid x =-    valid (singleton x)--prop_InsertIntoEmptyValid :: Int -> Property-prop_InsertIntoEmptyValid x =-    valid (insert x empty)--{---------------------------------------------------------------------  Single, Member, Insert, Delete, Member, FromList---------------------------------------------------------------------}-prop_Single :: Int -> Bool-prop_Single x-  = (insert x empty == singleton x)--prop_Member :: [Int] -> Int -> Bool-prop_Member xs n =-  let m  = fromList xs-  in all (\k -> k `member` m == (k `elem` xs)) (n : xs)--prop_NotMember :: [Int] -> Int -> Bool-prop_NotMember xs n =-  let m  = fromList xs-  in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs)--test_LookupSomething :: (Int -> IntSet -> Maybe Int) -> (Int -> Int -> Bool) -> [Int] -> Bool-test_LookupSomething lookup' cmp xs =-  let odd_sorted_xs = filter_odd $ nub $ sort xs-      t = fromList odd_sorted_xs-      test x = case List.filter (`cmp` x) odd_sorted_xs of-                 []             -> lookup' x t == Nothing-                 cs | 0 `cmp` 1 -> lookup' x t == Just (last cs) -- we want largest such element-                    | otherwise -> lookup' x t == Just (head cs) -- we want smallest such element-  in all test xs--  where filter_odd [] = []-        filter_odd [_] = []-        filter_odd (_ : o : xs) = o : filter_odd xs--prop_LookupLT :: [Int] -> Bool-prop_LookupLT = test_LookupSomething lookupLT (<)--prop_LookupGT :: [Int] -> Bool-prop_LookupGT = test_LookupSomething lookupGT (>)--prop_LookupLE :: [Int] -> Bool-prop_LookupLE = test_LookupSomething lookupLE (<=)--prop_LookupGE :: [Int] -> Bool-prop_LookupGE = test_LookupSomething lookupGE (>=)--prop_InsertDelete :: Int -> IntSet -> Property-prop_InsertDelete k t-  = not (member k t) ==>-      case delete k (insert k t) of-        t' -> valid t' .&&. t' === t--prop_MemberFromList :: [Int] -> Bool-prop_MemberFromList xs-  = all (`member` t) abs_xs && all ((`notMember` t) . negate) abs_xs-  where abs_xs = [abs x | x <- xs, x /= 0]-        t = fromList abs_xs--{---------------------------------------------------------------------  Union, Difference and Intersection---------------------------------------------------------------------}-prop_UnionInsert :: Int -> IntSet -> Property-prop_UnionInsert x t =-  case union t (singleton x) of-    t' ->-      valid t' .&&.-      t' === insert x t--prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool-prop_UnionAssoc t1 t2 t3-  = union t1 (union t2 t3) == union (union t1 t2) t3--prop_UnionComm :: IntSet -> IntSet -> Bool-prop_UnionComm t1 t2-  = (union t1 t2 == union t2 t1)--prop_Diff :: [Int] -> [Int] -> Property-prop_Diff xs ys =-  case difference (fromList xs) (fromList ys) of-    t ->-      valid t .&&.-      toAscList t === List.sort ((List.\\) (nub xs)  (nub ys))--prop_Int :: [Int] -> [Int] -> Property-prop_Int xs ys =-  case intersection (fromList xs) (fromList ys) of-    t ->-      valid t .&&.-      toAscList t === List.sort (nub ((List.intersect) (xs)  (ys)))--prop_disjoint :: IntSet -> IntSet -> Bool-prop_disjoint a b = a `disjoint` b == null (a `intersection` b)--{---------------------------------------------------------------------  Lists---------------------------------------------------------------------}-prop_Ordered-  = forAll (choose (5,100)) $ \n ->-    let xs = concat [[i-n,i-n]|i<-[0..2*n :: Int]]-    in fromAscList xs == fromList xs--prop_List :: [Int] -> Bool-prop_List xs-  = (sort (nub xs) == toAscList (fromList xs))--prop_DescList :: [Int] -> Bool-prop_DescList xs = (reverse (sort (nub xs)) == toDescList (fromList xs))--prop_AscDescList :: [Int] -> Bool-prop_AscDescList xs = toAscList s == reverse (toDescList s)-  where s = fromList xs--prop_fromList :: [Int] -> Property-prop_fromList xs-  = case fromList xs of-      t -> valid t .&&.-           t === fromAscList sort_xs .&&.-           t === fromDistinctAscList nub_sort_xs .&&.-           t === List.foldr insert empty xs-  where sort_xs = sort xs-        nub_sort_xs = List.map List.head $ List.group sort_xs--{---------------------------------------------------------------------  Bin invariants---------------------------------------------------------------------}-powersOf2 :: IntSet-powersOf2 = fromList [2^i | i <- [0..63]]---- Check the invariant that the mask is a power of 2.-prop_MaskPow2 :: IntSet -> Bool-prop_MaskPow2 (Bin _ msk left right) = member msk powersOf2 && prop_MaskPow2 left && prop_MaskPow2 right-prop_MaskPow2 _ = True---- Check that the prefix satisfies its invariant.-prop_Prefix :: IntSet -> Bool-prop_Prefix s@(Bin prefix msk left right) = all (\elem -> match elem prefix msk) (toList s) && prop_Prefix left && prop_Prefix right-prop_Prefix _ = True---- Check that the left elements don't have the mask bit set, and the right--- ones do.-prop_LeftRight :: IntSet -> Bool-prop_LeftRight (Bin _ msk left right) = and [x .&. msk == 0 | x <- toList left] && and [x .&. msk == msk | x <- toList right]-prop_LeftRight _ = True--{---------------------------------------------------------------------  IntSet operations are like Set operations---------------------------------------------------------------------}-toSet :: IntSet -> Set.Set Int-toSet = Set.fromList . toList---- Check that IntSet.isProperSubsetOf is the same as Set.isProperSubsetOf.-prop_isProperSubsetOf :: IntSet -> IntSet -> Bool-prop_isProperSubsetOf a b = isProperSubsetOf a b == Set.isProperSubsetOf (toSet a) (toSet b)---- In the above test, isProperSubsetOf almost always returns False (since a--- random set is almost never a subset of another random set).  So this second--- test checks the True case.-prop_isProperSubsetOf2 :: IntSet -> IntSet -> Bool-prop_isProperSubsetOf2 a b = isProperSubsetOf a c == (a /= c) where-  c = union a b--prop_isSubsetOf :: IntSet -> IntSet -> Bool-prop_isSubsetOf a b = isSubsetOf a b == Set.isSubsetOf (toSet a) (toSet b)--prop_isSubsetOf2 :: IntSet -> IntSet -> Bool-prop_isSubsetOf2 a b = isSubsetOf a (union a b)--prop_size :: IntSet -> Property-prop_size s = sz === foldl' (\i _ -> i + 1) (0 :: Int) s .&&.-              sz === List.length (toList s)-  where sz = size s--prop_findMax :: IntSet -> Property-prop_findMax s = not (null s) ==> findMax s == maximum (toList s)--prop_findMin :: IntSet -> Property-prop_findMin s = not (null s) ==> findMin s == minimum (toList s)--prop_ord :: IntSet -> IntSet -> Bool-prop_ord s1 s2 = s1 `compare` s2 == toList s1 `compare` toList s2--prop_readShow :: IntSet -> Bool-prop_readShow s = s == read (show s)--prop_foldR :: IntSet -> Bool-prop_foldR s = foldr (:) [] s == toList s--prop_foldR' :: IntSet -> Bool-prop_foldR' s = foldr' (:) [] s == toList s--prop_foldL :: IntSet -> Bool-prop_foldL s = foldl (flip (:)) [] s == List.foldl (flip (:)) [] (toList s)--prop_foldL' :: IntSet -> Bool-prop_foldL' s = foldl' (flip (:)) [] s == List.foldl' (flip (:)) [] (toList s)--prop_map :: IntSet -> Bool-prop_map s = map id s == s--prop_maxView :: IntSet -> Bool-prop_maxView s = case maxView s of-    Nothing -> null s-    Just (m,s') -> m == maximum (toList s) && s == insert m s' && m `notMember` s'--prop_minView :: IntSet -> Bool-prop_minView s = case minView s of-    Nothing -> null s-    Just (m,s') -> m == minimum (toList s) && s == insert m s' && m `notMember` s'--prop_split :: IntSet -> Int -> Property-prop_split s i = case split i s of-    (s1,s2) -> valid s1 .&&.-               valid s2 .&&.-               all (<i) (toList s1) .&&.-               all (>i) (toList s2) .&&.-               i `delete` s === union s1 s2--prop_splitMember :: IntSet -> Int -> Property-prop_splitMember s i = case splitMember i s of-    (s1,t,s2) -> valid s1 .&&.-                 valid s2 .&&.-                 all (<i) (toList s1) .&&.-                 all (>i) (toList s2) .&&.-                 t === i `member` s .&&.-                 i `delete` s === union s1 s2--prop_splitRoot :: IntSet -> Bool-prop_splitRoot s = loop ls && (s == unions ls)- where-  ls = splitRoot s-  loop [] = True-  loop (s1:rst) = List.null-                  [ (x,y) | x <- toList s1-                          , y <- toList (unions rst)-                          , x > y ]--prop_partition :: IntSet -> Int -> Property-prop_partition s i = case partition odd s of-    (s1,s2) -> valid s1 .&&.-               valid s2 .&&.-               all odd (toList s1) .&&.-               all even (toList s2) .&&.-               s === s1 `union` s2--prop_filter :: IntSet -> Int -> Property-prop_filter s i =-  let parts = partition odd s-      odds = filter odd s-      evens = filter even s-  in valid odds .&&.-     valid evens .&&.-     parts === (odds, evens)--prop_bitcount :: Int -> Word -> Bool-prop_bitcount a w = bitcount_orig a w == bitcount_new a w-  where-    bitcount_orig a0 x0 = go a0 x0-      where go a 0 = a-            go a x = go (a + 1) (x .&. (x-1))-    bitcount_new a x = a + popCount x
− tests/intset-strictness.hs 
@@ -1,43 +0,0 @@-module Main (main) where--import Prelude hiding (foldl)--import Test.ChasingBottoms.IsBottom-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)--import Data.IntSet----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Lazy module--pFoldlAccLazy :: Int -> Bool-pFoldlAccLazy k =-  isn'tBottom $ foldl (\_ x -> x) (bottom :: Int) (singleton k)----------------------------------------------------------------------------- * Test list--tests :: [Test]-tests =-    [-    -- Basic interface-      testGroup "IntSet"-      [ testProperty "foldl is lazy in accumulator" pFoldlAccLazy-      ]-    ]----------------------------------------------------------------------------- * Test harness--main :: IO ()-main = defaultMain tests----------------------------------------------------------------------------- * Utilities--isn'tBottom :: a -> Bool-isn'tBottom = not . isBottom
− tests/listutils-properties.hs 
@@ -1,60 +0,0 @@-module Main where--import Data.List (nub, nubBy)-import Data.Containers.ListUtils-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck (Property, (===))-import Test.QuickCheck.Function (Fun, apply)-import Test.QuickCheck.Poly (A, OrdA, B, OrdB, C)--main :: IO ()-main = defaultMain-         [ testProperty "nubOrd" prop_nubOrd-         , testProperty "nubOrdOn" prop_nubOrdOn-         , testProperty "nubOrdOn fusion" prop_nubOrdOnFusion-         , testProperty "nubInt" prop_nubInt-         , testProperty "nubIntOn" prop_nubIntOn-         , testProperty "nubIntOn fusion" prop_nubIntOnFusion-         ]---prop_nubOrd :: [OrdA] -> Property-prop_nubOrd xs = nubOrd xs === nub xs--prop_nubInt :: [Int] -> Property-prop_nubInt xs = nubInt xs === nub xs--prop_nubOrdOn :: Fun A OrdB -> [A] -> Property-prop_nubOrdOn f' xs =-  nubOrdOn f xs === nubBy (\x y -> f x == f y) xs-  where f = apply f'--prop_nubIntOn :: Fun A Int -> [A] -> Property-prop_nubIntOn f' xs =-  nubIntOn f xs === nubBy (\x y -> f x == f y) xs-  where f = apply f'--prop_nubOrdOnFusion :: Fun B C-                    -> Fun B OrdB-                    -> Fun A B-                    -> [A] -> Property-prop_nubOrdOnFusion f' g' h' xs =-  (map f . nubOrdOn g . map h $ xs)-    === (map f . nubBy (\x y -> g x == g y) . map h $ xs)-  where-    f = apply f'-    g = apply g'-    h = apply h'--prop_nubIntOnFusion :: Fun B C-                    -> Fun B Int-                    -> Fun A B-                    -> [A] -> Property-prop_nubIntOnFusion f' g' h' xs =-  (map f . nubIntOn g . map h $ xs)-    === (map f . nubBy (\x y -> g x == g y) . map h $ xs)-  where-    f = apply f'-    g = apply g'-    h = apply h'
− tests/map-properties.hs 
@@ -1,1400 +0,0 @@-{-# LANGUAGE CPP #-}--#ifdef STRICT-import Data.Map.Strict as Data.Map hiding (showTree, showTreeWith)-import Data.Map.Merge.Strict-#else-import Data.Map.Lazy as Data.Map hiding (showTree, showTreeWith)-import Data.Map.Merge.Lazy-#endif-import Data.Map.Internal (Map (..), link2, link, bin)-import Data.Map.Internal.Debug (showTree, showTreeWith, balanced)--import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>))-import Data.Functor.Identity (Identity(runIdentity))-import Data.Monoid-import Data.Maybe hiding (mapMaybe)-import qualified Data.Maybe as Maybe (mapMaybe)-import Data.Ord-import Data.Function-import Prelude hiding (lookup, null, map, filter, foldr, foldl, take, drop, splitAt)-import qualified Prelude--import Data.List (nub,sort)-import qualified Data.List as List-import qualified Data.Set as Set-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit hiding (Test, Testable)-import Test.QuickCheck-import Test.QuickCheck.Function (Fun (..), apply)-import Test.QuickCheck.Poly (A, B)-import Control.Arrow (first)--default (Int)--apply3 :: Fun (a,b,c) d -> a -> b -> c -> d-apply3 f a b c = apply f (a, b, c)--apply2 :: Fun (a,b) c -> a -> b -> c-apply2 f a b = apply f (a, b)--main :: IO ()-main = defaultMain-         [ testCase "ticket4242" test_ticket4242-         , testCase "index"      test_index-         , testCase "size"       test_size-         , testCase "size2"      test_size2-         , testCase "member"     test_member-         , testCase "notMember"  test_notMember-         , testCase "lookup"     test_lookup-         , testCase "findWithDefault"     test_findWithDefault-         , testCase "lookupLT"   test_lookupLT-         , testCase "lookupGT"   test_lookupGT-         , testCase "lookupLE"   test_lookupLE-         , testCase "lookupGE"   test_lookupGE-         , testCase "empty" test_empty-         , testCase "mempty" test_mempty-         , testCase "singleton" test_singleton-         , testCase "insert" test_insert-         , testCase "insertWith" test_insertWith-         , testCase "insertWithKey" test_insertWithKey-         , testCase "insertLookupWithKey" test_insertLookupWithKey-         , testCase "delete" test_delete-         , testCase "adjust" test_adjust-         , testCase "adjustWithKey" test_adjustWithKey-         , testCase "update" test_update-         , testCase "updateWithKey" test_updateWithKey-         , testCase "updateLookupWithKey" test_updateLookupWithKey-         , testCase "alter" test_alter-         , testCase "at" test_at-         , testCase "union" test_union-         , testCase "mappend" test_mappend-         , testCase "unionWith" test_unionWith-         , testCase "unionWithKey" test_unionWithKey-         , testCase "unions" test_unions-         , testCase "mconcat" test_mconcat-         , testCase "unionsWith" test_unionsWith-         , testCase "difference" test_difference-         , testCase "differenceWith" test_differenceWith-         , testCase "differenceWithKey" test_differenceWithKey-         , testCase "intersection" test_intersection-         , testCase "intersectionWith" test_intersectionWith-         , testCase "intersectionWithKey" test_intersectionWithKey-         , testCase "map" test_map-         , testCase "mapWithKey" test_mapWithKey-         , testCase "mapAccum" test_mapAccum-         , testCase "mapAccumWithKey" test_mapAccumWithKey-         , testCase "mapAccumRWithKey" test_mapAccumRWithKey-         , testCase "mapKeys" test_mapKeys-         , testCase "mapKeysWith" test_mapKeysWith-         , testCase "mapKeysMonotonic" test_mapKeysMonotonic-         , testCase "elems" test_elems-         , testCase "keys" test_keys-         , testCase "assocs" test_assocs-         , testCase "keysSet" test_keysSet-         , testCase "fromSet" test_fromSet-         , testCase "toList" test_toList-         , testCase "fromList" test_fromList-         , testCase "fromListWith" test_fromListWith-         , testCase "fromListWithKey" test_fromListWithKey-         , testCase "toAscList" test_toAscList-         , testCase "toDescList" test_toDescList-         , testCase "showTree" test_showTree-         , testCase "showTree'" test_showTree'-         , testCase "fromAscList" test_fromAscList-         , testCase "fromAscListWith" test_fromAscListWith-         , testCase "fromAscListWithKey" test_fromAscListWithKey-         , testCase "fromDistinctAscList" test_fromDistinctAscList-         , testCase "fromDistinctDescList" test_fromDistinctDescList-         , testCase "filter" test_filter-         , testCase "filterWithKey" test_filteWithKey-         , testCase "partition" test_partition-         , testCase "partitionWithKey" test_partitionWithKey-         , testCase "mapMaybe" test_mapMaybe-         , testCase "mapMaybeWithKey" test_mapMaybeWithKey-         , testCase "mapEither" test_mapEither-         , testCase "mapEitherWithKey" test_mapEitherWithKey-         , testCase "split" test_split-         , testCase "splitLookup" test_splitLookup-         , testCase "isSubmapOfBy" test_isSubmapOfBy-         , testCase "isSubmapOf" test_isSubmapOf-         , testCase "isProperSubmapOfBy" test_isProperSubmapOfBy-         , testCase "isProperSubmapOf" test_isProperSubmapOf-         , testCase "lookupIndex" test_lookupIndex-         , testCase "findIndex" test_findIndex-         , testCase "elemAt" test_elemAt-         , testCase "updateAt" test_updateAt-         , testCase "deleteAt" test_deleteAt-         , testCase "findMin" test_findMin-         , testCase "findMax" test_findMax-         , testCase "deleteMin" test_deleteMin-         , testCase "deleteMax" test_deleteMax-         , testCase "deleteFindMin" test_deleteFindMin-         , testCase "deleteFindMax" test_deleteFindMax-         , testCase "updateMin" test_updateMin-         , testCase "updateMax" test_updateMax-         , testCase "updateMinWithKey" test_updateMinWithKey-         , testCase "updateMaxWithKey" test_updateMaxWithKey-         , testCase "minView" test_minView-         , testCase "maxView" test_maxView-         , testCase "minViewWithKey" test_minViewWithKey-         , testCase "maxViewWithKey" test_maxViewWithKey-         , testCase "valid" test_valid-         , testProperty "valid"                prop_valid-         , testProperty "insert to singleton"  prop_singleton-         , testProperty "insert"               prop_insert-         , testProperty "insert then lookup"   prop_insertLookup-         , testProperty "insert then delete"   prop_insertDelete-         , testProperty "insert then delete2"  prop_insertDelete2-         , testProperty "delete non member"    prop_deleteNonMember-         , testProperty "deleteMin"            prop_deleteMin-         , testProperty "deleteMax"            prop_deleteMax-         , testProperty "split"                prop_split-         , testProperty "splitRoot"            prop_splitRoot-         , testProperty "split then link"      prop_link-         , testProperty "split then link2"     prop_link2-         , testProperty "union"                prop_union-         , testProperty "union model"          prop_unionModel-         , testProperty "union singleton"      prop_unionSingleton-         , testProperty "union associative"    prop_unionAssoc-         , testProperty "union+unionWith"      prop_unionWith-         , testProperty "unionWith"            prop_unionWith2-         , testProperty "union sum"            prop_unionSum-         , testProperty "difference"           prop_difference-         , testProperty "difference model"     prop_differenceModel-         , testProperty "withoutKeys"          prop_withoutKeys-         , testProperty "intersection"         prop_intersection-         , testProperty "restrictKeys"         prop_restrictKeys-         , testProperty "intersection model"   prop_intersectionModel-         , testProperty "intersectionWith"     prop_intersectionWith-         , testProperty "intersectionWithModel" prop_intersectionWithModel-         , testProperty "intersectionWithKey"  prop_intersectionWithKey-         , testProperty "intersectionWithKeyModel" prop_intersectionWithKeyModel-         , testProperty "differenceMerge"   prop_differenceMerge-         , testProperty "unionWithKeyMerge"   prop_unionWithKeyMerge-         , testProperty "mergeWithKey model"   prop_mergeWithKeyModel-         , testProperty "fromAscList"          prop_ordered-         , testProperty "fromDescList"         prop_rev_ordered-         , testProperty "fromDistinctDescList" prop_fromDistinctDescList-         , testProperty "fromList then toList" prop_list-         , testProperty "toDescList"           prop_descList-         , testProperty "toAscList+toDescList" prop_ascDescList-         , testProperty "fromList"             prop_fromList-         , testProperty "alter"                prop_alter-         , testProperty "alterF/alter"         prop_alterF_alter-         , testProperty "alterF/alter/noRULES" prop_alterF_alter_noRULES-         , testProperty "alterF/lookup"        prop_alterF_lookup-         , testProperty "alterF/lookup/noRULES" prop_alterF_lookup_noRULES-         , testProperty "index"                prop_index-         , testProperty "null"                 prop_null-         , testProperty "member"               prop_member-         , testProperty "notmember"            prop_notmember-         , testProperty "lookup"               prop_lookup-         , testProperty "find"                 prop_find-         , testProperty "findWithDefault"      prop_findWithDefault-         , testProperty "lookupLT"             prop_lookupLT-         , testProperty "lookupGT"             prop_lookupGT-         , testProperty "lookupLE"             prop_lookupLE-         , testProperty "lookupGE"             prop_lookupGE-         , testProperty "findIndex"            prop_findIndex-         , testProperty "lookupIndex"          prop_lookupIndex-         , testProperty "findMin"              prop_findMin-         , testProperty "findMax"              prop_findMax-         , testProperty "deleteMin"            prop_deleteMinModel-         , testProperty "deleteMax"            prop_deleteMaxModel-         , testProperty "filter"               prop_filter-         , testProperty "partition"            prop_partition-         , testProperty "map"                  prop_map-         , testProperty "fmap"                 prop_fmap-         , testProperty "mapkeys"              prop_mapkeys-         , testProperty "split"                prop_splitModel-         , testProperty "foldr"                prop_foldr-         , testProperty "foldr'"               prop_foldr'-         , testProperty "foldl"                prop_foldl-         , testProperty "foldl'"               prop_foldl'-         , testProperty "keysSet"              prop_keysSet-         , testProperty "fromSet"              prop_fromSet-         , testProperty "takeWhileAntitone"    prop_takeWhileAntitone-         , testProperty "dropWhileAntitone"    prop_dropWhileAntitone-         , testProperty "spanAntitone"         prop_spanAntitone-         , testProperty "take"                 prop_take-         , testProperty "drop"                 prop_drop-         , testProperty "splitAt"              prop_splitAt-         , testProperty "lookupMin"            prop_lookupMin-         , testProperty "lookupMax"            prop_lookupMax-         ]--{---------------------------------------------------------------------  Arbitrary trees---------------------------------------------------------------------}-instance (Enum k,Arbitrary a) => Arbitrary (Map k a) where-  arbitrary = sized (arbtree 0 maxkey)-    where maxkey = 10^(5 :: Int)--          arbtree :: (Enum k, Arbitrary a) => Int -> Int -> Int -> Gen (Map k a)-          arbtree lo hi n = do t <- gentree lo hi n-                               if balanced t then return t else arbtree lo hi n-            where gentree lo hi n-                    | n <= 0        = return Tip-                    | lo >= hi      = return Tip-                    | otherwise     = do{ x  <- arbitrary-                                        ; i  <- choose (lo,hi)-                                        ; m  <- choose (1,70)-                                        ; let (ml,mr)  | m==(1::Int)= (1,2)-                                                       | m==2       = (2,1)-                                                       | m==3       = (1,1)-                                                       | otherwise  = (2,2)-                                        ; l  <- gentree lo (i-1) (n `div` ml)-                                        ; r  <- gentree (i+1) hi (n `div` mr)-                                        ; return (bin (toEnum i) x l r)-                                        }---- A type with a peculiar Eq instance designed to make sure keys--- come from where they're supposed to.-data OddEq a = OddEq a Bool deriving (Show)-getOddEq :: OddEq a -> (a, Bool)-getOddEq (OddEq a b) = (a, b)-instance Arbitrary a => Arbitrary (OddEq a) where-  arbitrary = OddEq <$> arbitrary <*> arbitrary-instance Eq a => Eq (OddEq a) where-  OddEq x _ == OddEq y _ = x == y-instance Ord a => Ord (OddEq a) where-  OddEq x _ `compare` OddEq y _ = x `compare` y----------------------------------------------------------------------------type UMap = Map Int ()-type IMap = Map Int Int-type SMap = Map Int String--------------------------------------------------------------------- Unit tests-------------------------------------------------------------------test_ticket4242 :: Assertion-test_ticket4242 = (valid $ deleteMin $ deleteMin $ fromList [ (i, ()) | i <- [0,2,5,1,6,4,8,9,7,11,10,3] :: [Int] ]) @?= True--------------------------------------------------------------------- Operators--test_index :: Assertion-test_index = fromList [(5,'a'), (3,'b')] ! 5 @?= 'a'--------------------------------------------------------------------- Query--test_size :: Assertion-test_size = do-    null (empty)           @?= True-    null (singleton 1 'a') @?= False--test_size2 :: Assertion-test_size2 = do-    size empty                                   @?= 0-    size (singleton 1 'a')                       @?= 1-    size (fromList([(1,'a'), (2,'c'), (3,'b')])) @?= 3--test_member :: Assertion-test_member = do-    member 5 (fromList [(5,'a'), (3,'b')]) @?= True-    member 1 (fromList [(5,'a'), (3,'b')]) @?= False--test_notMember :: Assertion-test_notMember = do-    notMember 5 (fromList [(5,'a'), (3,'b')]) @?= False-    notMember 1 (fromList [(5,'a'), (3,'b')]) @?= True--test_lookup :: Assertion-test_lookup = do-    employeeCurrency "John" @?= Just "Euro"-    employeeCurrency "Pete" @?= Nothing-  where-    employeeDept = fromList([("John","Sales"), ("Bob","IT")])-    deptCountry = fromList([("IT","USA"), ("Sales","France")])-    countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])-    employeeCurrency :: String -> Maybe String-    employeeCurrency name = do-        dept <- lookup name employeeDept-        country <- lookup dept deptCountry-        lookup country countryCurrency--test_findWithDefault :: Assertion-test_findWithDefault = do-    findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) @?= 'x'-    findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) @?= 'a'--test_lookupLT :: Assertion-test_lookupLT = do-    lookupLT 3 (fromList [(3,'a'), (5,'b')]) @?= Nothing-    lookupLT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (3, 'a')--test_lookupGT :: Assertion-test_lookupGT = do-    lookupGT 4 (fromList [(3,'a'), (5,'b')]) @?= Just (5, 'b')-    lookupGT 5 (fromList [(3,'a'), (5,'b')]) @?= Nothing--test_lookupLE :: Assertion-test_lookupLE = do-    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')--test_lookupGE :: Assertion-test_lookupGE = do-    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--------------------------------------------------------------------- Construction--test_empty :: Assertion-test_empty = do-    (empty :: UMap)  @?= fromList []-    size empty @?= 0--test_mempty :: Assertion-test_mempty = do-    (mempty :: UMap)  @?= fromList []-    size (mempty :: UMap) @?= 0--test_singleton :: Assertion-test_singleton = do-    singleton 1 'a'        @?= fromList [(1, 'a')]-    size (singleton 1 'a') @?= 1--test_insert :: Assertion-test_insert = do-    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'--test_insertWith :: Assertion-test_insertWith = do-    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"--test_insertWithKey :: Assertion-test_insertWithKey = do-    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"-  where-    f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--test_insertLookupWithKey :: Assertion-test_insertLookupWithKey = do-    insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])-    insertLookupWithKey f 2 "xxx" (fromList [(5,"a"), (3,"b")]) @?= (Nothing,fromList [(2,"xxx"),(3,"b"),(5,"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")-  where-    f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value--------------------------------------------------------------------- Delete/Update--test_delete :: Assertion-test_delete = do-    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 :: IMap)--test_adjust :: Assertion-test_adjust = do-    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--test_adjustWithKey :: Assertion-test_adjustWithKey = do-    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-  where-    f key x = (show key) ++ ":new " ++ x--test_update :: Assertion-test_update = do-    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"-  where-    f x = if x == "a" then Just "new a" else Nothing--test_updateWithKey :: Assertion-test_updateWithKey = do-    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"- where-     f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--test_updateLookupWithKey :: Assertion-test_updateLookupWithKey = do-    updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) @?= (Just "5:new a", fromList [(3, "b"), (5, "5:new a")])-    updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) @?= (Nothing,  fromList [(3, "b"), (5, "a")])-    updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) @?= (Just "b", singleton 5 "a")-  where-    f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing--test_alter :: Assertion-test_alter = do-    alter f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]-    alter f 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"-    alter g 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "c")]-    alter g 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "c")]-  where-    f _ = Nothing-    g _ = Just "c"--test_at :: Assertion-test_at = do-    employeeCurrency "John" @?= Just "Euro"-    employeeCurrency "Pete" @?= Nothing-    atAlter f 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a")]-    atAlter f 5 (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"-    atAlter g 7 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "a"), (7, "c")]-    atAlter g 5 (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "c")]-  where-    f _ = Nothing-    g _ = Just "c"-    employeeDept = fromList([("John","Sales"), ("Bob","IT")])-    deptCountry = fromList([("IT","USA"), ("Sales","France")])-    countryCurrency = fromList([("USA", "Dollar"), ("France", "Euro")])-    employeeCurrency :: String -> Maybe String-    employeeCurrency name = do-        dept <- atLookup name employeeDept-        country <- atLookup dept deptCountry-        atLookup country countryCurrency---- This version of atAlter will rewrite to alterFIdentity--- if the rules fire.-atAlter :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a-atAlter f k m = runIdentity (alterF (pure . f) k m)---- A version of atAlter that uses a private copy of Identity--- to ensure that the adjustF/Identity rules don't fire and--- we use the basic implementation.-atAlterNoRULES :: Ord k => (Maybe a -> Maybe a) -> k -> Map k a -> Map k a-atAlterNoRULES f k m = runIdent (alterF (Ident . f) k m)--newtype Ident a = Ident { runIdent :: a }-instance Functor Ident where-  fmap f (Ident a) = Ident (f a)--atLookup :: Ord k => k -> Map k a -> Maybe a-atLookup k m = getConst (alterF Const k m)--atLookupNoRULES :: Ord k => k -> Map k a -> Maybe a-atLookupNoRULES k m = getConsty (alterF Consty k m)--newtype Consty a b = Consty { getConsty :: a}-instance Functor (Consty a) where-  fmap _ (Consty a) = Consty a--------------------------------------------------------------------- Combine--test_union :: Assertion-test_union = union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")]--test_mappend :: Assertion-test_mappend = mappend (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "a"), (7, "C")]--test_unionWith :: Assertion-test_unionWith = unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "aA"), (7, "C")]--test_unionWithKey :: Assertion-test_unionWithKey = unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= fromList [(3, "b"), (5, "5:a|A"), (7, "C")]-  where-    f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value--test_unions :: Assertion-test_unions = do-    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")]--test_mconcat :: Assertion-test_mconcat = do-    mconcat [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]-        @?= fromList [(3, "b"), (5, "a"), (7, "C")]-    mconcat [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]-        @?= fromList [(3, "B3"), (5, "A3"), (7, "C")]--test_unionsWith :: Assertion-test_unionsWith = unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]-     @?= fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]--test_difference :: Assertion-test_difference = difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 3 "b"--test_differenceWith :: Assertion-test_differenceWith = differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])-     @?= singleton 3 "b:B"- where-   f al ar = if al== "b" then Just (al ++ ":" ++ ar) else Nothing--test_differenceWithKey :: Assertion-test_differenceWithKey = differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])-     @?= singleton 3 "3:b|B"-  where-    f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing--test_intersection :: Assertion-test_intersection = intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "a"---test_intersectionWith :: Assertion-test_intersectionWith = intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "aA"--test_intersectionWithKey :: Assertion-test_intersectionWithKey = intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) @?= singleton 5 "5:a|A"-  where-    f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar--------------------------------------------------------------------- Traversal--test_map :: Assertion-test_map = map (++ "x") (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "bx"), (5, "ax")]--test_mapWithKey :: Assertion-test_mapWithKey = mapWithKey f (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "3:b"), (5, "5:a")]-  where-    f key x = (show key) ++ ":" ++ x--test_mapAccum :: Assertion-test_mapAccum = mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) @?= ("Everything: ba", fromList [(3, "bX"), (5, "aX")])-  where-    f a b = (a ++ b, b ++ "X")--test_mapAccumWithKey :: Assertion-test_mapAccumWithKey = mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])-  where-    f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--test_mapAccumRWithKey :: Assertion-test_mapAccumRWithKey = mapAccumRWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) @?= ("Everything: 5-a 3-b", fromList [(3, "bX"), (5, "aX")])-  where-    f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")--test_mapKeys :: Assertion-test_mapKeys = do-    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"--test_mapKeysWith :: Assertion-test_mapKeysWith = do-    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"--test_mapKeysMonotonic :: Assertion-test_mapKeysMonotonic = do-    mapKeysMonotonic (+ 1) (fromList [(5,"a"), (3,"b")])          @?= fromList [(4, "b"), (6, "a")]-    mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) @?= fromList [(6, "b"), (10, "a")]-    valid (mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")])) @?= True-    valid (mapKeysMonotonic (\ _ -> 1)     (fromList [(5,"a"), (3,"b")])) @?= False--------------------------------------------------------------------- Conversion--test_elems :: Assertion-test_elems = do-    elems (fromList [(5,"a"), (3,"b")]) @?= ["b","a"]-    elems (empty :: UMap) @?= []--test_keys :: Assertion-test_keys = do-    keys (fromList [(5,"a"), (3,"b")]) @?= [3,5]-    keys (empty :: UMap) @?= []--test_assocs :: Assertion-test_assocs = do-    assocs (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]-    assocs (empty :: UMap) @?= []--test_keysSet :: Assertion-test_keysSet = do-    keysSet (fromList [(5,"a"), (3,"b")]) @?= Set.fromList [3,5]-    keysSet (empty :: UMap) @?= Set.empty--test_fromSet :: Assertion-test_fromSet = do-   fromSet (\k -> replicate k 'a') (Set.fromList [3, 5]) @?= fromList [(5,"aaaaa"), (3,"aaa")]-   fromSet undefined Set.empty @?= (empty :: IMap)--------------------------------------------------------------------- Lists--test_toList :: Assertion-test_toList = do-    toList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]-    toList (empty :: SMap) @?= []--test_fromList :: Assertion-test_fromList = do-    fromList [] @?= (empty :: SMap)-    fromList [(5,"a"), (3,"b"), (5, "c")] @?= fromList [(5,"c"), (3,"b")]-    fromList [(5,"c"), (3,"b"), (5, "a")] @?= fromList [(5,"a"), (3,"b")]--test_fromListWith :: Assertion-test_fromListWith = do-    fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] @?= fromList [(3, "ab"), (5, "aba")]-    fromListWith (++) [] @?= (empty :: SMap)--test_fromListWithKey :: Assertion-test_fromListWithKey = do-    fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] @?= fromList [(3, "3ab"), (5, "5a5ba")]-    fromListWithKey f [] @?= (empty :: SMap)-  where-    f k a1 a2 = (show k) ++ a1 ++ a2--------------------------------------------------------------------- Ordered lists--test_toAscList :: Assertion-test_toAscList = toAscList (fromList [(5,"a"), (3,"b")]) @?= [(3,"b"), (5,"a")]--test_toDescList :: Assertion-test_toDescList = toDescList (fromList [(5,"a"), (3,"b")]) @?= [(5,"a"), (3,"b")]--test_showTree :: Assertion-test_showTree =-       (let t = fromDistinctAscList [(x,()) | x <- [1..5]]-        in showTree t) @?= "4:=()\n+--2:=()\n|  +--1:=()\n|  +--3:=()\n+--5:=()\n"--test_showTree' :: Assertion-test_showTree' =-       (let t = fromDistinctAscList [(x,()) | x <- [1..5]]-        in s t ) @?= "+--5:=()\n|\n4:=()\n|\n|  +--3:=()\n|  |\n+--2:=()\n   |\n   +--1:=()\n"-   where-    showElem k x  = show k ++ ":=" ++ show x--    s = showTreeWith showElem False True---test_fromAscList :: Assertion-test_fromAscList = do-    fromAscList [(3,"b"), (5,"a")]          @?= fromList [(3, "b"), (5, "a")]-    fromAscList [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "b")]-    valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) @?= True-    valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) @?= False--test_fromAscListWith :: Assertion-test_fromAscListWith = do-    fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] @?= fromList [(3, "b"), (5, "ba")]-    valid (fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")]) @?= True-    valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) @?= False--test_fromAscListWithKey :: Assertion-test_fromAscListWithKey = do-    fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")] @?= fromList [(3, "b"), (5, "5:b5:ba")]-    valid (fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b"), (5,"b")]) @?= True-    valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) @?= False-  where-    f k a1 a2 = (show k) ++ ":" ++ a1 ++ a2--test_fromDistinctAscList :: Assertion-test_fromDistinctAscList = do-    fromDistinctAscList [(3,"b"), (5,"a")] @?= fromList [(3, "b"), (5, "a")]-    valid (fromDistinctAscList [(3,"b"), (5,"a")])          @?= True-    valid (fromDistinctAscList [(3,"b"), (5,"a"), (5,"b")]) @?= False--test_fromDistinctDescList :: Assertion-test_fromDistinctDescList = do-    fromDistinctDescList [(5,"a"), (3,"b")] @?= fromList [(3, "b"), (5, "a")]-    valid (fromDistinctDescList [(5,"a"), (3,"b")])          @?= True-    valid (fromDistinctDescList [(3,"b"), (5,"a"), (5,"b")]) @?= False--------------------------------------------------------------------- Filter--test_filter :: Assertion-test_filter = do-    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--test_filteWithKey :: Assertion-test_filteWithKey = filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"--test_partition :: Assertion-test_partition = do-    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")])--test_partitionWithKey :: Assertion-test_partitionWithKey = do-    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")])--test_mapMaybe :: Assertion-test_mapMaybe = mapMaybe f (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "new a"-  where-    f x = if x == "a" then Just "new a" else Nothing--test_mapMaybeWithKey :: Assertion-test_mapMaybeWithKey = mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "key : 3"-  where-    f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing--test_mapEither :: Assertion-test_mapEither = do-    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 :: SMap), fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])- where-   f a = if a < "c" then Left a else Right a--test_mapEitherWithKey :: Assertion-test_mapEitherWithKey = do-    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 :: SMap), fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])-  where-    f k a = if k < 5 then Left (k * 2) else Right (a ++ a)--test_split :: Assertion-test_split = do-    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)--test_splitLookup :: Assertion-test_splitLookup = do-    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)--------------------------------------------------------------------- Submap--test_isSubmapOfBy :: Assertion-test_isSubmapOfBy = do-    isSubmapOfBy (==) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) @?= True-    isSubmapOfBy (<=) (fromList [('a',1)]) (fromList [('a',1),('b',2)]) @?= True-    isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)]) @?= True-    isSubmapOfBy (==) (fromList [('a',2)]) (fromList [('a',1),('b',2)]) @?= False-    isSubmapOfBy (<)  (fromList [('a',1)]) (fromList [('a',1),('b',2)]) @?= False-    isSubmapOfBy (==) (fromList [('a',1),('b',2)]) (fromList [('a',1)]) @?= False--test_isSubmapOf :: Assertion-test_isSubmapOf = do-    isSubmapOf (fromList [('a',1)]) (fromList [('a',1),('b',2)]) @?= True-    isSubmapOf (fromList [('a',1),('b',2)]) (fromList [('a',1),('b',2)]) @?= True-    isSubmapOf (fromList [('a',2)]) (fromList [('a',1),('b',2)]) @?= False-    isSubmapOf (fromList [('a',1),('b',2)]) (fromList [('a',1)]) @?= False--test_isProperSubmapOfBy :: Assertion-test_isProperSubmapOfBy = do-    isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True-    isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True-    isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False-    isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False-    isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)]) @?= False--test_isProperSubmapOf :: Assertion-test_isProperSubmapOf = do-    isProperSubmapOf (fromList [(1,1)]) (fromList [(1,1),(2,2)]) @?= True-    isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)]) @?= False-    isProperSubmapOf (fromList [(1,1),(2,2)]) (fromList [(1,1)]) @?= False--------------------------------------------------------------------- Indexed--test_lookupIndex :: Assertion-test_lookupIndex = do-    isJust (lookupIndex 2 (fromList [(5,"a"), (3,"b")]))   @?= False-    fromJust (lookupIndex 3 (fromList [(5,"a"), (3,"b")])) @?= 0-    fromJust (lookupIndex 5 (fromList [(5,"a"), (3,"b")])) @?= 1-    isJust (lookupIndex 6 (fromList [(5,"a"), (3,"b")]))   @?= False--test_findIndex :: Assertion-test_findIndex = do-    findIndex 3 (fromList [(5,"a"), (3,"b")]) @?= 0-    findIndex 5 (fromList [(5,"a"), (3,"b")]) @?= 1--test_elemAt :: Assertion-test_elemAt = do-    elemAt 0 (fromList [(5,"a"), (3,"b")]) @?= (3,"b")-    elemAt 1 (fromList [(5,"a"), (3,"b")]) @?= (5, "a")--test_updateAt :: Assertion-test_updateAt = do-    updateAt (\ _ _ -> Just "x") 0    (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "x"), (5, "a")]-    updateAt (\ _ _ -> Just "x") 1    (fromList [(5,"a"), (3,"b")]) @?= fromList [(3, "b"), (5, "x")]-    updateAt (\_ _  -> Nothing)  0    (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"-    updateAt (\_ _  -> Nothing)  1    (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"---    updateAt (\_ _  -> Nothing)  7    (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"--test_deleteAt :: Assertion-test_deleteAt = do-    deleteAt 0  (fromList [(5,"a"), (3,"b")]) @?= singleton 5 "a"-    deleteAt 1  (fromList [(5,"a"), (3,"b")]) @?= singleton 3 "b"--------------------------------------------------------------------- Min/Max--test_findMin :: Assertion-test_findMin = findMin (fromList [(5,"a"), (3,"b")]) @?= (3,"b")--test_findMax :: Assertion-test_findMax = findMax (fromList [(5,"a"), (3,"b")]) @?= (5,"a")--test_deleteMin :: Assertion-test_deleteMin = do-    deleteMin (fromList [(5,"a"), (3,"b"), (7,"c")]) @?= fromList [(5,"a"), (7,"c")]-    deleteMin (empty :: SMap) @?= empty--test_deleteMax :: Assertion-test_deleteMax = do-    deleteMax (fromList [(5,"a"), (3,"b"), (7,"c")]) @?= fromList [(3,"b"), (5,"a")]-    deleteMax (empty :: SMap) @?= empty--test_deleteFindMin :: Assertion-test_deleteFindMin = deleteFindMin (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((3,"b"), fromList[(5,"a"), (10,"c")])--test_deleteFindMax :: Assertion-test_deleteFindMax = deleteFindMax (fromList [(5,"a"), (3,"b"), (10,"c")]) @?= ((10,"c"), fromList [(3,"b"), (5,"a")])--test_updateMin :: Assertion-test_updateMin = do-    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"--test_updateMax :: Assertion-test_updateMax = do-    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"--test_updateMinWithKey :: Assertion-test_updateMinWithKey = do-    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"--test_updateMaxWithKey :: Assertion-test_updateMaxWithKey = do-    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"--test_minView :: Assertion-test_minView = do-    minView (fromList [(5,"a"), (3,"b")]) @?= Just ("b", singleton 5 "a")-    minView (empty :: SMap) @?= Nothing--test_maxView :: Assertion-test_maxView = do-    maxView (fromList [(5,"a"), (3,"b")]) @?= Just ("a", singleton 3 "b")-    maxView (empty :: SMap) @?= Nothing--test_minViewWithKey :: Assertion-test_minViewWithKey = do-    minViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((3,"b"), singleton 5 "a")-    minViewWithKey (empty :: SMap) @?= Nothing--test_maxViewWithKey :: Assertion-test_maxViewWithKey = do-    maxViewWithKey (fromList [(5,"a"), (3,"b")]) @?= Just ((5,"a"), singleton 3 "b")-    maxViewWithKey (empty :: SMap) @?= Nothing--------------------------------------------------------------------- Debug--test_valid :: Assertion-test_valid = do-    valid (fromAscList [(3,"b"), (5,"a")]) @?= True-    valid (fromAscList [(5,"a"), (3,"b")]) @?= False--------------------------------------------------------------------- QuickCheck-------------------------------------------------------------------prop_differenceMerge :: Fun (Int, A, B) (Maybe A) -> Map Int A -> Map Int B -> Property-prop_differenceMerge f m1 m2 =-  differenceWithKey (apply3 f) m1 m2 === merge preserveMissing dropMissing (zipWithMaybeMatched (apply3 f)) m1 m2--prop_unionWithKeyMerge :: Fun (Int, A, A) A -> Map Int A -> Map Int A -> Property-prop_unionWithKeyMerge f m1 m2 =-  unionWithKey (apply3 f) m1 m2 === unionWithKey' (apply3 f) m1 m2--unionWithKey' :: Ord k => (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a-unionWithKey' f = merge preserveMissing preserveMissing $-  zipWithMatched (\k a b -> f k a b)--prop_valid :: UMap -> Bool-prop_valid t = valid t--prop_singleton :: Int -> Int -> Bool-prop_singleton k x = insert k x empty == singleton k x--prop_insert :: Int -> UMap -> Bool-prop_insert k t = valid $ insert k () t--prop_insertLookup :: Int -> UMap -> Bool-prop_insertLookup k t = lookup k (insert k () t) /= Nothing--prop_insertDelete :: Int -> UMap -> Bool-prop_insertDelete k t = valid $ delete k (insert k () t)--prop_insertDelete2 :: Int -> UMap -> Property-prop_insertDelete2 k t = (lookup k t == Nothing) ==> (delete k (insert k () t) == t)--prop_deleteNonMember :: Int -> UMap -> Property-prop_deleteNonMember k t = (lookup k t == Nothing) ==> (delete k t == t)--prop_deleteMin :: UMap -> Bool-prop_deleteMin t = valid $ deleteMin $ deleteMin t--prop_deleteMax :: UMap -> Bool-prop_deleteMax t = valid $ deleteMax $ deleteMax t--prop_lookupMin :: IMap -> Property-prop_lookupMin m = lookupMin m === (fst <$> minViewWithKey m)--prop_lookupMax :: IMap -> Property-prop_lookupMax m = lookupMax m === (fst <$> maxViewWithKey m)--------------------------------------------------------------------prop_split :: Int -> UMap -> Bool-prop_split k t = let (r,l) = split k t-                 in (valid r, valid l) == (True, True)--prop_splitRoot :: UMap -> Bool-prop_splitRoot s = loop ls && (s == unions ls)- where-  ls = splitRoot s-  loop [] = True-  loop (s1:rst) = List.null-                  [ (x,y) | x <- toList s1-                          , y <- toList (unions rst)-                          , x > y ]--prop_link :: Int -> UMap -> Bool-prop_link k t = let (l,r) = split k t-                in valid (link k () l r)--prop_link2 :: Int -> UMap -> Bool-prop_link2 k t = let (l,r) = split k t-                 in valid (link2 l r)--------------------------------------------------------------------prop_union :: UMap -> UMap -> Bool-prop_union t1 t2 = valid (union t1 t2)--prop_unionModel :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_unionModel xs ys-  = sort (keys (union (fromList xs) (fromList ys)))-    == sort (nub (Prelude.map fst xs ++ Prelude.map fst ys))--prop_unionSingleton :: IMap -> Int -> Int -> Bool-prop_unionSingleton t k x = union (singleton k x) t == insert k x t--prop_unionAssoc :: IMap -> IMap -> IMap -> Bool-prop_unionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3--prop_unionWith :: IMap -> IMap -> Bool-prop_unionWith t1 t2 = (union t1 t2 == unionWith (\_ y -> y) t2 t1)--prop_unionWith2 :: IMap -> IMap -> Bool-prop_unionWith2 t1 t2 = valid (unionWithKey (\_ x y -> x+y) t1 t2)--prop_unionSum :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_unionSum xs ys-  = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))-    == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys))--prop_difference :: IMap -> IMap -> Bool-prop_difference t1 t2 = valid (difference t1 t2)--prop_differenceModel :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_differenceModel xs ys-  = sort (keys (difference (fromListWith (+) xs) (fromListWith (+) ys)))-    == sort ((List.\\) (nub (Prelude.map fst xs)) (nub (Prelude.map fst ys)))--prop_restrictKeys :: IMap -> IMap -> Property-prop_restrictKeys m s0 = valid restricted .&&. (m `restrictKeys` s === filterWithKey (\k _ -> k `Set.member` s) m)-  where-    s = keysSet s0-    restricted = restrictKeys m s--prop_withoutKeys :: IMap -> IMap -> Property-prop_withoutKeys m s0 = valid reduced .&&. (m `withoutKeys` s === filterWithKey (\k _ -> k `Set.notMember` s) m)-  where-    s = keysSet s0-    reduced = withoutKeys m s--prop_intersection :: IMap -> IMap -> Bool-prop_intersection t1 t2 = valid (intersection t1 t2)--prop_intersectionModel :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_intersectionModel xs ys-  = sort (keys (intersection (fromListWith (+) xs) (fromListWith (+) ys)))-    == sort (nub ((List.intersect) (Prelude.map fst xs) (Prelude.map fst ys)))--prop_intersectionWith :: Fun (Int, Int) (Maybe Int) -> IMap -> IMap -> Bool-prop_intersectionWith f t1 t2 = valid (intersectionWith (apply2 f) t1 t2)--prop_intersectionWithModel :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_intersectionWithModel xs ys-  = toList (intersectionWith f (fromList xs') (fromList ys'))-    == [(kx, f vx vy) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky]-    where xs' = List.nubBy ((==) `on` fst) xs-          ys' = List.nubBy ((==) `on` fst) ys-          f l r = l + 2 * r--prop_intersectionWithKey :: Fun (Int, Int, Int) (Maybe Int) -> IMap -> IMap -> Bool-prop_intersectionWithKey f t1 t2 = valid (intersectionWithKey (apply3 f) t1 t2)--prop_intersectionWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_intersectionWithKeyModel xs ys-  = toList (intersectionWithKey f (fromList xs') (fromList ys'))-    == [(kx, f kx vx vy) | (kx, vx) <- List.sort xs', (ky, vy) <- ys', kx == ky]-    where xs' = List.nubBy ((==) `on` fst) xs-          ys' = List.nubBy ((==) `on` fst) ys-          f k l r = k + 2 * l + 3 * r--prop_mergeWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool-prop_mergeWithKeyModel xs ys-  = and [ testMergeWithKey f keep_x keep_y-        | f <- [ \_k x1  _x2 -> Just x1-               , \_k _x1 x2  -> Just x2-               , \_k _x1 _x2 -> Nothing-               , \k  x1  x2  -> if k `mod` 2 == 0 then Nothing else Just (2 * x1 + 3 * x2)-               ]-        , keep_x <- [ True, False ]-        , keep_y <- [ True, False ]-        ]--    where xs' = List.nubBy ((==) `on` fst) xs-          ys' = List.nubBy ((==) `on` fst) ys--          xm = fromList xs'-          ym = fromList ys'--          testMergeWithKey f keep_x keep_y-            = toList (mergeWithKey f (keep keep_x) (keep keep_y) xm ym) == emulateMergeWithKey f keep_x keep_y-              where keep False _ = empty-                    keep True  m = m--                    emulateMergeWithKey f keep_x keep_y-                      = Maybe.mapMaybe combine (sort $ List.union (List.map fst xs') (List.map fst ys'))-                        where combine k = case (List.lookup k xs', List.lookup k ys') of-                                            (Nothing, Just y) -> if keep_y then Just (k, y) else Nothing-                                            (Just x, Nothing) -> if keep_x then Just (k, x) else Nothing-                                            (Just x, Just y) -> (\v -> (k, v)) `fmap` f k x y--          -- We prevent inlining testMergeWithKey to disable the SpecConstr-          -- optimalization. There are too many call patterns here so several-          -- warnings are issued if testMergeWithKey gets inlined.-          {-# NOINLINE testMergeWithKey #-}--------------------------------------------------------------------prop_ordered :: Property-prop_ordered-  = forAll (choose (5,100)) $ \n ->-    let xs = [(x,()) | x <- [0..n::Int]]-    in fromAscList xs == fromList xs--prop_rev_ordered :: Property-prop_rev_ordered-  = forAll (choose (5,100)) $ \n ->-    let xs = [(x,()) | x <- [0..n::Int]]-    in fromDescList (reverse xs) == fromList xs--prop_list :: [Int] -> Bool-prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])])--prop_descList :: [Int] -> Bool-prop_descList xs = (reverse (sort (nub xs)) == [x | (x,()) <- toDescList (fromList [(x,()) | x <- xs])])--prop_fromDistinctDescList :: Int -> [A] -> Property-prop_fromDistinctDescList top lst = valid converted .&&. (toList converted === reverse original) where-  original = zip [top, (top-1)..0] lst-  converted = fromDistinctDescList original--prop_ascDescList :: [Int] -> Bool-prop_ascDescList xs = toAscList m == reverse (toDescList m)-  where m = fromList $ zip xs $ repeat ()--prop_fromList :: [Int] -> Bool-prop_fromList xs-  = case fromList (zip xs xs) of-      t -> t == fromAscList (zip sort_xs sort_xs) &&-           t == fromDistinctAscList (zip nub_sort_xs nub_sort_xs) &&-           t == List.foldr (uncurry insert) empty (zip xs xs)-  where sort_xs = sort xs-        nub_sort_xs = List.map List.head $ List.group sort_xs--------------------------------------------------------------------prop_alter :: UMap -> Int -> Bool-prop_alter t k = balanced t' && case lookup k t of-    Just _  -> (size t - 1) == size t' && lookup k t' == Nothing-    Nothing -> (size t + 1) == size t' && lookup k t' /= Nothing-  where-    t' = alter f k t-    f Nothing   = Just ()-    f (Just ()) = Nothing--prop_alterF_alter :: Fun (Maybe Int) (Maybe Int) -> Int -> IMap -> Bool-prop_alterF_alter f k m = valid altered && altered == alter (apply f) k m-  where altered = atAlter (apply f) k m--prop_alterF_alter_noRULES :: Fun (Maybe Int) (Maybe Int) -> Int -> IMap -> Bool-prop_alterF_alter_noRULES f k m = valid altered &&-                                  altered == alter (apply f) k m-  where altered = atAlterNoRULES (apply f) k m--prop_alterF_lookup :: Int -> IMap -> Bool-prop_alterF_lookup k m = atLookup k m == lookup k m--prop_alterF_lookup_noRULES :: Int -> IMap -> Bool-prop_alterF_lookup_noRULES k m = atLookupNoRULES k m == lookup k m----------------------------------------------------------------------------- Compare against the list model (after nub on keys)--prop_index :: [Int] -> Property-prop_index xs = length xs > 0 ==>-  let m  = fromList (zip xs xs)-  in  xs == [ m ! i | i <- xs ]--prop_null :: IMap -> Bool-prop_null m = null m == (size m == 0)--prop_member :: [Int] -> Int -> Bool-prop_member xs n =-  let m  = fromList (zip xs xs)-  in all (\k -> k `member` m == (k `elem` xs)) (n : xs)--prop_notmember :: [Int] -> Int -> Bool-prop_notmember xs n =-  let m  = fromList (zip xs xs)-  in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs)--prop_lookup :: [(Int, Int)] -> Int -> Bool-prop_lookup xs n =-  let xs' = List.nubBy ((==) `on` fst) xs-      m = fromList xs'-  in all (\k -> lookup k m == List.lookup k xs') (n : List.map fst xs')--prop_find :: [(Int, Int)] -> Bool-prop_find xs =-  let xs' = List.nubBy ((==) `on` fst) xs-      m = fromList xs'-  in all (\(k, v) -> m ! k == v) xs'--prop_findWithDefault :: [(Int, Int)] -> Int -> Int -> Bool-prop_findWithDefault xs n x =-  let xs' = List.nubBy ((==) `on` fst) xs-      m = fromList xs'-  in all (\k -> findWithDefault x k m == maybe x id (List.lookup k xs')) (n : List.map fst xs')--test_lookupSomething :: (Int -> Map Int Int -> Maybe (Int, Int)) -> (Int -> Int -> Bool) -> [(Int, Int)] -> Bool-test_lookupSomething lookup' cmp xs =-  let odd_sorted_xs = filter_odd $ sort $ List.nubBy ((==) `on` fst) xs-      t = fromList odd_sorted_xs-      test k = case List.filter ((`cmp` k) . fst) odd_sorted_xs of-                 []             -> lookup' k t == Nothing-                 cs | 0 `cmp` 1 -> lookup' k t == Just (last cs) -- we want largest such element-                    | otherwise -> lookup' k t == Just (head cs) -- we want smallest such element-  in all test (List.map fst xs)--  where filter_odd [] = []-        filter_odd [_] = []-        filter_odd (_ : o : xs) = o : filter_odd xs--prop_lookupLT :: [(Int, Int)] -> Bool-prop_lookupLT = test_lookupSomething lookupLT (<)--prop_lookupGT :: [(Int, Int)] -> Bool-prop_lookupGT = test_lookupSomething lookupGT (>)--prop_lookupLE :: [(Int, Int)] -> Bool-prop_lookupLE = test_lookupSomething lookupLE (<=)--prop_lookupGE :: [(Int, Int)] -> Bool-prop_lookupGE = test_lookupSomething lookupGE (>=)--prop_findIndex :: [(Int, Int)] -> Property-prop_findIndex ys = length ys > 0 ==>-  let m = fromList ys-  in  findIndex (fst (head ys)) m `seq` True--prop_lookupIndex :: [(Int, Int)] -> Property-prop_lookupIndex ys = length ys > 0 ==>-  let m = fromList ys-  in  isJust (lookupIndex (fst (head ys)) m)--prop_findMin :: [(Int, Int)] -> Property-prop_findMin ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  findMin m == List.minimumBy (comparing fst) xs--prop_findMax :: [(Int, Int)] -> Property-prop_findMax ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  findMax m == List.maximumBy (comparing fst) xs--prop_deleteMinModel :: [(Int, Int)] -> Property-prop_deleteMinModel ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  toAscList (deleteMin m) == tail (sort xs)--prop_deleteMaxModel :: [(Int, Int)] -> Property-prop_deleteMaxModel ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  toAscList (deleteMax m) == init (sort xs)--prop_filter :: Fun Int Bool -> [(Int, Int)] -> Property-prop_filter p ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  filter (apply p) m == fromList (List.filter (apply p . snd) xs)--prop_take :: Int -> Map Int Int -> Property-prop_take n xs = valid taken .&&.-                 taken === fromDistinctAscList (List.take n (toList xs))-  where-    taken = take n xs--prop_drop :: Int -> Map Int Int -> Property-prop_drop n xs = valid dropped .&&.-                 dropped === fromDistinctAscList (List.drop n (toList xs))-  where-    dropped = drop n xs--prop_splitAt :: Int -> Map Int Int -> Property-prop_splitAt n xs = valid taken .&&.-                    valid dropped .&&.-                    taken === take n xs .&&.-                    dropped === drop n xs-  where-    (taken, dropped) = splitAt n xs--prop_takeWhileAntitone :: [(Either Int Int, Int)] -> Property-prop_takeWhileAntitone xs' = valid tw .&&. (tw === filterWithKey (\k _ -> isLeft k) xs)-  where-    xs = fromList xs'-    tw = takeWhileAntitone isLeft xs--prop_dropWhileAntitone :: [(Either Int Int, Int)] -> Property-prop_dropWhileAntitone xs' = valid tw .&&. (tw === filterWithKey (\k _ -> not (isLeft k)) xs)-  where-    xs = fromList xs'-    tw = dropWhileAntitone isLeft xs--prop_spanAntitone :: [(Either Int Int, Int)] -> Property-prop_spanAntitone xs' = valid tw .&&. valid dw-                        .&&. (tw === takeWhileAntitone isLeft xs)-                        .&&. (dw === dropWhileAntitone isLeft xs)-  where-    xs = fromList xs'-    (tw, dw) = spanAntitone isLeft xs--isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _ = False--prop_partition :: Fun Int Bool -> [(Int, Int)] -> Property-prop_partition p ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  partition (apply p) m == let (a,b) = (List.partition (apply p . snd) xs) in (fromList a, fromList b)--prop_map :: Fun Int Int -> [(Int, Int)] -> Property-prop_map f ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  map (apply f) m == fromList [ (a, apply f b) | (a,b) <- xs ]--prop_fmap :: Fun Int Int -> [(Int, Int)] -> Property-prop_fmap f ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  fmap (apply f) m == fromList [ (a, (apply f) b) | (a,b) <- xs ]--prop_mapkeys :: Fun Int Int -> [(Int, Int)] -> Property-prop_mapkeys f ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  mapKeys (apply f) m == (fromList $ List.nubBy ((==) `on` fst) $ reverse [ (apply f a, b) | (a,b) <- sort xs])--prop_splitModel :: Int -> [(Int, Int)] -> Property-prop_splitModel n ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      (l, r) = split n $ fromList xs-  in  toAscList l == sort [(k, v) | (k,v) <- xs, k < n] &&-      toAscList r == sort [(k, v) | (k,v) <- xs, k > n]--prop_foldr :: Int -> [(Int, Int)] -> Property-prop_foldr n ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  foldr (+) n m == List.foldr (+) n (List.map snd xs) &&-      foldr (:) [] m == List.map snd (List.sort xs) &&-      foldrWithKey (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) &&-      foldrWithKey (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) &&-      foldrWithKey (\k x xs -> (k,x):xs) [] m == List.sort xs---prop_foldr' :: Int -> [(Int, Int)] -> Property-prop_foldr' n ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  foldr' (+) n m == List.foldr (+) n (List.map snd xs) &&-      foldr' (:) [] m == List.map snd (List.sort xs) &&-      foldrWithKey' (\_ a b -> a + b) n m == List.foldr (+) n (List.map snd xs) &&-      foldrWithKey' (\k _ b -> k + b) n m == List.foldr (+) n (List.map fst xs) &&-      foldrWithKey' (\k x xs -> (k,x):xs) [] m == List.sort xs--prop_foldl :: Int -> [(Int, Int)] -> Property-prop_foldl n ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  foldl (+) n m == List.foldr (+) n (List.map snd xs) &&-      foldl (flip (:)) [] m == reverse (List.map snd (List.sort xs)) &&-      foldlWithKey (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) &&-      foldlWithKey (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) &&-      foldlWithKey (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs)--prop_foldl' :: Int -> [(Int, Int)] -> Property-prop_foldl' n ys = length ys > 0 ==>-  let xs = List.nubBy ((==) `on` fst) ys-      m  = fromList xs-  in  foldl' (+) n m == List.foldr (+) n (List.map snd xs) &&-      foldl' (flip (:)) [] m == reverse (List.map snd (List.sort xs)) &&-      foldlWithKey' (\b _ a -> a + b) n m == List.foldr (+) n (List.map snd xs) &&-      foldlWithKey' (\b k _ -> k + b) n m == List.foldr (+) n (List.map fst xs) &&-      foldlWithKey' (\xs k x -> (k,x):xs) [] m == reverse (List.sort xs)--prop_keysSet :: [(Int, Int)] -> Bool-prop_keysSet xs =-  keysSet (fromList xs) == Set.fromList (List.map fst xs)--prop_fromSet :: [(Int, Int)] -> Bool-prop_fromSet ys =-  let xs = List.nubBy ((==) `on` fst) ys-  in fromSet (\k -> fromJust $ List.lookup k xs) (Set.fromList $ List.map fst xs) == fromList xs
− tests/map-strictness.hs 
@@ -1,125 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main (main) where--import Test.ChasingBottoms.IsBottom-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck (Arbitrary(arbitrary))-import Test.QuickCheck.Function (Fun(..), apply)--import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M--instance (Arbitrary k, Arbitrary v, Ord k) =>-         Arbitrary (Map k v) where-    arbitrary = M.fromList `fmap` arbitrary--apply2 :: Fun (a, b) c -> a -> b -> c-apply2 f a b = apply f (a, b)--apply3 :: Fun (a, b, c) d -> a -> b -> c -> d-apply3 f a b c = apply f (a, b, c)----------------------------------------------------------------------------- * Properties----------------------------------------------------------------------------- ** Strict module--pSingletonKeyStrict :: Int -> Bool-pSingletonKeyStrict v = isBottom $ M.singleton (bottom :: Int) v--pSingletonValueStrict :: Int -> Bool-pSingletonValueStrict k = isBottom $ (M.singleton k (bottom :: Int))--pFindWithDefaultKeyStrict :: Int -> Map Int Int -> Bool-pFindWithDefaultKeyStrict def m = isBottom $ M.findWithDefault def bottom m--pFindWithDefaultValueStrict :: Int -> Map Int Int -> Bool-pFindWithDefaultValueStrict k m =-    M.member k m || (isBottom $ M.findWithDefault bottom k m)--pAdjustKeyStrict :: Fun Int Int -> Map Int Int -> Bool-pAdjustKeyStrict f m = isBottom $ M.adjust (apply f) bottom m--pAdjustValueStrict :: Int -> Map Int Int -> Bool-pAdjustValueStrict k m-    | k `M.member` m = isBottom $ M.adjust (const bottom) k m-    | otherwise       = case M.keys m of-        []     -> True-        (k':_) -> isBottom $ M.adjust (const bottom) k' m--pInsertKeyStrict :: Int -> Map Int Int -> Bool-pInsertKeyStrict v m = isBottom $ M.insert bottom v m--pInsertValueStrict :: Int -> Map Int Int -> Bool-pInsertValueStrict k m = isBottom $ M.insert k bottom m--pInsertWithKeyStrict :: Fun (Int, Int) Int -> Int -> Map Int Int -> Bool-pInsertWithKeyStrict f v m = isBottom $ M.insertWith (apply2 f) bottom v m--pInsertWithValueStrict :: Fun (Int, Int) Int -> Int -> Int -> Map Int Int-                       -> Bool-pInsertWithValueStrict f k v m-    | M.member k m = (isBottom $ M.insertWith (const2 bottom) k v m) &&-                     not (isBottom $ M.insertWith (const2 1) k bottom m)-    | otherwise    = isBottom $ M.insertWith (apply2 f) k bottom m--pInsertLookupWithKeyKeyStrict :: Fun (Int, Int, Int) Int -> Int-                              -> Map Int Int -> Bool-pInsertLookupWithKeyKeyStrict f v m = isBottom $ M.insertLookupWithKey (apply3 f) bottom v m--pInsertLookupWithKeyValueStrict :: Fun (Int, Int, Int) Int -> Int -> Int-                                -> Map Int Int -> Bool-pInsertLookupWithKeyValueStrict f k v m-    | M.member k m = (isBottom $ M.insertLookupWithKey (const3 bottom) k v m) &&-                     not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m)-    | otherwise    = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m----------------------------------------------------------------------------- * Test list--tests :: [Test]-tests =-    [-    -- Basic interface-      testGroup "Map.Strict"-      [ testProperty "singleton is key-strict" pSingletonKeyStrict-      , testProperty "singleton is value-strict" pSingletonValueStrict-      , testProperty "member is key-strict" $ keyStrict M.member-      , testProperty "lookup is key-strict" $ keyStrict M.lookup-      , testProperty "findWithDefault is key-strict" pFindWithDefaultKeyStrict-      , testProperty "findWithDefault is value-strict" pFindWithDefaultValueStrict-      , testProperty "! is key-strict" $ keyStrict (flip (M.!))-      , testProperty "delete is key-strict" $ keyStrict M.delete-      , testProperty "adjust is key-strict" pAdjustKeyStrict-      , testProperty "adjust is value-strict" pAdjustValueStrict-      , testProperty "insert is key-strict" pInsertKeyStrict-      , testProperty "insert is value-strict" pInsertValueStrict-      , testProperty "insertWith is key-strict" pInsertWithKeyStrict-      , testProperty "insertWith is value-strict" pInsertWithValueStrict-      , testProperty "insertLookupWithKey is key-strict"-        pInsertLookupWithKeyKeyStrict-      , testProperty "insertLookupWithKey is value-strict"-        pInsertLookupWithKeyValueStrict-      ]-    ]----------------------------------------------------------------------------- * Test harness--main :: IO ()-main = defaultMain tests----------------------------------------------------------------------------- * Utilities--keyStrict :: (Int -> Map Int Int -> a) -> Map Int Int -> Bool-keyStrict f m = isBottom $ f bottom m--const2 :: a -> b -> c -> a-const2 x _ _ = x--const3 :: a -> b -> c -> d -> a-const3 x _ _ _ = x
− tests/seq-properties.hs 
@@ -1,919 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE PatternGuards #-}--#include "containers.h"--import Data.Sequence.Internal-  ( Sized (..)-  , Seq (Seq)-  , FingerTree(..)-  , Node(..)-  , Elem(..)-  , Digit (..)-  , node2-  , node3-  , deep )--import Data.Sequence--import Control.Applicative (Applicative(..), liftA2)-import Control.Arrow ((***))-import Control.Monad.Trans.State.Strict-import Data.Array (listArray)-import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, fold), toList, all, sum, foldl', foldr')-import Data.Functor ((<$>), (<$))-import Data.Maybe-import Data.Function (on)-import Data.Monoid (Monoid(..), All(..), Endo(..), Dual(..))-import Data.Traversable (Traversable(traverse), sequenceA)-import Prelude hiding (-  lookup, null, length, take, drop, splitAt,-  foldl, foldl1, foldr, foldr1, scanl, scanl1, scanr, scanr1,-  filter, reverse, replicate, zip, zipWith, zip3, zipWith3,-  all, sum)-import qualified Prelude-import qualified Data.List-import Test.QuickCheck hiding ((><))-import Test.QuickCheck.Poly-#if __GLASGOW_HASKELL__ >= 800-import Test.QuickCheck.Property-#endif-import Test.QuickCheck.Function-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Control.Monad.Zip (MonadZip (..))-import Control.DeepSeq (deepseq)-import Control.Monad.Fix (MonadFix (..))---main :: IO ()-main = defaultMain-       [ testProperty "fmap" prop_fmap-       , testProperty "(<$)" prop_constmap-       , testProperty "foldr" prop_foldr-       , testProperty "foldr'" prop_foldr'-       , testProperty "lazy foldr'" prop_lazyfoldr'-       , testProperty "foldr1" prop_foldr1-       , testProperty "foldl" prop_foldl-       , testProperty "foldl'" prop_foldl'-       , testProperty "lazy foldl'" prop_lazyfoldl'-       , testProperty "foldl1" prop_foldl1-       , testProperty "(==)" prop_equals-       , testProperty "compare" prop_compare-       , testProperty "mappend" prop_mappend-       , testProperty "singleton" prop_singleton-       , testProperty "(<|)" prop_cons-       , testProperty "(|>)" prop_snoc-       , testProperty "(><)" prop_append-       , testProperty "fromList" prop_fromList-       , testProperty "fromFunction" prop_fromFunction-       , testProperty "fromArray" prop_fromArray-       , testProperty "replicate" prop_replicate-       , testProperty "replicateA" prop_replicateA-       , testProperty "replicateM" prop_replicateM-       , testProperty "iterateN" prop_iterateN-       , testProperty "unfoldr" prop_unfoldr-       , testProperty "unfoldl" prop_unfoldl-       , testProperty "null" prop_null-       , testProperty "length" prop_length-       , testProperty "viewl" prop_viewl-       , testProperty "viewr" prop_viewr-       , testProperty "scanl" prop_scanl-       , testProperty "scanl1" prop_scanl1-       , testProperty "scanr" prop_scanr-       , testProperty "scanr1" prop_scanr1-       , testProperty "tails" prop_tails-       , testProperty "inits" prop_inits-       , testProperty "takeWhileL" prop_takeWhileL-       , testProperty "takeWhileR" prop_takeWhileR-       , testProperty "dropWhileL" prop_dropWhileL-       , testProperty "dropWhileR" prop_dropWhileR-       , testProperty "spanl" prop_spanl-       , testProperty "spanr" prop_spanr-       , testProperty "breakl" prop_breakl-       , testProperty "breakr" prop_breakr-       , testProperty "partition" prop_partition-       , testProperty "filter" prop_filter-       , testProperty "sort" prop_sort-       , testProperty "sortStable" prop_sortStable-       , testProperty "sortBy" prop_sortBy-       , testProperty "sortOn" prop_sortOn-       , testProperty "sortOnStable" prop_sortOnStable-       , testProperty "unstableSort" prop_unstableSort-       , testProperty "unstableSortBy" prop_unstableSortBy-       , testProperty "unstableSortOn" prop_unstableSortOn-       , testProperty "index" prop_index-       , testProperty "(!?)" prop_safeIndex-       , testProperty "adjust" prop_adjust-       , testProperty "insertAt" prop_insertAt-       , testProperty "deleteAt" prop_deleteAt-       , testProperty "update" prop_update-       , testProperty "take" prop_take-       , testProperty "drop" prop_drop-       , testProperty "splitAt" prop_splitAt-       , testProperty "chunksOf" prop_chunksOf-       , testProperty "elemIndexL" prop_elemIndexL-       , testProperty "elemIndicesL" prop_elemIndicesL-       , testProperty "elemIndexR" prop_elemIndexR-       , testProperty "elemIndicesR" prop_elemIndicesR-       , testProperty "findIndexL" prop_findIndexL-       , testProperty "findIndicesL" prop_findIndicesL-       , testProperty "findIndexR" prop_findIndexR-       , testProperty "findIndicesR" prop_findIndicesR-       , testProperty "foldlWithIndex" prop_foldlWithIndex-       , testProperty "foldrWithIndex" prop_foldrWithIndex-       , testProperty "mapWithIndex" prop_mapWithIndex-       , testProperty "foldMapWithIndex/foldlWithIndex" prop_foldMapWithIndexL-       , testProperty "foldMapWithIndex/foldrWithIndex" prop_foldMapWithIndexR-       , testProperty "traverseWithIndex" prop_traverseWithIndex-       , testProperty "reverse" prop_reverse-       , testProperty "zip" prop_zip-       , testProperty "zipWith" prop_zipWith-       , testProperty "zip3" prop_zip3-       , testProperty "zipWith3" prop_zipWith3-       , testProperty "zip4" prop_zip4-       , testProperty "zipWith4" prop_zipWith4-       , testProperty "mzip-naturality" prop_mzipNaturality-       , testProperty "mzip-preservation" prop_mzipPreservation-       , testProperty "munzip-lazy" prop_munzipLazy-       , testProperty "<*>" prop_ap-       , testProperty "<*> NOINLINE" prop_ap_NOINLINE-       , testProperty "liftA2" prop_liftA2-       , testProperty "*>" prop_then-       , testProperty "cycleTaking" prop_cycleTaking-       , testProperty "intersperse" prop_intersperse-       , testProperty ">>=" prop_bind-       , testProperty "mfix" test_mfix-#if __GLASGOW_HASKELL__ >= 800-       , testProperty "Empty pattern" prop_empty_pat-       , testProperty "Empty constructor" prop_empty_con-       , testProperty "Left view pattern" prop_viewl_pat-       , testProperty "Left view constructor" prop_viewl_con-       , testProperty "Right view pattern" prop_viewr_pat-       , testProperty "Right view constructor" prop_viewr_con-#endif-       ]----------------------------------------------------------------------------- Arbitrary---------------------------------------------------------------------------instance Arbitrary a => Arbitrary (Seq a) where-    arbitrary = Seq <$> arbitrary-    shrink (Seq x) = map Seq (shrink x)--instance Arbitrary a => Arbitrary (Elem a) where-    arbitrary = Elem <$> arbitrary--instance (Arbitrary a, Sized a) => Arbitrary (FingerTree a) where-    arbitrary = sized arb-      where-        arb :: (Arbitrary b, Sized b) => Int -> Gen (FingerTree b)-        arb 0 = return EmptyT-        arb 1 = Single <$> arbitrary-        arb n = do-            pr <- arbitrary-            sf <- arbitrary-            let n_pr = Prelude.length (toList pr)-            let n_sf = Prelude.length (toList sf)-            -- adding n `div` 7 ensures that n_m >= 0, and makes more Singles-            let n_m = max (n `div` 7) ((n - n_pr - n_sf) `div` 3)-            m <- arb n_m-            return $ deep pr m sf--    shrink (Deep _ (One a) EmptyT (One b)) = [Single a, Single b]-    shrink (Deep _ pr m sf) =-        [deep pr' m sf | pr' <- shrink pr] ++-        [deep pr m' sf | m' <- shrink m] ++-        [deep pr m sf' | sf' <- shrink sf]-    shrink (Single x) = map Single (shrink x)-    shrink EmptyT = []--instance (Arbitrary a, Sized a) => Arbitrary (Node a) where-    arbitrary = oneof [-        node2 <$> arbitrary <*> arbitrary,-        node3 <$> arbitrary <*> arbitrary <*> arbitrary]--    shrink (Node2 _ a b) =-        [node2 a' b | a' <- shrink a] ++-        [node2 a b' | b' <- shrink b]-    shrink (Node3 _ a b c) =-        [node2 a b, node2 a c, node2 b c] ++-        [node3 a' b c | a' <- shrink a] ++-        [node3 a b' c | b' <- shrink b] ++-        [node3 a b c' | c' <- shrink c]--instance Arbitrary a => Arbitrary (Digit a) where-    arbitrary = oneof [-        One <$> arbitrary,-        Two <$> arbitrary <*> arbitrary,-        Three <$> arbitrary <*> arbitrary <*> arbitrary,-        Four <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary]--    shrink (One a) = map One (shrink a)-    shrink (Two a b) = [One a, One b]-    shrink (Three a b c) = [Two a b, Two a c, Two b c]-    shrink (Four a b c d) = [Three a b c, Three a b d, Three a c d, Three b c d]----------------------------------------------------------------------------- Valid trees---------------------------------------------------------------------------class Valid a where-    valid :: a -> Bool--instance Valid (Elem a) where-    valid _ = True--instance Valid (Seq a) where-    valid (Seq xs) = valid xs--instance (Sized a, Valid a) => Valid (FingerTree a) where-    valid EmptyT = True-    valid (Single x) = valid x-    valid (Deep s pr m sf) =-        s == size pr + size m + size sf && valid pr && valid m && valid sf--instance (Sized a, Valid a) => Valid (Node a) where-    valid node = size node == sum (fmap size node) && all valid node--instance Valid a => Valid (Digit a) where-    valid = all valid--{---------------------------------------------------------------------  The general plan is to compare each function with a list equivalent.-  Each operation should produce a valid tree representing the same-  sequence as produced by its list counterpart on corresponding inputs.-  (The list versions are often lazier, but these properties ignore-  strictness.)---------------------------------------------------------------------}---- utilities for partial conversions--infix 4 ~=--(~=) :: Eq a => Maybe a -> a -> Bool-(~=) = maybe (const False) (==)---- Partial conversion of an output sequence to a list.-toList' :: Seq a -> Maybe [a]-toList' xs-  | valid xs = Just (toList xs)-  | otherwise = Nothing--toListList' :: Seq (Seq a) -> Maybe [[a]]-toListList' xss = toList' xss >>= mapM toList'--toListPair' :: (Seq a, Seq b) -> Maybe ([a], [b])-toListPair' (xs, ys) = (,) <$> toList' xs <*> toList' ys---- Extra "polymorphic" test type-newtype D = D{ unD :: Integer }-  deriving ( Eq )--instance Show D where-  showsPrec n (D x) = showsPrec n x--instance Arbitrary D where-  arbitrary    = (D . (+1) . abs) `fmap` arbitrary-  shrink (D x) = [ D x' | x' <- shrink x, x' > 0 ]--instance CoArbitrary D where-  coarbitrary = coarbitrary . unD---- instances--prop_fmap :: Seq Int -> Bool-prop_fmap xs =-    toList' (fmap f xs) ~= map f (toList xs)-  where f = (+100)--prop_constmap :: A -> Seq A -> Bool-prop_constmap x xs =-    toList' (x <$ xs) ~= map (const x) (toList xs)--prop_foldr :: Seq A -> Property-prop_foldr xs =-    foldr f z xs === Prelude.foldr f z (toList xs)-  where-    f = (:)-    z = []--prop_foldr' :: Seq A -> Property-prop_foldr' xs =-    foldr' f z xs === foldr' f z (toList xs)-  where-    f = (:)-    z = []--prop_lazyfoldr' :: Seq () -> Property-prop_lazyfoldr' xs =-    not (null xs) ==>-    foldr'-        (\e _ ->-              e)-        (error "Data.Sequence.foldr': should be lazy in initial accumulator")-        xs ===-    ()--prop_foldr1 :: Seq Int -> Property-prop_foldr1 xs =-    not (null xs) ==> foldr1 f xs == Data.List.foldr1 f (toList xs)-  where f = (-)--prop_foldl :: Seq A -> Property-prop_foldl xs =-    foldl f z xs === Prelude.foldl f z (toList xs)-  where-    f = flip (:)-    z = []--prop_foldl' :: Seq A -> Property-prop_foldl' xs =-    foldl' f z xs === foldl' f z (toList xs)-  where-    f = flip (:)-    z = []--prop_lazyfoldl' :: Seq () -> Property-prop_lazyfoldl' xs =-    not (null xs) ==>-    foldl'-        (\_ e ->-              e)-        (error "Data.Sequence.foldl': should be lazy in initial accumulator")-        xs ===-    ()--prop_foldl1 :: Seq Int -> Property-prop_foldl1 xs =-    not (null xs) ==> foldl1 f xs == Data.List.foldl1 f (toList xs)-  where f = (-)--prop_equals :: Seq OrdA -> Seq OrdA -> Bool-prop_equals xs ys =-    (xs == ys) == (toList xs == toList ys)--prop_compare :: Seq OrdA -> Seq OrdA -> Bool-prop_compare xs ys =-    compare xs ys == compare (toList xs) (toList ys)--prop_mappend :: Seq A -> Seq A -> Bool-prop_mappend xs ys =-    toList' (mappend xs ys) ~= toList xs ++ toList ys---- * Construction--{--    toList' empty ~= []--}--prop_singleton :: A -> Bool-prop_singleton x =-    toList' (singleton x) ~= [x]--prop_cons :: A -> Seq A -> Bool-prop_cons x xs =-    toList' (x <| xs) ~= x : toList xs--prop_snoc :: Seq A -> A -> Bool-prop_snoc xs x =-    toList' (xs |> x) ~= toList xs ++ [x]--prop_append :: Seq A -> Seq A -> Bool-prop_append xs ys =-    toList' (xs >< ys) ~= toList xs ++ toList ys--prop_fromList :: [A] -> Bool-prop_fromList xs =-    toList' (fromList xs) ~= xs--prop_fromFunction :: [A] -> Bool-prop_fromFunction xs =-    toList' (fromFunction (Prelude.length xs) (xs!!)) ~= xs--prop_fromArray :: [A] -> Bool-prop_fromArray xs =-    toList' (fromArray (listArray (42, 42+Prelude.length xs-1) xs)) ~= xs---- ** Repetition--prop_replicate :: NonNegative Int -> A -> Bool-prop_replicate (NonNegative m) x =-    toList' (replicate n x) ~= Prelude.replicate n x-  where n = m `mod` 10000--prop_replicateA :: NonNegative Int -> Bool-prop_replicateA (NonNegative m) =-    traverse toList' (replicateA n a) ~= sequenceA (Prelude.replicate n a)-  where-    n = m `mod` 10000-    a = Action 1 0 :: M Int--prop_replicateM :: NonNegative Int -> Bool-prop_replicateM (NonNegative m) =-    traverse toList' (replicateM n a) ~= sequence (Prelude.replicate n a)-  where-    n = m `mod` 10000-    a = Action 1 0 :: M Int---- ** Iterative construction--prop_iterateN :: NonNegative Int -> Int -> Bool-prop_iterateN (NonNegative m) x =-    toList' (iterateN n f x) ~= Prelude.take n (Prelude.iterate f x)-  where-    n = m `mod` 10000-    f = (+1)--prop_unfoldr :: [A] -> Bool-prop_unfoldr z =-    toList' (unfoldr f z) ~= Data.List.unfoldr f z-  where-    f [] = Nothing-    f (x:xs) = Just (x, xs)--prop_unfoldl :: [A] -> Bool-prop_unfoldl z =-    toList' (unfoldl f z) ~= Data.List.reverse (Data.List.unfoldr (fmap swap . f) z)-  where-    f [] = Nothing-    f (x:xs) = Just (xs, x)-    swap (x,y) = (y,x)---- * Deconstruction---- ** Queries--prop_null :: Seq A -> Bool-prop_null xs =-    null xs == Prelude.null (toList xs)--prop_length :: Seq A -> Bool-prop_length xs =-    length xs == Prelude.length (toList xs)---- ** Views--prop_viewl :: Seq A -> Bool-prop_viewl xs =-    case viewl xs of-    EmptyL ->   Prelude.null (toList xs)-    x :< xs' -> valid xs' && toList xs == x : toList xs'--prop_viewr :: Seq A -> Bool-prop_viewr xs =-    case viewr xs of-    EmptyR ->   Prelude.null (toList xs)-    xs' :> x -> valid xs' && toList xs == toList xs' ++ [x]---- * Scans--prop_scanl :: [A] -> Seq A -> Bool-prop_scanl z xs =-    toList' (scanl f z xs) ~= Data.List.scanl f z (toList xs)-  where f = flip (:)--prop_scanl1 :: Seq Int -> Property-prop_scanl1 xs =-    not (null xs) ==> toList' (scanl1 f xs) ~= Data.List.scanl1 f (toList xs)-  where f = (-)--prop_scanr :: [A] -> Seq A -> Bool-prop_scanr z xs =-    toList' (scanr f z xs) ~= Data.List.scanr f z (toList xs)-  where f = (:)--prop_scanr1 :: Seq Int -> Property-prop_scanr1 xs =-    not (null xs) ==> toList' (scanr1 f xs) ~= Data.List.scanr1 f (toList xs)-  where f = (-)---- * Sublists--prop_tails :: Seq A -> Bool-prop_tails xs =-    toListList' (tails xs) ~= Data.List.tails (toList xs)--prop_inits :: Seq A -> Bool-prop_inits xs =-    toListList' (inits xs) ~= Data.List.inits (toList xs)---- ** Sequential searches--- We use predicates with varying density.--prop_takeWhileL :: Positive Int -> Seq Int -> Bool-prop_takeWhileL (Positive n) xs =-    toList' (takeWhileL p xs) ~= Prelude.takeWhile p (toList xs)-  where p x = x `mod` n == 0--prop_takeWhileR :: Positive Int -> Seq Int -> Bool-prop_takeWhileR (Positive n) xs =-    toList' (takeWhileR p xs) ~= Prelude.reverse (Prelude.takeWhile p (Prelude.reverse (toList xs)))-  where p x = x `mod` n == 0--prop_dropWhileL :: Positive Int -> Seq Int -> Bool-prop_dropWhileL (Positive n) xs =-    toList' (dropWhileL p xs) ~= Prelude.dropWhile p (toList xs)-  where p x = x `mod` n == 0--prop_dropWhileR :: Positive Int -> Seq Int -> Bool-prop_dropWhileR (Positive n) xs =-    toList' (dropWhileR p xs) ~= Prelude.reverse (Prelude.dropWhile p (Prelude.reverse (toList xs)))-  where p x = x `mod` n == 0--prop_spanl :: Positive Int -> Seq Int -> Bool-prop_spanl (Positive n) xs =-    toListPair' (spanl p xs) ~= Data.List.span p (toList xs)-  where p x = x `mod` n == 0--prop_spanr :: Positive Int -> Seq Int -> Bool-prop_spanr (Positive n) xs =-    toListPair' (spanr p xs) ~= (Prelude.reverse *** Prelude.reverse) (Data.List.span p (Prelude.reverse (toList xs)))-  where p x = x `mod` n == 0--prop_breakl :: Positive Int -> Seq Int -> Bool-prop_breakl (Positive n) xs =-    toListPair' (breakl p xs) ~= Data.List.break p (toList xs)-  where p x = x `mod` n == 0--prop_breakr :: Positive Int -> Seq Int -> Bool-prop_breakr (Positive n) xs =-    toListPair' (breakr p xs) ~= (Prelude.reverse *** Prelude.reverse) (Data.List.break p (Prelude.reverse (toList xs)))-  where p x = x `mod` n == 0--prop_partition :: Positive Int -> Seq Int -> Bool-prop_partition (Positive n) xs =-    toListPair' (partition p xs) ~= Data.List.partition p (toList xs)-  where p x = x `mod` n == 0--prop_filter :: Positive Int -> Seq Int -> Bool-prop_filter (Positive n) xs =-    toList' (filter p xs) ~= Prelude.filter p (toList xs)-  where p x = x `mod` n == 0---- * Sorting--prop_sort :: Seq OrdA -> Bool-prop_sort xs =-    toList' (sort xs) ~= Data.List.sort (toList xs)--data UnstableOrd = UnstableOrd-    { ordKey :: OrdA-    , _ignored :: A-    } deriving (Show)--instance Eq UnstableOrd where-    x == y = compare x y == EQ--instance Ord UnstableOrd where-    compare (UnstableOrd x _) (UnstableOrd y _) = compare x y--instance Arbitrary UnstableOrd where-    arbitrary = liftA2 UnstableOrd arbitrary arbitrary-    shrink (UnstableOrd x y) =-        [ UnstableOrd x' y'-        | (x',y') <- shrink (x, y) ]--prop_sortStable :: Seq UnstableOrd -> Bool-prop_sortStable xs =-    (fmap . fmap) unignore (toList' (sort xs)) ~=-    fmap unignore (Data.List.sort (toList xs))-  where-    unignore (UnstableOrd x y) = (x, y)--prop_sortBy :: Seq (OrdA, B) -> Bool-prop_sortBy xs =-    toList' (sortBy f xs) ~= Data.List.sortBy f (toList xs)-  where f (x1, _) (x2, _) = compare x1 x2--prop_sortOn :: Fun A OrdB -> Seq A -> Bool-prop_sortOn (Fun _ f) xs =-    toList' (sortOn f xs) ~= listSortOn f (toList xs)-  where-#if MIN_VERSION_base(4,8,0)-    listSortOn = Data.List.sortOn-#else-    listSortOn k = Data.List.sortBy (compare `on` k)-#endif--prop_sortOnStable :: Fun A UnstableOrd -> Seq A -> Bool-prop_sortOnStable (Fun _ f) xs =-    toList' (sortOn f xs) ~= listSortOn f (toList xs)-  where-#if MIN_VERSION_base(4,8,0)-    listSortOn = Data.List.sortOn-#else-    listSortOn k = Data.List.sortBy (compare `on` k)-#endif--prop_unstableSort :: Seq OrdA -> Bool-prop_unstableSort xs =-    toList' (unstableSort xs) ~= Data.List.sort (toList xs)--prop_unstableSortBy :: Seq OrdA -> Bool-prop_unstableSortBy xs =-    toList' (unstableSortBy compare xs) ~= Data.List.sort (toList xs)--prop_unstableSortOn :: Fun A OrdB -> Seq A -> Property-prop_unstableSortOn (Fun _ f) xs =-    toList' (unstableSortBy (compare `on` f) xs) === toList' (unstableSortOn f xs)---- * Indexing--prop_index :: Seq A -> Property-prop_index xs =-    not (null xs) ==> forAll (choose (0, length xs-1)) $ \ i ->-    index xs i == toList xs !! i--prop_safeIndex :: Seq A -> Property-prop_safeIndex xs =-    forAll (choose (-3, length xs + 3)) $ \i ->-    ((i < 0 || i >= length xs) .&&. lookup i xs === Nothing) .||.-    lookup i xs === Just (toList xs !! i)--prop_insertAt :: A -> Seq A -> Property-prop_insertAt x xs =-  forAll (choose (-3, length xs + 3)) $ \i ->-      let res = insertAt i x xs-      in valid res .&&. res === case splitAt i xs of (front, back) -> front >< x <| back--prop_deleteAt :: Seq A -> Property-prop_deleteAt xs =-  forAll (choose (-3, length xs + 3)) $ \i ->-      let res = deleteAt i xs-      in valid res .&&.-          (((0 <= i && i < length xs) .&&. res === case splitAt i xs of (front, back) -> front >< drop 1 back)-            .||. ((i < 0 || i >= length xs) .&&. res === xs))--prop_adjust :: Int -> Int -> Seq Int -> Bool-prop_adjust n i xs =-    toList' (adjust f i xs) ~= adjustList f i (toList xs)-  where f = (+n)--prop_update :: Int -> A -> Seq A -> Bool-prop_update i x xs =-    toList' (update i x xs) ~= adjustList (const x) i (toList xs)--prop_take :: Int -> Seq A -> Bool-prop_take n xs =-    toList' (take n xs) ~= Prelude.take n (toList xs)--prop_drop :: Int -> Seq A -> Bool-prop_drop n xs =-    toList' (drop n xs) ~= Prelude.drop n (toList xs)--prop_splitAt :: Int -> Seq A -> Bool-prop_splitAt n xs =-    toListPair' (splitAt n xs) ~= Prelude.splitAt n (toList xs)--prop_chunksOf :: Seq A -> Property-prop_chunksOf xs =-  forAll (choose (1, length xs + 3)) $ \n ->-    let chunks = chunksOf n xs-    in valid chunks .&&.-       conjoin [valid c .&&. 1 <= length c && length c <= n | c <- toList chunks] .&&.-       fold chunks === xs--adjustList :: (a -> a) -> Int -> [a] -> [a]-adjustList f i xs =-    [if j == i then f x else x | (j, x) <- Prelude.zip [0..] xs]---- ** Indexing with predicates--- The elem* tests have poor coverage, but for find* we use predicates--- of varying density.--prop_elemIndexL :: A -> Seq A -> Bool-prop_elemIndexL x xs =-    elemIndexL x xs == Data.List.elemIndex x (toList xs)--prop_elemIndicesL :: A -> Seq A -> Bool-prop_elemIndicesL x xs =-    elemIndicesL x xs == Data.List.elemIndices x (toList xs)--prop_elemIndexR :: A -> Seq A -> Bool-prop_elemIndexR x xs =-    elemIndexR x xs == listToMaybe (Prelude.reverse (Data.List.elemIndices x (toList xs)))--prop_elemIndicesR :: A -> Seq A -> Bool-prop_elemIndicesR x xs =-    elemIndicesR x xs == Prelude.reverse (Data.List.elemIndices x (toList xs))--prop_findIndexL :: Positive Int -> Seq Int -> Bool-prop_findIndexL (Positive n) xs =-    findIndexL p xs == Data.List.findIndex p (toList xs)-  where p x = x `mod` n == 0--prop_findIndicesL :: Positive Int -> Seq Int -> Bool-prop_findIndicesL (Positive n) xs =-    findIndicesL p xs == Data.List.findIndices p (toList xs)-  where p x = x `mod` n == 0--prop_findIndexR :: Positive Int -> Seq Int -> Bool-prop_findIndexR (Positive n) xs =-    findIndexR p xs == listToMaybe (Prelude.reverse (Data.List.findIndices p (toList xs)))-  where p x = x `mod` n == 0--prop_findIndicesR :: Positive Int -> Seq Int -> Bool-prop_findIndicesR (Positive n) xs =-    findIndicesR p xs == Prelude.reverse (Data.List.findIndices p (toList xs))-  where p x = x `mod` n == 0---- * Folds--prop_foldlWithIndex :: [(Int, A)] -> Seq A -> Bool-prop_foldlWithIndex z xs =-    foldlWithIndex f z xs == Data.List.foldl (uncurry . f) z (Data.List.zip [0..] (toList xs))-  where f ys n y = (n,y):ys--prop_foldrWithIndex :: [(Int, A)] -> Seq A -> Bool-prop_foldrWithIndex z xs =-    foldrWithIndex f z xs == Data.List.foldr (uncurry f) z (Data.List.zip [0..] (toList xs))-  where f n y ys = (n,y):ys--prop_foldMapWithIndexL :: (Fun (B, Int, A) B) -> B -> Seq A -> Bool-prop_foldMapWithIndexL (Fun _ f) z t = foldlWithIndex f' z t ==-  appEndo (getDual (foldMapWithIndex (\i -> Dual . Endo . flip (flip f' i)) t)) z-  where f' b i a = f (b, i, a)--prop_foldMapWithIndexR :: (Fun (Int, A, B) B) -> B -> Seq A -> Bool-prop_foldMapWithIndexR (Fun _ f) z t = foldrWithIndex f' z t ==-   appEndo (foldMapWithIndex (\i -> Endo . f' i) t) z-  where f' i a b = f (i, a, b)---- * Transformations--prop_mapWithIndex :: Seq A -> Bool-prop_mapWithIndex xs =-    toList' (mapWithIndex f xs) ~= map (uncurry f) (Data.List.zip [0..] (toList xs))-  where f = (,)--prop_traverseWithIndex :: Seq Int -> Bool-prop_traverseWithIndex xs =-    runState (traverseWithIndex (\i x -> modify ((i,x) :)) xs) [] ==-    runState (sequenceA . mapWithIndex (\i x -> modify ((i,x) :)) $ xs) [] --prop_reverse :: Seq A -> Bool-prop_reverse xs =-    toList' (reverse xs) ~= Prelude.reverse (toList xs)---- ** Zips--prop_zip :: Seq A -> Seq B -> Bool-prop_zip xs ys =-    toList' (zip xs ys) ~= Prelude.zip (toList xs) (toList ys)--prop_zipWith :: Seq A -> Seq B -> Bool-prop_zipWith xs ys =-    toList' (zipWith f xs ys) ~= Prelude.zipWith f (toList xs) (toList ys)-  where f = (,)--prop_zip3 :: Seq A -> Seq B -> Seq C -> Bool-prop_zip3 xs ys zs =-    toList' (zip3 xs ys zs) ~= Prelude.zip3 (toList xs) (toList ys) (toList zs)--prop_zipWith3 :: Seq A -> Seq B -> Seq C -> Bool-prop_zipWith3 xs ys zs =-    toList' (zipWith3 f xs ys zs) ~= Prelude.zipWith3 f (toList xs) (toList ys) (toList zs)-  where f = (,,)--prop_zip4 :: Seq A -> Seq B -> Seq C -> Seq Int -> Bool-prop_zip4 xs ys zs ts =-    toList' (zip4 xs ys zs ts) ~= Data.List.zip4 (toList xs) (toList ys) (toList zs) (toList ts)--prop_zipWith4 :: Seq A -> Seq B -> Seq C -> Seq Int -> Bool-prop_zipWith4 xs ys zs ts =-    toList' (zipWith4 f xs ys zs ts) ~= Data.List.zipWith4 f (toList xs) (toList ys) (toList zs) (toList ts)-  where f = (,,,)---- This comes straight from the MonadZip documentation-prop_mzipNaturality :: Fun A C -> Fun B D -> Seq A -> Seq B -> Property-prop_mzipNaturality f g sa sb =-  fmap (apply f *** apply g) (mzip sa sb) ===-  mzip (apply f <$> sa) (apply g <$> sb)---- This is a slight optimization of the MonadZip preservation--- law that works because sequences don't have any decorations.-prop_mzipPreservation :: Fun A B -> Seq A -> Property-prop_mzipPreservation f sa =-  let sb = fmap (apply f) sa-  in munzip (mzip sa sb) === (sa, sb)---- We want to ensure that------ munzip xs = xs `seq` (fmap fst x, fmap snd x)------ even in the presence of bottoms (alternatives are all balance---- fragile).-prop_munzipLazy :: Seq (Integer, B) -> Bool-prop_munzipLazy pairs = deepseq ((`seq` ()) <$> repaired) True-  where-    partialpairs = mapWithIndex (\i a -> update i err pairs) pairs-    firstPieces = fmap (fst . munzip) partialpairs-    repaired = mapWithIndex (\i s -> update i 10000 s) firstPieces-    err = error "munzip isn't lazy enough"---- Applicative operations--prop_ap :: Seq A -> Seq B -> Bool-prop_ap xs ys =-    toList' ((,) <$> xs <*> ys) ~= ( (,) <$> toList xs <*> toList ys )--prop_ap_NOINLINE :: Seq A -> Seq B -> Bool-prop_ap_NOINLINE xs ys =-    toList' (((,) <$> xs) `apNOINLINE` ys) ~= ( (,) <$> toList xs <*> toList ys )--{-# NOINLINE apNOINLINE #-}-apNOINLINE :: Seq (a -> b) -> Seq a -> Seq b-apNOINLINE fs xs = fs <*> xs--prop_liftA2 :: Seq A -> Seq B -> Property-prop_liftA2 xs ys = valid q .&&.-    toList q === liftA2 (,) (toList xs) (toList ys)-  where-    q = liftA2 (,) xs ys--prop_then :: Seq A -> Seq B -> Bool-prop_then xs ys =-    toList' (xs *> ys) ~= (toList xs *> toList ys)--prop_intersperse :: A -> Seq A -> Bool-prop_intersperse x xs =-    toList' (intersperse x xs) ~= Data.List.intersperse x (toList xs)--prop_cycleTaking :: Int -> Seq A -> Property-prop_cycleTaking n xs =-    (n <= 0 || not (null xs)) ==> toList' (cycleTaking n xs) ~= Data.List.take n (Data.List.cycle (toList xs))--#if __GLASGOW_HASKELL__ >= 800-prop_empty_pat :: Seq A -> Bool-prop_empty_pat xs@Empty = null xs-prop_empty_pat xs = not (null xs)--prop_empty_con :: Bool-prop_empty_con = null Empty--prop_viewl_pat :: Seq A -> Property-prop_viewl_pat xs@(y :<| ys)-  | z :< zs <- viewl xs = y === z .&&. ys === zs-  | otherwise = property failed-prop_viewl_pat xs = property . liftBool $ null xs--prop_viewl_con :: A -> Seq A -> Property-prop_viewl_con x xs = x :<| xs === x <| xs--prop_viewr_pat :: Seq A -> Property-prop_viewr_pat xs@(ys :|> y)-  | zs :> z <- viewr xs = y === z .&&. ys === zs-  | otherwise = property failed-prop_viewr_pat xs = property . liftBool $ null xs--prop_viewr_con :: Seq A -> A -> Property-prop_viewr_con xs x = xs :|> x === xs |> x-#endif---- Monad operations--prop_bind :: Seq A -> Fun A (Seq B) -> Bool-prop_bind xs (Fun _ f) =-    toList' (xs >>= f) ~= (toList xs >>= toList . f)---- MonadFix operation---- It's exceedingly difficult to construct a proper QuickCheck--- property for mfix because the function passed to it must be--- lazy. The following property is really just a unit test in--- disguise, and not a terribly meaningful one.-test_mfix :: Property-test_mfix = toList resS === resL-  where-    facty :: (Int -> Int) -> Int -> Int-    facty _ 0 = 1; facty f n = n * f (n - 1)--    resS :: Seq Int-    resS = fmap ($ 12) $ mfix (\f -> fromList [facty f, facty (+1), facty (+2)])--    resL :: [Int]-    resL = fmap ($ 12) $ mfix (\f -> [facty f, facty (+1), facty (+2)])---- Simple test monad--data M a = Action Int a-    deriving (Eq, Show)--instance Functor M where-    fmap f (Action n x) = Action n (f x)--instance Applicative M where-    pure x = Action 0 x-    Action m f <*> Action n x = Action (m+n) (f x)--instance Monad M where-    return x = Action 0 x-    Action m x >>= f = let Action n y = f x in Action (m+n) y--instance Foldable M where-    foldMap f (Action _ x) = f x--instance Traversable M where-    traverse f (Action n x) = Action n <$> f x
− tests/set-properties.hs 
@@ -1,637 +0,0 @@-{-# LANGUAGE CPP #-}-import qualified Data.IntSet as IntSet-import Data.List (nub,sort)-import qualified Data.List as List-import Data.Monoid (mempty)-import Data.Maybe-import Data.Set-import Prelude hiding (lookup, null, map, filter, foldr, foldl, all, take, drop, splitAt)-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit hiding (Test, Testable)-import Test.QuickCheck-import Test.QuickCheck.Function-import Test.QuickCheck.Poly-import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Class-import Control.Monad (liftM, liftM3)-import Data.Functor.Identity-import Data.Foldable (all)-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative (Applicative (..), (<$>))-#endif-import Control.Applicative (liftA2)--main :: IO ()-main = defaultMain [ testCase "lookupLT" test_lookupLT-                   , testCase "lookupGT" test_lookupGT-                   , testCase "lookupLE" test_lookupLE-                   , testCase "lookupGE" test_lookupGE-                   , testCase "lookupIndex" test_lookupIndex-                   , testCase "findIndex" test_findIndex-                   , testCase "elemAt" test_elemAt-                   , testCase "deleteAt" test_deleteAt-                   , testProperty "prop_Valid" prop_Valid-                   , testProperty "prop_Single" prop_Single-                   , testProperty "prop_Member" prop_Member-                   , testProperty "prop_NotMember" prop_NotMember-                   , testProperty "prop_LookupLT" prop_LookupLT-                   , testProperty "prop_LookupGT" prop_LookupGT-                   , testProperty "prop_LookupLE" prop_LookupLE-                   , testProperty "prop_LookupGE" prop_LookupGE-                   , testProperty "prop_InsertValid" prop_InsertValid-                   , testProperty "prop_InsertDelete" prop_InsertDelete-                   , testProperty "prop_InsertBiased" prop_InsertBiased-                   , testProperty "prop_DeleteValid" prop_DeleteValid-                   , testProperty "prop_Link" prop_Link-                   , testProperty "prop_Merge" prop_Merge-                   , testProperty "prop_UnionValid" prop_UnionValid-                   , testProperty "prop_UnionInsert" prop_UnionInsert-                   , testProperty "prop_UnionAssoc" prop_UnionAssoc-                   , testProperty "prop_UnionComm" prop_UnionComm-                   , testProperty "prop_UnionBiased" prop_UnionBiased-                   , testProperty "prop_DiffValid" prop_DiffValid-                   , testProperty "prop_Diff" prop_Diff-                   , testProperty "prop_IntValid" prop_IntValid-                   , testProperty "prop_Int" prop_Int-                   , testProperty "prop_IntBiased" prop_IntBiased-                   , testProperty "prop_Ordered" prop_Ordered-                   , testProperty "prop_DescendingOrdered" prop_DescendingOrdered-                   , testProperty "prop_List" prop_List-                   , testProperty "prop_DescList" prop_DescList-                   , testProperty "prop_AscDescList" prop_AscDescList-                   , testProperty "prop_fromList" prop_fromList-                   , testProperty "prop_fromListDesc" prop_fromListDesc-                   , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf-                   , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2-                   , testProperty "prop_isSubsetOf" prop_isSubsetOf-                   , testProperty "prop_isSubsetOf2" prop_isSubsetOf2-                   , testProperty "prop_disjoint" prop_disjoint-                   , testProperty "prop_size" prop_size-                   , testProperty "prop_lookupMax" prop_lookupMax-                   , testProperty "prop_lookupMin" prop_lookupMin-                   , testProperty "prop_findMax" prop_findMax-                   , testProperty "prop_findMin" prop_findMin-                   , testProperty "prop_ord" prop_ord-                   , testProperty "prop_readShow" prop_readShow-                   , testProperty "prop_foldR" prop_foldR-                   , testProperty "prop_foldR'" prop_foldR'-                   , testProperty "prop_foldL" prop_foldL-                   , testProperty "prop_foldL'" prop_foldL'-                   , testProperty "prop_map" prop_map-                   , testProperty "prop_map2" prop_map2-                   , testProperty "prop_mapMonotonic" prop_mapMonotonic-                   , testProperty "prop_maxView" prop_maxView-                   , testProperty "prop_minView" prop_minView-                   , testProperty "prop_split" prop_split-                   , testProperty "prop_splitMember" prop_splitMember-                   , testProperty "prop_splitRoot" prop_splitRoot-                   , testProperty "prop_partition" prop_partition-                   , testProperty "prop_filter" prop_filter-                   , testProperty "takeWhileAntitone"    prop_takeWhileAntitone-                   , testProperty "dropWhileAntitone"    prop_dropWhileAntitone-                   , testProperty "spanAntitone"         prop_spanAntitone-                   , testProperty "take"                 prop_take-                   , testProperty "drop"                 prop_drop-                   , testProperty "splitAt"              prop_splitAt-                   , testProperty "powerSet"             prop_powerSet-                   , testProperty "cartesianProduct"     prop_cartesianProduct-                   , testProperty "disjointUnion"        prop_disjointUnion-                   ]---- A type with a peculiar Eq instance designed to make sure keys--- come from where they're supposed to.-data OddEq a = OddEq a Bool deriving (Show)--getOddEq :: OddEq a -> (a, Bool)-getOddEq (OddEq b a) = (b, a)-instance Arbitrary a => Arbitrary (OddEq a) where-  arbitrary = OddEq <$> arbitrary <*> arbitrary-instance Eq a => Eq (OddEq a) where-  OddEq x _ == OddEq y _ = x == y-instance Ord a => Ord (OddEq a) where-  OddEq x _ `compare` OddEq y _ = x `compare` y--------------------------------------------------------------------- Unit tests-------------------------------------------------------------------test_lookupLT :: Assertion-test_lookupLT = do-    lookupLT 3 (fromList [3, 5]) @?= Nothing-    lookupLT 5 (fromList [3, 5]) @?= Just 3--test_lookupGT :: Assertion-test_lookupGT = do-   lookupGT 4 (fromList [3, 5]) @?= Just 5-   lookupGT 5 (fromList [3, 5]) @?= Nothing--test_lookupLE :: Assertion-test_lookupLE = do-   lookupLE 2 (fromList [3, 5]) @?= Nothing-   lookupLE 4 (fromList [3, 5]) @?= Just 3-   lookupLE 5 (fromList [3, 5]) @?= Just 5--test_lookupGE :: Assertion-test_lookupGE = do-   lookupGE 3 (fromList [3, 5]) @?= Just 3-   lookupGE 4 (fromList [3, 5]) @?= Just 5-   lookupGE 6 (fromList [3, 5]) @?= Nothing--{---------------------------------------------------------------------  Indexed---------------------------------------------------------------------}--test_lookupIndex :: Assertion-test_lookupIndex = do-    isJust   (lookupIndex 2 (fromList [5,3])) @?= False-    fromJust (lookupIndex 3 (fromList [5,3])) @?= 0-    fromJust (lookupIndex 5 (fromList [5,3])) @?= 1-    isJust   (lookupIndex 6 (fromList [5,3])) @?= False--test_findIndex :: Assertion-test_findIndex = do-    findIndex 3 (fromList [5,3]) @?= 0-    findIndex 5 (fromList [5,3]) @?= 1--test_elemAt :: Assertion-test_elemAt = do-    elemAt 0 (fromList [5,3]) @?= 3-    elemAt 1 (fromList [5,3]) @?= 5--test_deleteAt :: Assertion-test_deleteAt = do-    deleteAt 0 (fromList [5,3]) @?= singleton 5-    deleteAt 1 (fromList [5,3]) @?= singleton 3--{---------------------------------------------------------------------  Arbitrary, reasonably balanced trees---------------------------------------------------------------------}---- | The IsInt class lets us constrain a type variable to be Int in an entirely--- standard way. The constraint @ IsInt a @ is essentially equivalent to the--- GHC-only constraint @ a ~ Int @, but @ IsInt @ requires manual intervention--- to use. If ~ is ever standardized, we should certainly use it instead.--- Earlier versions used an Enum constraint, but this is confusing because--- not all Enum instances will work properly for the Arbitrary instance here.-class (Show a, Read a, Integral a, Arbitrary a) => IsInt a where-  fromIntF :: f Int -> f a--instance IsInt Int where-  fromIntF = id---- | Convert an Int to any instance of IsInt-fromInt :: IsInt a => Int -> a-fromInt = runIdentity . fromIntF . Identity--{- We don't actually need this, but we can add it if we ever do-toIntF :: IsInt a => g a -> g Int-toIntF = unf . fromIntF . F $ id--newtype F g a b = F {unf :: g b -> a}--toInt :: IsInt a => a -> Int-toInt = runIdentity . toIntF . Identity -}----- How much the minimum value of an arbitrary set should vary-positionFactor :: Int-positionFactor = 1---- How much the gap between consecutive elements in an arbitrary--- set should vary-gapRange :: Int-gapRange = 5--instance IsInt a => Arbitrary (Set a) where-  arbitrary = sized (\sz0 -> do-        sz <- choose (0, sz0)-        middle <- choose (-positionFactor * (sz + 1), positionFactor * (sz + 1))-        let shift = (sz * (gapRange) + 1) `quot` 2-            start = middle - shift-        t <- evalStateT (mkArb step sz) start-        if valid t then pure t else error "Test generated invalid tree!")-    where-      step = do-        i <- get-        diff <- lift $ choose (1, gapRange)-        let i' = i + diff-        put i'-        pure (fromInt i')--class Monad m => MonadGen m where-  liftGen :: Gen a -> m a-instance MonadGen Gen where-  liftGen = id-instance MonadGen m => MonadGen (StateT s m) where-  liftGen = lift . liftGen---- | Given an action that produces successively larger elements and--- a size, produce a set of arbitrary shape with exactly that size.-mkArb :: MonadGen m => m a -> Int -> m (Set a)-mkArb step n-  | n <= 0 = return Tip-  | n == 1 = singleton `liftM` step-  | n == 2 = do-     dir <- liftGen arbitrary-     p <- step-     q <- step-     if dir-       then return (Bin 2 q (singleton p) Tip)-       else return (Bin 2 p Tip (singleton q))-  | otherwise = do-      -- This assumes a balance factor of delta = 3-      let upper = (3*(n - 1)) `quot` 4-      let lower = (n + 2) `quot` 4-      ln <- liftGen $ choose (lower, upper)-      let rn = n - ln - 1-      liftM3 (\lt x rt -> Bin n x lt rt) (mkArb step ln) step (mkArb step rn)---- | Given a strictly increasing list of elements, produce an arbitrarily--- shaped set with exactly those elements.-setFromList :: [a] -> Gen (Set a)-setFromList xs = flip evalStateT xs $ mkArb step (length xs)-  where-    step = do-      x : xs <- get-      put xs-      pure x--data TwoSets = TwoSets (Set Int) (Set Int) deriving (Show)--data TwoLists a = TwoLists [a] [a]--data Options2 = One2 | Two2 | Both2 deriving (Bounded, Enum)-instance Arbitrary Options2 where-  arbitrary = arbitraryBoundedEnum---- We produce two lists from a simple "universe". This instance--- is intended to give good results when the two lists are then--- combined with each other; if other elements are used with them,--- they may or may not behave particularly well.-instance IsInt a => Arbitrary (TwoLists a) where-  arbitrary = sized $ \sz0 -> do-    sz <- choose (0, sz0)-    let universe = [0,3..3*(fromInt sz - 1)]-    divide2Gen universe--instance Arbitrary TwoSets where-  arbitrary = do-    TwoLists l r <- arbitrary-    TwoSets <$> setFromList l <*> setFromList r--divide2Gen :: [a] -> Gen (TwoLists a)-divide2Gen [] = pure (TwoLists [] [])-divide2Gen (x : xs) = do-  way <- arbitrary-  TwoLists ls rs <- divide2Gen xs-  case way of-    One2 -> pure (TwoLists (x : ls) rs)-    Two2 -> pure (TwoLists ls (x : rs))-    Both2 -> pure (TwoLists (x : ls) (x : rs))--{---------------------------------------------------------------------  Valid trees---------------------------------------------------------------------}-forValid :: (IsInt a,Testable b) => (Set a -> b) -> Property-forValid f = forAll arbitrary $ \t ->-    classify (size t == 0) "empty" $-    classify (size t > 0  && size t <= 10) "small" $-    classify (size t > 10 && size t <= 64) "medium" $-    classify (size t > 64) "large" $ f t--forValidUnitTree :: Testable a => (Set Int -> a) -> Property-forValidUnitTree f = forValid f--prop_Valid :: Property-prop_Valid = forValidUnitTree $ \t -> valid t--{---------------------------------------------------------------------  Single, Member, Insert, Delete---------------------------------------------------------------------}-prop_Single :: Int -> Bool-prop_Single x = (insert x empty == singleton x)--prop_Member :: [Int] -> Int -> Bool-prop_Member xs n =-  let m  = fromList xs-  in all (\k -> k `member` m == (k `elem` xs)) (n : xs)--prop_NotMember :: [Int] -> Int -> Bool-prop_NotMember xs n =-  let m  = fromList xs-  in all (\k -> k `notMember` m == (k `notElem` xs)) (n : xs)--test_LookupSomething :: (Int -> Set Int -> Maybe Int) -> (Int -> Int -> Bool) -> [Int] -> Bool-test_LookupSomething lookup' cmp xs =-  let odd_sorted_xs = filter_odd $ nub $ sort xs-      t = fromList odd_sorted_xs-      test x = case List.filter (`cmp` x) odd_sorted_xs of-                 []             -> lookup' x t == Nothing-                 cs | 0 `cmp` 1 -> lookup' x t == Just (last cs) -- we want largest such element-                    | otherwise -> lookup' x t == Just (head cs) -- we want smallest such element-  in all test xs--  where filter_odd [] = []-        filter_odd [_] = []-        filter_odd (_ : o : xs) = o : filter_odd xs--prop_LookupLT :: [Int] -> Bool-prop_LookupLT = test_LookupSomething lookupLT (<)--prop_LookupGT :: [Int] -> Bool-prop_LookupGT = test_LookupSomething lookupGT (>)--prop_LookupLE :: [Int] -> Bool-prop_LookupLE = test_LookupSomething lookupLE (<=)--prop_LookupGE :: [Int] -> Bool-prop_LookupGE = test_LookupSomething lookupGE (>=)--prop_InsertValid :: Int -> Property-prop_InsertValid k = forValidUnitTree $ \t -> valid (insert k t)--prop_InsertDelete :: Int -> Set Int -> Property-prop_InsertDelete k t = not (member k t) ==> delete k (insert k t) == t--prop_InsertBiased :: Int -> Set Int -> Bool-prop_InsertBiased k t = (k, True) `member` kt-  where-    t' = mapMonotonic (`OddEq` False) t-    kt' = insert (OddEq k True) t'-    kt = mapMonotonic getOddEq kt'--prop_DeleteValid :: Int -> Property-prop_DeleteValid k = forValidUnitTree $ \t -> valid (delete k (insert k t))--{---------------------------------------------------------------------  Balance---------------------------------------------------------------------}-prop_Link :: Int -> Property-prop_Link x = forValidUnitTree $ \t ->-    let (l,r) = split x t-    in valid (link x l r)--prop_Merge :: Int -> Property-prop_Merge x = forValidUnitTree $ \t ->-    let (l,r) = split x t-    in valid (merge l r)--{---------------------------------------------------------------------  Union---------------------------------------------------------------------}-prop_UnionValid :: Property-prop_UnionValid-  = forValidUnitTree $ \t1 ->-    forValidUnitTree $ \t2 ->-    valid (union t1 t2)--prop_UnionInsert :: Int -> Set Int -> Bool-prop_UnionInsert x t = union t (singleton x) == insert x t--prop_UnionAssoc :: Set Int -> Set Int -> Set Int -> Bool-prop_UnionAssoc t1 t2 t3 = union t1 (union t2 t3) == union (union t1 t2) t3--prop_UnionComm :: TwoSets -> Bool-prop_UnionComm (TwoSets t1 t2) = (union t1 t2 == union t2 t1)--prop_UnionBiased :: TwoSets -> Property-prop_UnionBiased (TwoSets l r) = union l' r' === union l' (difference r' l')-  where-    l' = mapMonotonic (`OddEq` False) l-    r' = mapMonotonic (`OddEq` True) r--prop_IntBiased :: TwoSets -> Bool-prop_IntBiased (TwoSets l r) = all (\(OddEq _ b) -> not b) l'r'-  where-    l' = mapMonotonic (`OddEq` False) l-    r' = mapMonotonic (`OddEq` True) r-    l'r' = intersection l' r'--prop_DiffValid :: Property-prop_DiffValid = forValidUnitTree $ \t1 ->-    forValidUnitTree $ \t2 ->-    valid (difference t1 t2)--prop_Diff :: [Int] -> [Int] -> Bool-prop_Diff xs ys = toAscList (difference (fromList xs) (fromList ys))-                  == List.sort ((List.\\) (nub xs)  (nub ys))--prop_IntValid :: Property-prop_IntValid = forValidUnitTree $ \t1 ->-    forValidUnitTree $ \t2 ->-    valid (intersection t1 t2)--prop_Int :: [Int] -> [Int] -> Bool-prop_Int xs ys = toAscList (intersection (fromList xs) (fromList ys))-                 == List.sort (nub ((List.intersect) (xs)  (ys)))--prop_disjoint :: Set Int -> Set Int -> Bool-prop_disjoint a b = a `disjoint` b == null (a `intersection` b)--{---------------------------------------------------------------------  Lists---------------------------------------------------------------------}-prop_Ordered :: Property-prop_Ordered = forAll (choose (5,100)) $ \n ->-    let xs = [0..n::Int]-    in fromAscList xs === fromList xs--prop_DescendingOrdered :: Property-prop_DescendingOrdered = forAll (choose (5,100)) $ \n ->-    let xs = [n,n-1..0::Int]-    in fromDescList xs === fromList xs--prop_List :: [Int] -> Bool-prop_List xs = (sort (nub xs) == toList (fromList xs))--prop_DescList :: [Int] -> Bool-prop_DescList xs = (reverse (sort (nub xs)) == toDescList (fromList xs))--prop_AscDescList :: [Int] -> Bool-prop_AscDescList xs = toAscList s == reverse (toDescList s)-  where s = fromList xs--prop_fromList :: [Int] -> Property-prop_fromList xs =-           t === fromAscList sort_xs .&&.-           t === fromDistinctAscList nub_sort_xs .&&.-           t === List.foldr insert empty xs-  where t = fromList xs-        sort_xs = sort xs-        nub_sort_xs = List.map List.head $ List.group sort_xs--prop_fromListDesc :: [Int] -> Property-prop_fromListDesc xs =-           t === fromDescList sort_xs .&&.-           t === fromDistinctDescList nub_sort_xs .&&.-           t === List.foldr insert empty xs-  where t = fromList xs-        sort_xs = reverse (sort xs)-        nub_sort_xs = List.map List.head $ List.group sort_xs--{---------------------------------------------------------------------  Set operations are like IntSet operations---------------------------------------------------------------------}-toIntSet :: Set Int -> IntSet.IntSet-toIntSet = IntSet.fromList . toList---- Check that Set Int.isProperSubsetOf is the same as Set.isProperSubsetOf.-prop_isProperSubsetOf :: TwoSets -> Bool-prop_isProperSubsetOf (TwoSets a b) = isProperSubsetOf a b == IntSet.isProperSubsetOf (toIntSet a) (toIntSet b)---- In the above test, isProperSubsetOf almost always returns False (since a--- random set is almost never a subset of another random set).  So this second--- test checks the True case.-prop_isProperSubsetOf2 :: TwoSets -> Bool-prop_isProperSubsetOf2 (TwoSets a b) = isProperSubsetOf a c == (a /= c) where-  c = union a b--prop_isSubsetOf :: TwoSets -> Bool-prop_isSubsetOf (TwoSets a b) = isSubsetOf a b == IntSet.isSubsetOf (toIntSet a) (toIntSet b)--prop_isSubsetOf2 :: TwoSets -> Bool-prop_isSubsetOf2 (TwoSets a b) = isSubsetOf a (union a b)--prop_size :: Set Int -> Bool-prop_size s = size s == List.length (toList s)--prop_findMax :: Set Int -> Property-prop_findMax s = not (null s) ==> findMax s == maximum (toList s)--prop_findMin :: Set Int -> Property-prop_findMin s = not (null s) ==> findMin s == minimum (toList s)--prop_lookupMin :: Set Int -> Property-prop_lookupMin m = lookupMin m === (fst <$> minView m)--prop_lookupMax :: Set Int -> Property-prop_lookupMax m = lookupMax m === (fst <$> maxView m)--prop_ord :: TwoSets -> Bool-prop_ord (TwoSets s1 s2) = s1 `compare` s2 == toList s1 `compare` toList s2--prop_readShow :: Set Int -> Bool-prop_readShow s = s == read (show s)--prop_foldR :: Set Int -> Bool-prop_foldR s = foldr (:) [] s == toList s--prop_foldR' :: Set Int -> Bool-prop_foldR' s = foldr' (:) [] s == toList s--prop_foldL :: Set Int -> Bool-prop_foldL s = foldl (flip (:)) [] s == List.foldl (flip (:)) [] (toList s)--prop_foldL' :: Set Int -> Bool-prop_foldL' s = foldl' (flip (:)) [] s == List.foldl' (flip (:)) [] (toList s)--prop_map :: Set Int -> Bool-prop_map s = map id s == s--prop_map2 :: Fun Int Int -> Fun Int Int -> Set Int -> Property-prop_map2 f g s = map (apply f) (map (apply g) s) === map (apply f . apply g) s--prop_mapMonotonic :: Set Int -> Property-prop_mapMonotonic s = mapMonotonic id s === s--prop_maxView :: Set Int -> Bool-prop_maxView s = case maxView s of-    Nothing -> null s-    Just (m,s') -> m == maximum (toList s) && s == insert m s' && m `notMember` s'--prop_minView :: Set Int -> Bool-prop_minView s = case minView s of-    Nothing -> null s-    Just (m,s') -> m == minimum (toList s) && s == insert m s' && m `notMember` s'--prop_split :: Set Int -> Int -> Bool-prop_split s i = case split i s of-    (s1,s2) -> all (<i) (toList s1) && all (>i) (toList s2) && i `delete` s == union s1 s2--prop_splitMember :: Set Int -> Int -> Bool-prop_splitMember s i = case splitMember i s of-    (s1,t,s2) -> all (<i) (toList s1) && all (>i) (toList s2) && t == i `member` s && i `delete` s == union s1 s2--prop_splitRoot :: Set Int -> Bool-prop_splitRoot s = loop ls && (s == unions ls)- where-  ls = splitRoot s-  loop [] = True-  loop (s1:rst) = List.null-                  [ (x,y) | x <- toList s1-                          , y <- toList (unions rst)-                          , x > y ]--prop_partition :: Set Int -> Int -> Bool-prop_partition s i = case partition odd s of-    (s1,s2) -> all odd (toList s1) && all even (toList s2) && s == s1 `union` s2--prop_filter :: Set Int -> Int -> Bool-prop_filter s i = partition odd s == (filter odd s, filter even s)--prop_take :: Int -> Set Int -> Property-prop_take n xs = valid taken .&&.-                 taken === fromDistinctAscList (List.take n (toList xs))-  where-    taken = take n xs--prop_drop :: Int -> Set Int -> Property-prop_drop n xs = valid dropped .&&.-                 dropped === fromDistinctAscList (List.drop n (toList xs))-  where-    dropped = drop n xs--prop_splitAt :: Int -> Set Int -> Property-prop_splitAt n xs = valid taken .&&.-                    valid dropped .&&.-                    taken === take n xs .&&.-                    dropped === drop n xs-  where-    (taken, dropped) = splitAt n xs--prop_takeWhileAntitone :: [Either Int Int] -> Property-prop_takeWhileAntitone xs' = valid tw .&&. tw === filter isLeft xs-  where-    xs = fromList xs'-    tw = takeWhileAntitone isLeft xs--prop_dropWhileAntitone :: [Either Int Int] -> Property-prop_dropWhileAntitone xs' = valid tw .&&. tw === filter (not . isLeft) xs-  where-    xs = fromList xs'-    tw = dropWhileAntitone isLeft xs--prop_spanAntitone :: [Either Int Int] -> Property-prop_spanAntitone xs' = valid tw .&&. valid dw-                        .&&. tw === takeWhileAntitone isLeft xs-                        .&&. dw === dropWhileAntitone isLeft xs-  where-    xs = fromList xs'-    (tw, dw) = spanAntitone isLeft xs--prop_powerSet :: Set Int -> Property-prop_powerSet xs = valid ps .&&. ps === ps'-  where-    xs' = take 10 xs--    ps = powerSet xs'-    ps' = fromList . fmap fromList $ lps (toList xs')--    lps [] = [[]]-    lps (y : ys) = fmap (y:) (lps ys) ++ lps ys--prop_cartesianProduct :: Set Int -> Set Int -> Property-prop_cartesianProduct xs ys =-  valid cp .&&. toList cp === liftA2 (,) (toList xs) (toList ys)-  where cp = cartesianProduct xs ys--prop_disjointUnion :: Set Int -> Set Int -> Property-prop_disjointUnion xs ys =-  valid du .&&. du === union (mapMonotonic Left xs) (mapMonotonic Right ys)-  where du = disjointUnion xs ys--isLeft :: Either a b -> Bool-isLeft (Left _) = True-isLeft _ = False
− tests/tree-properties.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE CPP #-}--import Data.Tree as T--import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>), liftA2)--import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Test.QuickCheck-import Test.QuickCheck.Function (Fun (..), apply)-import Test.QuickCheck.Poly (A, B, C)-import Control.Monad.Fix (MonadFix (..))-import Control.Monad (ap)--default (Int)--main :: IO ()-main = defaultMain-         [-           testProperty "monad_id1"                prop_monad_id1-         , testProperty "monad_id2"                prop_monad_id2-         , testProperty "monad_assoc"              prop_monad_assoc-         , testProperty "ap_ap"                    prop_ap_ap-         , testProperty "ap_liftA2"                prop_ap_liftA2-         , testProperty "monadFix_ls"              prop_monadFix_ls-         ]--{---------------------------------------------------------------------  Arbitrary trees---------------------------------------------------------------------}----- This instance isn't balanced very well; the trees will probably tend--- to lean left. But it's better than nothing and we can fix it later.-instance Arbitrary a => Arbitrary (Tree a) where-  arbitrary = sized (fmap snd . arbtree)-    where-      arbtree :: Arbitrary a => Int -> Gen (Int, Tree a)-      arbtree 0 = fmap ((,) 1) $ Node <$> arbitrary <*> pure []-      arbtree n = do-        root <- arbitrary-        num_children <- choose (0, n - 1)-        (st, tl) <- go num_children-        return (1+st, Node root tl)--      go 0 = pure (0, [])-      go n = do-        (sh, hd) <- arbtree n-        (st, tl) <- go (n - sh)-        pure (sh + st, hd : tl)--#if defined(__GLASGOW_HASKELL__)-  shrink = genericShrink-#endif--------------------------------------------------------------------- Unit tests-------------------------------------------------------------------------------------------------------------------------------------- QuickCheck-------------------------------------------------------------------apply2 :: Fun (a, b) c -> a -> b -> c-apply2 f a b = apply f (a, b)--prop_ap_ap :: Tree (Fun A B) -> Tree A -> Property-prop_ap_ap fs xs = (apply <$> fs <*> xs) === ((apply <$> fs) `ap` xs)--prop_ap_liftA2 :: Fun (A, B) C -> Tree A -> Tree B -> Property-prop_ap_liftA2 f as bs = (apply2 f <$> as <*> bs) === liftA2 (apply2 f) as bs--prop_monad_id1 :: Tree A -> Property-prop_monad_id1 t = (t >>= pure) === t--prop_monad_id2 :: A -> Fun A (Tree B) -> Property-prop_monad_id2 a f = (pure a >>= apply f) === apply f a--prop_monad_assoc :: Tree A -> Fun A (Tree B) -> Fun B (Tree C) -> Property-prop_monad_assoc ta atb btc =-  ((ta >>= apply atb) >>= apply btc)-  ===-  (ta >>= \a -> apply atb a >>= apply btc)---- The left shrinking law------ This test is kind of wonky and unprincipled, because it's--- rather tricky to construct test cases!--- This is the most important MonadFix law to test because it's the--- least intuitive by far, and because it's the only one that's--- sensitive to the Monad instance.-prop_monadFix_ls :: Int -> Tree Int -> Fun Int (Tree Int) -> Property-prop_monadFix_ls val ta ti =-  fmap ($val) (mfix (\x -> ta >>= \y -> f x y))-  ===-  fmap ($val) (ta >>= \y -> mfix (\x -> f x y))-  where-    fact :: Int -> (Int -> Int) -> Int -> Int-    fact x _ 0 = x + 1-    fact x f n = x + n * f ((n - 1) `mod` 23)--    f :: (Int -> Int) -> Int -> Tree (Int -> Int)-    f q y = let t = apply ti y-            in fmap (\w -> fact w q) t