containers 0.6.2.1 → 0.6.3.1

raw patch · 20 files changed

+1184/−232 lines, 20 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• changelog.md +53/−0
• containers.cabal +4/−3
• src/Data/Containers/ListUtils.hs +10/−0
• src/Data/Graph.hs +1/−1
• src/Data/IntMap/Internal.hs +159/−72
• src/Data/IntMap/Lazy.hs +4/−1
• src/Data/IntMap/Strict.hs +4/−1
• src/Data/IntMap/Strict/Internal.hs +118/−42
• src/Data/IntSet.hs +5/−1
• src/Data/IntSet/Internal.hs +302/−51
• src/Data/Map/Internal.hs +54/−4
• src/Data/Map/Lazy.hs +3/−0
• src/Data/Map/Strict.hs +3/−0
• src/Data/Map/Strict/Internal.hs +25/−1
• src/Data/Sequence.hs +9/−3
• src/Data/Sequence/Internal.hs +347/−45
• src/Data/Sequence/Internal/Sorting.hs +0/−1
• src/Data/Set.hs +4/−0
• src/Data/Set/Internal.hs +71/−0
• src/Data/Tree.hs +8/−6

@@ -1,5 +1,58 @@ # Changelog for [`containers` package](http://github.com/haskell/containers) +## 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).

@@ -1,5 +1,5 @@ name: containers-version: 0.6.2.1+version: 0.6.3.1 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org@@ -20,18 +20,19 @@     remains valid even if structures are shared.  build-type: Simple-cabal-version:  >=1.8+cabal-version:  >=1.10 extra-source-files:     include/containers.h     changelog.md -tested-with: GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3+tested-with: GHC==8.8.2, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3  source-repository head     type:     git     location: http://github.com/haskell/containers.git  Library+    default-language: Haskell2010     build-depends: base >= 4.6 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.5     hs-source-dirs: src     ghc-options: -O2 -Wall

@@ -17,6 +17,8 @@ -- 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 (@@ -53,6 +55,8 @@ -- 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 #-}@@ -65,6 +69,8 @@ -- -- @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.@@ -129,6 +135,8 @@ -- ==== Strictness -- -- @nubInt@ is strict in the elements of the list.+--+-- @since 0.6.0.1 nubInt :: [Int] -> [Int] nubInt = nubIntOn id {-# INLINE nubInt #-}@@ -142,6 +150,8 @@ -- -- @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.

@@ -383,7 +383,7 @@ -- 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.+-- vertices of a given vertex, and b) how to retrieve a vertex given a key. -- -- @(graph, nodeFromVertex, vertexFromKey) = graphFromEdges edgeList@ --

