containers 0.5.10.2 → 0.5.11.0

raw patch · 37 files changed

+2600/−666 lines, 37 filesdep ~QuickCheckdep ~basedep ~criterionPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: QuickCheck, base, criterion, test-framework, test-framework-quickcheck2

API changes (from Hackage documentation)

Files

• Data/Graph.hs +16/−0
• Data/IntMap/Internal.hs +167/−34
• Data/IntMap/Lazy.hs +3/−1
• Data/IntMap/Merge/Lazy.hs +2/−0
• Data/IntMap/Merge/Strict.hs +2/−0
• Data/IntMap/Strict.hs +6/−1
• Data/IntSet.hs +1/−0
• Data/IntSet/Internal.hs +61/−25
• Data/Map/Internal.hs +117/−11
• Data/Map/Lazy.hs +47/−35
• Data/Map/Merge/Lazy.hs +2/−0
• Data/Map/Merge/Strict.hs +2/−0
• Data/Map/Strict.hs +58/−44
• Data/Map/Strict/Internal.hs +4/−1
• Data/Sequence.hs +167/−17
• Data/Sequence/Internal.hs +388/−361
• Data/Sequence/Internal/Sorting.hs +425/−0
• Data/Set.hs +29/−23
• Data/Set/Internal.hs +135/−1
• Data/Tree.hs +29/−3
• Utils/Containers/Internal/BitUtil.hs +35/−18
• Utils/Containers/Internal/State.hs +35/−0
• benchmarks/IntMap.hs +2/−0
• benchmarks/IntSet.hs +4/−0
• benchmarks/Map.hs +1/−0
• benchmarks/Sequence.hs +41/−1
• benchmarks/Set.hs +4/−0
• changelog.md +74/−1
• containers.cabal +210/−27
• tests/IntMapValidity.hs +63/−0
• tests/IntSetValidity.hs +87/−0
• tests/intmap-properties.hs +115/−37
• tests/intmap-strictness.hs +1/−0
• tests/intset-properties.hs +95/−25
• tests/seq-properties.hs +37/−0
• tests/set-properties.hs +29/−0
• tests/tree-properties.hs +106/−0

@@ -117,40 +117,55 @@                                         -- 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) #endif  #if __GLASGOW_HASKELL__ >= 706+-- | @since 0.5.9 deriving instance Generic1 SCC #endif  #if __GLASGOW_HASKELL__ >= 702+-- | @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.@@ -163,6 +178,7 @@     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)

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE PatternGuards #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash, DeriveDataTypeable, StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -11,6 +12,8 @@ {-# LANGUAGE TypeFamilies #-} #endif +{-# OPTIONS_HADDOCK not-home #-}+ #include "containers.h"  -----------------------------------------------------------------------------@@ -39,6 +42,8 @@ -- -- This defines the data structures and core (hidden) manipulations -- on representations.+--+-- @since 0.5.9 -----------------------------------------------------------------------------  -- [Note: INLINE bit fiddling]@@ -72,7 +77,7 @@       IntMap(..), Key          -- instance Eq,Show      -- * Operators-    , (!), (\\)+    , (!), (!?), (\\)      -- * Query     , null@@ -231,6 +236,8 @@     , isProperSubmapOf, isProperSubmapOfBy      -- * Min\/Max+    , lookupMin+    , lookupMax     , findMin     , findMax     , deleteMin@@ -294,7 +301,6 @@ #endif  import Control.DeepSeq (NFData(rnf))-import Control.Monad (liftM) import Data.Bits import qualified Data.Foldable as Foldable import Data.Maybe (fromMaybe)@@ -348,6 +354,17 @@                     {-# 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 @@ -377,11 +394,22 @@ (!) :: 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 -}+infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}  {--------------------------------------------------------------------   Types@@ -395,6 +423,7 @@ #else     mappend = (<>) +-- | @since 0.5.7 instance Semigroup (IntMap a) where     (<>)    = union     stimes  = stimesIdempotentMonoid@@ -1330,17 +1359,20 @@ -- -- 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@@ -1355,6 +1387,8 @@   -- | 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 =@@ -1368,6 +1402,8 @@   -- | 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@@ -1382,6 +1418,8 @@   -- | Map covariantly over a @'WhenMissing' f x@.+--+-- @since 0.5.9 mapWhenMissing   :: (Applicative f, Monad f)   => (a -> b)@@ -1419,6 +1457,8 @@   -- | 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)@@ -1427,6 +1467,8 @@   -- | Map contravariantly over a @'WhenMatched' f _ y z@.+--+-- @since 0.5.9 contramapFirstWhenMatched   :: (b -> a)   -> WhenMatched f a y z@@ -1437,6 +1479,8 @@   -- | Map contravariantly over a @'WhenMatched' f x _ z@.+--+-- @since 0.5.9 contramapSecondWhenMatched   :: (b -> a)   -> WhenMatched f x a z@@ -1462,6 +1506,8 @@ -- -- 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  @@ -1470,12 +1516,16 @@ -- -- 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 #-}@@ -1483,16 +1533,20 @@  -- | 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)@@ -1507,6 +1561,8 @@   -- | 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 =@@ -1520,6 +1576,8 @@   -- | 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@@ -1534,6 +1592,8 @@   -- | Map covariantly over a @'WhenMatched' f x y@.+--+-- @since 0.5.9 mapWhenMatched   :: Functor f   => (a -> b)@@ -1548,6 +1608,8 @@ -- -- 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  @@ -1557,6 +1619,8 @@ -- > zipWithMatched -- >   :: (Key -> x -> y -> z) -- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9 zipWithMatched   :: Applicative f   => (Key -> x -> y -> z)@@ -1568,6 +1632,8 @@ -- | 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)@@ -1582,6 +1648,8 @@ -- > zipWithMaybeMatched -- >   :: (Key -> x -> y -> Maybe z) -- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9 zipWithMaybeMatched   :: Applicative f   => (Key -> x -> y -> Maybe z)@@ -1595,6 +1663,8 @@ -- 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@@ -1610,6 +1680,8 @@ -- 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)@@ -1625,6 +1697,8 @@ -- 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@@ -1639,6 +1713,8 @@ -- 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@@ -1656,6 +1732,8 @@ -- -- 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@@ -1671,6 +1749,8 @@ -- 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@@ -1686,6 +1766,8 @@ -- >   \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@@ -1710,6 +1792,8 @@  -- | 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@@ -1722,6 +1806,8 @@ -- 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@@ -1809,7 +1895,7 @@ -- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing) -- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g) ----- @since 0.5.8+-- @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@@@ -1884,7 +1970,7 @@ -- site. To prevent excessive inlining, you should generally only use -- 'mergeA' to define custom combining functions. ----- @since 0.5.8+-- @since 0.5.9 mergeA   :: (Applicative f)   => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@@@ -2022,17 +2108,26 @@ -- > maxViewWithKey empty == Nothing  maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)-maxViewWithKey t =+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 -> Nothing+    Nil -> error "maxViewWithKeySure Nil"     Bin p m l r | m < 0 ->-      Just $ case go l of View k a l' -> ((k, a), binCheckLeft p m l' r)-    _ -> Just $ case go t of View k a t' -> ((k, a), t')+      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 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.@@ -2044,14 +2139,31 @@ 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 ->-      Just $ case go r of View k a r' -> ((k, a), binCheckRight p m l r')-    _ -> Just $ case go t of View k a t' -> ((k, a), t')+      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 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. --@@ -2069,50 +2181,64 @@ updateMin :: (a -> Maybe a) -> IntMap a -> IntMap a updateMin f = updateMinWithKey (const f) --- Similar to the Arrow instance.-first :: (a -> c) -> (a, b) -> (c, b)-first f (x,y) = (f x,y)- -- | /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 = liftM (first snd) (maxViewWithKey t)+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 = liftM (first snd) (minViewWithKey t)+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.-findMin :: IntMap a -> (Key, a)-findMin Nil = error $ "findMin: empty map has no minimal element"-findMin (Tip k v) = (k,v)-findMin (Bin _ m l r)+-- | /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)      = (k,v)+    where go (Tip k v)      = Just (k,v)           go (Bin _ _ l' _) = go l'-          go Nil            = error "findMax Nil"+          go Nil            = Nothing --- | /O(min(n,W))/. The maximal key of the map.-findMax :: IntMap a -> (Key, a)-findMax Nil = error $ "findMax: empty map has no maximal element"-findMax (Tip k v) = (k,v)-findMax (Bin _ m l r)+-- | /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)      = (k,v)+    where go (Tip k v)      = Just (k,v)           go (Bin _ _ _ r') = go r'-          go Nil            = error "findMax Nil"+          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;@@ -2737,6 +2863,8 @@ -- @'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@@ -2827,6 +2955,7 @@   Lists --------------------------------------------------------------------} #if __GLASGOW_HASKELL__ >= 708+-- | @since 0.5.6.2 instance GHCExts.IsList (IntMap a) where   type Item (IntMap a) = (Key,a)   fromList = fromList@@ -3024,6 +3153,7 @@ 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)@@ -3041,6 +3171,7 @@     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)@@ -3068,6 +3199,7 @@     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)@@ -3095,6 +3227,7 @@ #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

