diff --git a/Data/Graph.hs b/Data/Graph.hs --- a/Data/Graph.hs +++ b/Data/Graph.hs @@ -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) diff --git a/Data/IntMap/Internal.hs b/Data/IntMap/Internal.hs --- a/Data/IntMap/Internal.hs +++ b/Data/IntMap/Internal.hs @@ -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' – @@ -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 diff --git a/Data/IntMap/Lazy.hs b/Data/IntMap/Lazy.hs --- a/Data/IntMap/Lazy.hs +++ b/Data/IntMap/Lazy.hs @@ -63,7 +63,7 @@ #endif -- * Operators - , (!), (\\) + , (!), (!?), (\\) -- * Query , IM.null @@ -187,6 +187,8 @@ , isProperSubmapOf, isProperSubmapOfBy -- * Min\/Max + , lookupMin + , lookupMax , findMin , findMax , deleteMin diff --git a/Data/IntMap/Merge/Lazy.hs b/Data/IntMap/Merge/Lazy.hs --- a/Data/IntMap/Merge/Lazy.hs +++ b/Data/IntMap/Merge/Lazy.hs @@ -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 diff --git a/Data/IntMap/Merge/Strict.hs b/Data/IntMap/Merge/Strict.hs --- a/Data/IntMap/Merge/Strict.hs +++ b/Data/IntMap/Merge/Strict.hs @@ -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 diff --git a/Data/IntMap/Strict.hs b/Data/IntMap/Strict.hs --- a/Data/IntMap/Strict.hs +++ b/Data/IntMap/Strict.hs @@ -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 diff --git a/Data/IntSet.hs b/Data/IntSet.hs --- a/Data/IntSet.hs +++ b/Data/IntSet.hs @@ -74,6 +74,7 @@ , lookupGE , isSubsetOf , isProperSubsetOf + , disjoint -- * Construction , empty diff --git a/Data/IntSet/Internal.hs b/Data/IntSet/Internal.hs --- a/Data/IntSet/Internal.hs +++ b/Data/IntSet/Internal.hs @@ -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 #-} {-------------------------------------------------------------------- diff --git a/Data/Map/Internal.hs b/Data/Map/Internal.hs --- a/Data/Map/Internal.hs +++ b/Data/Map/Internal.hs @@ -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 . +-- +-- @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 diff --git a/Data/Map/Lazy.hs b/Data/Map/Lazy.hs --- a/Data/Map/Lazy.hs +++ b/Data/Map/Lazy.hs @@ -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 +-- +-- package instead. +-- +-- For a walkthrough of the most commonly used functions see the +-- . +-- +-- 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/\", -- . -- --- 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 (). ----------------------------------------------------------------------------- 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 diff --git a/Data/Map/Merge/Lazy.hs b/Data/Map/Merge/Lazy.hs --- a/Data/Map/Merge/Lazy.hs +++ b/Data/Map/Merge/Lazy.hs @@ -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 diff --git a/Data/Map/Merge/Strict.hs b/Data/Map/Merge/Strict.hs --- a/Data/Map/Merge/Strict.hs +++ b/Data/Map/Merge/Strict.hs @@ -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 diff --git a/Data/Map/Strict.hs b/Data/Map/Strict.hs --- a/Data/Map/Strict.hs +++ b/Data/Map/Strict.hs @@ -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 +-- +-- package instead. +-- +-- For a walkthrough of the most commonly used functions see the +-- . +-- +-- 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/\", -- . -- --- 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 (). --- --- 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 diff --git a/Data/Map/Strict/Internal.hs b/Data/Map/Strict/Internal.hs --- a/Data/Map/Strict/Internal.hs +++ b/Data/Map/Strict/Internal.hs @@ -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" diff --git a/Data/Sequence.hs b/Data/Sequence.hs --- a/Data/Sequence.hs +++ b/Data/Sequence.hs @@ -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. --- +-- * 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]) +@ +-} diff --git a/Data/Sequence/Internal.hs b/Data/Sequence/Internal.hs --- a/Data/Sequence/Internal.hs +++ b/Data/Sequence/Internal.hs @@ -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) diff --git a/Data/Sequence/Internal/Sorting.hs b/Data/Sequence/Internal/Sorting.hs new file mode 100644 --- /dev/null +++ b/Data/Sequence/Internal/Sorting.hs @@ -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 #-} diff --git a/Data/Set.hs b/Data/Set.hs --- a/Data/Set.hs +++ b/Data/Set.hs @@ -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 +-- . +-- +-- 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/\", -- . -- --- 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 diff --git a/Data/Set/Internal.hs b/Data/Set/Internal.hs --- a/Data/Set/Internal.hs +++ b/Data/Set/Internal.hs @@ -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 diff --git a/Data/Tree.hs b/Data/Tree.hs --- a/Data/Tree.hs +++ b/Data/Tree.hs @@ -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) diff --git a/Utils/Containers/Internal/BitUtil.hs b/Utils/Containers/Internal/BitUtil.hs --- a/Utils/Containers/Internal/BitUtil.hs +++ b/Utils/Containers/Internal/BitUtil.hs @@ -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 #-} diff --git a/Utils/Containers/Internal/State.hs b/Utils/Containers/Internal/State.hs new file mode 100644 --- /dev/null +++ b/Utils/Containers/Internal/State.hs @@ -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) diff --git a/benchmarks/IntMap.hs b/benchmarks/IntMap.hs --- a/benchmarks/IntMap.hs +++ b/benchmarks/IntMap.hs @@ -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 diff --git a/benchmarks/IntSet.hs b/benchmarks/IntSet.hs --- a/benchmarks/IntSet.hs +++ b/benchmarks/IntSet.hs @@ -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] diff --git a/benchmarks/Map.hs b/benchmarks/Map.hs --- a/benchmarks/Map.hs +++ b/benchmarks/Map.hs @@ -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 diff --git a/benchmarks/Sequence.hs b/benchmarks/Sequence.hs --- a/benchmarks/Sequence.hs +++ b/benchmarks/Sequence.hs @@ -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 diff --git a/benchmarks/Set.hs b/benchmarks/Set.hs --- a/benchmarks/Set.hs +++ b/benchmarks/Set.hs @@ -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] diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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! diff --git a/containers.cabal b/containers.cabal --- a/containers.cabal +++ b/containers.cabal @@ -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 diff --git a/tests/IntMapValidity.hs b/tests/IntMapValidity.hs new file mode 100644 --- /dev/null +++ b/tests/IntMapValidity.hs @@ -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) diff --git a/tests/IntSetValidity.hs b/tests/IntSetValidity.hs new file mode 100644 --- /dev/null +++ b/tests/IntSetValidity.hs @@ -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 diff --git a/tests/intmap-properties.hs b/tests/intmap-properties.hs --- a/tests/intmap-properties.hs +++ b/tests/intmap-properties.hs @@ -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) diff --git a/tests/intmap-strictness.hs b/tests/intmap-strictness.hs --- a/tests/intmap-strictness.hs +++ b/tests/intmap-strictness.hs @@ -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 diff --git a/tests/intset-properties.hs b/tests/intset-properties.hs --- a/tests/intset-properties.hs +++ b/tests/intset-properties.hs @@ -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 s2) && i `delete` s == union s1 s2 + (s1,s2) -> valid s1 .&&. + valid s2 .&&. + 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 s2) && t == i `member` s && i `delete` s == union s1 s2 + (s1,t,s2) -> valid s1 .&&. + valid s2 .&&. + 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 + diff --git a/tests/seq-properties.hs b/tests/seq-properties.hs --- a/tests/seq-properties.hs +++ b/tests/seq-properties.hs @@ -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 diff --git a/tests/set-properties.hs b/tests/set-properties.hs --- a/tests/set-properties.hs +++ b/tests/set-properties.hs @@ -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 diff --git a/tests/tree-properties.hs b/tests/tree-properties.hs new file mode 100644 --- /dev/null +++ b/tests/tree-properties.hs @@ -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