@@ -131,6 +131,9 @@     , intersectionWith     , intersectionWithKey +    -- ** Compose+    , compose+     -- ** General combining function     , SimpleWhenMissing     , SimpleWhenMatched@@ -266,6 +269,7 @@     , natFromInt     , intFromNat     , link+    , linkWithMask     , bin     , binCheckLeft     , binCheckRight@@ -478,7 +482,9 @@   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+          start (Bin _ m l r)+            | m < 0     = go (start r) l+            | otherwise = go (start l) r            go !m Nil = m           go m (Tip _ y) = max m y@@ -487,7 +493,9 @@   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+          start (Bin _ m l r)+            | m < 0     = go (start r) l+            | otherwise = go (start l) r            go !m Nil = m           go m (Tip _ y) = min m y@@ -761,6 +769,27 @@               | otherwise        = disjoint t1 r2  {--------------------------------------------------------------------+  Compose+--------------------------------------------------------------------}+-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument+--+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- @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.@@ -1825,8 +1854,9 @@   :: 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)+filterWithKeyA f (Bin p m l r)+  | m < 0     = liftA2 (flip (bin p m)) (filterWithKeyA f r) (filterWithKeyA f l)+  | otherwise = liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r)  -- | This wasn't in Data.Bool until 4.7.0, so we define it here bool :: a -> a -> Bool -> a@@ -1867,7 +1897,9 @@     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)+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)+      | otherwise = liftA2 (bin p m) (go l) (go r)   -- | Merge two maps.@@ -2039,8 +2071,8 @@       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)+          | zero k1 m2       = binA p2 m2 (merge2 l2) (g2t r2)+          | otherwise        = binA p2 m2 (g2t l2) (merge2 r2)         merge2 (Tip k2 x2)   = mergeTips k1 x1 k2 x2         merge2 Nil           = subsingletonBy g1k k1 x1 @@ -2048,23 +2080,23 @@       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)+          | zero k2 m1       = binA p1 m1 (merge1 l1) (g1t r1)+          | otherwise        = binA p1 m1 (g1t l1) (merge1 r1)         merge1 (Tip k1 x1)   = mergeTips k1 x1 k2 x2         merge1 Nil           = subsingletonBy g2k k2 x2      go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)       | shorter m1 m2  = merge1       | shorter m2 m1  = merge2-      | p1 == p2       = liftA2 (bin p1 m1)   (go  l1 l2) (go r1 r2)-      | otherwise      = liftA2 (link_ p1 p2) (g1t t1)    (g2t   t2)+      | p1 == p2       = binA p1 m1 (go l1 l2) (go r1 r2)+      | otherwise      = linkA p1 (g1t t1) p2 (g2t t2)       where-        merge1 | nomatch p2 p1 m1  = 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)+        merge1 | nomatch p2 p1 m1  = linkA p1 (g1t t1) p2 (g2t t2)+               | zero p2 m1        = binA p1 m1 (go  l1 t2) (g1t r1)+               | otherwise         = binA p1 m1 (g1t l1)    (go  r1 t2)+        merge2 | nomatch p1 p2 m2  = linkA p1 (g1t t1) p2 (g2t t2)+               | zero p1 m2        = binA p2 m2 (go  t1 l2) (g2t    r2)+               | otherwise         = binA p2 m2 (g2t    l2) (go  t1 r2)      subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x     {-# INLINE subsingletonBy #-}@@ -2084,11 +2116,6 @@     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@@ -2097,12 +2124,26 @@         -> 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+      | zero p1 m = binA p m t1 t2+      | otherwise = binA p m t2 t1       where         m = branchMask p1 p2         p = mask p1 m     {-# INLINE linkA #-}++    -- A variant of 'bin' that ensures that effects for negative keys are executed+    -- first.+    binA+        :: Applicative f+        => Prefix+        -> Mask+        -> f (IntMap a)+        -> f (IntMap a)+        -> f (IntMap a)+    binA p m a b+      | m < 0     = liftA2 (flip (bin p m)) b a+      | otherwise = liftA2       (bin p m)  a b+    {-# INLINE binA #-} {-# INLINE mergeA #-}  @@ -2309,7 +2350,7 @@  {- | /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,+ @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':@@ -2456,7 +2497,7 @@     go Nil = pure Nil     go (Tip k v) = Tip k <$> f k v     go (Bin p m l r)-      | m < 0     = liftA2 (Bin p m) (go r) (go l)+      | m < 0     = liftA2 (flip (Bin p m)) (go r) (go l)       | otherwise = liftA2 (Bin p m) (go l) (go r) {-# INLINE traverseWithKey #-} @@ -2484,20 +2525,32 @@ 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')+      Bin p m l r+        | m < 0 ->+            let (a1,r') = mapAccumL f a r+                (a2,l') = mapAccumL f a1 l+            in (a2,Bin p m l' r')+        | otherwise  ->+            let (a1,l') = mapAccumL f a l+                (a2,r') = mapAccumL f a1 r+            in (a2,Bin p m l' r')       Tip k x     -> let (a',x') = f a k x in (a',Tip k x')       Nil         -> (a,Nil) --- | /O(n)/. The function @'mapAccumR'@ threads an accumulating+-- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccumRWithKey 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')+      Bin p m l r+        | m < 0 ->+            let (a1,l') = mapAccumRWithKey f a l+                (a2,r') = mapAccumRWithKey f a1 r+            in (a2,Bin p m l' r')+        | otherwise  ->+            let (a1,r') = mapAccumRWithKey f a r+                (a2,l') = mapAccumRWithKey f a1 l+            in (a2,Bin p m l' r')       Tip k x     -> let (a',x') = f a k x in (a',Tip k x')       Nil         -> (a,Nil) @@ -3111,8 +3164,8 @@ -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]  fromAscList :: [(Key,a)] -> IntMap a-fromAscList xs-  = fromAscListWithKey (\_ x _ -> x) xs+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.@@ -3121,8 +3174,8 @@ -- > 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+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.@@ -3132,14 +3185,8 @@ -- > 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+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.@@ -3147,36 +3194,72 @@ -- -- > 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+fromDistinctAscList :: [(Key,a)] -> IntMap a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromMonoListWithKey distinct f = go   where-    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+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1 -#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)+    -- `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' -    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+    -- 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' -data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada+    -- `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 --------------------------------------------------------------------}@@ -3297,13 +3380,17 @@   Link --------------------------------------------------------------------} link :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a-link p1 t1 p2 t2+link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Mask -> Prefix -> IntMap a -> IntMap a -> IntMap a+linkWithMask m p1 t1 {-p2-} t2   | zero p1 m = Bin p m t1 t2   | otherwise = Bin p m t2 t1   where-    m = branchMask p1 p2     p = mask p1 m-{-# INLINE link #-}+{-# INLINE linkWithMask #-}  {--------------------------------------------------------------------   @bin@ assures that we never have empty trees within a tree.

@@ -58,7 +58,7 @@ -- --    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\", --      Workshop on ML, September 1998, pages 77-86,---      <http://citeseer.ist.psu.edu/okasaki98fast.html>+--      <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),@@ -145,6 +145,9 @@      -- ** Disjoint     , disjoint++    -- ** Compose+    , compose      -- ** Universal combining function     , mergeWithKey

@@ -75,7 +75,7 @@ -- --    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\", --      Workshop on ML, September 1998, pages 77-86,---      <http://citeseer.ist.psu.edu/okasaki98fast.html>+--      <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),@@ -164,6 +164,9 @@      -- ** Disjoint     , disjoint++    -- ** Compose+    , compose      -- ** Universal combining function     , mergeWithKey

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-}  #include "containers.h" @@ -72,7 +73,7 @@ -- --    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\", --      Workshop on ML, September 1998, pages 77-86,---      <http://citeseer.ist.psu.edu/okasaki98fast.html>+--      <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),@@ -162,6 +163,9 @@     -- ** Disjoint     , disjoint +    -- ** Compose+    , compose+     -- ** Universal combining function     , mergeWithKey @@ -257,11 +261,8 @@ import Data.IntMap.Internal   ( IntMap (..)   , Key-  , Prefix-  , Mask   , mask   , branchMask-  , shorter   , nomatch   , zero   , natFromInt@@ -270,6 +271,7 @@   , binCheckLeft   , binCheckRight   , link+  , linkWithMask    , (\\)   , (!)@@ -717,6 +719,27 @@   = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2  {--------------------------------------------------------------------+  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 '!?')+-- @+--+-- @since 0.6.3.1+compose :: IntMap c -> IntMap Int -> IntMap c+compose bc !ab+  | null bc = empty+  | otherwise = mapMaybe (bc !?) ab++{--------------------------------------------------------------------   MergeWithKey --------------------------------------------------------------------} @@ -894,7 +917,9 @@   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)+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (Bin p m)) (go r) (go l)+      | otherwise = liftA2 (Bin p m) (go l) (go r) {-# INLINE traverseWithKey #-}  -- | /O(n)/. Traverse keys\/values and collect the 'Just' results.@@ -904,7 +929,9 @@     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)+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)+      | otherwise = liftA2 (bin p m) (go l) (go r)  -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys.@@ -934,22 +961,34 @@   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')+          Bin p m l r+            | m < 0 ->+                let (a1 :*: r') = go f a r+                    (a2 :*: l') = go f a1 l+                in (a2 :*: Bin p m l' r')+            | otherwise ->+                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+-- | /O(n)/. The function @'mapAccumRWithKey'@ threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c) mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0   where     go f a t       = case t of-          Bin p m l r -> let (a1 :*: r') = go f a r-                             (a2 :*: l') = go f a1 l-                         in (a2 :*: Bin p m l' r')+          Bin p m l r+            | m < 0 ->+              let (a1 :*: l') = go f a l+                  (a2 :*: r') = go f a1 r+              in (a2 :*: Bin p m l' r')+            | otherwise ->+              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) @@ -1098,8 +1137,8 @@ -- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]  fromAscList :: [(Key,a)] -> IntMap a-fromAscList xs-  = fromAscListWithKey (\_ x _ -> x) xs+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.@@ -1108,8 +1147,8 @@ -- > 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+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.@@ -1118,14 +1157,8 @@ -- > 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+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.@@ -1134,24 +1167,67 @@ -- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]  fromDistinctAscList :: [(Key,a)] -> IntMap a-fromDistinctAscList []         = Nil-fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | /O(n)/. Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromMonoListWithKey distinct f = go   where-    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+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1 -    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)+    -- `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' -    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+    -- 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' -data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada+    -- `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