@@ -63,7 +63,7 @@ #endif      -- * Operators-    , (!), (\\)+    , (!), (!?), (\\)      -- * Query     , IM.null@@ -187,6 +187,8 @@     , isProperSubmapOf, isProperSubmapOfBy      -- * Min\/Max+    , lookupMin+    , lookupMax     , findMin     , findMax     , deleteMin

@@ -43,6 +43,8 @@ -- 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

@@ -43,6 +43,8 @@ -- 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

@@ -70,7 +70,7 @@ #endif      -- * Operators-    , (!), (\\)+    , (!), (!?), (\\)      -- * Query     , null@@ -194,6 +194,8 @@     , isProperSubmapOf, isProperSubmapOfBy      -- * Min\/Max+    , lookupMin+    , lookupMax     , findMin     , findMax     , deleteMin@@ -237,6 +239,7 @@    , (\\)   , (!)+  , (!?)   , empty   , assocs   , filter@@ -271,6 +274,8 @@   , lookupGE   , lookupLT   , lookupGT+  , lookupMin+  , lookupMax   , minView   , maxView   , minViewWithKey

@@ -74,6 +74,7 @@             , lookupGE             , isSubsetOf             , isProperSubsetOf+            , disjoint              -- * Construction             , empty

@@ -10,6 +10,8 @@ {-# LANGUAGE TypeFamilies #-} #endif +{-# OPTIONS_HADDOCK not-home #-}+ #include "containers.h"  -----------------------------------------------------------------------------@@ -67,6 +69,8 @@ -- 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]@@ -98,6 +102,7 @@ module Data.IntSet.Internal (     -- * Set type       IntSet(..), Key -- instance Eq,Show+    , Prefix, Mask, BitMap      -- * Operators     , (\\)@@ -113,6 +118,7 @@     , lookupGE     , isSubsetOf     , isProperSubsetOf+    , disjoint      -- * Construction     , empty@@ -177,6 +183,7 @@     , suffixBitMask     , prefixBitMask     , bitmapOf+    , zero     ) where  import Control.DeepSeq (NFData(rnf))@@ -247,8 +254,8 @@ -- 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 all but the last 5 (on 32 bit arches) or 6---            bits (on 64 bit arches). The values of the map represented by a tip+-- 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 @@ -270,6 +277,7 @@ #else     mappend = (<>) +-- | @since 0.5.7 instance Semigroup IntSet where     (<>)    = union     stimes  = stimesIdempotentMonoid@@ -319,7 +327,7 @@  -- | /O(min(n,W))/. Is the value a member of the set? --- See Note: Local 'go' functions and capturing]+-- See Note: Local 'go' functions and capturing. member :: Key -> IntSet -> Bool member !x = go   where@@ -653,6 +661,54 @@   {--------------------------------------------------------------------+  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.@@ -933,6 +989,7 @@   Lists --------------------------------------------------------------------} #if __GLASGOW_HASKELL__ >= 708+-- | @since 0.5.6.2 instance GHCExts.IsList IntSet where   type Item IntSet = Key   fromList = fromList@@ -1245,6 +1302,7 @@ {--------------------------------------------------------------------   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@@ -1447,28 +1505,6 @@                 | otherwise     =         go (bi + 1) (n `shiftRL` 1)  #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-#if MIN_VERSION_base(4,5,0)-bitcount a x = a + popCount x-#else-bitcount a0 x0 = go a0 x0-  where go a 0 = a-        go a x = go (a + 1) (x .&. (x-1))-#endif-{-# INLINE bitcount #-}   {--------------------------------------------------------------------

@@ -17,6 +17,8 @@ {-# LANGUAGE MagicHash #-} #endif +{-# OPTIONS_HADDOCK not-home #-}+ #include "containers.h"  #if !(WORD_SIZE_IN_BITS >= 61)@@ -77,6 +79,8 @@ -- -- 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]@@ -129,6 +133,7 @@ module Data.Map.Internal (     -- * Map type       Map(..)          -- instance Eq,Show,Read+    , Size      -- * Operators     , (!), (!?), (\\)@@ -429,6 +434,8 @@ -- -- 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@@ -1486,6 +1493,8 @@ -- @ -- 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@@ -1506,6 +1515,8 @@ -- @ -- 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@@ -1524,6 +1535,8 @@ -- @ -- 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)@@ -1712,9 +1725,13 @@  minViewWithKey :: Map k a -> Maybe ((k,a), Map k a) minViewWithKey Tip = Nothing-minViewWithKey (Bin _ k x l r) =+minViewWithKey (Bin _ k x l r) = Just $   case minViewSure k x l r of-    MinView km xm t -> Just ((km, xm), t)+    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.@@ -1724,9 +1741,11 @@  maxViewWithKey :: Map k a -> Maybe ((k,a), Map k a) maxViewWithKey Tip = Nothing-maxViewWithKey (Bin _ k x l r) =+maxViewWithKey (Bin _ k x l r) = Just $   case maxViewSure k x l r of-    MaxView km xm t -> Just ((km, xm), t)+    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@@ -1738,7 +1757,7 @@ minView :: Map k a -> Maybe (a, Map k a) minView t = case minViewWithKey t of               Nothing -> Nothing-              Just ((_, x), t') -> Just (x, t')+              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@@ -1750,7 +1769,7 @@ maxView :: Map k a -> Maybe (a, Map k a) maxView t = case maxViewWithKey t of               Nothing -> Nothing-              Just ((_, x), t') -> Just (x, t')+              Just ~((_, x), t') -> Just (x, t')  {--------------------------------------------------------------------   Union.@@ -1880,7 +1899,8 @@ -- | /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 = 'filterWithKey' (\k _ -> k `'Set.notMember'` s) m+-- m `'withoutKeys'` s = m `'difference'` 'fromSet' (const ()) s -- @ -- -- @since 0.5.8@@ -1961,7 +1981,8 @@ -- found in a 'Set'. -- -- @--- m `restrictKeys` s = 'filterWithKey' (\k _ -> k `'Set.member'` s) m+-- m `'restrictKeys'` s = 'filterWithKey' (\k _ -> k `'Set.member'` s) m+-- m `'restrictKeys'` s = m `'intersect' 'fromSet' (const ()) s -- @ -- -- @since 0.5.8@@ -2043,15 +2064,19 @@ -- -- 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@@ -2064,6 +2089,8 @@   {-# 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@@ -2075,6 +2102,8 @@   {-# 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@@ -2087,6 +2116,8 @@   {-# 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@@ -2115,6 +2146,8 @@ {-# 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)@@ -2122,6 +2155,8 @@ {-# 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@@ -2130,6 +2165,8 @@ {-# 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@@ -2142,6 +2179,8 @@ -- -- 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@@ -2149,25 +2188,33 @@ -- -- 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 $@@ -2180,6 +2227,8 @@   {-# 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@@ -2191,6 +2240,8 @@   {-# 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@@ -2203,6 +2254,8 @@   {-# 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@@ -2214,6 +2267,8 @@ -- -- 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@@ -2223,6 +2278,8 @@ -- 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@@ -2231,6 +2288,8 @@  -- | 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@@ -2244,6 +2303,8 @@ -- 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@@ -2255,6 +2316,8 @@ -- 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@@ -2270,6 +2333,8 @@ -- 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)@@ -2286,6 +2351,8 @@ -- 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@@ -2301,6 +2368,8 @@ -- 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@@ -2318,6 +2387,8 @@ -- 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@@ -2333,6 +2404,8 @@ -- 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@@ -2349,6 +2422,8 @@ -- @ -- -- 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@@ -2362,6 +2437,8 @@ 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@@ -2373,6 +2450,8 @@ -- 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@@ -2449,7 +2528,7 @@ -- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing) -- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g) ----- @since 0.5.8+-- @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@@@ -2523,7 +2602,7 @@ -- site. To prevent excessive inlining, you should generally only use -- 'mergeA' to define custom combining functions. ----- @since 0.5.8+-- @since 0.5.9 mergeA   :: (Applicative f, Ord k)   => WhenMissing f k a c -- ^ What to do with keys in @m1@ but not @m2@@@ -2743,6 +2822,8 @@ -- 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@@ -2758,6 +2839,8 @@ -- 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@@ -2778,6 +2861,8 @@ -- 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)@@ -3016,7 +3101,8 @@ -- -- 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@.+-- 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"@@ -3166,6 +3252,8 @@ -- @'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@@ -3230,6 +3318,7 @@   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@@ -3415,6 +3504,8 @@ -- > 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)@@ -3454,6 +3545,8 @@ -- > 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@@ -3550,6 +3643,8 @@ -- > 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.@@ -3763,6 +3858,7 @@     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@@ -3771,6 +3867,7 @@     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. --@@ -3977,20 +4074,25 @@   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)@@ -3998,9 +4100,11 @@         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@@ -4133,6 +4237,8 @@ --  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

@@ -14,20 +14,57 @@ -- Maintainer  :  libraries@haskell.org -- Portability :  portable ----- An efficient implementation of ordered maps from keys to values--- (dictionaries). ----- API of this module is strict in the keys, but lazy in the values.--- If you need value-strict maps, use "Data.Map.Strict" instead.--- The 'Map' type itself 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).+-- = Finite Maps (lazy interface) ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@. A 'Map' is strict in its keys but lazy+-- in its values. ----- >  import qualified Data.Map.Lazy as Map+-- 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: --@@ -45,22 +82,9 @@ --      \"/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.Lazy (-    -- * Strictness properties-    -- $strictness-     -- * Map type     Map              -- instance Eq,Show,Read @@ -238,15 +262,3 @@ import Data.Map.Internal.DeprecatedShowTree (showTree, showTreeWith) import Data.Map.Internal.Debug (valid) import Prelude ()---- $strictness------ This module satisfies the following strictness property:------ * Key arguments are evaluated to WHNF------ Here are some examples that illustrate the property:------ > insertWith (\ new old -> old) undefined v m  ==  undefined--- > insertWith (\ new old -> old) k undefined m  ==  OK--- > delete undefined m  ==  undefined

@@ -43,6 +43,8 @@ -- 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

@@ -43,6 +43,8 @@ -- 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

@@ -15,20 +15,68 @@ -- Maintainer  :  libraries@haskell.org -- Portability :  portable ----- 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).+-- = Finite Maps (strict interface) ----- These modules are intended to be imported qualified, to avoid name--- clashes with Prelude functions, e.g.+-- The @'Map' k v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @k@ to values of type @v@. ----- >  import qualified Data.Map.Strict as Map+-- 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 on strict maps, 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: --@@ -46,29 +94,13 @@ --      \"/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     (-    -- * Strictness properties-    -- $strictness-     -- * Map type     Map              -- instance Eq,Show,Read @@ -245,21 +277,3 @@  import Data.Map.Strict.Internal import Prelude ()---- $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

