containers 0.5.10.1 → 0.5.10.2
raw patch · 18 files changed
+629/−279 lines, 18 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Data.IntMap.Internal.Debug: showTree :: Show a => IntMap a -> String
+ Data.IntMap.Internal.Debug: showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String
+ Data.Sequence.Internal: liftA2Seq :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
Files
- Data/Graph.hs +2/−2
- Data/IntMap/Internal.hs +167/−71
- Data/IntMap/Internal/Debug.hs +6/−0
- Data/IntMap/Internal/DeprecatedDebug.hs +20/−0
- Data/IntMap/Lazy.hs +2/−1
- Data/IntMap/Strict.hs +114/−54
- Data/IntSet/Internal.hs +5/−3
- Data/Map/Internal.hs +61/−33
- Data/Map/Strict/Internal.hs +14/−10
- Data/Sequence/Internal.hs +113/−70
- Data/Set/Internal.hs +25/−18
- Data/Tree.hs +16/−2
- changelog.md +41/−3
- containers.cabal +3/−1
- tests/Makefile +2/−2
- tests/intmap-properties.hs +17/−6
- tests/intset-properties.hs +4/−2
- tests/seq-properties.hs +17/−1
Data/Graph.hs view
@@ -80,8 +80,8 @@ import Data.Tree (Tree(Node), Forest) -- std interfaces-#if !MIN_VERSION_base(4,8,0) import Control.Applicative+#if !MIN_VERSION_base(4,8,0) import qualified Data.Foldable as F import Data.Traversable #else@@ -157,7 +157,7 @@ traverse f (AcyclicSCC vertex) = AcyclicSCC <$> f vertex traverse _f (CyclicSCC []) = pure (CyclicSCC []) traverse f (CyclicSCC (x : xs)) =- (\x' xs' -> CyclicSCC (x' : xs')) <$> f x <*> traverse f xs+ liftA2 (\x' xs' -> CyclicSCC (x' : xs')) (f x) (traverse f xs) instance NFData a => NFData (SCC a) where rnf (AcyclicSCC v) = rnf v
Data/IntMap/Internal.hs view
@@ -281,8 +281,9 @@ #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity (..))+import Control.Applicative (liftA2) #else-import Control.Applicative (Applicative(pure, (<*>)), (<$>))+import Control.Applicative (Applicative(pure, (<*>)), (<$>), liftA2) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse)) import Data.Word (Word)@@ -353,6 +354,16 @@ type Prefix = Int type Mask = Int ++-- Some stuff from "Data.IntSet.Internal", for 'restrictKeys' and+-- 'withoutKeys' to use.+type IntSetPrefix = Int+type IntSetBitMap = Word++bitmapOf :: Int -> IntSetBitMap+bitmapOf x = shiftLL 1 (x .&. IntSet.suffixBitMask)+{-# INLINE bitmapOf #-}+ {-------------------------------------------------------------------- Operators --------------------------------------------------------------------}@@ -501,9 +512,11 @@ -- > size (singleton 1 'a') == 1 -- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3 size :: IntMap a -> Int-size (Bin _ _ l r) = size l + size r-size (Tip _ _) = 1-size Nil = 0+size = go 0+ where+ go !acc (Bin _ _ l r) = go (go acc l) r+ go acc (Tip _ _) = 1 + acc+ go acc Nil = acc -- | /O(min(n,W))/. Is the key a member of the map? --@@ -1035,7 +1048,9 @@ differenceWithKey f m1 m2 = mergeWithKey f id (const Nil) m1 m2 --- | Remove all the keys in a given set from a map.++-- TODO(wrengr): re-verify that asymptotic bound+-- | /O(n+m)/. Remove all the keys in a given set from a map. -- -- @ -- m `withoutKeys` s = 'filterWithKey' (\k _ -> k `'IntSet.notMember'` s) m@@ -1043,32 +1058,63 @@ -- -- @since 0.5.8 withoutKeys :: IntMap a -> IntSet.IntSet -> IntMap a-withoutKeys = go- where- go t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)- | shorter m1 m2 = merge1- | shorter m2 m1 = merge2- | p1 == p2 = bin p1 m1 (go l1 l2) (go r1 r2)- | otherwise = t1- where- merge1 | nomatch p2 p1 m1 = t1- | zero p2 m1 = binCheckLeft p1 m1 (go l1 t2) r1- | otherwise = binCheckRight p1 m1 l1 (go r1 t2)- merge2 | nomatch p1 p2 m2 = t1- | zero p1 m2 = bin p2 m2 (go t1 l2) Nil- | otherwise = bin p2 m2 Nil (go t1 r2)+withoutKeys t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)+ | shorter m1 m2 = difference1+ | shorter m2 m1 = difference2+ | p1 == p2 = bin p1 m1 (withoutKeys l1 l2) (withoutKeys r1 r2)+ | otherwise = t1+ where+ difference1+ | nomatch p2 p1 m1 = t1+ | zero p2 m1 = binCheckLeft p1 m1 (withoutKeys l1 t2) r1+ | otherwise = binCheckRight p1 m1 l1 (withoutKeys r1 t2)+ difference2+ | nomatch p1 p2 m2 = t1+ | zero p1 m2 = withoutKeys t1 l2+ | otherwise = withoutKeys t1 r2+withoutKeys t1@(Bin p1 m1 _ _) (IntSet.Tip p2 bm2) =+ let minbit = bitmapOf p1+ lt_minbit = minbit - 1+ maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))+ gt_maxbit = maxbit `xor` complement (maxbit - 1)+ -- TODO(wrengr): should we manually inline/unroll 'updatePrefix'+ -- and 'withoutBM' here, in order to avoid redundant case analyses?+ in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)+withoutKeys t1@(Bin _ _ _ _) IntSet.Nil = t1+withoutKeys t1@(Tip k1 _) t2+ | k1 `IntSet.member` t2 = Nil+ | otherwise = t1+withoutKeys Nil _ = Nil - go t1'@(Bin _ _ _ _) t2'@(IntSet.Tip _ _) =- filterWithKey (\k _ -> k `IntSet.notMember` t2') t1' - go t1@(Bin _ _ _ _) IntSet.Nil = t1+updatePrefix+ :: IntSetPrefix -> IntMap a -> (IntMap a -> IntMap a) -> IntMap a+updatePrefix !kp t@(Bin p m l r) f+ | m .&. IntSet.suffixBitMask /= 0 =+ if p .&. IntSet.prefixBitMask == kp then f t else t+ | nomatch kp p m = t+ | zero kp m = binCheckLeft p m (updatePrefix kp l f) r+ | otherwise = binCheckRight p m l (updatePrefix kp r f)+updatePrefix kp t@(Tip kx _) f+ | kx .&. IntSet.prefixBitMask == kp = f t+ | otherwise = t+updatePrefix _ Nil _ = Nil - go t1'@(Tip k1' _) t2'- | k1' `IntSet.member` t2' = Nil- | otherwise = t1'- go Nil _ = Nil +withoutBM :: IntSetBitMap -> IntMap a -> IntMap a+withoutBM 0 t = t+withoutBM bm (Bin p m l r) =+ let leftBits = bitmapOf (p .|. m) - 1+ bmL = bm .&. leftBits+ bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+ in bin p m (withoutBM bmL l) (withoutBM bmR r)+withoutBM bm t@(Tip k _)+ -- TODO(wrengr): need we manually inline 'IntSet.Member' here?+ | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = Nil+ | otherwise = t+withoutBM _ Nil = Nil + {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------}@@ -1080,6 +1126,8 @@ intersection m1 m2 = mergeWithKey' bin const (const Nil) (const Nil) m1 m2 ++-- TODO(wrengr): re-verify that asymptotic bound -- | /O(n+m)/. The restriction of a map to the keys in a set. -- -- @@@ -1088,30 +1136,64 @@ -- -- @since 0.5.8 restrictKeys :: IntMap a -> IntSet.IntSet -> IntMap a-restrictKeys = go- where- go t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)- | shorter m1 m2 = merge1- | shorter m2 m1 = merge2- | p1 == p2 = bin p1 m1 (go l1 l2) (go r1 r2)- | otherwise = Nil- where- merge1 | nomatch p2 p1 m1 = Nil- | zero p2 m1 = bin p1 m1 (go l1 t2) Nil- | otherwise = bin p1 m1 Nil (go r1 t2)- merge2 | nomatch p1 p2 m2 = Nil- | zero p1 m2 = bin p2 m2 (go t1 l2) Nil- | otherwise = bin p2 m2 Nil (go t1 r2)+restrictKeys t1@(Bin p1 m1 l1 r1) t2@(IntSet.Bin p2 m2 l2 r2)+ | shorter m1 m2 = intersection1+ | shorter m2 m1 = intersection2+ | p1 == p2 = bin p1 m1 (restrictKeys l1 l2) (restrictKeys r1 r2)+ | otherwise = Nil+ where+ intersection1+ | nomatch p2 p1 m1 = Nil+ | zero p2 m1 = restrictKeys l1 t2+ | otherwise = restrictKeys r1 t2+ intersection2+ | nomatch p1 p2 m2 = Nil+ | zero p1 m2 = restrictKeys t1 l2+ | otherwise = restrictKeys t1 r2+restrictKeys t1@(Bin p1 m1 _ _) (IntSet.Tip p2 bm2) =+ let minbit = bitmapOf p1+ ge_minbit = complement (minbit - 1)+ maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))+ le_maxbit = maxbit .|. (maxbit - 1)+ -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'+ -- and 'restrictBM' here, in order to avoid redundant case analyses?+ in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)+restrictKeys (Bin _ _ _ _) IntSet.Nil = Nil+restrictKeys t1@(Tip k1 _) t2+ | k1 `IntSet.member` t2 = t1+ | otherwise = Nil+restrictKeys Nil _ = Nil - go t1'@(Bin _ _ _ _) t2'@(IntSet.Tip _ _) =- filterWithKey (\k _ -> k `IntSet.member` t2') t1'- go (Bin _ _ _ _) IntSet.Nil = Nil - go t1'@(Tip k1' _) t2'- | k1' `IntSet.member` t2' = t1'- | otherwise = Nil- go Nil _ = Nil+-- | /O(min(n,W))/. Restrict to the sub-map with all keys matching+-- a key prefix.+lookupPrefix :: IntSetPrefix -> IntMap a -> IntMap a+lookupPrefix !kp t@(Bin p m l r)+ | m .&. IntSet.suffixBitMask /= 0 =+ if p .&. IntSet.prefixBitMask == kp then t else Nil+ | nomatch kp p m = Nil+ | zero kp m = lookupPrefix kp l+ | otherwise = lookupPrefix kp r+lookupPrefix kp t@(Tip kx _)+ | (kx .&. IntSet.prefixBitMask) == kp = t+ | otherwise = Nil+lookupPrefix _ Nil = Nil ++restrictBM :: IntSetBitMap -> IntMap a -> IntMap a+restrictBM 0 _ = Nil+restrictBM bm (Bin p m l r) =+ let leftBits = bitmapOf (p .|. m) - 1+ bmL = bm .&. leftBits+ bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+ in bin p m (restrictBM bmL l) (restrictBM bmR r)+restrictBM bm t@(Tip k _)+ -- TODO(wrengr): need we manually inline 'IntSet.Member' here?+ | k `IntSet.member` IntSet.Tip (k .&. IntSet.prefixBitMask) bm = t+ | otherwise = Nil+restrictBM _ Nil = Nil++ -- | /O(n+m)/. The intersection with a combining function. -- -- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"@@ -1618,7 +1700,7 @@ filterWithKeyA _ Nil = pure Nil filterWithKeyA f t@(Tip k x) = (\b -> if b then t else Nil) <$> f k x filterWithKeyA f (Bin p m l r) =- bin p m <$> filterWithKeyA f l <*> filterWithKeyA f r+ liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r) -- | This wasn't in Data.Bool until 4.7.0, so we define it here bool :: a -> a -> Bool -> a@@ -1655,7 +1737,7 @@ where go Nil = pure Nil go (Tip k x) = maybe Nil (Tip k) <$> f k x- go (Bin p m l r) = bin p m <$> go l <*> go r+ go (Bin p m l r) = liftA2 (bin p m) (go l) (go r) -- | Merge two maps.@@ -1827,8 +1909,8 @@ where merge2 t2@(Bin p2 m2 l2 r2) | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2)- | zero k1 m2 = bin p2 m2 <$> merge2 l2 <*> g2t r2- | otherwise = bin p2 m2 <$> g2t l2 <*> merge2 r2+ | zero k1 m2 = liftA2 (bin p2 m2) (merge2 l2) (g2t r2)+ | otherwise = liftA2 (bin p2 m2) (g2t l2) (merge2 r2) merge2 (Tip k2 x2) = mergeTips k1 x1 k2 x2 merge2 Nil = subsingletonBy g1k k1 x1 @@ -1836,34 +1918,34 @@ where merge1 t1@(Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2)- | zero k2 m1 = bin p1 m1 <$> merge1 l1 <*> g1t r1- | otherwise = bin p1 m1 <$> g1t l1 <*> merge1 r1+ | zero k2 m1 = liftA2 (bin p1 m1) (merge1 l1) (g1t r1)+ | otherwise = liftA2 (bin p1 m1) (g1t l1) (merge1 r1) merge1 (Tip k1 x1) = mergeTips k1 x1 k2 x2 merge1 Nil = subsingletonBy g2k k2 x2 go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2) | shorter m1 m2 = merge1 | shorter m2 m1 = merge2- | p1 == p2 = bin p1 m1 <$> go l1 l2 <*> go r1 r2- | otherwise = link_ p1 p2 <$> g1t t1 <*> g2t t2+ | p1 == p2 = liftA2 (bin p1 m1) (go l1 l2) (go r1 r2)+ | otherwise = liftA2 (link_ p1 p2) (g1t t1) (g2t t2) where- merge1 | nomatch p2 p1 m1 = link_ p1 p2 <$> g1t t1 <*> g2t t2- | zero p2 m1 = bin p1 m1 <$> go l1 t2 <*> g1t r1- | otherwise = bin p1 m1 <$> g1t l1 <*> go r1 t2- merge2 | nomatch p1 p2 m2 = link_ p1 p2 <$> g1t t1 <*> g2t t2- | zero p1 m2 = bin p2 m2 <$> go t1 l2 <*> g2t r2- | otherwise = bin p2 m2 <$> g2t l2 <*> go t1 r2+ merge1 | nomatch p2 p1 m1 = liftA2 (link_ p1 p2) (g1t t1) (g2t t2)+ | zero p2 m1 = liftA2 (bin p1 m1) (go l1 t2) (g1t r1)+ | otherwise = liftA2 (bin p1 m1) (g1t l1) (go r1 t2)+ merge2 | nomatch p1 p2 m2 = liftA2 (link_ p1 p2) (g1t t1) (g2t t2)+ | zero p1 m2 = liftA2 (bin p2 m2) (go t1 l2) (g2t r2)+ | otherwise = liftA2 (bin p2 m2) (g2t l2) (go t1 r2) subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x {-# INLINE subsingletonBy #-} mergeTips k1 x1 k2 x2 | k1 == k2 = maybe Nil (Tip k1) <$> f k1 x1 x2- | k1 < k2 = subdoubleton k1 k2 <$> g1k k1 x1 <*> g2k k2 x2+ | k1 < k2 = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2) {- = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2 -}- | otherwise = subdoubleton k2 k1 <$> g2k k2 x2 <*> g1k k1 x1+ | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1) {-# INLINE mergeTips #-} subdoubleton _ _ Nothing Nothing = Nil@@ -1885,8 +1967,8 @@ -> Prefix -> f (IntMap a) -> f (IntMap a) linkA p1 t1 p2 t2- | zero p1 m = bin p m <$> t1 <*> t2- | otherwise = bin p m <$> t2 <*> t1+ | zero p1 m = liftA2 (bin p m) t1 t2+ | otherwise = liftA2 (bin p m) t2 t1 where m = branchMask p1 p2 p = mask p1 m@@ -2203,7 +2285,7 @@ where go Nil = pure Nil go (Tip k v) = Tip k <$> f k v- go (Bin p m l r) = Bin p m <$> go l <*> go r+ go (Bin p m l r) = liftA2 (Bin p m) (go l) (go r) {-# INLINE traverseWithKey #-} -- | /O(n)/. The function @'mapAccum'@ threads an accumulating@@ -3066,20 +3148,31 @@ {-------------------------------------------------------------------- Endian independent bit twiddling --------------------------------------------------------------------}++-- | Should this key follow the left subtree of a 'Bin' with switching+-- bit @m@? N.B., the answer is only valid when @match i p m@ is true. zero :: Key -> Mask -> Bool zero i m = (natFromInt i) .&. (natFromInt m) == 0 {-# INLINE zero #-} nomatch,match :: Key -> Prefix -> Mask -> Bool++-- | Does the key @i@ differ from the prefix @p@ before getting to+-- the switching bit @m@? nomatch i p m = (mask i m) /= p {-# INLINE nomatch #-} +-- | Does the key @i@ match the prefix @p@ (up to but not including+-- bit @m@)? match i p m = (mask i m) == p {-# INLINE match #-} ++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@. mask :: Key -> Mask -> Prefix mask i m = maskW (natFromInt i) (natFromInt m)@@ -3089,16 +3182,21 @@ {-------------------------------------------------------------------- Big endian operations --------------------------------------------------------------------}++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@. maskW :: Nat -> Nat -> Prefix maskW i m = intFromNat (i .&. (complement (m-1) `xor` m)) {-# INLINE maskW #-} +-- | Does the left switching bit specify a shorter prefix? shorter :: Mask -> Mask -> Bool shorter m1 m2 = (natFromInt m1) > (natFromInt m2) {-# INLINE shorter #-} +-- | The first switching bit where the two prefixes disagree. branchMask :: Prefix -> Prefix -> Mask branchMask p1 p2 = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))@@ -3108,8 +3206,9 @@ Utilities --------------------------------------------------------------------} --- | /O(1)/. Decompose a map into pieces based on the structure of the underlying--- tree. This function is useful for consuming a map in parallel.+-- | /O(1)/. Decompose a map into pieces based on the structure+-- of the underlying tree. This function is useful for consuming a+-- map in parallel. -- -- No guarantee is made as to the sizes of the pieces; an internal, but -- deterministic process determines this. However, it is guaranteed that the@@ -3139,9 +3238,6 @@ {-------------------------------------------------------------------- Debugging --------------------------------------------------------------------}-{-# DEPRECATED showTree, showTreeWith- "These debugging functions will be moved to a separate module in future versions"- #-} -- | /O(n)/. Show the tree that implements the map. The tree is shown -- in a compressed, hanging format.
+ Data/IntMap/Internal/Debug.hs view
@@ -0,0 +1,6 @@+module Data.IntMap.Internal.Debug+ ( showTree+ , showTreeWith+ ) where++import Data.IntMap.Internal
+ Data/IntMap/Internal/DeprecatedDebug.hs view
@@ -0,0 +1,20 @@+module Data.IntMap.Internal.DeprecatedDebug where+import qualified Data.IntMap.Internal as IM+import Data.IntMap.Internal (IntMap)++{-# DEPRECATED showTree, showTreeWith+ "These debugging functions will be removed from this module. They are available from Data.IntMap.Internal.Debug."+ #-}++-- | /O(n)/. Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => IntMap a -> String+showTree = IM.showTree++{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the map. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String+showTreeWith = IM.showTreeWith
Data/IntMap/Lazy.hs view
@@ -207,7 +207,8 @@ , showTreeWith ) where -import Data.IntMap.Internal as IM+import Data.IntMap.Internal as IM hiding (showTree, showTreeWith)+import Data.IntMap.Internal.DeprecatedDebug -- $strictness --
Data/IntMap/Strict.hs view
@@ -217,62 +217,93 @@ import Prelude hiding (lookup,map,filter,foldr,foldl,null) import Data.Bits-import Data.IntMap.Internal hiding- ( findWithDefault- , singleton- , insert- , insertWith- , insertWithKey- , insertLookupWithKey- , adjust- , adjustWithKey- , update- , updateWithKey- , updateLookupWithKey- , alter- , alterF- , unionsWith- , unionWith- , unionWithKey- , differenceWith- , differenceWithKey- , intersectionWith- , intersectionWithKey- , mergeWithKey- , updateMinWithKey- , updateMaxWithKey- , updateMax- , updateMin- , map- , mapWithKey- , mapAccum- , mapAccumWithKey- , mapAccumRWithKey- , mapKeysWith- , mapMaybe- , mapMaybeWithKey- , mapEither- , mapEitherWithKey- , fromSet- , fromList- , fromListWith- , fromListWithKey- , fromAscList- , fromAscListWith- , fromAscListWithKey- , fromDistinctAscList- )+import qualified Data.IntMap.Internal as L+import Data.IntMap.Internal+ ( IntMap (..)+ , Key+ , Prefix+ , Mask+ , mask+ , branchMask+ , shorter+ , nomatch+ , zero+ , natFromInt+ , intFromNat+ , bin+ , binCheckLeft+ , binCheckRight+ , link + , (\\)+ , (!)+ , empty+ , assocs+ , filter+ , filterWithKey+ , findMin+ , findMax+ , foldMapWithKey+ , foldr+ , foldl+ , foldr'+ , foldl'+ , foldlWithKey+ , foldrWithKey+ , foldlWithKey'+ , foldrWithKey'+ , keysSet+ , mergeWithKey'+ , delete+ , deleteMin+ , deleteMax+ , deleteFindMax+ , deleteFindMin+ , difference+ , elems+ , intersection+ , isProperSubmapOf+ , isProperSubmapOfBy+ , isSubmapOf+ , isSubmapOfBy+ , lookup+ , lookupLE+ , lookupGE+ , lookupLT+ , lookupGT+ , minView+ , maxView+ , minViewWithKey+ , maxViewWithKey+ , keys+ , mapKeys+ , mapKeysMonotonic+ , member+ , notMember+ , null+ , partition+ , partitionWithKey+ , restrictKeys+ , size+ , split+ , splitLookup+ , splitRoot+ , toAscList+ , toDescList+ , toList+ , union+ , unions+ , withoutKeys+ )+import Data.IntMap.Internal.DeprecatedDebug (showTree, showTreeWith) import qualified Data.IntSet.Internal as IntSet import Utils.Containers.Internal.BitUtil import Utils.Containers.Internal.StrictFold import Utils.Containers.Internal.StrictPair-#if __GLASGOW_HASKELL__ >= 709-import Data.Coerce-#endif #if !MIN_VERSION_base(4,8,0) import Data.Functor((<$>)) #endif+import Control.Applicative (Applicative (..), liftA2) -- $strictness --@@ -777,12 +808,8 @@ #ifdef __GLASGOW_HASKELL__ {-# NOINLINE [1] map #-} {-# RULES-"map/map" forall f g xs . map f (map g xs) = map (f . g) xs- #-}-#endif-#if __GLASGOW_HASKELL__ >= 709-{-# RULES-"map/coerce" map coerce = coerce+"map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs+"map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs #-} #endif @@ -799,16 +826,49 @@ Nil -> Nil #ifdef __GLASGOW_HASKELL__+-- Pay close attention to strictness here. We need to force the+-- intermediate result for map f . map g, and we need to refrain+-- from forcing it for map f . L.map g, etc.+--+-- TODO Consider moving map and mapWithKey to IntMap.Internal so we can write+-- non-orphan RULES for things like L.map f (map g xs). We'd need a new function+-- for this, and we'd have to pay attention to simplifier phases. Something like+--+-- lsmap :: (b -> c) -> (a -> b) -> IntMap a -> IntMap c+-- lsmap _ _ Nil = Nil+-- lsmap f g (Tip k x) = let !gx = g x in Tip k (f gx)+-- lsmap f g (Bin p m l r) = Bin p m (lsmap f g l) (lsmap f g r) {-# NOINLINE [1] mapWithKey #-} {-# RULES "mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+ mapWithKey (\k a -> f k $! g k a) xs+"mapWithKey/mapWithKeyL" forall f g xs . mapWithKey f (L.mapWithKey g xs) = mapWithKey (\k a -> f k (g k a)) xs "mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+ mapWithKey (\k a -> f k $! g a) xs+"mapWithKey/mapL" forall f g xs . mapWithKey f (L.map g xs) = mapWithKey (\k a -> f k (g a)) xs "map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+ mapWithKey (\k a -> f $! g k a) xs+"map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) = mapWithKey (\k a -> f (g k a)) xs #-} #endif++-- | /O(n)/.+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')]) == Nothing+traverseWithKey :: Applicative t => (Key -> a -> t b) -> IntMap a -> t (IntMap b)+traverseWithKey f = go+ where+ go Nil = pure Nil+ go (Tip k v) = (\ !v' -> Tip k v') <$> f k v+ go (Bin p m l r) = liftA2 (Bin p m) (go l) (go r)+{-# INLINE traverseWithKey #-} -- | /O(n)/. The function @'mapAccum'@ threads an accumulating -- argument through the map in ascending order of keys.
Data/IntSet/Internal.hs view
@@ -311,9 +311,11 @@ -- | /O(n)/. Cardinality of the set. size :: IntSet -> Int-size (Bin _ _ l r) = size l + size r-size (Tip _ bm) = bitcount 0 bm-size Nil = 0+size = go 0+ where+ go !acc (Bin _ _ l r) = go (go acc l) r+ go acc (Tip _ bm) = acc + bitcount 0 bm+ go acc Nil = acc -- | /O(min(n,W))/. Is the value a member of the set?
Data/Map/Internal.hs view
@@ -359,8 +359,9 @@ #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity (..))+import Control.Applicative (liftA3) #else-import Control.Applicative (Applicative(..), (<$>))+import Control.Applicative (Applicative(..), (<$>), liftA3) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse)) #endif@@ -387,7 +388,7 @@ #endif #if __GLASGOW_HASKELL__-import GHC.Exts (build)+import GHC.Exts (build, lazy) #if !MIN_VERSION_base(4,8,0) import Data.Functor ((<$)) #endif@@ -754,49 +755,69 @@ -- > insert 5 'x' empty == singleton 5 'x' -- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper insert :: Ord k => k -> a -> Map k a -> Map k a-insert = go+insert kx0 = go kx0 kx0 where -- Unlike insertR, we only get sharing here -- when the inserted value is at the same address- -- as the present value. We try anyway. If we decide- -- not to, then Data.Map.Strict should probably- -- get its own union implementation.- go :: Ord k => k -> a -> Map k a -> Map k a- go !kx x Tip = singleton kx x- go !kx x t@(Bin sz ky y l r) =+ -- as the present value. We try anyway; this condition+ -- seems particularly likely to occur in 'union'.+ go :: Ord k => k -> k -> a -> Map k a -> Map k a+ go orig !_ x Tip = singleton (lazy orig) x+ go orig !kx x t@(Bin sz ky y l r) = case compare kx ky of LT | l' `ptrEq` l -> t | otherwise -> balanceL ky y l' r- where !l' = go kx x l+ where !l' = go orig kx x l GT | r' `ptrEq` r -> t | otherwise -> balanceR ky y l r'- where !r' = go kx x r- EQ | kx `ptrEq` ky && x `ptrEq` y -> t- | otherwise -> Bin sz kx x l r+ where !r' = go orig kx x r+ EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t+ | otherwise -> Bin sz (lazy orig) x l r #if __GLASGOW_HASKELL__ {-# INLINABLE insert #-} #else {-# INLINE insert #-} #endif +#ifndef __GLASGOW_HASKELL__+lazy :: a -> a+lazy a = a+#endif++-- [Note: Avoiding worker/wrapper]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- 'insert' has to go to great lengths to get pointer equality right and+-- to prevent unnecessary allocation. The trouble is that GHC *really* wants+-- to unbox the key and throw away the boxed one. This is bad for us, because+-- we want to compare the pointer of the box we are given to the one already+-- present if they compare EQ. It's also bad for us because it leads to the+-- key being *reboxed* if it's actually stored in the map. Ugh! So we pass the+-- 'go' function *two copies* of the key we're given. One of them we use for+-- comparisons; the other we keep in our pocket. To prevent worker/wrapper from+-- messing with the copy in our pocket, we sprinkle about calls to the magical+-- function 'lazy'. This is all horrible, but it seems to work okay.++ -- Insert a new key and value in the map if it is not already present. -- Used by `union`. -- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper insertR :: Ord k => k -> a -> Map k a -> Map k a-insertR = go+insertR kx0 = go kx0 kx0 where- go :: Ord k => k -> a -> Map k a -> Map k a- go !kx x Tip = singleton kx x- go kx x t@(Bin _ ky y l r) =+ go :: Ord k => k -> k -> a -> Map k a -> Map k a+ go orig !_ x Tip = singleton (lazy orig) x+ go orig !kx x t@(Bin _ ky y l r) = case compare kx ky of LT | l' `ptrEq` l -> t | otherwise -> balanceL ky y l' r- where !l' = go kx x l+ where !l' = go orig kx x l GT | r' `ptrEq` r -> t | otherwise -> balanceR ky y l r'- where !r' = go kx x r+ where !r' = go orig kx x r EQ -> t #if __GLASGOW_HASKELL__ {-# INLINABLE insertR #-}@@ -1831,6 +1852,12 @@ Difference --------------------------------------------------------------------} +-- We don't currently attempt to use any pointer equality tricks for+-- 'difference'. To do so, we'd have to match on the first argument+-- and split the second. Unfortunately, the proof of the time bound+-- relies on doing it the way we do, and it's not clear whether that+-- bound holds the other way.+ -- | /O(m*log(n\/m + 1)), m <= n/. Difference of two maps. -- Return elements of the first map not existing in the second map. --@@ -1850,7 +1877,7 @@ {-# INLINABLE difference #-} #endif --- | /O(m*log(n/m + 1)), m <= n/. Remove all keys in a 'Set' from a 'Map'.+-- | /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@@ -1930,7 +1957,7 @@ {-# INLINABLE intersection #-} #endif --- | /O(m*log(n/m + 1)), m <= n/. Restrict a 'Map' to only those keys+-- | /O(m*log(n\/m + 1)), m <= n/. Restrict a 'Map' to only those keys -- found in a 'Set'. -- -- @@@ -2514,10 +2541,10 @@ go Tip t2 = g2t t2 go (Bin _ kx x1 l1 r1) t2 = case splitLookup kx t2 of (l2, mx2, r2) -> case mx2 of- Nothing -> (\l' mx' r' -> maybe link2 (link kx) mx' l' r')- <$> l1l2 <*> g1k kx x1 <*> r1r2- Just x2 -> (\l' mx' r' -> maybe link2 (link kx) mx' l' r')- <$> l1l2 <*> f kx x1 x2 <*> r1r2+ Nothing -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')+ l1l2 (g1k kx x1) r1r2+ Just x2 -> liftA3 (\l' mx' r' -> maybe link2 (link kx) mx' l' r')+ l1l2 (f kx x1 x2) r1r2 where !l1l2 = go l1 l2 !r1r2 = go r1 r2@@ -2588,7 +2615,7 @@ {-------------------------------------------------------------------- Submap --------------------------------------------------------------------}--- | /O(m*log(n/m + 1)), m <= n/.+-- | /O(m*log(n\/m + 1)), m <= n/. -- This function is defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@). -- isSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool@@ -2597,7 +2624,7 @@ {-# INLINABLE isSubmapOf #-} #endif -{- | /O(m*log(n/m + 1)), m <= n/.+{- | /O(m*log(n\/m + 1)), m <= n/. The expression (@'isSubmapOfBy' f t1 t2@) returns 'True' if all keys in @t1@ are in tree @t2@, and when @f@ returns 'True' when applied to their respective values. For example, the following@@ -2635,7 +2662,7 @@ {-# INLINABLE submap' #-} #endif --- | /O(m*log(n/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).+-- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal). -- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@). isProperSubmapOf :: (Ord k,Eq a) => Map k a -> Map k a -> Bool isProperSubmapOf m1 m2@@ -2644,7 +2671,7 @@ {-# INLINABLE isProperSubmapOf #-} #endif -{- | /O(m*log(n/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal).+{- | /O(m*log(n\/m + 1)), m <= n/. Is this a proper submap? (ie. a submap but not equal). The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when @m1@ and @m2@ are not equal, all keys in @m1@ are in @m2@, and when @f@ returns 'True' when@@ -2701,7 +2728,7 @@ filterWithKeyA :: Applicative f => (k -> a -> f Bool) -> Map k a -> f (Map k a) filterWithKeyA _ Tip = pure Tip filterWithKeyA p t@(Bin _ kx x l r) =- combine <$> p kx x <*> filterWithKeyA p l <*> filterWithKeyA p r+ liftA3 combine (p kx x) (filterWithKeyA p l) (filterWithKeyA p r) where combine True pl pr | pl `ptrEq` l && pr `ptrEq` r = t@@ -2816,14 +2843,15 @@ Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r) -- | /O(n)/. Traverse keys\/values and collect the 'Just' results.-+--+-- @since 0.5.8 traverseMaybeWithKey :: Applicative f => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b) traverseMaybeWithKey = go where go _ Tip = pure Tip go f (Bin _ kx x Tip Tip) = maybe Tip (\x' -> Bin 1 kx x' Tip Tip) <$> f kx x- go f (Bin _ kx x l r) = combine <$> go f l <*> f kx x <*> go f r+ go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r) where combine !l' mx !r' = case mx of Nothing -> link2 l' r'@@ -2923,7 +2951,7 @@ where go Tip = pure Tip go (Bin 1 k v _ _) = (\v' -> Bin 1 k v' Tip Tip) <$> f k v- go (Bin s k v l r) = flip (Bin s k) <$> go l <*> f k v <*> go r+ go (Bin s k v l r) = liftA3 (flip (Bin s k)) (go l) (f k v) (go r) {-# INLINE traverseWithKey #-} -- | /O(n)/. The function 'mapAccum' threads an accumulating
Data/Map/Strict/Internal.hs view
@@ -398,11 +398,12 @@ import Data.Map.Internal.DeprecatedShowTree (showTree, showTreeWith) import Data.Map.Internal.Debug (valid) -import Control.Applicative (Const (..))+import Control.Applicative (Const (..), liftA3) #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative (..), (<$>)) #endif import qualified Data.Set.Internal as Set+import qualified Data.Map.Internal as L import Utils.Containers.Internal.StrictFold import Utils.Containers.Internal.StrictPair @@ -1270,6 +1271,8 @@ Nothing -> link2 (mapMaybeWithKey f l) (mapMaybeWithKey f r) -- | /O(n)/. Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.5.8 traverseMaybeWithKey :: Applicative f => (k -> a -> f (Maybe b)) -> Map k a -> f (Map k b)@@ -1277,7 +1280,7 @@ where go _ Tip = pure Tip go f (Bin _ kx x Tip Tip) = maybe Tip (\ !x' -> Bin 1 kx x' Tip Tip) <$> f kx x- go f (Bin _ kx x l r) = combine <$> go f l <*> f kx x <*> go f r+ go f (Bin _ kx x l r) = liftA3 combine (go f l) (f kx x) (go f r) where combine !l' mx !r' = case mx of Nothing -> link2 l' r'@@ -1334,13 +1337,8 @@ #ifdef __GLASGOW_HASKELL__ {-# NOINLINE [1] map #-} {-# RULES-"map/map" forall f g xs . map f (map g xs) = map (f . g) xs- #-}-#endif-#if __GLASGOW_HASKELL__ >= 709--- Safe coercions were introduced in 7.8, but did not work well with RULES yet.-{-# RULES-"mapSeq/coerce" map coerce = coerce+"map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs+"map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs #-} #endif @@ -1359,10 +1357,16 @@ {-# NOINLINE [1] mapWithKey #-} {-# RULES "mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+ mapWithKey (\k a -> f k $! g k a) xs+"mapWithKey/mapWithKeyL" forall f g xs . mapWithKey f (L.mapWithKey g xs) = mapWithKey (\k a -> f k (g k a)) xs "mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+ mapWithKey (\k a -> f k $! g a) xs+"mapWithKey/mapL" forall f g xs . mapWithKey f (L.map g xs) = mapWithKey (\k a -> f k (g a)) xs "map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+ mapWithKey (\k a -> f $! g k a) xs+"map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) = mapWithKey (\k a -> f (g k a)) xs #-} #endif@@ -1380,7 +1384,7 @@ where go Tip = pure Tip go (Bin 1 k v _ _) = (\ !v' -> Bin 1 k v' Tip Tip) <$> f k v- go (Bin s k v l r) = (\ l' !v' r' -> Bin s k v' l' r') <$> go l <*> f k v <*> go r+ go (Bin s k v l r) = liftA3 (\ l' !v' r' -> Bin s k v' l' r') (go l) (f k v) (go r) {-# INLINE traverseWithKey #-} -- | /O(n)/. The function 'mapAccum' threads an accumulating
Data/Sequence/Internal.hs view
@@ -174,6 +174,7 @@ traverseWithIndex, -- :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b) reverse, -- :: Seq a -> Seq a intersperse, -- :: a -> Seq a -> Seq a+ liftA2Seq, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c -- ** Zips zip, -- :: Seq a -> Seq b -> Seq (a, b) zipWith, -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c@@ -285,9 +286,10 @@ infixr 5 :<| infixl 5 :|> --- TODO: Once GHC implements some way to prevent non-exhaustive--- pattern match warnings for pattern synonyms, we should be--- sure to take advantage of that.+#if __GLASGOW_HASKELL__ >= 801+{-# COMPLETE (:<|), Empty #-}+{-# COMPLETE (:|>), Empty #-}+#endif -- | A pattern synonym matching an empty sequence. pattern Empty :: Seq a@@ -413,8 +415,8 @@ traverseFTE _f EmptyT = pure empty traverseFTE f (Single x) = Seq . Single . Elem <$> f x traverseFTE f (Deep s pr m sf) =- (\pr' m' sf' -> coerce $ Deep s pr' m' sf') <$>- traverse f pr <*> traverse (traverse f) m <*> traverse f sf+ liftA3 (\pr' m' sf' -> coerce $ Deep s pr' m' sf')+ (traverse f pr) (traverse (traverse f) m) (traverse f sf) #else instance Traversable Seq where traverse f (Seq xs) = Seq <$> traverse (traverse f) xs@@ -432,24 +434,43 @@ instance Applicative Seq where pure = singleton xs *> ys = cycleNTimes (length xs) ys+ (<*>) = apSeq+#if MIN_VERSION_base(4,10,0)+ liftA2 = liftA2Seq+#endif - fs <*> xs@(Seq xsFT) = case viewl fs of- EmptyL -> empty- firstf :< fs' -> case viewr fs' of- EmptyR -> fmap firstf xs- Seq fs''FT :> lastf -> case rigidify xsFT of- RigidEmpty -> empty- RigidOne (Elem x) -> fmap ($x) fs- RigidTwo (Elem x1) (Elem x2) ->- Seq $ ap2FT firstf fs''FT lastf (x1, x2)- RigidThree (Elem x1) (Elem x2) (Elem x3) ->- Seq $ ap3FT firstf fs''FT lastf (x1, x2, x3)- RigidFull r@(Rigid s pr _m sf) -> Seq $- Deep (s * length fs)- (fmap (fmap firstf) (nodeToDigit pr))- (aptyMiddle (fmap firstf) (fmap lastf) fmap fs''FT r)- (fmap (fmap lastf) (nodeToDigit sf))+apSeq :: Seq (a -> b) -> Seq a -> Seq b+apSeq fs xs@(Seq xsFT) = case viewl fs of+ EmptyL -> empty+ firstf :< fs' -> case viewr fs' of+ EmptyR -> fmap firstf xs+ Seq fs''FT :> lastf -> case rigidify xsFT of+ RigidEmpty -> empty+ RigidOne (Elem x) -> fmap ($x) fs+ RigidTwo (Elem x1) (Elem x2) ->+ Seq $ ap2FT firstf fs''FT lastf (x1, x2)+ RigidThree (Elem x1) (Elem x2) (Elem x3) ->+ Seq $ ap3FT firstf fs''FT lastf (x1, x2, x3)+ RigidFull r@(Rigid s pr _m sf) -> Seq $+ Deep (s * length fs)+ (fmap (fmap firstf) (nodeToDigit pr))+ (aptyMiddle (fmap firstf) (fmap lastf) fmap fs''FT r)+ (fmap (fmap lastf) (nodeToDigit sf))+{-# NOINLINE [1] apSeq #-} +{-# RULES+"ap/fmap1" forall f xs ys . apSeq (fmapSeq f xs) ys = liftA2Seq f xs ys+"ap/fmap2" forall f gs xs . apSeq gs (fmapSeq f xs) =+ liftA2Seq (\g x -> g (f x)) gs xs+"fmap/ap" forall f gs xs . fmapSeq f (gs `apSeq` xs) =+ liftA2Seq (\g x -> f (g x)) gs xs+"fmap/liftA2" forall f g m n . fmapSeq f (liftA2Seq g m n) =+ liftA2Seq (\x y -> f (g x y)) m n+"liftA2/fmap1" forall f g m n . liftA2Seq f (fmapSeq g m) n =+ liftA2Seq (\x y -> f (g x) y) m n+"liftA2/fmap2" forall f g m n . liftA2Seq f m (fmapSeq g n) =+ liftA2Seq (\x y -> f x (g y)) m n+ #-} ap2FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a) -> FingerTree (Elem b) ap2FT firstf fs lastf (x,y) =@@ -464,7 +485,47 @@ (mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) fs) (Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z)) +lift2FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b) -> FingerTree (Elem c)+lift2FT f firstx xs lastx (y1,y2) =+ Deep (size xs * 2 + 4)+ (Two (Elem $ f firstx y1) (Elem $ f firstx y2))+ (mapMulFT 2 (\(Elem x) -> Node2 2 (Elem (f x y1)) (Elem (f x y2))) xs)+ (Two (Elem $ f lastx y1) (Elem $ f lastx y2)) +lift3FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b,b) -> FingerTree (Elem c)+lift3FT f firstx xs lastx (y1,y2,y3) =+ Deep (size xs * 3 + 6)+ (Three (Elem $ f firstx y1) (Elem $ f firstx y2) (Elem $ f firstx y3))+ (mapMulFT 3 (\(Elem x) -> Node3 3 (Elem (f x y1)) (Elem (f x y2)) (Elem (f x y3))) xs)+ (Three (Elem $ f lastx y1) (Elem $ f lastx y2) (Elem $ f lastx y3))++liftA2Seq :: (a -> b -> c) -> Seq a -> Seq b -> Seq c+liftA2Seq f xs ys@(Seq ysFT) = case viewl xs of+ EmptyL -> empty+ firstx :< xs' -> case viewr xs' of+ EmptyR -> f firstx <$> ys+ Seq xs''FT :> lastx -> case rigidify ysFT of+ RigidEmpty -> empty+ RigidOne (Elem y) -> fmap (\x -> f x y) xs+ RigidTwo (Elem y1) (Elem y2) ->+ Seq $ lift2FT f firstx xs''FT lastx (y1, y2)+ RigidThree (Elem y1) (Elem y2) (Elem y3) ->+ Seq $ lift3FT f firstx xs''FT lastx (y1, y2, y3)+ RigidFull r@(Rigid s pr _m sf) -> Seq $+ Deep (s * length xs)+ (fmap (fmap (f firstx)) (nodeToDigit pr))+ (aptyMiddle (fmap (f firstx)) (fmap (f lastx)) (lift_elem f) xs''FT r)+ (fmap (fmap (f lastx)) (nodeToDigit sf))+ where+ lift_elem :: (a -> b -> c) -> a -> Elem b -> Elem c+#if __GLASGOW_HASKELL__ >= 708+ lift_elem = coerce+#else+ lift_elem f x (Elem y) = Elem (f x y)+#endif+{-# NOINLINE [1] liftA2Seq #-}++ data Rigidified a = RigidEmpty | RigidOne a | RigidTwo a a@@ -514,12 +575,12 @@ -- class, but as it is we have to build up 'map23' explicitly through the -- recursion. aptyMiddle- :: (c -> d)- -> (c -> d)- -> ((a -> b) -> c -> d)- -> FingerTree (Elem (a -> b))- -> Rigid c- -> FingerTree (Node d)+ :: (b -> c)+ -> (b -> c)+ -> (a -> b -> c)+ -> FingerTree (Elem a)+ -> Rigid b+ -> FingerTree (Node c) -- Not at the bottom yet @@ -846,8 +907,8 @@ traverse _ EmptyT = pure EmptyT traverse f (Single x) = Single <$> f x traverse f (Deep v pr m sf) =- deep' v <$> traverse f pr <*> traverse (traverse f) m <*>- traverse f sf+ liftA3 (Deep v) (traverse f pr) (traverse (traverse f) m)+ (traverse f sf) instance NFData a => NFData (FingerTree a) where rnf EmptyT = ()@@ -929,9 +990,9 @@ instance Traversable Digit where {-# INLINE traverse #-} traverse f (One a) = One <$> f a- traverse f (Two a b) = Two <$> f a <*> f b- traverse f (Three a b c) = Three <$> f a <*> f b <*> f c- traverse f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d+ traverse f (Two a b) = liftA2 Two (f a) (f b)+ traverse f (Three a b c) = liftA3 Three (f a) (f b) (f c)+ traverse f (Four a b c d) = liftA3 Four (f a) (f b) (f c) <*> f d instance NFData a => NFData (Digit a) where rnf (One a) = rnf a@@ -968,24 +1029,6 @@ deriving Show #endif --- Sometimes, we need to apply a Node2, Node3, or Deep constructor--- to a size and pass the result to a function. If we calculate,--- say, `Node2 n <$> x <*> y`, then according to -ddump-simpl,--- GHC boxes up `n`, passes it to the strict constructor for `Node2`,--- and passes the result to `fmap`. Using `node2'` instead prevents--- this, forming a closure with the unboxed size.-{-# INLINE node2' #-}-node2' :: Int -> a -> a -> Node a-node2' !s = \a b -> Node2 s a b--{-# INLINE node3' #-}-node3' :: Int -> a -> a -> a -> Node a-node3' !s = \a b c -> Node3 s a b c--{-# INLINE deep' #-}-deep' :: Int -> Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a-deep' !s = \pr m sf -> Deep s pr m sf- 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@@ -1011,8 +1054,8 @@ instance Traversable Node where {-# INLINE traverse #-}- traverse f (Node2 v a b) = node2' v <$> f a <*> f b- traverse f (Node3 v a b c) = node3' v <$> f a <*> f b <*> f c+ traverse f (Node2 v a b) = liftA2 (Node2 v) (f a) (f b)+ traverse f (Node3 v a b c) = liftA3 (Node3 v) (f a) (f b) (f c) instance NFData a => NFData (Node a) where rnf (Node2 _ a b) = rnf a `seq` rnf b@@ -1130,12 +1173,12 @@ (q,1) -> deepA two (applicativeTree (q - 1) mSize' n3) two (q,_) -> deepA three (applicativeTree (q - 1) mSize' n3) two where !mSize' = 3 * mSize- n3 = liftA3 (node3' mSize') m m m+ n3 = liftA3 (Node3 mSize') m m m where one = fmap One m two = liftA2 Two m m three = liftA3 Three m m m- deepA = liftA3 (deep' (n * mSize))+ deepA = liftA3 (Deep (n * mSize)) emptyTree = pure EmptyT ------------------------------------------------------------------------@@ -1157,7 +1200,7 @@ | otherwise = error "replicate takes a nonnegative integer argument" -- | 'replicateA' is an 'Applicative' version of 'replicate', and makes--- /O(log n)/ calls to '<*>' 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)@@ -1661,7 +1704,7 @@ instance Traversable ViewL where traverse _ EmptyL = pure EmptyL- traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs+ traverse f (x :< xs) = liftA2 (:<) (f x) (traverse f xs) -- | /O(1)/. Analyse the left end of a sequence. viewl :: Seq a -> ViewL a@@ -1728,7 +1771,7 @@ instance Traversable ViewR where traverse _ EmptyR = pure EmptyR- traverse f (xs :> x) = (:>) <$> traverse f xs <*> f x+ traverse f (xs :> x) = liftA2 (:>) (traverse f xs) (f x) -- | /O(1)/. Analyse the right end of a sequence. viewr :: Seq a -> ViewR a@@ -2666,10 +2709,10 @@ traverseWithIndexTreeE _ !_s EmptyT = pure EmptyT traverseWithIndexTreeE f s (Single xs) = Single <$> f s xs traverseWithIndexTreeE f s (Deep n pr m sf) =- deep' n <$>- traverseWithIndexDigitE f s pr <*>- traverseWithIndexTreeN (traverseWithIndexNodeE f) sPspr m <*>- traverseWithIndexDigitE f sPsprm sf+ liftA3 (Deep n)+ (traverseWithIndexDigitE f s pr)+ (traverseWithIndexTreeN (traverseWithIndexNodeE f) sPspr m)+ (traverseWithIndexDigitE f sPsprm sf) where !sPspr = s + size pr !sPsprm = sPspr + size m@@ -2678,10 +2721,10 @@ traverseWithIndexTreeN _ !_s EmptyT = pure EmptyT traverseWithIndexTreeN f s (Single xs) = Single <$> f s xs traverseWithIndexTreeN f s (Deep n pr m sf) =- deep' n <$>- traverseWithIndexDigitN f s pr <*>- traverseWithIndexTreeN (traverseWithIndexNodeN f) sPspr m <*>- traverseWithIndexDigitN f sPsprm sf+ liftA3 (Deep n)+ (traverseWithIndexDigitN f s pr)+ (traverseWithIndexTreeN (traverseWithIndexNodeN f) sPspr m)+ (traverseWithIndexDigitN f sPsprm sf) where !sPspr = s + size pr !sPsprm = sPspr + size m@@ -2695,16 +2738,16 @@ {-# INLINE traverseWithIndexDigit #-} traverseWithIndexDigit :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Digit a -> f (Digit b) traverseWithIndexDigit f !s (One a) = One <$> f s a- traverseWithIndexDigit f s (Two a b) = Two <$> f s a <*> f sPsa b+ traverseWithIndexDigit f s (Two a b) = liftA2 Two (f s a) (f sPsa b) where !sPsa = s + size a traverseWithIndexDigit f s (Three a b c) =- Three <$> f s a <*> f sPsa b <*> f sPsab c+ liftA3 Three (f s a) (f sPsa b) (f sPsab c) where !sPsa = s + size a !sPsab = sPsa + size b traverseWithIndexDigit f s (Four a b c d) =- Four <$> f s a <*> f sPsa b <*> f sPsab c <*> f sPsabc d+ liftA3 Four (f s a) (f sPsa b) (f sPsab c) <*> f sPsabc d where !sPsa = s + size a !sPsab = sPsa + size b@@ -2718,11 +2761,11 @@ {-# INLINE traverseWithIndexNode #-} traverseWithIndexNode :: (Applicative f, Sized a) => (Int -> a -> f b) -> Int -> Node a -> f (Node b)- traverseWithIndexNode f !s (Node2 ns a b) = node2' ns <$> f s a <*> f sPsa b+ traverseWithIndexNode f !s (Node2 ns a b) = liftA2 (Node2 ns) (f s a) (f sPsa b) where !sPsa = s + size a traverseWithIndexNode f s (Node3 ns a b c) =- node3' ns <$> f s a <*> f sPsa b <*> f sPsab c+ liftA3 (Node3 ns) (f s a) (f sPsa b) (f sPsab c) where !sPsa = s + size a !sPsab = sPsa + size b
Data/Set/Internal.hs view
@@ -239,7 +239,7 @@ import Utils.Containers.Internal.PtrEquality #if __GLASGOW_HASKELL__-import GHC.Exts ( build )+import GHC.Exts ( build, lazy ) #if __GLASGOW_HASKELL__ >= 708 import qualified GHC.Exts as GHCExts #endif@@ -505,42 +505,49 @@ -- it is replaced with the new value. -- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper (in Data.Map.Internal) insert :: Ord a => a -> Set a -> Set a-insert = go+insert x0 = go x0 x0 where- go :: Ord a => a -> Set a -> Set a- go !x Tip = singleton x- go !x t@(Bin sz y l r) = case compare x y of+ go :: Ord a => a -> a -> Set a -> Set a+ go orig !_ Tip = singleton (lazy orig)+ go orig !x t@(Bin sz y l r) = case compare x y of LT | l' `ptrEq` l -> t | otherwise -> balanceL y l' r- where !l' = go x l+ where !l' = go orig x l GT | r' `ptrEq` r -> t | otherwise -> balanceR y l r'- where !r' = go x r- EQ | x `ptrEq` y -> t- | otherwise -> Bin sz x l r+ where !r' = go orig x r+ EQ | lazy orig `seq` (orig `ptrEq` y) -> t+ | otherwise -> Bin sz (lazy orig) l r #if __GLASGOW_HASKELL__ {-# INLINABLE insert #-} #else {-# INLINE insert #-} #endif +#ifndef __GLASGOW_HASKELL__+lazy :: a -> a+lazy a = a+#endif+ -- Insert an element to the set only if it is not in the set. -- Used by `union`. -- See Note: Type of local 'go' function+-- See Note: Avoiding worker/wrapper (in Data.Map.Internal) insertR :: Ord a => a -> Set a -> Set a-insertR = go+insertR x0 = go x0 x0 where- go :: Ord a => a -> Set a -> Set a- go !x Tip = singleton x- go !x t@(Bin _ y l r) = case compare x y of+ go :: Ord a => a -> a -> Set a -> Set a+ go orig !_ Tip = singleton (lazy orig)+ go orig !x t@(Bin _ y l r) = case compare x y of LT | l' `ptrEq` l -> t | otherwise -> balanceL y l' r- where !l' = go x l+ where !l' = go orig x l GT | r' `ptrEq` r -> t | otherwise -> balanceR y l r'- where !r' = go x r+ where !r' = go orig x r EQ -> t #if __GLASGOW_HASKELL__ {-# INLINABLE insertR #-}@@ -669,7 +676,7 @@ {-# INLINABLE unions #-} #endif --- | /O(m*log(n/m + 1)), m <= n/. The union of two sets, preferring the first set when+-- | /O(m*log(n\/m + 1)), m <= n/. The union of two sets, preferring the first set when -- equal elements are encountered. union :: Ord a => Set a -> Set a -> Set a union t1 Tip = t1@@ -689,7 +696,7 @@ {-------------------------------------------------------------------- Difference --------------------------------------------------------------------}--- | /O(m*log(n/m + 1)), m <= n/. Difference of two sets.+-- | /O(m*log(n\/m + 1)), m <= n/. Difference of two sets. difference :: Ord a => Set a -> Set a -> Set a difference Tip _ = Tip difference t1 Tip = t1@@ -706,7 +713,7 @@ {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------}--- | /O(m*log(n/m + 1)), m <= n/. The intersection of two sets.+-- | /O(m*log(n\/m + 1)), m <= n/. The intersection of two sets. -- Elements of the result come from the first set, so for example -- -- > import qualified Data.Set as S
Data/Tree.hs view
@@ -38,8 +38,9 @@ #if MIN_VERSION_base(4,8,0) import Data.Foldable (toList)+import Control.Applicative (Applicative(..), liftA2) #else-import Control.Applicative (Applicative(..), (<$>))+import Control.Applicative (Applicative(..), liftA2, (<$>)) import Data.Foldable (Foldable(foldMap), toList) import Data.Monoid (Monoid(..)) import Data.Traversable (Traversable(traverse))@@ -73,6 +74,10 @@ import Data.Semigroup (Semigroup (..)) #endif +#if !MIN_VERSION_base(4,8,0)+import Data.Functor ((<$))+#endif+ -- | Multi-way trees, also known as /rose trees/. data Tree a = Node { rootLabel :: a, -- ^ label value@@ -128,6 +133,7 @@ instance Functor Tree where fmap = fmapTree+ x <$ Node _ ts = Node x (map (x <$) ts) fmapTree :: (a -> b) -> Tree a -> Tree b fmapTree f (Node x ts) = Node (f x) (map (fmapTree f) ts)@@ -144,6 +150,14 @@ pure x = Node x [] Node f tfs <*> tx@(Node x txs) = Node (f x) (map (f <$>) txs ++ map (<*> tx) tfs)+#if MIN_VERSION_base(4,10,0)+ liftA2 f (Node x txs) ty@(Node y tys) =+ Node (f x y) (map (f x <$>) tys ++ map (\tx -> liftA2 f tx ty) txs)+#endif+ Node x txs <* ty@(Node _ tys) =+ Node x (map (x <$) tys ++ map (<* ty) txs)+ Node _ txs *> ty@(Node y tys) =+ Node y (tys ++ map (*> ty) txs) instance Monad Tree where return = pure@@ -151,7 +165,7 @@ where Node x' ts' = f x instance Traversable Tree where- traverse f (Node x ts) = Node <$> f x <*> traverse (traverse f) ts+ traverse f (Node x ts) = liftA2 Node (f x) (traverse (traverse f) ts) instance Foldable Tree where foldMap f (Node x ts) = f x `mappend` foldMap (foldMap f) ts
changelog.md view
@@ -1,9 +1,39 @@ # Changelog for [`containers` package](http://github.com/haskell/containers) -## 0.5.10.1+## 0.5.10.2 * Planned for GHC 8.2. +* Use `COMPLETE` pragmas to declare complete sets of pattern synonyms+ for `Data.Sequence`. At last!++* Make `Data.IntMap.Strict.traverseWithKey` force the values before+ installing them in the result. Previously, this function could be used to+ produce an `IntMap` containing undefined values.++* Fix strictness bugs in various rewrite rules for `Data.Map.Strict` and+ `Data.IntMap.Strict`. Previously, rules could unintentionally reduce+ strictness. The most important change in this regard is the elimination+ of rules rewriting `*.Strict.map coerce` to `coerce`. To map a coercion+ over a structure for free, be sure to use the lazy `map` or `fmap`.+ It is possible to write rules that do a somewhat better job of this, but+ it turns out to be a bit messy.++* Optimize `Data.IntMap.restrictKeys` and `Data.IntMap.withoutKeys`. The+ semantic fix in 0.5.10.1 left them rather slow in certain cases.++* Speed up `size` for `IntSet` and `IntMap` (thanks, Mike Ledger!).++* Define a custom `liftA2` in `Applicative` instances for base 4.10, and use+ `liftA2` rather than `<*>` whenever it may be beneficial.++* Add `liftA2`-related `RULES` for `Data.Sequence`.++* Export non-deprecated versions of `showTree` and `showTreeWith` from+ `Data.IntMap.Internal.Debug`.++## 0.5.10.1+ * Fix completely incorrect implementations of `Data.IntMap.restrictKeys` and `Data.IntMap.withoutKeys`. Make the tests for these actually run. (Thanks to Tom Smalley for reporting this.)@@ -15,6 +45,10 @@ * Remove meaningless stability annotations (Thanks, Simon Jakobi.) +## 0.5.9.2++* Backport bug fixes from 0.5.10.1+ ## 0.5.9.1 * Add `merge` and `mergeA` for `Data.IntMap`.@@ -46,6 +80,10 @@ total functions instead. New implementations of said functions lead to slight performance improvements overall. +## 0.5.8.2++* Backport bug fixes from 0.5.10.1.+ ## 0.5.8.1 *Aug 2016* ### General package changes@@ -83,8 +121,8 @@ Many thanks to Cale Gibbard, Ryan Trinkle, and Dan Doel for inspiring the merge idea and helping refine the interface. - * Add `fromDescList`, `fromDescListWith`, `fromDescListWithKey`,- and `fromDistinctDescList` to `Data.Map`.+ * Add `traverseMaybeWithKey`, `fromDescList`, `fromDescListWith`,+ `fromDescListWithKey`, and `fromDistinctDescList` to `Data.Map`. * Add `fromDescList` and `fromDistinctDescList` to `Data.Set`.
containers.cabal view
@@ -1,5 +1,5 @@ name: containers-version: 0.5.10.1+version: 0.5.10.2 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org@@ -45,6 +45,7 @@ Data.IntMap.Lazy Data.IntMap.Strict Data.IntMap.Internal+ Data.IntMap.Internal.Debug Data.IntMap.Merge.Lazy Data.IntMap.Merge.Strict Data.IntSet.Internal@@ -74,6 +75,7 @@ Utils.Containers.Internal.StrictMaybe Utils.Containers.Internal.PtrEquality Data.Map.Internal.DeprecatedShowTree+ Data.IntMap.Internal.DeprecatedDebug include-dirs: include
tests/Makefile view
@@ -8,10 +8,10 @@ all: %-properties: %-properties.hs force- ghc -O2 -DTESTING $< -i.. -o $@ -outputdir tmp+ ghc -I../include -O2 -DTESTING $< -i.. -o $@ -outputdir tmp %-strict-properties: %-properties.hs force- ghc -O2 -DTESTING -DSTRICT $< -o $@ -i.. -outputdir tmp+ ghc -I../include -O2 -DTESTING -DSTRICT $< -o $@ -i.. -outputdir tmp .PHONY: force clean force:
tests/intmap-properties.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE CPP #-} #ifdef STRICT-import Data.IntMap.Strict as Data.IntMap+import Data.IntMap.Strict as Data.IntMap hiding (showTree) #else-import Data.IntMap.Lazy as Data.IntMap+import Data.IntMap.Lazy as Data.IntMap hiding (showTree) #endif+import Data.IntMap.Internal.Debug (showTree) import Data.Monoid import Data.Maybe hiding (mapMaybe)@@ -141,6 +142,7 @@ , testProperty "alter" prop_alter , testProperty "index" prop_index , testProperty "null" prop_null+ , testProperty "size" prop_size , testProperty "member" prop_member , testProperty "notmember" prop_notmember , testProperty "lookup" prop_lookup@@ -805,17 +807,21 @@ ys' = List.nubBy ((==) `on` fst) ys f k l r = k + 2 * l + 3 * r +-- TODO: the second argument should be simply an 'IntSet', but that+-- runs afoul of our orphan instance. prop_restrictKeys :: IMap -> IMap -> Property-prop_restrictKeys m s0 = m `restrictKeys` s === filterWithKey (\k _ -> k `IntSet.member` s) m+prop_restrictKeys m s0 =+ m `restrictKeys` s === filterWithKey (\k _ -> k `IntSet.member` s) m where s = keysSet s0- restricted = restrictKeys m s +-- TODO: the second argument should be simply an 'IntSet', but that+-- runs afoul of our orphan instance. prop_withoutKeys :: IMap -> IMap -> Property-prop_withoutKeys m s0 = m `withoutKeys` s === filterWithKey (\k _ -> k `IntSet.notMember` s) m+prop_withoutKeys m s0 =+ m `withoutKeys` s === filterWithKey (\k _ -> k `IntSet.notMember` s) m where s = keysSet s0- reduced = withoutKeys m s prop_mergeWithKeyModel :: [(Int,Int)] -> [(Int,Int)] -> Bool prop_mergeWithKeyModel xs ys@@ -900,6 +906,11 @@ prop_null :: IMap -> Bool prop_null m = null m == (size m == 0)++prop_size :: UMap -> Property+prop_size im = sz === foldl' (\i _ -> i + 1) (0 :: Int) im .&&.+ sz === List.length (toList im)+ where sz = size im prop_member :: [Int] -> Int -> Bool prop_member xs n =
tests/intset-properties.hs view
@@ -261,8 +261,10 @@ prop_isSubsetOf2 :: IntSet -> IntSet -> Bool prop_isSubsetOf2 a b = isSubsetOf a (union a b) -prop_size :: IntSet -> Bool-prop_size s = size s == List.length (toList s)+prop_size :: IntSet -> Property+prop_size s = sz === foldl' (\i _ -> i + 1) (0 :: Int) s .&&.+ sz === List.length (toList s)+ where sz = size s prop_findMax :: IntSet -> Property prop_findMax s = not (null s) ==> findMax s == maximum (toList s)
tests/seq-properties.hs view
@@ -16,7 +16,7 @@ import Data.Sequence -import Control.Applicative (Applicative(..))+import Control.Applicative (Applicative(..), liftA2) import Control.Arrow ((***)) import Control.Monad.Trans.State.Strict import Data.Array (listArray)@@ -133,6 +133,8 @@ , testProperty "munzip-lazy" prop_munzipLazy #endif , testProperty "<*>" prop_ap+ , testProperty "<*> NOINLINE" prop_ap_NOINLINE+ , testProperty "liftA2" prop_liftA2 , testProperty "*>" prop_then , testProperty "cycleTaking" prop_cycleTaking , testProperty "intersperse" prop_intersperse@@ -745,6 +747,20 @@ prop_ap :: Seq A -> Seq B -> Bool prop_ap xs ys = toList' ((,) <$> xs <*> ys) ~= ( (,) <$> toList xs <*> toList ys )++prop_ap_NOINLINE :: Seq A -> Seq B -> Bool+prop_ap_NOINLINE xs ys =+ toList' (((,) <$> xs) `apNOINLINE` ys) ~= ( (,) <$> toList xs <*> toList ys )++{-# NOINLINE apNOINLINE #-}+apNOINLINE :: Seq (a -> b) -> Seq a -> Seq b+apNOINLINE fs xs = fs <*> xs++prop_liftA2 :: Seq A -> Seq B -> Property+prop_liftA2 xs ys = valid q .&&.+ toList q === liftA2 (,) (toList xs) (toList ys)+ where+ q = liftA2 (,) xs ys prop_then :: Seq A -> Seq B -> Bool prop_then xs ys =