@@ -47,7 +47,7 @@ -- --    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\", --      Workshop on ML, September 1998, pages 77-86,---      <http://citeseer.ist.psu.edu/okasaki98fast.html>+--      <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),@@ -86,6 +86,9 @@             -- * Deletion             , delete +            -- * Generalized insertion/deletion+            , alterF+             -- * Query             , member             , notMember@@ -115,6 +118,7 @@              -- * Map             , IS.map+            , mapMonotonic              -- * Folds             , IS.foldr

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-} #endif@@ -53,7 +54,7 @@ -- --    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\", --      Workshop on ML, September 1998, pages 77-86,---      <http://citeseer.ist.psu.edu/okasaki98fast.html>+--      <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),@@ -125,6 +126,7 @@     , singleton     , insert     , delete+    , alterF      -- * Combine     , union@@ -141,6 +143,7 @@      -- * Map     , map+    , mapMonotonic      -- * Folds     , foldr@@ -186,6 +189,7 @@     , zero     ) where +import Control.Applicative (Const(..)) import Control.DeepSeq (NFData(rnf)) import Data.Bits import qualified Data.List as List@@ -210,20 +214,19 @@ import Utils.Containers.Internal.StrictPair  #if __GLASGOW_HASKELL__-import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix), DataType, mkDataType)+import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType)+import qualified Data.Data 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.Exts (indexInt8OffAddr#)+import qualified GHC.Exts #endif  import qualified Data.Foldable as Foldable-#if !MIN_VERSION_base(4,8,0)+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity(..))+#else import Data.Foldable (Foldable()) #endif @@ -310,7 +313,7 @@   dataTypeOf _   = intSetDataType  fromListConstr :: Constr-fromListConstr = mkConstr intSetDataType "fromList" [] Prefix+fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix  intSetDataType :: DataType intSetDataType = mkDataType "Data.IntSet.Internal.IntSet" [fromListConstr]@@ -503,7 +506,43 @@   | otherwise = t deleteBM _ _ Nil = Nil +-- | /O(min(n,W))/. @('alterF' f x s)@ can delete or insert @x@ in @s@ depending+-- on whether it is already present in @s@.+--+-- In short:+--+-- @+-- 'member' x \<$\> 'alterF' f x s = f ('member' x s)+-- @+--+-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".+--+-- @since 0.6.3.1+alterF :: Functor f => (Bool -> f Bool) -> Key -> IntSet -> f IntSet+alterF f k s = fmap choose (f member_)+  where+    member_ = member k s +    (inserted, deleted)+      | member_   = (s         , delete k s)+      | otherwise = (insert k s, s         )++    choose True  = inserted+    choose False = deleted+#ifndef __GLASGOW_HASKELL__+{-# INLINE alterF #-}+#else+{-# INLINABLE [2] alterF #-}++{-# RULES+"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s+ #-}+#endif++#if MIN_VERSION_base(4,8,0)+{-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> IntSet -> Identity IntSet #-}+#endif+ {--------------------------------------------------------------------   Union --------------------------------------------------------------------}@@ -911,6 +950,23 @@ map :: (Key -> Key) -> IntSet -> IntSet map f = fromList . List.map f . toList +-- | /O(n)/. The+--+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.+-- /The precondition is not checked./+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapMonotonic f s == map f s+-- >     where ls = toList s+--+-- @since 0.6.3.1++-- Note that for now the test is insufficient to support any fancier implementation.+mapMonotonic :: (Key -> Key) -> IntSet -> IntSet+mapMonotonic f = fromDistinctAscList . List.map f . toAscList++ {--------------------------------------------------------------------   Fold --------------------------------------------------------------------}@@ -999,7 +1055,7 @@ --------------------------------------------------------------------} #if __GLASGOW_HASKELL__ >= 708 -- | @since 0.5.6.2-instance GHCExts.IsList IntSet where+instance GHC.Exts.IsList IntSet where   type Item IntSet = Key   fromList = fromList   toList   = toList@@ -1043,9 +1099,9 @@ -- 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.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 = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}+{-# 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 @@ -1060,41 +1116,74 @@ -- | /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+fromAscList = fromMonoList+{-# NOINLINE fromAscList #-}  -- | /O(n)/. Build a set from an ascending list of distinct elements. -- /The precondition (input list is strictly ascending) is not checked./ fromDistinctAscList :: [Key] -> IntSet-fromDistinctAscList []         = Nil-fromDistinctAscList (z0 : zs0) = work (prefixOf z0) (bitmapOf z0) zs0 Nada+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-    -- '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+    -- `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' -    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)+    -- 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' -    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+    -- `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' -data Stack = Push {-# UNPACK #-} !Prefix !IntSet !Stack | Nada+    -- `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@@ -1124,9 +1213,157 @@ --------------------------------------------------------------------}  instance Ord IntSet where-    compare s1 s2 = compare (toAscList s1) (toAscList s2)-    -- tentative implementation. See if more efficient exists.+  compare Nil Nil = EQ+  compare Nil _ = LT+  compare _ Nil = GT+  compare t1@(Tip _ _) t2@(Tip _ _)+    = orderingOf $ relateTipTip t1 t2+  compare xs ys+    | (xsNeg, xsNonNeg) <- splitSign xs+    , (ysNeg, ysNonNeg) <- splitSign ys+    = case relate xsNeg ysNeg of+       Less -> LT+       Prefix -> if null xsNonNeg then LT else GT+       Equals -> orderingOf (relate xsNonNeg ysNonNeg)+       FlipPrefix -> if null ysNonNeg then GT else LT+       Greater -> GT +-- | detailed outcome of lexicographic comparison of lists.+-- w.r.t. Ordering, there are two extra cases,+-- since (++) is not monotonic w.r.t. lex. order on lists+-- (which is used by definition):+-- consider comparison of  (Bin [0,3,4] [ 6] ) to  (Bin [0,3] [7] )+-- where [0,3,4] > [0,3]  but [0,3,4,6] < [0,3,7].++data Relation+  = Less  -- ^ holds for [0,3,4] [0,3,5,1]+  | Prefix -- ^ holds for [0,3,4] [0,3,4,5]+  | Equals -- ^  holds for [0,3,4] [0,3,4]+  | FlipPrefix -- ^ holds for [0,3,4] [0,3]+  | Greater -- ^ holds for [0,3,4] [0,2,5]+  deriving (Show, Eq)+   +orderingOf :: Relation -> Ordering+{-# INLINE orderingOf #-}+orderingOf r = case r of+  Less -> LT+  Prefix -> LT+  Equals -> EQ+  FlipPrefix -> GT+  Greater -> GT++-- | precondition: each argument is non-mixed+relate :: IntSet -> IntSet -> Relation+relate Nil Nil = Equals+relate Nil _t2 = Prefix+relate _t1 Nil = FlipPrefix+relate t1@Tip{} t2@Tip{} = relateTipTip t1 t2+relate t1@(Bin _p1 m1 l1 r1) t2@(Bin _p2 m2 l2 r2)+  | succUpperbound t1 <= lowerbound t2 = Less+  | lowerbound t1 >= succUpperbound t2 = Greater+  | otherwise = case compare (natFromInt m1) (natFromInt m2) of+      GT -> combine_left (relate l1 t2)+      EQ -> combine (relate l1 l2) (relate r1 r2)+      LT -> combine_right (relate t1 l2)+relate t1@(Bin _p1 m1 l1 _r1) t2@(Tip p2 _bm2)+  | succUpperbound t1 <= lowerbound t2 = Less+  | lowerbound t1 >= succUpperbound t2 = Greater+  | 0 == (m1 .&. p2) = combine_left (relate l1 t2)+  | otherwise = Less+relate t1@(Tip p1 _bm1) t2@(Bin _p2 m2 l2 _r2)+  | succUpperbound t1 <= lowerbound t2 = Less+  | lowerbound t1 >= succUpperbound t2 = Greater+  | 0 == (p1 .&. m2) = combine_right (relate t1 l2)+  | otherwise = Greater++relateTipTip :: IntSet -> IntSet -> Relation+{-# INLINE relateTipTip #-}+relateTipTip (Tip p1 bm1) (Tip p2 bm2) = case compare p1 p2 of+  LT -> Less+  EQ -> relateBM bm1 bm2+  GT -> Greater+relateTipTip _ _ = error "relateTipTip"++relateBM :: BitMap -> BitMap -> Relation+{-# inline relateBM #-}+relateBM w1 w2 | w1 == w2 = Equals+relateBM w1 w2 =+  let delta = xor w1 w2+      lowest_diff_mask = delta .&. complement (delta-1)+      prefix = (complement lowest_diff_mask + 1)+            .&. (complement lowest_diff_mask)+  in  if 0 == lowest_diff_mask .&. w1+      then if 0 == w1 .&. prefix+           then Prefix else Greater+      else if 0 == w2 .&. prefix+           then FlipPrefix else Less++-- | This function has the property+-- relate t1@(Bin p m l1 r1) t2@(Bin p m l2 r2) = combine (relate l1 l2) (relate r1 r2)+-- It is important that `combine` is lazy in the second argument (achieved by inlining)+combine :: Relation -> Relation -> Relation+{-# inline combine #-}+combine r eq = case r of+      Less -> Less+      Prefix -> Greater+      Equals -> eq+      FlipPrefix -> Less+      Greater -> Greater++-- | This function has the property+-- relate t1@(Bin p1 m1 l1 r1) t2 = combine_left (relate l1 t2)+-- under the precondition that the range of l1 contains the range of t2,+-- and r1 is non-empty+combine_left :: Relation -> Relation+{-# inline combine_left #-}+combine_left r = case r of+      Less -> Less+      Prefix -> Greater+      Equals -> FlipPrefix+      FlipPrefix -> FlipPrefix+      Greater -> Greater++-- | This function has the property+-- relate t1 t2@(Bin p2 m2 l2 r2) = combine_right (relate t1 l2)+-- under the precondition that the range of t1 is included in the range of l2,+-- and r2 is non-empty+combine_right :: Relation -> Relation+{-# inline combine_right #-}+combine_right r = case r of+      Less -> Less+      Prefix -> Prefix+      Equals -> Prefix+      FlipPrefix -> Less+      Greater -> Greater++-- | shall only be applied to non-mixed non-Nil trees+lowerbound :: IntSet -> Int+{-# INLINE lowerbound #-}+lowerbound Nil = error "lowerbound: Nil"+lowerbound (Tip p _) = p+lowerbound (Bin p _ _ _) = p++-- | this is one more than the actual upper bound (to save one operation)+-- shall only be applied to non-mixed non-Nil trees+succUpperbound :: IntSet -> Int+{-# INLINE succUpperbound #-}+succUpperbound Nil = error "succUpperbound: Nil"+succUpperbound (Tip p _) = p + wordSize +succUpperbound (Bin p m _ _) = p + shiftR m 1++-- | split a set into subsets of negative and non-negative elements+splitSign :: IntSet -> (IntSet,IntSet)+{-# INLINE splitSign #-}+splitSign t@(Tip kx _)+  | kx >= 0 = (Nil, t)+  | otherwise = (t, Nil)+splitSign t@(Bin p m l r)+  -- m < 0 is the usual way to find out if we have positives and negatives (see findMax)+  | m < 0 = (r, l)+  | p < 0 = (t, Nil)+  | otherwise = (Nil, t)+splitSign Nil = (Nil, Nil)+ {--------------------------------------------------------------------   Show --------------------------------------------------------------------}@@ -1249,13 +1486,17 @@   Link --------------------------------------------------------------------} link :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet-link p1 t1 p2 t2+link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Mask -> Prefix -> IntSet -> IntSet -> IntSet+linkWithMask m p1 t1 {-p2-} t2   | zero p1 m = Bin p m t1 t2   | otherwise = Bin p m t2 t1   where-    m = branchMask p1 p2     p = mask p1 m-{-# INLINE link #-}+{-# INLINE linkWithMask #-}  {--------------------------------------------------------------------   @bin@ assures that we never have empty trees within a tree.@@ -1377,6 +1618,16 @@ {-# INLINE foldr'Bits #-}  #if defined(__GLASGOW_HASKELL__) && (WORD_SIZE_IN_BITS==32 || WORD_SIZE_IN_BITS==64)+indexOfTheOnlyBit :: Nat -> Int+{-# INLINE indexOfTheOnlyBit #-}+#if MIN_VERSION_base(4,8,0) && (WORD_SIZE_IN_BITS==64)+indexOfTheOnlyBit bitmask = countTrailingZeros bitmask++lowestBitSet x = countTrailingZeros x++highestBitSet x = WORD_SIZE_IN_BITS - 1 - countLeadingZeros x++#else {----------------------------------------------------------------------   For lowestBitSet we use wordsize-dependant implementation based on   multiplication and DeBrujn indeces, which was proposed by Edward Kmett@@ -1390,11 +1641,9 @@   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+  GHC.Exts.I# (lsbArray `GHC.Exts.indexInt8OffAddr#` unboxInt (intFromNat ((bitmask * magic) `shiftRL` offset)))+  where unboxInt (GHC.Exts.I# i) = i #if WORD_SIZE_IN_BITS==32         magic = 0x077CB531         offset = 27@@ -1411,6 +1660,12 @@ -- is 48B on 32-bit and 56B on 64-bit architectures -- so the 32B and 64B array -- is actually improvement on 32-bit and only a 8B size increase on 64-bit. +lowestBitSet x = indexOfTheOnlyBit (lowestBitMask x)++highestBitSet x = indexOfTheOnlyBit (highestBitMask x)++#endif+ lowestBitMask :: Nat -> Nat lowestBitMask x = x .&. negate x {-# INLINE lowestBitMask #-}@@ -1431,10 +1686,6 @@                      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