@@ -3,6 +3,7 @@ #if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-} #endif+{-# OPTIONS_HADDOCK not-home #-}  #include "containers.h" @@ -85,6 +86,7 @@      -- * Map type     Map(..)          -- instance Eq,Show,Read+    , L.Size      -- * Operators     , (!), (!?), (\\)@@ -1432,7 +1434,8 @@ -- -- 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@.+-- 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"

@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+#ifdef __HADDOCK_VERSION__+{-# OPTIONS_GHC -Wno-unused-imports #-}+#endif  #include "containers.h" @@ -13,40 +16,123 @@ -- Maintainer  :  libraries@haskell.org -- Portability :  portable ----- General purpose finite sequences.--- Apart from being finite and having strict operations, sequences--- also differ from lists in supporting a wider variety of operations--- efficiently.+-- = Finite sequences --+-- 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. ----- The implementation uses 2-3 finger trees annotated with sizes,--- as described in section 4.2 of+-- 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 -----    * 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>+-- * 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/: 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.+-- 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. ----- /Warning/: The size of a 'Seq' must not exceed @maxBound::Int@.  Violation+-- 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+-- 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@@ -62,7 +148,7 @@     -- ** Repetition     replicate,      -- :: Int -> a -> Seq a     replicateA,     -- :: Applicative f => Int -> f a -> f (Seq a)-    replicateM,     -- :: Monad m => Int -> m a -> m (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@@ -103,8 +189,10 @@     -- * 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@@ -139,14 +227,76 @@     traverseWithIndex, -- :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)     reverse,        -- :: Seq a -> Seq a     intersperse,    -- :: a -> Seq a -> Seq a-    -- ** Zips+    -- ** 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])+@+-}

@@ -6,6 +6,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} #endif #if __GLASGOW_HASKELL__ >= 703 {-# LANGUAGE Trustworthy #-}@@ -13,14 +14,14 @@ #if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE DeriveGeneric #-} #endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE TypeFamilies #-}-#endif #ifdef DEFINE_PATTERN_SYNONYMS {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} #endif+{-# LANGUAGE PatternGuards #-} +{-# OPTIONS_HADDOCK not-home #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Data.Sequence.Internal@@ -52,8 +53,8 @@ -- 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+-- 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,@@ -75,6 +76,7 @@ -- '>>', particularly repeatedly and particularly in combination with -- 'replicate' or 'fromFunction'. --+-- @since 0.5.9 -----------------------------------------------------------------------------  module Data.Sequence.Internal (@@ -84,6 +86,12 @@ #else     Seq (..), #endif+    State(..),+    execState,+    foldDigit,+    foldNode,+    foldWithIndexDigit,+    foldWithIndexNode,      -- * Construction     empty,          -- :: Seq a@@ -97,7 +105,7 @@     -- ** Repetition     replicate,      -- :: Int -> a -> Seq a     replicateA,     -- :: Applicative f => Int -> f a -> f (Seq a)-    replicateM,     -- :: Monad m => Int -> m a -> m (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@@ -135,11 +143,6 @@     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-    unstableSort,   -- :: Ord a => Seq a -> Seq a-    unstableSortBy, -- :: (a -> a -> Ordering) -> Seq a -> Seq a     -- * Indexing     lookup,         -- :: Int -> Seq a -> Maybe a     (!?),           -- :: Seq a -> Int -> Maybe a@@ -175,13 +178,15 @@     reverse,        -- :: Seq a -> Seq a     intersperse,    -- :: a -> Seq a -> Seq a     liftA2Seq,      -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-    -- ** Zips+    -- ** 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,@@ -191,20 +196,24 @@  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,-    takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)+    unzip, takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all) import qualified Data.List import Control.Applicative (Applicative(..), (<$>), (<**>),  Alternative,-                            WrappedMonad(..), liftA, liftA2, liftA3)-import qualified Control.Applicative as Applicative (Alternative(..))+                            liftA2, liftA3)+import qualified Control.Applicative as Applicative import Control.DeepSeq (NFData(rnf))-import Control.Monad (MonadPlus(..), ap)+import Control.Monad (MonadPlus(..)) import Data.Monoid (Monoid(..)) import Data.Functor (Functor(..))+import Utils.Containers.Internal.State (State(..), execState) #if MIN_VERSION_base(4,6,0) import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr'), toList) #else@@ -259,6 +268,7 @@ #if MIN_VERSION_base(4,4,0) import Control.Monad.Zip (MonadZip (..)) #endif+import Control.Monad.Fix (MonadFix (..), fix)  default () @@ -291,19 +301,25 @@ {-# COMPLETE (:|>), Empty #-} #endif --- | A pattern synonym matching an empty sequence.+-- | A bidirectional pattern synonym matching an empty sequence.+--+-- @since 0.5.8 pattern Empty :: Seq a pattern Empty = Seq EmptyT --- | A pattern synonym viewing the front of a non-empty+-- | 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 pattern synonym viewing the rear of a non-empty+-- | 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@@ -431,6 +447,19 @@       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@@ -720,7 +749,7 @@ 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) --- | Intersperse an element between the elements of a sequence.+-- | \( O(n) \). Intersperse an element between the elements of a sequence. -- -- @ -- intersperse a empty = empty@@ -748,6 +777,7 @@     mzero = empty     mplus = (><) +-- | @since 0.5.4 instance Alternative Seq where     empty = empty     (<|>) = (><)@@ -768,13 +798,16 @@ #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@@ -795,6 +828,7 @@ #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@@ -807,6 +841,7 @@     mappend = (><)  #if MIN_VERSION_base(4,9,0)+-- | @since 0.5.7 instance Semigroup.Semigroup (Seq a) where     (<>)    = (><) #endif@@ -942,11 +977,15 @@     deriving Show #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 f (One a) = f a-    foldMap f (Two a b) = f a <> f b-    foldMap f (Three a b c) = f a <> f b <> f c-    foldMap f (Four a b c d) = f a <> f b <> f c <> f d+    foldMap = foldDigit mappend      foldr f z (One a) = a `f` z     foldr f z (Two a b) = a `f` (b `f` z)@@ -1029,9 +1068,13 @@     deriving Show #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 f (Node2 _ a b) = f a <> f b-    foldMap f (Node3 _ a b c) = f a <> f b <> f c+    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))@@ -1129,27 +1172,6 @@     Identity f <*> Identity x = Identity (f x) #endif --- | This is essentially a clone of Control.Monad.State.Strict.-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)- -- | '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@@ -1185,38 +1207,47 @@ -- Construction ------------------------------------------------------------------------ --- | /O(1)/. The empty sequence.+-- | \( O(1) \). The empty sequence. empty           :: Seq a empty           =  Seq EmptyT --- | /O(1)/. A singleton sequence.+-- | \( 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@.+-- | \( 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'.+-- \( 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      = unwrapMonad (replicateA n (WrapMonad 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+-- | /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. --@@ -1234,7 +1265,7 @@   where     (reps, final) = n `quotRem` length xs --- | /O(log(kn))/. @'cycleNTimes' k xs@ concatenates @k@ copies of @xs@. This+-- \( 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@@ -1294,7 +1325,7 @@    where converted = node3 pr q sf  --- | /O(1)/. Add an element to the left end of a sequence.+-- | \( 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)@@ -1343,7 +1374,7 @@ 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.+-- | \( 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)@@ -1380,7 +1411,7 @@ snocTree' (Deep s pr m (One a)) b =     Deep (s + size b) pr m (Two a b) --- | /O(log(min(n1,n2)))/. Concatenate two sequences.+-- | \( O(\log(\min(n_1,n_2))) \). Concatenate two sequences. (><)            :: Seq a -> Seq a -> Seq a Seq xs >< Seq ys = Seq (appendTree0 xs ys) @@ -1634,7 +1665,7 @@ 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+-- | \( 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))@@ -1647,12 +1678,12 @@ -- Deconstruction ------------------------------------------------------------------------ --- | /O(1)/. Is this the empty sequence?+-- | \( 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.+-- | \( O(1) \). The number of elements in the sequence. length          :: Seq a -> Int length (Seq xs) =  size xs @@ -1671,9 +1702,11 @@ deriving instance Data a => Data (ViewL a) #endif #if __GLASGOW_HASKELL__ >= 706+-- | @since 0.5.8 deriving instance Generic1 ViewL #endif #if __GLASGOW_HASKELL__ >= 702+-- | @since 0.5.8 deriving instance Generic (ViewL a) #endif @@ -1706,7 +1739,7 @@     traverse _ EmptyL       = pure EmptyL     traverse f (x :< xs)    = liftA2 (:<) (f x) (traverse f xs) --- | /O(1)/. Analyse the left end of a sequence.+-- | \( O(1) \). Analyse the left end of a sequence. viewl           ::  Seq a -> ViewL a viewl (Seq xs)  =  case viewLTree xs of     EmptyLTree -> EmptyL@@ -1736,9 +1769,11 @@ deriving instance Data a => Data (ViewR a) #endif #if __GLASGOW_HASKELL__ >= 706+-- | @since 0.5.8 deriving instance Generic1 ViewR #endif #if __GLASGOW_HASKELL__ >= 702+-- | @since 0.5.8 deriving instance Generic (ViewR a) #endif @@ -1773,7 +1808,7 @@     traverse _ EmptyR       = pure EmptyR     traverse f (xs :> x)    = liftA2 (:>) (traverse f xs) (f x) --- | /O(1)/. Analyse the right end of a sequence.+-- | \( O(1) \). Analyse the right end of a sequence. viewr           ::  Seq a -> ViewR a viewr (Seq xs)  =  case viewRTree xs of     EmptyRTree -> EmptyR@@ -1832,7 +1867,7 @@  -- Indexing --- | /O(log(min(i,n-i)))/. The element at the specified position,+-- | \( 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.@@ -1848,9 +1883,10 @@   -- 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"+  | 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,+-- | \( 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'. --@@ -1879,7 +1915,7 @@                 Place _ (Elem x) -> Just x   | otherwise = Nothing --- | /O(log(min(i,n-i)))/. A flipped, infix version of `lookup`.+-- | \( O(\log(\min(i,n-i))) \). A flipped, infix version of `lookup`. -- -- @since 0.5.8 (!?) ::           Seq a -> Int -> Maybe a@@ -1946,7 +1982,7 @@     sab     = sa + size b     sabc    = sab + size c --- | /O(log(min(i,n-i)))/. Replace the element at the specified position.+-- | \( 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)@@ -2010,18 +2046,20 @@     sab     = sa + size b     sabc    = sab + size c --- | /O(log(min(i,n-i)))/. Update the element at the specified position.  If+-- | \( 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.+-- | \( 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. --@@ -2110,7 +2148,7 @@     sab     = sa + size b     sabc    = sab + size c --- | /O(log(min(i,n-i)))/. @'insertAt' i x xs@ inserts @x@ into @xs@+-- | \( 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. -- -- @@@ -2118,7 +2156,7 @@ -- 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@@ -2266,7 +2304,7 @@         sab = sa + size b         sabc = sab + size c --- | /O(log(min(i,n-i)))/. Delete the element of a sequence at a given+-- | \( 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. -- -- @@@ -2544,7 +2582,7 @@         sabc = sab + size c  --- | /O(n)/. A generalization of 'fmap', 'mapWithIndex' takes a mapping+-- | 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@@ -2607,8 +2645,34 @@  #-} #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 --- | /O(n)/. A generalization of 'foldMap', 'foldMapWithIndex' takes a folding+{-# 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. --@@ -2650,45 +2714,16 @@       !sPsprm = sPspr + size m    foldMapWithIndexDigitE :: Monoid m => (Int -> Elem a -> m) -> Int -> Digit (Elem a) -> m-  foldMapWithIndexDigitE f i t = foldMapWithIndexDigit f i t+  foldMapWithIndexDigitE f i t = foldWithIndexDigit (<>) f i t    foldMapWithIndexDigitN :: Monoid m => (Int -> Node a -> m) -> Int -> Digit (Node a) -> m-  foldMapWithIndexDigitN f i t = foldMapWithIndexDigit f i t--  {-# INLINE foldMapWithIndexDigit #-}-  foldMapWithIndexDigit :: (Monoid m, Sized a) => (Int -> a -> m) -> Int -> Digit a -> m-  foldMapWithIndexDigit f !s (One a) = f s a-  foldMapWithIndexDigit f s (Two a b) = f s a <> f sPsa b-    where-      !sPsa = s + size a-  foldMapWithIndexDigit f s (Three a b c) =-                                      f s a <> f sPsa b <> f sPsab c-    where-      !sPsa = s + size a-      !sPsab = sPsa + size b-  foldMapWithIndexDigit 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+  foldMapWithIndexDigitN f i t = foldWithIndexDigit (<>) f i t    foldMapWithIndexNodeE :: Monoid m => (Int -> Elem a -> m) -> Int -> Node (Elem a) -> m-  foldMapWithIndexNodeE f i t = foldMapWithIndexNode f i t+  foldMapWithIndexNodeE f i t = foldWithIndexNode (<>) f i t    foldMapWithIndexNodeN :: Monoid m => (Int -> Node a -> m) -> Int -> Node (Node a) -> m-  foldMapWithIndexNodeN f i t = foldMapWithIndexNode f i t--  {-# INLINE foldMapWithIndexNode #-}-  foldMapWithIndexNode :: (Monoid m, Sized a) => (Int -> a -> m) -> Int -> Node a -> m-  foldMapWithIndexNode f !s (Node2 _ a b) = f s a <> f sPsa b-    where-      !sPsa = s + size a-  foldMapWithIndexNode f s (Node3 _ a b c) =-                                     f s a <> f sPsa b <> f sPsab c-    where-      !sPsa = s + size a-      !sPsab = sPsa + size b+  foldMapWithIndexNodeN f i t = foldWithIndexNode (<>) f i t  #if __GLASGOW_HASKELL__ {-# INLINABLE foldMapWithIndex #-}@@ -2802,8 +2837,10 @@ -}  --- | /O(n)/. Convert a given sequence length and a function representing that+-- | \( 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@@ -2843,10 +2880,12 @@ #endif     {-# INLINE lift_elem #-} --- | /O(n)/. Create a sequence consisting of the elements of an 'Array'.+-- | \( 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)@@ -2860,7 +2899,7 @@  -- Splitting --- | /O(log(min(i,n-i)))/. The first @i@ elements of a sequence.+-- | \( 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.@@ -3022,7 +3061,7 @@     scd     = size c + sd     sbcd    = size b + scd --- | /O(log(min(i,n-i)))/. Elements of a sequence after the first @i@.+-- | \( 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.@@ -3188,7 +3227,7 @@     scd     = size c + sd     sbcd    = size b + scd --- | /O(log(min(i,n-i)))/. Split a sequence at a given position.+-- | \( 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)@@ -3203,7 +3242,7 @@   | i <= 0 = (empty, xs)   | otherwise = (xs, empty) --- | /O(log(min(i,n-i))) A version of 'splitAt' that does not attempt to+-- | \( 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@@ -3285,7 +3324,7 @@     sprmla  = 1 + sprml     sprmlab = sprmla + 1 -splitPrefixE :: Int -> Int -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> +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@@ -3301,7 +3340,7 @@   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) -> +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@@ -3370,9 +3409,16 @@     scd     = size c + sd     sbcd    = size b + scd --- | /O(n)/. @chunksOf n xs@ splits @xs@ into chunks of size @n>0@.--- If @n@ does not divide the length of @xs@ evenly, then the last element+-- | \(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@@ -3385,23 +3431,23 @@     (numReps, endLength) = length s `quotRem` n     (most, end) = splitAt (length s - endLength) s --- | /O(n)/.  Returns a sequence of all suffixes of this sequence,+-- | \( 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.+-- 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,+-- | \( 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.+-- 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) @@ -3510,13 +3556,13 @@ listToMaybe' :: [a] -> Maybe a listToMaybe' = foldr (\ x _ -> Just x) Nothing --- | /O(i)/ where /i/ is the prefix length.  'takeWhileL', applied+-- | \( 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+-- | \( 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@. --@@ -3524,26 +3570,26 @@ takeWhileR :: (a -> Bool) -> Seq a -> Seq a takeWhileR p = fst . spanr p --- | /O(i)/ where /i/ is the prefix length.  @'dropWhileL' p xs@ returns+-- | \( 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+-- | \( 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+-- | \( 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+-- | \( 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.@@ -3551,7 +3597,7 @@ spanr p = breakr (not . p)  {-# INLINE breakl #-}--- | /O(i)/ where /i/ is the breakpoint index.  'breakl', applied to a+-- | \( 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@@ -3567,7 +3613,7 @@ 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+-- | \( 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)@@ -3577,7 +3623,7 @@       | p x         = (xs `snoc'` x) :*: ys       | otherwise   = xs :*: (ys `snoc'` x) --- | /O(n)/.  The 'filter' function takes a predicate @p@ and a sequence+-- | \( 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@@ -3691,7 +3737,7 @@ -- 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.+-- | \( 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@@ -3881,7 +3927,8 @@ #endif  #ifdef __GLASGOW_HASKELL__-instance IsString (Seq Char) where+-- | @since 0.5.7+instance a ~ Char => IsString (Seq a) where     fromString = fromList #endif @@ -3889,14 +3936,14 @@ -- Reverse ------------------------------------------------------------------------ --- | /O(n)/. The reverse of a sequence.+-- | \( 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+-- | \( 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)@@ -3990,7 +4037,7 @@ -- -- David Feuer, with some guidance from Carter Schonwald, December 2014 --- | /O(n)/. Constructs a new sequence with the same structure as an existing+-- | \( 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@@ -4123,78 +4170,74 @@  -- MonadZip appeared in base 4.4.0 #if MIN_VERSION_base(4,4,0)--- We use a custom definition of munzip to *try* to avoid retaining+-- 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 attempts to use the selector thunk--- optimization to prevent that. Unfortunately, that optimization is--- fragile, so we can't actually guarantee anything. If someone finds--- a leak, we can try to throw explicit bindings and NOINLINE pragmas--- around and see if that fixes it.+-- 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 = unzipWith id--class UnzipWith f where-  unzipWith :: (x -> (a, b)) -> f x -> (f a, f b)--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)+  munzip = unzip #endif --- We're super-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.-instance UnzipWith Node where-  unzipWith f (Node2 s x y) =-    case (f x, f y) of-      (~(x1, x2), ~(y1, y2)) -> (Node2 s x1 y1, Node2 s x2 y2)-  unzipWith f (Node3 s x y z) =-    case (f x, f y, f z) of-      (~(x1, x2), ~(y1, y2), ~(z1, z2)) -> (Node3 s x1 y1 z1, Node3 s x2 y2 z2)---- 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. See the note at the Seq instance for an explanation--- of why the Digit (Elem a) case is handled specially.-instance UnzipWith Digit where-  unzipWith f (One x) =-    case f x of-      (x1, x2) -> (One x1, One x2)-  unzipWith f (Two x y) =-    case (f x, f y) of-      ((x1, x2), (y1, y2)) -> (Two x1 y1, Two x2 y2)-  unzipWith f (Three x y z) =-    case (f x, f y, f z) of-      ((x1, x2), (y1, y2), (z1, z2)) -> (Three x1 y1 z1, Three x2 y2 z2)-  unzipWith f (Four x y z w) =-    case (f x, f y, f z, f w) of-      ((x1, x2), (y1, y2), (z1, z2), (w1, w2)) -> (Four x1 y1 z1 w1, Four x2 y2 z2 w2)--instance UnzipWith FingerTree where-  unzipWith _ EmptyT = (EmptyT, EmptyT)-  unzipWith f (Single x) = case f x of-    (x1, x2) -> (Single x1, Single x2)-  unzipWith f (Deep s pr m sf) =-    case unzipWith f pr of { (pr1, pr2) ->-    case unzipWith f sf of { (sf1, sf2) ->-    case unzipWith (unzipWith f) m of { ~(m1, m2) ->-      (Deep s pr1 m1 sf1, Deep s pr2 m2 sf2)}}}+-- | 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 --- We need to handle the top level of the sequence specially, to make unzipping behave--- well in the presence of undefined elements. For example, what do we want from+-- | \( O(n) \). Unzip a sequence using a function to divide elements. ----- munzip [(1,2), undefined, (5,6)]?+-- @ 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)))@@ -4211,26 +4254,158 @@ -- -- ([undefined, undefined, 5], [undefined, undefined, 6]) ----- so we pretty much have to be completely lazy in the elements. We could--- do this by adding extra laziness to the Digit instance or to the Elem instance,--- but either of those would give unnecessary extra laziness lower in the tree.-instance UnzipWith Seq where-  unzipWith _f (Seq EmptyT) = (empty, empty)-  unzipWith f (Seq (Single (Elem x))) = case f x of ~(a, b) -> (singleton a, singleton b)-  unzipWith f (Seq (Deep s pr m sf)) =-    case unzipWith (\(Elem x) -> case f x of ~(a, b) -> (Elem a, Elem b)) pr of { (pr1, pr2) ->-    case unzipWith (\(Elem x) -> case f x of ~(a, b) -> (Elem a, Elem b)) sf of { (sf1, sf2) ->-    case unzipWith (unzipWith (unzipWith f)) m of { ~(m1, m2) ->-      (Seq (Deep s pr1 m1 sf1), Seq (Deep s pr2 m2 sf2))}}}+-- 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 --- | /O(min(n1,n2))/.  'zip' takes two sequences and returns a sequence+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(n1,n2))/.  'zipWith' generalizes 'zip' by zipping with the+-- | \( 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.@@ -4248,12 +4423,12 @@     goLeaf (Seq (Single (Elem b))) a = f a b     goLeaf _ _ = error "Data.Sequence.zipWith'.goLeaf internal error: not a singleton" --- | /O(min(n1,n2,n3))/.  'zip3' takes three sequences and returns a+-- | \( 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(n1,n2,n3))/.  'zipWith3' takes a function which combines+-- | \( 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@@ -4267,12 +4442,12 @@ 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(n1,n2,n3,n4))/.  'zip4' takes four sequences and returns a+-- | \( 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(n1,n2,n3,n4))/.  'zipWith4' takes a function which combines+-- | \( 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@@ -4284,83 +4459,6 @@     s3' = take minLen s3     s4' = take minLen s4 ---------------------------------------------------------------------------- Sorting------ sort and sortBy are implemented by simple deforestations of---      \ xs -> fromList2 (length xs) . Data.List.sortBy cmp . toList--- which does not get deforested automatically, it would appear.------ Unstable sorting is performed by a heap sort implementation based on--- pairing heaps.  Because the internal structure of sequences is quite--- varied, it is difficult to get blocks of elements of roughly the same--- length, which would improve merge sort performance.  Pairing heaps,--- on the other hand, are relatively resistant to the effects of merging--- heaps of wildly different sizes, as guaranteed by its amortized--- constant-time merge operation.  Moreover, extensive use of SpecConstr--- transformations can be done on pairing heaps, especially when we're--- only constructing them to immediately be unrolled.------ On purely random sequences of length 50000, with no RTS options,--- I get the following statistics, in which heapsort is about 42.5%--- faster:  (all comparisons done with -O2)------ Times (ms)            min      mean    +/-sd    median    max--- to/from list:       103.802  108.572    7.487  106.436  143.339--- unstable heapsort:   60.686   62.968    4.275   61.187   79.151------ Heapsort, it would seem, is less of a memory hog than Data.List.sortBy.--- The gap is narrowed when more memory is available, but heapsort still--- wins, 15% faster, with +RTS -H128m:------ Times (ms)            min    mean    +/-sd  median    max--- to/from list:       42.692  45.074   2.596  44.600  56.601--- unstable heapsort:  37.100  38.344   3.043  37.715  55.526------ In addition, on strictly increasing sequences the gap is even wider--- than normal; heapsort is 68.5% faster with no RTS options:--- Times (ms)            min    mean    +/-sd  median    max--- to/from list:       52.236  53.574   1.987  53.034  62.098--- unstable heapsort:  16.433  16.919   0.931  16.681  21.622------ This may be attributed to the elegant nature of the pairing heap.------ wasserman.louis@gmail.com, 7/20/09----------------------------------------------------------------------------- | /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 considerably--- faster, and in particular uses less memory.-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 considerably--- faster, and in particular uses less memory.-sortBy :: (a -> a -> Ordering) -> Seq a -> Seq a-sortBy cmp xs = fromList2 (length xs) (Data.List.sortBy cmp (toList 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',--- and performs extremely well -- frequently twice as fast as 'sort' ----- when the sequence is already nearly sorted.-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', and performs extremely well ----- frequently twice as fast as 'sortBy' -- when the sequence is already--- nearly sorted.-unstableSortBy :: (a -> a -> Ordering) -> Seq a -> Seq a-unstableSortBy cmp (Seq xs) =-    fromList2 (size xs) $ maybe [] (unrollPQ cmp) $-        toPQ cmp (\ (Elem x) -> PQueue x Nil) xs- -- | fromList2, given a list and its length, constructs a completely -- balanced Seq whose elements are that list using the replicateA -- generalization.@@ -4369,74 +4467,3 @@   where     ht (x:xs) = (xs, x)     ht []     = error "fromList2: short list"---- | A 'PQueue' is a simple pairing heap.-data PQueue e = PQueue e (PQL e)-data PQL e = Nil | {-# UNPACK #-} !(PQueue e) :& PQL e--infixr 8 :&--#ifdef TESTING--instance Functor PQueue where-    fmap f (PQueue x ts) = PQueue (f x) (fmap f ts)--instance Functor PQL where-    fmap f (q :& qs) = fmap f q :& fmap f qs-    fmap _ Nil = Nil--instance Show e => Show (PQueue e) where-    show = unlines . draw . fmap show---- borrowed wholesale from Data.Tree, as Data.Tree actually depends--- on Data.Sequence-draw :: PQueue String -> [String]-draw (PQueue x ts0) = x : drawSubTrees ts0-  where-    drawSubTrees Nil = []-    drawSubTrees (t :& Nil) =-        "|" : shift "`- " "   " (draw t)-    drawSubTrees (t :& ts) =-        "|" : shift "+- " "|  " (draw t) ++ drawSubTrees ts--    shift first other = Data.List.zipWith (++) (first : repeat other)-#endif---- | 'unrollPQ', given a comparator function, unrolls a 'PQueue' into--- a sorted list.-unrollPQ :: (e -> e -> Ordering) -> PQueue e -> [e]-unrollPQ cmp = unrollPQ'-  where-    {-# INLINE unrollPQ' #-}-    unrollPQ' (PQueue x ts) = x:mergePQs0 ts-    (<+>) = mergePQ cmp-    mergePQs0 Nil = []-    mergePQs0 (t :& Nil) = unrollPQ' t-    mergePQs0 (t1 :& t2 :& ts) = mergePQs (t1 <+> t2) ts-    mergePQs !t ts = case ts of-        Nil             -> unrollPQ' t-        t1 :& Nil       -> unrollPQ' (t <+> t1)-        t1 :& t2 :& ts' -> mergePQs (t <+> (t1 <+> t2)) ts'---- | 'toPQ', given an ordering function and a mechanism for queueifying--- elements, converts a 'FingerTree' to a 'PQueue'.-toPQ :: (e -> e -> Ordering) -> (a -> PQueue e) -> FingerTree a -> Maybe (PQueue e)-toPQ _ _ EmptyT = Nothing-toPQ _ f (Single x) = Just (f x)-toPQ cmp f (Deep _ pr m sf) = Just (maybe (pr' <+> sf') ((pr' <+> sf') <+>) (toPQ cmp fNode m))-  where-    fDigit digit = case fmap f digit of-        One a           -> a-        Two a b         -> a <+> b-        Three a b c     -> a <+> b <+> c-        Four a b c d    -> (a <+> b) <+> (c <+> d)-    (<+>) = mergePQ cmp-    fNode = fDigit . nodeToDigit-    pr' = fDigit pr-    sf' = fDigit sf---- | 'mergePQ' merges two 'PQueue's.-mergePQ :: (a -> a -> Ordering) -> PQueue a -> PQueue a -> PQueue a-mergePQ cmp q1@(PQueue x1 ts1) q2@(PQueue x2 ts2)-  | cmp x1 x2 == GT     = PQueue x2 (q1 :& ts2)-  | otherwise           = PQueue x1 (q2 :& ts1)