@@ -192,6 +192,9 @@     -- ** Disjoint     , disjoint +    -- ** Compose+    , compose+     -- ** General combining function     , SimpleWhenMissing     , SimpleWhenMatched@@ -391,6 +394,9 @@ #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable()) #endif+#if MIN_VERSION_base(4,10,0)+import Data.Bifoldable+#endif import Data.Typeable import Prelude hiding (lookup, map, filter, foldr, foldl, null, splitAt, take, drop) @@ -1628,7 +1634,7 @@ -- | /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+-- > lookupMin empty = Nothing -- -- @since 0.5.9 @@ -2085,6 +2091,27 @@   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 '!?')+-- @+--+-- @since 0.6.3.1+compose :: Ord b => Map b c -> Map a b -> Map a c+compose bc !ab+  | null bc = empty+  | otherwise = mapMaybe (bc !?) ab+ #if !MIN_VERSION_base (4,8,0) -- | The identity type. newtype Identity a = Identity { runIdentity :: a }@@ -2830,7 +2857,7 @@  {- | /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,+ @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':@@ -3147,7 +3174,7 @@       (a3,r') = mapAccumL f a2 r   in (a3,Bin sx kx x' l' r') --- | /O(n)/. The function 'mapAccumR' threads an accumulating+-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumRWithKey _ a Tip = (a,Tip)@@ -3949,7 +3976,7 @@ -- | /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 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@@ -4254,6 +4281,29 @@   {-# INLINABLE sum #-}   product = foldl' (*) 1   {-# INLINABLE product #-}+#endif++#if MIN_VERSION_base(4,10,0)+-- | @since 0.6.3.1+instance Bifoldable Map where+  bifold = go+    where go Tip = mempty+          go (Bin 1 k v _ _) = k `mappend` v+          go (Bin _ k v l r) = go l `mappend` (k `mappend` (v `mappend` go r))+  {-# INLINABLE bifold #-}+  bifoldr f g z = go z+    where go z' Tip             = z'+          go z' (Bin _ k v l r) = go (f k (g v (go z' r))) l+  {-# INLINE bifoldr #-}+  bifoldl f g z = go z+    where go z' Tip             = z'+          go z' (Bin _ k v l r) = go (g (f (go z' l) k) v) r+  {-# INLINE bifoldl #-}+  bifoldMap f g t = go t+    where go Tip = mempty+          go (Bin 1 k v _ _) = f k `mappend` g v+          go (Bin _ k v l r) = go l `mappend` (f k `mappend` (g v `mappend` go r))+  {-# INLINE bifoldMap #-} #endif  instance (NFData k, NFData a) => NFData (Map k a) where

@@ -166,6 +166,9 @@     -- ** Disjoint     , disjoint +    -- ** Compose+    , compose+     -- ** General combining functions     -- | See "Data.Map.Merge.Lazy" 

@@ -182,6 +182,9 @@     -- ** Disjoint     , disjoint +    -- ** Compose+    , compose+     -- ** General combining functions     -- | See "Data.Map.Merge.Strict" 

@@ -145,6 +145,9 @@     -- ** Disjoint     , disjoint +    -- ** Compose+    , compose+     -- ** General combining function     , SimpleWhenMissing     , SimpleWhenMatched@@ -1201,6 +1204,27 @@ {-# INLINE forceMaybe #-}  {--------------------------------------------------------------------+  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 '!?')+-- @+--+-- @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++{--------------------------------------------------------------------   MergeWithKey --------------------------------------------------------------------} @@ -1432,7 +1456,7 @@       (a3,r') = mapAccumL f a2 r   in x' `seq` (a3,Bin sx kx x' l' r') --- | /O(n)/. The function 'mapAccumR' threads an accumulating+-- | /O(n)/. The function 'mapAccumRWithKey' threads an accumulating -- argument through the map in descending order of keys. mapAccumRWithKey :: (a -> k -> b -> (a,c)) -> a -> Map k b -> (a,Map k c) mapAccumRWithKey _ a Tip = (a,Tip)

@@ -102,9 +102,15 @@ -- -- 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.+-- 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 --

@@ -514,6 +514,7 @@ #if MIN_VERSION_base(4,10,0)     liftA2 = liftA2Seq #endif+    xs <* ys = beforeSeq xs ys  apSeq :: Seq (a -> b) -> Seq a -> Seq b apSeq fs xs@(Seq xsFT) = case viewl fs of@@ -530,7 +531,7 @@          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)+                    (liftA2Middle (fmap firstf) (fmap lastf) fmap fs''FT r)                     (fmap (fmap lastf) (nodeToDigit sf)) {-# NOINLINE [1] apSeq #-} @@ -590,7 +591,7 @@       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)+             (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@@ -637,65 +638,128 @@ -- digit of a 'Rigid' tree. type Digit23 a = Node a --- | 'aptyMiddle' does most of the hard work of computing @fs<*>xs@.  It+-- | '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 prefix of @xs@ and a suffix corresponding to the suffix of @xs@ omitted;+-- 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. ----- @map23@ itself is a bit horrifying because of the nested types involved. Its+-- @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 @map23@ explicitly through the+-- class, but as it is we have to build up @f@ explicitly through the -- recursion.-aptyMiddle-  :: (b -> c)-     -> (b -> c)-     -> (a -> b -> c)-     -> FingerTree (Elem a)-     -> Rigid b-     -> FingerTree (Node c)+--+-- === 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 -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))+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 -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))+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 -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))+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@@ -721,7 +785,7 @@ -- @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 !_ _ 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) @@ -885,7 +949,11 @@  instance Monoid (Seq a) where     mempty = empty+#if MIN_VERSION_base(4,9,0)+    mappend = (Semigroup.<>)+#else     mappend = (><)+#endif  #if MIN_VERSION_base(4,9,0) -- | @since 0.5.7@@ -1375,6 +1443,240 @@     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

@@ -394,7 +394,6 @@     pr' = foldDigit (<+>) f pr     sf' = foldDigit (<+>) f sf     m' = foldToMaybeTree (<+>) (foldNode (<+>) f) m-{-# INLINE foldToMaybeTree #-}  -- | A 'Data.Sequence.foldMapWithIndex'-like function, specialized to the -- 'Data.Semigroup.Option' monoid, which takes advantage of the

@@ -88,6 +88,10 @@             -- * Deletion             , delete +            -- * Generalized insertion/deletion++            , alterF+             -- * Query             , member             , notMember

@@ -148,6 +148,7 @@             , singleton             , insert             , delete+            , alterF             , powerSet              -- * Combine@@ -230,6 +231,7 @@             ) where  import Prelude hiding (filter,foldl,foldr,null,map,take,drop,splitAt)+import Control.Applicative (Const(..)) import qualified Data.List as List import Data.Bits (shiftL, shiftR) #if !MIN_VERSION_base(4,8,0)@@ -245,6 +247,9 @@ import Data.Semigroup (stimesIdempotentMonoid) import Data.Functor.Classes #endif+#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+#endif import qualified Data.Foldable as Foldable #if !MIN_VERSION_base(4,8,0) import Data.Foldable (Foldable (foldMap))@@ -592,6 +597,72 @@ {-# 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++#if MIN_VERSION_base(4,8,0)+{-# SPECIALIZE alterF :: Ord a => (Bool -> Identity Bool) -> a -> Set a -> Identity (Set a) #-}+#endif++data AlteredSet a+      -- | The needle is present in the original set.+      -- 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  {--------------------------------------------------------------------