@@ -0,0 +1,425 @@+{-# 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.+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.+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@.+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).+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'.+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@.+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 #-}

@@ -13,14 +13,38 @@ -- Maintainer  :  libraries@haskell.org -- Portability :  portable ----- An efficient implementation of sets. --+-- = 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: --@@ -38,21 +62,9 @@ --      \"/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, its--- behaviour is undefined. -----------------------------------------------------------------------------  module Data.Set (-            -- * Strictness properties-            -- $strictness-             -- * Set type #if !defined(TESTING)               Set          -- instance Eq,Ord,Show,Read,Data,Typeable@@ -74,18 +86,22 @@             , lookupGE             , isSubsetOf             , isProperSubsetOf+            , disjoint              -- * Construction             , empty             , singleton             , insert             , delete+            , powerSet              -- * Combine             , union             , unions             , difference             , intersection+            , cartesianProduct+            , disjointUnion              -- * Filter             , S.filter@@ -161,13 +177,3 @@             ) where  import Data.Set.Internal as S---- $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

@@ -12,6 +12,8 @@ {-# LANGUAGE TypeFamilies #-} #endif +{-# OPTIONS_HADDOCK not-home #-}+ #include "containers.h"  -----------------------------------------------------------------------------@@ -70,6 +72,8 @@ -- /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]@@ -121,6 +125,7 @@ module Data.Set.Internal (             -- * Set type               Set(..)       -- instance Eq,Ord,Show,Read,Data,Typeable+            , Size              -- * Operators             , (\\)@@ -136,18 +141,22 @@             , lookupGE             , isSubsetOf             , isProperSubsetOf+            , disjoint              -- * Construction             , empty             , singleton             , insert             , delete+            , powerSet              -- * Combine             , union             , unions             , difference             , intersection+            , cartesianProduct+            , disjointUnion              -- * Filter             , filter@@ -231,6 +240,9 @@ 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)) @@ -243,7 +255,8 @@ #if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as GHCExts #endif-import Text.Read+import Text.Read ( readPrec, Read (..), Lexeme (..), parens, prec+                 , lexP, readListPrecDefault ) import Data.Data #endif @@ -283,6 +296,7 @@ #else     mappend = (<>) +-- | @since 0.5.7 instance Ord a => Semigroup (Set a) where     (<>)    = union     stimes  = stimesIdempotentMonoid@@ -609,7 +623,28 @@ {-# 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 --------------------------------------------------------------------}@@ -872,6 +907,7 @@   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@@ -982,6 +1018,8 @@  -- | /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__@@ -1029,6 +1067,8 @@  -- 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@@ -1069,14 +1109,17 @@     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)@@ -1163,6 +1206,8 @@ -- > 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@@ -1186,6 +1231,8 @@ -- > 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@@ -1208,6 +1255,8 @@ -- > 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"@@ -1227,6 +1276,8 @@ -- > 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 =@@ -1245,6 +1296,8 @@ -- @ -- 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@@ -1264,6 +1317,8 @@ -- @ -- 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@@ -1306,6 +1361,8 @@ -- 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@@ -1321,6 +1378,8 @@ -- 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@@ -1341,6 +1400,8 @@ -- 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)@@ -1621,6 +1682,8 @@ --  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@@ -1628,6 +1691,77 @@     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 disjoin 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

@@ -1,3 +1,4 @@+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}@@ -47,6 +48,7 @@ #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@@ -84,7 +86,15 @@         subForest :: Forest a   -- ^ zero or more child trees     } #ifdef __GLASGOW_HASKELL__-#if __GLASGOW_HASKELL__ >= 706+#if __GLASGOW_HASKELL__ >= 802+  deriving ( Eq+           , Read+           , Show+           , Data+           , Generic  -- ^ @since 0.5.8+           , Generic1 -- ^ @since 0.5.8+           )+#elif __GLASGOW_HASKELL__ >= 706   deriving (Eq, Read, Show, Data, Generic, Generic1) #elif __GLASGOW_HASKELL__ >= 702   deriving (Eq, Read, Show, Data, Generic)@@ -97,22 +107,26 @@ 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@@ -161,9 +175,19 @@  instance Monad Tree where     return = pure-    Node x ts >>= f = Node x' (ts' ++ map (>>= f) ts)-      where Node x' ts' = f x+    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) @@ -221,6 +245,8 @@         iterate (concatMap subForest) [t]  -- | Catamorphism on trees.+--+-- @since 0.5.8 foldTree :: (a -> [b] -> b) -> Tree a -> b foldTree f = go where     go (Node x ts) = f x (map go ts)

@@ -3,7 +3,7 @@ {-# LANGUAGE MagicHash #-} #endif #if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} #endif  #include "containers.h"@@ -31,26 +31,50 @@ -- closely.  module Utils.Containers.Internal.BitUtil-    ( highestBitMask+    ( bitcount+    , highestBitMask     , shiftLL     , shiftRL     , wordSize     ) where  import Data.Bits ((.|.), xor)+#if MIN_VERSION_base(4,5,0)+import Data.Bits (popCount, unsafeShiftL, unsafeShiftR)+#else+import Data.Bits ((.&.), shiftL, shiftR)+#endif #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 -#if __GLASGOW_HASKELL__-import GHC.Exts (Word(..), Int(..))-import GHC.Prim (uncheckedShiftL#, uncheckedShiftRL#)+{----------------------------------------------------------------------+  [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+#if MIN_VERSION_base(4,5,0)+bitcount a x = a + popCount x #else-import Data.Word (shiftL, shiftR)+bitcount a0 x0 = go a0 x0+  where go a 0 = a+        go a x = go (a + 1) (x .&. (x-1)) #endif+{-# INLINE bitcount #-}  -- The highestBitMask implementation is based on -- http://graphics.stanford.edu/~seander/bithacks.html#RoundUpPowerOf2@@ -73,19 +97,12 @@  -- Right and left logical shifts. shiftRL, shiftLL :: Word -> Int -> Word-#if __GLASGOW_HASKELL__-{---------------------------------------------------------------------  GHC: use unboxing to get @shiftRL@ inlined.---------------------------------------------------------------------}-shiftRL (W# x) (I# i) = W# (uncheckedShiftRL# x i)-shiftLL (W# x) (I# i) = W# (uncheckedShiftL#  x i)-{-# INLINE CONLIKE shiftRL #-}-{-# INLINE CONLIKE shiftLL #-}+#if MIN_VERSION_base(4,5,0)+shiftRL = unsafeShiftR+shiftLL = unsafeShiftL #else-shiftRL x i   = shiftR x i-shiftLL x i   = shiftL x i-{-# INLINE shiftRL #-}-{-# INLINE shiftLL #-}+shiftRL = shiftR+shiftLL = shiftL #endif  {-# INLINE wordSize #-}

@@ -0,0 +1,35 @@+{-# 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)

@@ -40,6 +40,8 @@         , 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

@@ -32,6 +32,10 @@         , 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]

@@ -91,6 +91,7 @@         , 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

@@ -24,6 +24,11 @@         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 ()@@ -128,6 +133,42 @@          , 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]+         ]       ]  {-@@ -165,7 +206,6 @@ 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

@@ -33,6 +33,10 @@         , 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]

@@ -1,8 +1,81 @@ # Changelog for [`containers` package](http://github.com/haskell/containers) +## 0.5.11++* Released with GHC 8.4.++### New functions and class instances++* Add a `MonadFix` instance for `Data.Sequence`.++* Add a `MonadFix` instance for `Data.Tree`.++* Add `powerSet`, `cartesianProduct`, and `disjointUnion` for+  `Data.Set`. (Thanks, Edward Kmett.)++* Add `disjoint` for `Data.Set` and `Data.IntSet`. (Thanks, Víctor López Juan.)++* Add `lookupMin` and `lookupMax` to `Data.IntMap`. (Thanks, bwroga.)++* Add `unzip` and `unzipWith` to `Data.Sequence`. Make unzipping+  build its results in lockstep to avoid certain space leaks.++* Add carefully optimized implementations of `sortOn` and `unstableSortOn`+  to `Data.Sequence`. (Thanks, Donnacha Oisín Kidney.)++### Changes to existing functions and features++* Make `Data.Sequence.replicateM` a synonym for `replicateA`+  for post-AMP `base`.++* 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)+  ```++* Make `>>=` for `Data.Tree` strict in the result of its second argument;+  being too lazy here is almost useless, and violates one of the monad identity+  laws. Specifically, `return () >>= \_ -> undefined` should always be+  `undefined`, but this was not the case.++* Harmonize laziness details for `minView` and `maxView` between+  `Data.IntMap` and `Data.Map`.++### Performance improvement++* Speed up both stable and unstable sorting for `Data.Sequence` by (Thanks, Donnacha+  Oisín Kidney.)++### Other changes++* Update for recent and upcoming GHC and Cabal versions (Thanks, Herbert+  Valerio Reidel, Simon Jakobi, and Ryan Scott.)++* Improve external and internal documentation (Thanks, Oleg Grenrus+  and Benjamin Hodgson.)++* Add tutorial-style documentation.++* Add Haddock `@since` annotations for changes made since version+  0.5.4 (Thanks, Simon Jakobi.)++* Add a (very incomplete) test suite for `Data.Tree`.++* Add structural validity checks to the test suites for `Data.IntMap`+  and `Data.IntSet` (Thanks to Joachim Breitner for catching an error+  in a first draft.)+ ## 0.5.10.2 -* Planned for GHC 8.2.+* Released with GHC 8.2.  * Use `COMPLETE` pragmas to declare complete sets of pattern synonyms   for `Data.Sequence`. At last!