@@ -93,7 +93,7 @@ -- | 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+        subForest :: [Tree a]   -- ^ zero or more child trees     } #ifdef __GLASGOW_HASKELL__   deriving ( Eq@@ -107,6 +107,8 @@   deriving (Eq, Read, Show) #endif +-- | This type synonym exists primarily for historical+-- reasons. type Forest a = [Tree a]  #if MIN_VERSION_base(4,9,0)@@ -249,7 +251,7 @@ -- `- 20 -- @ ---drawForest :: Forest String -> String+drawForest :: [Tree String] -> String drawForest  = unlines . map drawTree  draw :: Tree String -> [String]@@ -321,7 +323,7 @@ -- -- 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+-- > 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: --@@ -377,7 +379,7 @@ -- -- For a monadic version see 'unfoldForestM_BF'. ---unfoldForest :: (b -> (a, [b])) -> [b] -> Forest a+unfoldForest :: (b -> (a, [b])) -> [b] -> [Tree a] unfoldForest f = map (unfoldTree f)  -- | Monadic tree builder, in depth-first order.@@ -388,7 +390,7 @@     return (Node a ts)  -- | Monadic forest builder, in depth-first order-unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m (Forest a)+unfoldForestM :: Monad m => (b -> m (a, [b])) -> [b] -> m ([Tree a]) unfoldForestM f = Prelude.mapM (unfoldTreeM f)  -- | Monadic tree builder, in breadth-first order.@@ -410,7 +412,7 @@ -- -- 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 :: 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