@@ -1,5 +1,5 @@ name: containers-version: 0.5.10.2+version: 0.5.11.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org@@ -7,10 +7,18 @@ synopsis: Assorted concrete container types category: Data Structures description:+    .     This package contains efficient general-purpose implementations-    of various basic immutable container types.  The declared cost of-    each operation is either worst-case or amortized, but remains-    valid even if structures are shared.+    of various immutable container types including sets, maps, sequences,+    trees, and graphs.+    .+    For a walkthrough of what this package provides with examples of common+    operations see the [containers+    introduction](https://haskell-containers.readthedocs.io).+    .+    The declared cost of each operation is either worst-case or amortized, but+    remains valid even if structures are shared.+ build-type: Simple cabal-version:  >=1.8 extra-source-files:@@ -65,12 +73,14 @@         Data.Graph         Data.Sequence         Data.Sequence.Internal+        Data.Sequence.Internal.Sorting         Data.Tree         Utils.Containers.Internal.BitUtil         Utils.Containers.Internal.BitQueue         Utils.Containers.Internal.StrictPair      other-modules:+        Utils.Containers.Internal.State         Utils.Containers.Internal.StrictFold         Utils.Containers.Internal.StrictMaybe         Utils.Containers.Internal.PtrEquality@@ -91,7 +101,7 @@   build-depends:     base >= 4.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2,+    criterion >= 0.4.0 && < 1.3,     deepseq >= 1.1.0.0 && < 1.5  benchmark intset-benchmarks@@ -102,7 +112,7 @@   build-depends:     base >= 4.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2,+    criterion >= 0.4.0 && < 1.3,     deepseq >= 1.1.0.0 && < 1.5  benchmark map-benchmarks@@ -113,7 +123,7 @@   build-depends:     base >= 4.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2,+    criterion >= 0.4.0 && < 1.3,     deepseq >= 1.1.0.0 && < 1.5,     transformers @@ -125,7 +135,7 @@   build-depends:     base >= 4.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2,+    criterion >= 0.4.0 && < 1.3,     deepseq >= 1.1.0.0 && < 1.5,     random < 1.2,     transformers@@ -138,53 +148,67 @@   build-depends:     base >= 4.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2,+    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.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2+    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.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2+    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.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2+    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.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2+    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.StrictFold+      Utils.Containers.Internal.StrictPair   ghc-options: -O2   cpp-options: -DTESTING   other-modules:@@ -192,7 +216,7 @@   build-depends:     base >= 4.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2,+    criterion >= 0.4.0 && < 1.3,     deepseq >= 1.1.0.0 && < 1.5,     ghc-prim @@ -200,6 +224,21 @@   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.StrictFold+      Utils.Containers.Internal.StrictMaybe+      Utils.Containers.Internal.StrictPair   ghc-options: -O2   cpp-options: -DTESTING   other-modules:@@ -207,7 +246,7 @@   build-depends:     base >= 4.2 && < 5,     containers,-    criterion >= 0.4.0 && < 1.2,+    criterion >= 0.4.0 && < 1.3,     deepseq >= 1.1.0.0 && < 1.5,     ghc-prim @@ -221,6 +260,20 @@ 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.BitUtil+        Utils.Containers.Internal.PtrEquality+        Utils.Containers.Internal.StrictFold+        Utils.Containers.Internal.StrictMaybe+        Utils.Containers.Internal.StrictPair     type: exitcode-stdio-1.0     cpp-options: -DTESTING @@ -231,7 +284,7 @@      build-depends:         HUnit,-        QuickCheck,+        QuickCheck >= 2.7.1,         test-framework,         test-framework-hunit,         test-framework-quickcheck2,@@ -240,6 +293,21 @@ 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.StrictFold+        Utils.Containers.Internal.StrictMaybe+        Utils.Containers.Internal.StrictPair     type: exitcode-stdio-1.0     cpp-options: -DTESTING -DSTRICT @@ -250,7 +318,7 @@      build-depends:         HUnit,-        QuickCheck,+        QuickCheck >= 2.7.1,         test-framework,         test-framework-hunit,         test-framework-quickcheck2,@@ -259,6 +327,9 @@ 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 @@ -268,13 +339,22 @@     include-dirs: include      build-depends:-        QuickCheck,+        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.StrictFold+        Utils.Containers.Internal.StrictPair     type: exitcode-stdio-1.0     cpp-options: -DTESTING @@ -285,7 +365,7 @@      build-depends:         HUnit,-        QuickCheck,+        QuickCheck >= 2.7.1,         test-framework,         test-framework-hunit,         test-framework-quickcheck2,@@ -294,6 +374,17 @@ 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.StrictFold+        Utils.Containers.Internal.StrictPair     type: exitcode-stdio-1.0     cpp-options: -DTESTING @@ -304,7 +395,7 @@      build-depends:         HUnit,-        QuickCheck,+        QuickCheck >= 2.7.1,         test-framework,         test-framework-hunit,         test-framework-quickcheck2@@ -312,6 +403,17 @@ 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.StrictFold+        Utils.Containers.Internal.StrictPair     type: exitcode-stdio-1.0     cpp-options: -DTESTING -DSTRICT @@ -322,7 +424,7 @@      build-depends:         HUnit,-        QuickCheck,+        QuickCheck >= 2.7.1,         test-framework,         test-framework-hunit,         test-framework-quickcheck2@@ -330,6 +432,16 @@ 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.StrictFold+        Utils.Containers.Internal.StrictPair     type: exitcode-stdio-1.0     cpp-options: -DTESTING @@ -340,7 +452,7 @@      build-depends:         HUnit,-        QuickCheck,+        QuickCheck >= 2.7.1,         test-framework,         test-framework-hunit,         test-framework-quickcheck2@@ -348,6 +460,27 @@ Test-suite deprecated-properties     hs-source-dirs: tests, .     main-is: deprecated-properties.hs+    other-modules:+        Data.IntMap+        Data.IntMap.Internal+        Data.IntMap.Internal.DeprecatedDebug+        Data.IntMap.Lazy+        Data.IntMap.Strict+        Data.IntSet.Internal+        Data.Map+        Data.Map.Internal+        Data.Map.Internal.Debug+        Data.Map.Internal.DeprecatedShowTree+        Data.Map.Lazy+        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.StrictFold+        Utils.Containers.Internal.StrictMaybe+        Utils.Containers.Internal.StrictPair     type: exitcode-stdio-1.0     cpp-options: -DTESTING @@ -357,13 +490,17 @@     include-dirs: include      build-depends:-        QuickCheck,+        QuickCheck >= 2.7.1,         test-framework,         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 @@ -373,14 +510,46 @@     include-dirs: include      build-depends:-        QuickCheck,+        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.3 && < 5, array, 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.StrictFold+      Utils.Containers.Internal.StrictMaybe+      Utils.Containers.Internal.StrictPair   type: exitcode-stdio-1.0    build-depends:@@ -388,7 +557,7 @@     base >= 4.3 && < 5,     ChasingBottoms,     deepseq >= 1.2 && < 1.5,-    QuickCheck >= 2.4.0.1,+    QuickCheck >= 2.7.1,     ghc-prim,     test-framework >= 0.3.3,     test-framework-quickcheck2 >= 0.2.9@@ -400,6 +569,14 @@ 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.StrictFold+      Utils.Containers.Internal.StrictPair   type: exitcode-stdio-1.0   other-extensions: CPP, BangPatterns @@ -408,7 +585,7 @@     base >= 4.3 && < 5,     ChasingBottoms,     deepseq >= 1.2 && < 1.5,-    QuickCheck >= 2.4.0.1,+    QuickCheck >= 2.7.1,     ghc-prim,     test-framework >= 0.3.3,     test-framework-quickcheck2 >= 0.2.9@@ -419,6 +596,12 @@ 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.StrictFold+      Utils.Containers.Internal.StrictPair   type: exitcode-stdio-1.0   other-extensions: CPP, BangPatterns @@ -427,7 +610,7 @@     base >= 4.3 && < 5,     ChasingBottoms,     deepseq >= 1.2 && < 1.5,-    QuickCheck >= 2.4.0.1,+    QuickCheck >= 2.7.1,     ghc-prim,     test-framework >= 0.3.3,     test-framework-quickcheck2 >= 0.2.9

@@ -0,0 +1,63 @@+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 _ _ _) -> all (sharedPrefix p) (keys b)+  where+    sharedPrefix :: Prefix -> Int -> Bool+    sharedPrefix p a = 0 == (p `xor` (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)

@@ -0,0 +1,87 @@+{-# 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 _ _ _) -> all (sharedPrefix p) (elems b)+  where+    sharedPrefix :: Prefix -> Int -> Bool+    sharedPrefix p a = 0 == (p `xor` (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)++-- 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

@@ -6,6 +6,7 @@ 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)@@ -31,6 +32,7 @@ main = defaultMain          [                testCase "index"      test_index+             , testCase "index_lookup" test_index_lookup              , testCase "size"       test_size              , testCase "size2"      test_size2              , testCase "member"     test_member@@ -106,6 +108,8 @@              , 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@@ -120,6 +124,8 @@              , 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@@ -141,6 +147,7 @@              , 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@@ -152,6 +159,8 @@              , 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@@ -190,7 +199,12 @@                 ; 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 ()@@ -217,6 +231,11 @@ 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 @@ -682,6 +701,16 @@ ---------------------------------------------------------------- -- 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") @@ -745,27 +774,56 @@     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_singleton :: Int -> Int -> Bool-prop_singleton k x = insert k x empty == singleton k x+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) ==> (delete k (insert k () t) == t)+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)] -> Bool-prop_unionModel xs ys-  = sort (keys (union (fromList xs) (fromList ys)))-    == sort (nub (Prelude.map fst xs ++ Prelude.map fst ys))+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@@ -781,15 +839,23 @@   = sum (elems (unionWith (+) (fromListWith (+) xs) (fromListWith (+) ys)))     == (sum (Prelude.map snd xs) + sum (Prelude.map snd ys)) -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_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)] -> 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_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@@ -876,19 +942,20 @@ prop_ascDescList xs = toAscList m == reverse (toDescList m)   where m = fromList $ zip xs $ repeat () -prop_fromList :: [Int] -> Bool+prop_fromList :: [Int] -> Property 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)+      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 -> Bool-prop_alter t k = case lookup k t of+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@@ -904,6 +971,11 @@   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) @@ -966,18 +1038,18 @@ prop_lookupGE :: [(Int, Int)] -> Bool prop_lookupGE = test_lookupSomething lookupGE (>=) -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_lookupMin :: IntMap Int -> Property+prop_lookupMin im = lookupMin im === listToMaybe (toAscList im) -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_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@@ -993,14 +1065,18 @@ 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)+      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  = fromList xs-  in  partition (apply p) m == let (a,b) = (List.partition (apply p . snd) xs) in (fromList a, fromList b)+      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 ==>@@ -1024,8 +1100,10 @@ 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]+  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)

@@ -91,6 +91,7 @@       , 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

@@ -10,6 +10,7 @@ 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@@ -23,6 +24,10 @@                    , 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@@ -49,6 +54,7 @@                    , 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@@ -109,8 +115,39 @@                 ; 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@@ -155,7 +192,9 @@  prop_InsertDelete :: Int -> IntSet -> Property prop_InsertDelete k t-  = not (member k t) ==> delete k (insert k t) == t+  = not (member k t) ==>+      case delete k (insert k t) of+        t' -> valid t' .&&. t' === t  prop_MemberFromList :: [Int] -> Bool prop_MemberFromList xs@@ -164,11 +203,14 @@         t = fromList abs_xs  {---------------------------------------------------------------------  Union+  Union, Difference and Intersection --------------------------------------------------------------------}-prop_UnionInsert :: Int -> IntSet -> Bool-prop_UnionInsert x t-  = union t (singleton x) == insert x t+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@@ -178,16 +220,23 @@ prop_UnionComm t1 t2   = (union t1 t2 == union t2 t1) -prop_Diff :: [Int] -> [Int] -> Bool-prop_Diff xs ys-  =  toAscList (difference (fromList xs) (fromList ys))-    == List.sort ((List.\\) (nub xs)  (nub ys))+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] -> Bool-prop_Int xs ys-  =  toAscList (intersection (fromList xs) (fromList ys))-    == List.sort (nub ((List.intersect) (xs)  (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 --------------------------------------------------------------------}@@ -207,12 +256,13 @@ prop_AscDescList xs = toAscList s == reverse (toDescList s)   where s = fromList xs -prop_fromList :: [Int] -> Bool+prop_fromList :: [Int] -> Property prop_fromList xs   = case fromList xs of-      t -> t == fromAscList sort_xs &&-           t == fromDistinctAscList nub_sort_xs &&-           t == List.foldr insert empty xs+      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 @@ -303,13 +353,22 @@     Nothing -> null s     Just (m,s') -> m == minimum (toList s) && s == insert m s' && m `notMember` s' -prop_split :: IntSet -> Int -> Bool+prop_split :: IntSet -> Int -> Property 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+    (s1,s2) -> valid s1 .&&.+               valid s2 .&&.+               all (<i) (toList s1) .&&.+               all (>i) (toList s2) .&&.+               i `delete` s === union s1 s2 -prop_splitMember :: IntSet -> Int -> Bool+prop_splitMember :: IntSet -> Int -> Property 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+    (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)@@ -321,12 +380,22 @@                           , y <- toList (unions rst)                           , x > y ] -prop_partition :: IntSet -> Int -> Bool+prop_partition :: IntSet -> Int -> Property prop_partition s i = case partition odd s of-    (s1,s2) -> all odd (toList s1) && all even (toList s2) && s == s1 `union` s2+    (s1,s2) -> valid s1 .&&.+               valid s2 .&&.+               all odd (toList s1) .&&.+               all even (toList s2) .&&.+               s === s1 `union` s2 -prop_filter :: IntSet -> Int -> Bool-prop_filter s i = partition odd s == (filter odd s, filter even s)+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)  #if MIN_VERSION_base(4,5,0) prop_bitcount :: Int -> Word -> Bool@@ -337,3 +406,4 @@             go a x = go (a + 1) (x .&. (x-1))     bitcount_new a x = a + popCount x #endif+

@@ -23,6 +23,7 @@ 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 (@@ -44,6 +45,7 @@ import Control.Monad.Zip (MonadZip (..)) #endif import Control.DeepSeq (deepseq)+import Control.Monad.Fix (MonadFix (..))   main :: IO ()@@ -94,8 +96,10 @@        , testProperty "filter" prop_filter        , testProperty "sort" prop_sort        , testProperty "sortBy" prop_sortBy+       , testProperty "sortOn" prop_sortOn        , testProperty "unstableSort" prop_unstableSort        , testProperty "unstableSortBy" prop_unstableSortBy+       , testProperty "unstableSortOn" prop_unstableSortOn        , testProperty "index" prop_index        , testProperty "(!?)" prop_safeIndex        , testProperty "adjust" prop_adjust@@ -139,6 +143,7 @@        , 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@@ -538,6 +543,16 @@     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_unstableSort :: Seq OrdA -> Bool prop_unstableSort xs =     toList' (unstableSort xs) ~= Data.List.sort (toList xs)@@ -546,6 +561,10 @@ 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@@ -806,6 +825,24 @@ 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 

@@ -21,6 +21,7 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative (..), (<$>)) #endif+import Control.Applicative (liftA2)  main :: IO () main = defaultMain [ testCase "lookupLT" test_lookupLT@@ -66,6 +67,7 @@                    , 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@@ -93,6 +95,9 @@                    , 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@@ -422,6 +427,9 @@ 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 --------------------------------------------------------------------}@@ -602,6 +610,27 @@   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

@@ -0,0 +1,106 @@+{-# 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)++-- 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