containers 0.5.3.1 → 0.5.4.0
raw patch · 16 files changed
+348/−144 lines, 16 files
Files
- Data/Graph.hs +33/−3
- Data/IntMap/Base.hs +54/−25
- Data/IntMap/Lazy.hs +1/−0
- Data/IntMap/Strict.hs +10/−9
- Data/IntSet.hs +1/−0
- Data/IntSet/Base.hs +63/−22
- Data/Map/Base.hs +61/−34
- Data/Map/Lazy.hs +2/−1
- Data/Map/Strict.hs +13/−12
- Data/Set.hs +2/−1
- Data/Set/Base.hs +55/−28
- containers.cabal +1/−1
- tests/intmap-properties.hs +11/−0
- tests/intset-properties.hs +11/−0
- tests/map-properties.hs +15/−4
- tests/set-properties.hs +15/−4
Data/Graph.hs view
@@ -72,6 +72,7 @@ import Data.Tree (Tree(Node), Forest) -- std interfaces+import Control.Applicative import Control.DeepSeq (NFData(rnf)) import Data.Maybe import Data.Array@@ -93,6 +94,10 @@ rnf (AcyclicSCC v) = rnf v rnf (CyclicSCC vs) = rnf vs +instance Functor SCC where+ fmap f (AcyclicSCC v) = AcyclicSCC (f v)+ fmap f (CyclicSCC vs) = CyclicSCC (fmap f vs)+ -- | The vertices of a list of strongly connected components. flattenSCCs :: [SCC a] -> [a] flattenSCCs = concatMap flattenSCC@@ -286,8 +291,23 @@ instance Monad (SetM s) where return x = SetM $ const (return x)- SetM v >>= f = SetM $ \ s -> do { x <- v s; runSetM (f x) s }+ {-# INLINE return #-}+ SetM v >>= f = SetM $ \s -> do { x <- v s; runSetM (f x) s }+ {-# INLINE (>>=) #-} +instance Functor (SetM s) where+ f `fmap` SetM v = SetM $ \s -> f `fmap` v s+ {-# INLINE fmap #-}++instance Applicative (SetM s) where+ pure x = SetM $ const (return x)+ {-# INLINE pure #-}+ SetM f <*> SetM v = SetM $ \s -> f s >>= (`fmap` v s)+ -- We could also use the following definition+ -- SetM f <*> SetM v = SetM $ \s -> f s <*> v s+ -- but Applicative (ST s) instance is present only in GHC 7.2++ {-# INLINE (<*>) #-}+ run :: Bounds -> (forall s. SetM s a) -> a run bnds act = runST (newArray bnds False >>= runSetM act) @@ -304,8 +324,18 @@ newtype SetM s a = SetM { runSetM :: IntSet -> (a, IntSet) } instance Monad (SetM s) where- return x = SetM $ \ s -> (x, s)- SetM v >>= f = SetM $ \ s -> case v s of (x, s') -> runSetM (f x) s'+ return x = SetM $ \s -> (x, s)+ SetM v >>= f = SetM $ \s -> case v s of (x, s') -> runSetM (f x) s'++instance Functor (SetM s) where+ f `fmap` SetM v = SetM $ \s -> case v s of (x, s') -> (f x, s')+ {-# INLINE fmap #-}++instance Applicative (SetM s) where+ pure x = SetM $ \s -> (x, s)+ {-# INLINE pure #-}+ SetM f <*> SetM v = SetM $ \s -> case f s of (k, s') -> case v s' of (x, s'') -> (k x, s'')+ {-# INLINE (<*>) #-} run :: Bounds -> SetM s a -> a run _ act = fst (runSetM act Set.empty)
Data/IntMap/Base.hs view
@@ -165,6 +165,7 @@ , split , splitLookup+ , splitRoot -- * Submap , isSubmapOf, isSubmapOfBy@@ -196,7 +197,7 @@ -- * Utility , natFromInt , intFromNat- , join+ , link , bin , zero , nomatch@@ -572,12 +573,12 @@ insert k x t = k `seq` case t of Bin p m l r- | nomatch k p m -> join k (Tip k x) p t+ | nomatch k p m -> link k (Tip k x) p t | zero k m -> Bin p m (insert k x l) r | otherwise -> Bin p m l (insert k x r) Tip ky _ | k==ky -> Tip k x- | otherwise -> join k (Tip k x) ky t+ | otherwise -> link k (Tip k x) ky t Nil -> Tip k x -- right-biased insertion, used by 'union'@@ -610,12 +611,12 @@ insertWithKey f k x t = k `seq` case t of Bin p m l r- | nomatch k p m -> join k (Tip k x) p t+ | nomatch k p m -> link k (Tip k x) p t | zero k m -> Bin p m (insertWithKey f k x l) r | otherwise -> Bin p m l (insertWithKey f k x r) Tip ky y | k==ky -> Tip k (f k x y)- | otherwise -> join k (Tip k x) ky t+ | otherwise -> link k (Tip k x) ky t Nil -> Tip k x -- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)@@ -637,12 +638,12 @@ insertLookupWithKey f k x t = k `seq` case t of Bin p m l r- | nomatch k p m -> (Nothing,join k (Tip k x) p t)+ | nomatch k p m -> (Nothing,link k (Tip k x) p t) | zero k m -> let (found,l') = insertLookupWithKey f k x l in (found,Bin p m l' r) | otherwise -> let (found,r') = insertLookupWithKey f k x r in (found,Bin p m l r') Tip ky y | k==ky -> (Just y,Tip k (f k x y))- | otherwise -> (Nothing,join k (Tip k x) ky t)+ | otherwise -> (Nothing,link k (Tip k x) ky t) Nil -> (Nothing,Tip k x) @@ -762,7 +763,7 @@ Bin p m l r | nomatch k p m -> case f Nothing of Nothing -> t- Just x -> join k (Tip k x) p t+ Just x -> link k (Tip k x) p t | zero k m -> bin p m (alter f k l) r | otherwise -> bin p m l (alter f k r) Tip ky y@@ -770,7 +771,7 @@ Just x -> Tip ky x Nothing -> Nil | otherwise -> case f Nothing of- Just x -> join k (Tip k x) ky t+ Just x -> link k (Tip k x) ky t Nothing -> Tip ky y Nil -> case f Nothing of Just x -> Tip k x@@ -956,39 +957,39 @@ | shorter m1 m2 = merge1 | shorter m2 m1 = merge2 | p1 == p2 = bin' p1 m1 (go l1 l2) (go r1 r2)- | otherwise = maybe_join p1 (g1 t1) p2 (g2 t2)+ | otherwise = maybe_link p1 (g1 t1) p2 (g2 t2) where- merge1 | nomatch p2 p1 m1 = maybe_join p1 (g1 t1) p2 (g2 t2)+ merge1 | nomatch p2 p1 m1 = maybe_link p1 (g1 t1) p2 (g2 t2) | zero p2 m1 = bin' p1 m1 (go l1 t2) (g1 r1) | otherwise = bin' p1 m1 (g1 l1) (go r1 t2)- merge2 | nomatch p1 p2 m2 = maybe_join p1 (g1 t1) p2 (g2 t2)+ merge2 | nomatch p1 p2 m2 = maybe_link p1 (g1 t1) p2 (g2 t2) | zero p1 m2 = bin' p2 m2 (go t1 l2) (g2 r2) | otherwise = bin' p2 m2 (g2 l2) (go t1 r2) go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge t2' k2' t1'- where merge t2 k2 t1@(Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = maybe_join p1 (g1 t1) k2 (g2 t2)+ where merge t2 k2 t1@(Bin p1 m1 l1 r1) | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2) | zero k2 m1 = bin' p1 m1 (merge t2 k2 l1) (g1 r1) | otherwise = bin' p1 m1 (g1 l1) (merge t2 k2 r1) merge t2 k2 t1@(Tip k1 _) | k1 == k2 = f t1 t2- | otherwise = maybe_join k1 (g1 t1) k2 (g2 t2)+ | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2) merge t2 _ Nil = g2 t2 go t1@(Bin _ _ _ _) Nil = g1 t1 go t1'@(Tip k1' _) t2' = merge t1' k1' t2'- where merge t1 k1 t2@(Bin p2 m2 l2 r2) | nomatch k1 p2 m2 = maybe_join k1 (g1 t1) p2 (g2 t2)+ where merge t1 k1 t2@(Bin p2 m2 l2 r2) | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2) | zero k1 m2 = bin' p2 m2 (merge t1 k1 l2) (g2 r2) | otherwise = bin' p2 m2 (g2 l2) (merge t1 k1 r2) merge t1 k1 t2@(Tip k2 _) | k1 == k2 = f t1 t2- | otherwise = maybe_join k1 (g1 t1) k2 (g2 t2)+ | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2) merge t1 _ Nil = g1 t1 go Nil t2 = g2 t2 - maybe_join _ Nil _ t2 = t2- maybe_join _ t1 _ Nil = t1- maybe_join p1 t1 p2 t2 = join p1 t1 p2 t2- {-# INLINE maybe_join #-}+ maybe_link _ Nil _ t2 = t2+ maybe_link _ t1 _ Nil = t1+ maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2+ {-# INLINE maybe_link #-} {-# INLINE mergeWithKey' #-} {--------------------------------------------------------------------@@ -1923,7 +1924,7 @@ else work z zs (Push px tx stk) finish _ t Nada = t- finish px tx (Push py ty stk) = finish p (join py ty px tx) stk+ finish px tx (Push py ty stk) = finish p (link py ty px tx) stk where m = branchMask px py p = mask px m @@ -2004,16 +2005,16 @@ Helpers --------------------------------------------------------------------} {--------------------------------------------------------------------- Join+ Link --------------------------------------------------------------------}-join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a-join p1 t1 p2 t2+link :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a+link p1 t1 p2 t2 | zero p1 m = Bin p m t1 t2 | otherwise = Bin p m t2 t1 where m = branchMask p1 p2 p = mask p1 m-{-# INLINE join #-}+{-# INLINE link #-} {-------------------------------------------------------------------- @bin@ assures that we never have empty trees within a tree.@@ -2076,6 +2077,34 @@ go z [] = z go z (x:xs) = let z' = f z x in z' `seq` go z' xs {-# INLINE foldlStrict #-}++-- | /O(1)/. Decompose a map into pieces based on the structure of the underlying+-- tree. This function is useful for consuming a map in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this. However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==+-- > [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]+--+-- > splitRoot empty == []+--+-- Note that the current implementation does not return more than two submaps,+-- but you should not depend on this behaviour because it can change in the+-- future without notice.+splitRoot :: IntMap a -> [IntMap a]+splitRoot orig =+ case orig of+ Nil -> []+ x@(Tip _ _) -> [x]+ Bin _ m l r | m < 0 -> [r, l]+ | otherwise -> [l, r]+{-# INLINE splitRoot #-}+ {-------------------------------------------------------------------- Debugging
Data/IntMap/Lazy.hs view
@@ -175,6 +175,7 @@ , split , splitLookup+ , splitRoot -- * Submap , isSubmapOf, isSubmapOfBy
Data/IntMap/Strict.hs view
@@ -181,6 +181,7 @@ , split , splitLookup+ , splitRoot -- * Submap , isSubmapOf, isSubmapOfBy@@ -328,12 +329,12 @@ insert k x t = k `seq` x `seq` case t of Bin p m l r- | nomatch k p m -> join k (Tip k x) p t+ | nomatch k p m -> link k (Tip k x) p t | zero k m -> Bin p m (insert k x l) r | otherwise -> Bin p m l (insert k x r) Tip ky _ | k==ky -> Tip k x- | otherwise -> join k (Tip k x) ky t+ | otherwise -> link k (Tip k x) ky t Nil -> Tip k x -- right-biased insertion, used by 'union'@@ -369,12 +370,12 @@ insertWithKey f k x t = k `seq` case t of Bin p m l r- | nomatch k p m -> join k (singleton k x) p t+ | nomatch k p m -> link k (singleton k x) p t | zero k m -> Bin p m (insertWithKey f k x l) r | otherwise -> Bin p m l (insertWithKey f k x r) Tip ky y | k==ky -> Tip k $! f k x y- | otherwise -> join k (singleton k x) ky t+ | otherwise -> link k (singleton k x) ky t Nil -> singleton k x -- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)@@ -398,12 +399,12 @@ go f k x t = case t of Bin p m l r- | nomatch k p m -> Nothing :*: join k (singleton k x) p t+ | nomatch k p m -> Nothing :*: link k (singleton k x) p t | zero k m -> let (found :*: l') = go f k x l in (found :*: Bin p m l' r) | otherwise -> let (found :*: r') = go f k x r in (found :*: Bin p m l r') Tip ky y | k==ky -> (Just y :*: (Tip k $! f k x y))- | otherwise -> (Nothing :*: join k (singleton k x) ky t)+ | otherwise -> (Nothing :*: link k (singleton k x) ky t) Nil -> Nothing :*: (singleton k x) @@ -506,7 +507,7 @@ Bin p m l r | nomatch k p m -> case f Nothing of Nothing -> t- Just x -> x `seq` join k (Tip k x) p t+ Just x -> x `seq` link k (Tip k x) p t | zero k m -> bin p m (alter f k l) r | otherwise -> bin p m l (alter f k r) Tip ky y@@ -514,7 +515,7 @@ Just x -> x `seq` Tip ky x Nothing -> Nil | otherwise -> case f Nothing of- Just x -> x `seq` join k (Tip k x) ky t+ Just x -> x `seq` link k (Tip k x) ky t Nothing -> t Nil -> case f Nothing of Just x -> x `seq` Tip k x@@ -970,7 +971,7 @@ else work z zs (Push px tx stk) finish _ t Nada = t- finish px tx (Push py ty stk) = finish p (join py ty px tx) stk+ finish px tx (Push py ty stk) = finish p (link py ty px tx) stk where m = branchMask px py p = mask px m
Data/IntSet.hs view
@@ -90,6 +90,7 @@ , partition , split , splitMember+ , splitRoot -- * Map , IS.map
Data/IntSet/Base.hs view
@@ -111,6 +111,7 @@ , partition , split , splitMember+ , splitRoot -- * Map , map@@ -158,6 +159,26 @@ , bitmapOf ) where +-- We want to be able to compile without cabal. Nevertheless+-- #if defined(MIN_VERSION_base) && MIN_VERSION_base(4,5,0)+-- does not work, because if MIN_VERSION_base is undefined,+-- the last condition is syntactically wrong.+#define MIN_VERSION_base_4_5_0 0+#ifdef MIN_VERSION_base+#if MIN_VERSION_base(4,5,0)+#undef MIN_VERSION_base_4_5_0+#define MIN_VERSION_base_4_5_0 1+#endif+#endif++#define MIN_VERSION_base_4_7_0 0+#ifdef MIN_VERSION_base+#if MIN_VERSION_base(4,7,0)+#undef MIN_VERSION_base_4_7_0+#define MIN_VERSION_base_4_7_0 1+#endif+#endif+ import Control.DeepSeq (NFData) import Data.Bits import qualified Data.List as List@@ -438,12 +459,12 @@ insertBM kx bm t = kx `seq` bm `seq` case t of Bin p m l r- | nomatch kx p m -> join kx (Tip kx bm) p t+ | nomatch kx p m -> link kx (Tip kx bm) p t | zero kx m -> Bin p m (insertBM kx bm l) r | otherwise -> Bin p m l (insertBM kx bm r) Tip kx' bm' | kx' == kx -> Tip kx' (bm .|. bm')- | otherwise -> join kx (Tip kx bm) kx' t+ | otherwise -> link kx (Tip kx bm) kx' t Nil -> Tip kx bm -- | /O(min(n,W))/. Delete a value in the set. Returns the@@ -481,13 +502,13 @@ | shorter m1 m2 = union1 | shorter m2 m1 = union2 | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)- | otherwise = join p1 t1 p2 t2+ | otherwise = link p1 t1 p2 t2 where- union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2+ union1 | nomatch p2 p1 m1 = link p1 t1 p2 t2 | zero p2 m1 = Bin p1 m1 (union l1 t2) r1 | otherwise = Bin p1 m1 l1 (union r1 t2) - union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2+ union2 | nomatch p1 p2 m2 = link p1 t1 p2 t2 | zero p1 m2 = Bin p2 m2 (union t1 l2) r2 | otherwise = Bin p2 m2 l2 (union t1 r2) @@ -999,7 +1020,7 @@ else work (prefixOf z) (bitmapOf z) zs (Push px tx stk) finish _ t Nada = t- finish px tx (Push py ty stk) = finish p (join py ty px tx) stk+ finish px tx (Push py ty stk) = finish p (link py ty px tx) stk where m = branchMask px py p = mask px m @@ -1159,16 +1180,16 @@ Helpers --------------------------------------------------------------------} {--------------------------------------------------------------------- Join+ Link --------------------------------------------------------------------}-join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet-join p1 t1 p2 t2+link :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet+link p1 t1 p2 t2 | zero p1 m = Bin p m t1 t2 | otherwise = Bin p m t2 t1 where m = branchMask p1 p2 p = mask p1 m-{-# INLINE join #-}+{-# INLINE link #-} {-------------------------------------------------------------------- @bin@ assures that we never have empty trees within a tree.@@ -1193,7 +1214,11 @@ ----------------------------------------------------------------------} suffixBitMask :: Int+#if MIN_VERSION_base_4_7_0+suffixBitMask = finiteBitSize (undefined::Word) - 1+#else suffixBitMask = bitSize (undefined::Word) - 1+#endif {-# INLINE suffixBitMask #-} prefixBitMask :: Int@@ -1439,18 +1464,6 @@ Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)" ----------------------------------------------------------------------} --- We want to be able to compile without cabal. Nevertheless--- #if defined(MIN_VERSION_base) && MIN_VERSION_base(4,5,0)--- does not work, because if MIN_VERSION_base is undefined,--- the last condition is syntactically wrong.-#define MIN_VERSION_base_4_5_0 0-#ifdef MIN_VERSION_base-#if MIN_VERSION_base(4,5,0)-#undef MIN_VERSION_base_4_5_0-#define MIN_VERSION_base_4_5_0 1-#endif-#endif- bitcount :: Int -> Word -> Int #if MIN_VERSION_base_4_5_0 bitcount a x = a + popCount x@@ -1471,3 +1484,31 @@ go z [] = z go z (x:xs) = let z' = f z x in z' `seq` go z' xs {-# INLINE foldlStrict #-}++-- | /O(1)/. Decompose a set into pieces based on the structure of the underlying+-- tree. This function is useful for consuming a set in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this. However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]+-- > splitRoot empty == []+--+-- Note that the current implementation does not return more than two subsets,+-- but you should not depend on this behaviour because it can change in the+-- future without notice. Also, the current version does not continue+-- splitting all the way to individual singleton sets -- it stops at some+-- point.+splitRoot :: IntSet -> [IntSet]+splitRoot orig =+ case orig of+ Nil -> []+ -- NOTE: we don't currently split below Tip, but we could.+ x@(Tip _ _) -> [x]+ Bin _ m l r | m < 0 -> [r, l]+ | otherwise -> [l, r]+{-# INLINE splitRoot #-}
Data/Map/Base.hs view
@@ -211,6 +211,7 @@ , split , splitLookup+ , splitRoot -- * Submap , isSubmapOf, isSubmapOfBy@@ -251,7 +252,7 @@ , balanceL , balanceR , delta- , join+ , link , insertMax , merge , glue@@ -1221,10 +1222,10 @@ -- left-biased hedge union hedgeUnion :: Ord a => MaybeS a -> MaybeS a -> Map a b -> Map a b -> Map a b hedgeUnion _ _ t1 Tip = t1-hedgeUnion blo bhi Tip (Bin _ kx x l r) = join kx x (filterGt blo l) (filterLt bhi r)+hedgeUnion blo bhi Tip (Bin _ kx x l r) = link kx x (filterGt blo l) (filterLt bhi r) hedgeUnion _ _ t1 (Bin _ kx x Tip Tip) = insertR kx x t1 -- According to benchmarks, this special case increases -- performance up to 30%. It does not help in difference or intersection.-hedgeUnion blo bhi (Bin _ kx x l r) t2 = join kx x (hedgeUnion blo bmi l (trim blo bmi t2))+hedgeUnion blo bhi (Bin _ kx x l r) t2 = link kx x (hedgeUnion blo bmi l (trim blo bmi t2)) (hedgeUnion bmi bhi r (trim bmi bhi t2)) where bmi = JustS kx #if __GLASGOW_HASKELL__ >= 700@@ -1276,7 +1277,7 @@ hedgeDiff :: Ord a => MaybeS a -> MaybeS a -> Map a b -> Map a c -> Map a b hedgeDiff _ _ Tip _ = Tip-hedgeDiff blo bhi (Bin _ kx x l r) Tip = join kx x (filterGt blo l) (filterLt bhi r)+hedgeDiff blo bhi (Bin _ kx x l r) Tip = link kx x (filterGt blo l) (filterLt bhi r) hedgeDiff blo bhi t (Bin _ kx _ l r) = merge (hedgeDiff blo bmi (trim blo bmi t) l) (hedgeDiff bmi bhi (trim bmi bhi t) r) where bmi = JustS kx@@ -1343,7 +1344,7 @@ hedgeInt _ _ Tip _ = Tip hedgeInt blo bhi (Bin _ kx x l r) t2 = let l' = hedgeInt blo bmi l (trim blo bmi t2) r' = hedgeInt bmi bhi r (trim bmi bhi t2)- in if kx `member` t2 then join kx x l' r' else merge l' r'+ in if kx `member` t2 then link kx x l' r' else merge l' r' where bmi = JustS kx #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE hedgeInt #-}@@ -1424,18 +1425,18 @@ go t1 t2 = hedgeMerge NothingS NothingS t1 t2 hedgeMerge _ _ t1 Tip = g1 t1- hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ join kx x (filterGt blo l) (filterLt bhi r)+ hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ link kx x (filterGt blo l) (filterLt bhi r) hedgeMerge blo bhi (Bin _ kx x l r) t2 = let l' = hedgeMerge blo bmi l (trim blo bmi t2) (found, trim_t2) = trimLookupLo kx bhi t2 r' = hedgeMerge bmi bhi r trim_t2 in case found of Nothing -> case g1 (singleton kx x) of Tip -> merge l' r'- (Bin _ _ x' Tip Tip) -> join kx x' l' r'+ (Bin _ _ x' Tip Tip) -> link kx x' l' r' _ -> error "mergeWithKey: Given function only1 does not fulfil required conditions (see documentation)" Just x2 -> case f kx x x2 of Nothing -> merge l' r'- Just x' -> join kx x' l' r'+ Just x' -> link kx x' l' r' where bmi = JustS kx {-# INLINE mergeWithKey #-} @@ -1543,7 +1544,7 @@ filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a filterWithKey _ Tip = Tip filterWithKey p (Bin _ kx x l r)- | p kx x = join kx x (filterWithKey p l) (filterWithKey p r)+ | p kx x = link kx x (filterWithKey p l) (filterWithKey p r) | otherwise = merge (filterWithKey p l) (filterWithKey p r) -- | /O(n)/. Partition the map according to a predicate. The first@@ -1571,8 +1572,8 @@ where go _ Tip = (Tip :*: Tip) go p (Bin _ kx x l r)- | p kx x = join kx x l1 r1 :*: merge l2 r2- | otherwise = merge l1 r1 :*: join kx x l2 r2+ | p kx x = link kx x l1 r1 :*: merge l2 r2+ | otherwise = merge l1 r1 :*: link kx x l2 r2 where (l1 :*: l2) = go p l (r1 :*: r2) = go p r@@ -1593,7 +1594,7 @@ mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b mapMaybeWithKey _ Tip = Tip mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of- Just y -> join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)+ Just y -> link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r) Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r) -- | /O(n)/. Map values and separate the 'Left' and 'Right' results.@@ -1623,8 +1624,8 @@ where go _ Tip = (Tip :*: Tip) go f (Bin _ kx x l r) = case f kx x of- Left y -> join kx y l1 r1 :*: merge l2 r2- Right z -> merge l1 r1 :*: join kx z l2 r2+ Left y -> link kx y l1 r1 :*: merge l2 r2+ Right z -> merge l1 r1 :*: link kx z l2 r2 where (l1 :*: l2) = go f l (r1 :*: r2) = go f r@@ -1974,8 +1975,8 @@ go _ t [(kx, x)] = insertMax kx x t go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs | otherwise = case create s xss of- (r, ys, []) -> go (s `shiftL` 1) (join kx x l r) ys- (r, _, ys) -> fromList' (join kx x l r) ys+ (r, ys, []) -> go (s `shiftL` 1) (link kx x l r) ys+ (r, _, ys) -> fromList' (link kx x l r) ys -- The create is returning a triple (tree, xs, ys). Both xs and ys -- represent not yet processed elements and only one of them can be nonempty.@@ -1992,7 +1993,7 @@ (l, [(ky, y)], zs) -> (insertMax ky y l, [], zs) (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys) | otherwise -> case create (s `shiftR` 1) yss of- (r, zs, ws) -> (join ky y l r, zs, ws)+ (r, zs, ws) -> (link ky y l r, zs, ws) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif@@ -2164,7 +2165,7 @@ STRICT_1_OF_3(go) go _ t [] = t go s l ((kx, x) : xs) = case create s xs of- (r, ys) -> go (s `shiftL` 1) (join kx x l r) ys+ (r, ys) -> go (s `shiftL` 1) (link kx x l r) ys STRICT_1_OF_2(create) create _ [] = (Tip, [])@@ -2173,7 +2174,7 @@ | otherwise = case create (s `shiftR` 1) xs of res@(_, []) -> res (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of- (r, zs) -> (join ky y l r, zs)+ (r, zs) -> (link ky y l r, zs) {--------------------------------------------------------------------@@ -2254,7 +2255,7 @@ filterGt (JustS b) t = filter' b t where filter' _ Tip = Tip filter' b' (Bin _ kx x l r) =- case compare b' kx of LT -> join kx x (filter' b' l) r+ case compare b' kx of LT -> link kx x (filter' b' l) r EQ -> r GT -> filter' b' r #if __GLASGOW_HASKELL__ >= 700@@ -2266,7 +2267,7 @@ filterLt (JustS b) t = filter' b t where filter' _ Tip = Tip filter' b' (Bin _ kx x l r) =- case compare kx b' of LT -> join kx x l (filter' b' r)+ case compare kx b' of LT -> link kx x l (filter' b' r) EQ -> l GT -> filter' b' l #if __GLASGOW_HASKELL__ >= 700@@ -2293,8 +2294,8 @@ case t of Tip -> (Tip :*: Tip) Bin _ kx x l r -> case compare k kx of- LT -> let (lt :*: gt) = go k l in lt :*: join kx x gt r- GT -> let (lt :*: gt) = go k r in join kx x l lt :*: gt+ LT -> let (lt :*: gt) = go k l in lt :*: link kx x gt r+ GT -> let (lt :*: gt) = go k r in link kx x l lt :*: gt EQ -> (l :*: r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE split #-}@@ -2315,10 +2316,10 @@ Tip -> (Tip,Nothing,Tip) Bin _ kx x l r -> case compare k kx of LT -> let (lt,z,gt) = splitLookup k l- gt' = join kx x gt r+ gt' = link kx x gt r in gt' `seq` (lt,z,gt') GT -> let (lt,z,gt) = splitLookup k r- lt' = join kx x l lt+ lt' = link kx x l lt in lt' `seq` (lt',z,gt) EQ -> (l,Just x,r) #if __GLASGOW_HASKELL__ >= 700@@ -2337,7 +2338,7 @@ [balance k x l r] Restores the balance and size. Assumes that the original tree was balanced and that [l] or [r] has changed by at most one element.- [join k x l r] Restores balance and size.+ [link k x l r] Restores balance and size. Furthermore, we can construct a new tree from two trees. Both operations assume that all values in [l] < all values in [r] and that [l] and [r]@@ -2347,7 +2348,7 @@ [merge l r] Merges two trees and restores balance. Note: in contrast to Adam's paper, we use (<=) comparisons instead- of (<) comparisons in [join], [merge] and [balance].+ of (<) comparisons in [link], [merge] and [balance]. Quickcheck (on [difference]) showed that this was necessary in order to maintain the invariants. It is quite unsatisfactory that I haven't been able to find out why this is actually the case! Fortunately, it@@ -2355,14 +2356,14 @@ --------------------------------------------------------------------} {--------------------------------------------------------------------- Join+ Link --------------------------------------------------------------------}-join :: k -> a -> Map k a -> Map k a -> Map k a-join kx x Tip r = insertMin kx x r-join kx x l Tip = insertMax kx x l-join kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)- | delta*sizeL < sizeR = balanceL kz z (join kx x l lz) rz- | delta*sizeR < sizeL = balanceR ky y ly (join kx x ry r)+link :: k -> a -> Map k a -> Map k a -> Map k a+link kx x Tip r = insertMin kx x r+link kx x l Tip = insertMax kx x l+link kx x l@(Bin sizeL ky y ly ry) r@(Bin sizeR kz z lz rz)+ | delta*sizeL < sizeR = balanceL kz z (link kx x l lz) rz+ | delta*sizeR < sizeL = balanceR ky y ly (link kx x ry r) | otherwise = bin kx x l r @@ -2813,3 +2814,29 @@ go z [] = z go z (x:xs) = let z' = f z x in z' `seq` go z' xs {-# INLINE foldlStrict #-}+++-- | /O(1)/. Decompose a map into pieces based on the structure of the underlying+-- tree. This function is useful for consuming a map in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this. However, it is guaranteed that the pieces+-- returned will be in ascending order (all elements in the first submap less than all+-- elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList (zip [1..6] ['a'..])) ==+-- > [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d')],fromList [(5,'e'),(6,'f')]]+--+-- > splitRoot empty == []+--+-- Note that the current implementation does not return more than three submaps,+-- but you should not depend on this behaviour because it can change in the+-- future without notice.+splitRoot :: Map k b -> [Map k b]+splitRoot orig =+ case orig of+ Tip -> []+ Bin _ k v l r -> [l, singleton k v, r]+{-# INLINE splitRoot #-}
Data/Map/Lazy.hs view
@@ -171,6 +171,7 @@ , split , splitLookup+ , splitRoot -- * Submap , isSubmapOf, isSubmapOfBy@@ -208,7 +209,7 @@ -- * Internals , bin , balanced- , join+ , link , merge #endif
Data/Map/Strict.hs view
@@ -178,6 +178,7 @@ , split , splitLookup+ , splitRoot -- * Submap , isSubmapOf, isSubmapOfBy@@ -215,7 +216,7 @@ -- * Internals , bin , balanced- , join+ , link , merge #endif ) where@@ -842,18 +843,18 @@ go t1 t2 = hedgeMerge NothingS NothingS t1 t2 hedgeMerge _ _ t1 Tip = g1 t1- hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ join kx x (filterGt blo l) (filterLt bhi r)+ hedgeMerge blo bhi Tip (Bin _ kx x l r) = g2 $ link kx x (filterGt blo l) (filterLt bhi r) hedgeMerge blo bhi (Bin _ kx x l r) t2 = let l' = hedgeMerge blo bmi l (trim blo bmi t2) (found, trim_t2) = trimLookupLo kx bhi t2 r' = hedgeMerge bmi bhi r trim_t2 in case found of Nothing -> case g1 (singleton kx x) of Tip -> merge l' r'- (Bin _ _ x' Tip Tip) -> join kx x' l' r'+ (Bin _ _ x' Tip Tip) -> link kx x' l' r' _ -> error "mergeWithKey: Given function only1 does not fulfil required conditions (see documentation)" Just x2 -> case f kx x x2 of Nothing -> merge l' r'- Just x' -> x' `seq` join kx x' l' r'+ Just x' -> x' `seq` link kx x' l' r' where bmi = JustS kx {-# INLINE mergeWithKey #-} @@ -877,7 +878,7 @@ mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b mapMaybeWithKey _ Tip = Tip mapMaybeWithKey f (Bin _ kx x l r) = case f kx x of- Just y -> y `seq` join kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r)+ Just y -> y `seq` link kx y (mapMaybeWithKey f l) (mapMaybeWithKey f r) Nothing -> merge (mapMaybeWithKey f l) (mapMaybeWithKey f r) -- | /O(n)/. Map values and separate the 'Left' and 'Right' results.@@ -907,8 +908,8 @@ where go _ Tip = (Tip :*: Tip) go f (Bin _ kx x l r) = case f kx x of- Left y -> y `seq` (join kx y l1 r1 :*: merge l2 r2)- Right z -> z `seq` (merge l1 r1 :*: join kx z l2 r2)+ Left y -> y `seq` (link kx y l1 r1 :*: merge l2 r2)+ Right z -> z `seq` (merge l1 r1 :*: link kx z l2 r2) where (l1 :*: l2) = go f l (r1 :*: r2) = go f r@@ -1039,8 +1040,8 @@ go _ t [(kx, x)] = x `seq` insertMax kx x t go s l xs@((kx, x) : xss) | not_ordered kx xss = fromList' l xs | otherwise = case create s xss of- (r, ys, []) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys- (r, _, ys) -> x `seq` fromList' (join kx x l r) ys+ (r, ys, []) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys+ (r, _, ys) -> x `seq` fromList' (link kx x l r) ys -- The create is returning a triple (tree, xs, ys). Both xs and ys -- represent not yet processed elements and only one of them can be nonempty.@@ -1057,7 +1058,7 @@ (l, [(ky, y)], zs) -> y `seq` (insertMax ky y l, [], zs) (l, ys@((ky, y):yss), _) | not_ordered ky yss -> (l, [], ys) | otherwise -> case create (s `shiftR` 1) yss of- (r, zs, ws) -> y `seq` (join ky y l r, zs, ws)+ (r, zs, ws) -> y `seq` (link ky y l r, zs, ws) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif@@ -1169,7 +1170,7 @@ STRICT_1_OF_3(go) go _ t [] = t go s l ((kx, x) : xs) = case create s xs of- (r, ys) -> x `seq` go (s `shiftL` 1) (join kx x l r) ys+ (r, ys) -> x `seq` go (s `shiftL` 1) (link kx x l r) ys STRICT_1_OF_2(create) create _ [] = (Tip, [])@@ -1178,4 +1179,4 @@ | otherwise = case create (s `shiftR` 1) xs of res@(_, []) -> res (l, (ky, y):ys) -> case create (s `shiftR` 1) ys of- (r, zs) -> y `seq` (join ky y l r, zs)+ (r, zs) -> y `seq` (link ky y l r, zs)
Data/Set.hs view
@@ -80,6 +80,7 @@ , partition , split , splitMember+ , splitRoot -- * Indexed , lookupIndex@@ -132,7 +133,7 @@ -- Internals (for testing) , bin , balanced- , join+ , link , merge #endif ) where
Data/Set/Base.hs view
@@ -126,6 +126,7 @@ , partition , split , splitMember+ , splitRoot -- * Indexed , lookupIndex@@ -177,7 +178,7 @@ -- Internals (for testing) , bin , balanced- , join+ , link , merge ) where @@ -568,10 +569,10 @@ hedgeUnion :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a hedgeUnion _ _ t1 Tip = t1-hedgeUnion blo bhi Tip (Bin _ x l r) = join x (filterGt blo l) (filterLt bhi r)+hedgeUnion blo bhi Tip (Bin _ x l r) = link x (filterGt blo l) (filterLt bhi r) hedgeUnion _ _ t1 (Bin _ x Tip Tip) = insertR x t1 -- According to benchmarks, this special case increases -- performance up to 30%. It does not help in difference or intersection.-hedgeUnion blo bhi (Bin _ x l r) t2 = join x (hedgeUnion blo bmi l (trim blo bmi t2))+hedgeUnion blo bhi (Bin _ x l r) t2 = link x (hedgeUnion blo bmi l (trim blo bmi t2)) (hedgeUnion bmi bhi r (trim bmi bhi t2)) where bmi = JustS x #if __GLASGOW_HASKELL__ >= 700@@ -593,7 +594,7 @@ hedgeDiff :: Ord a => MaybeS a -> MaybeS a -> Set a -> Set a -> Set a hedgeDiff _ _ Tip _ = Tip-hedgeDiff blo bhi (Bin _ x l r) Tip = join x (filterGt blo l) (filterLt bhi r)+hedgeDiff blo bhi (Bin _ x l r) Tip = link x (filterGt blo l) (filterLt bhi r) hedgeDiff blo bhi t (Bin _ x l r) = merge (hedgeDiff blo bmi (trim blo bmi t) l) (hedgeDiff bmi bhi (trim bmi bhi t) r) where bmi = JustS x@@ -629,7 +630,7 @@ hedgeInt _ _ Tip _ = Tip hedgeInt blo bhi (Bin _ x l r) t2 = let l' = hedgeInt blo bmi l (trim blo bmi t2) r' = hedgeInt bmi bhi r (trim bmi bhi t2)- in if x `member` t2 then join x l' r' else merge l' r'+ in if x `member` t2 then link x l' r' else merge l' r' where bmi = JustS x #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE hedgeInt #-}@@ -642,7 +643,7 @@ filter :: (a -> Bool) -> Set a -> Set a filter _ Tip = Tip filter p (Bin _ x l r)- | p x = join x (filter p l) (filter p r)+ | p x = link x (filter p l) (filter p r) | otherwise = merge (filter p l) (filter p r) -- | /O(n)/. Partition the set into two sets, one with all elements that satisfy@@ -654,8 +655,8 @@ go _ Tip = (Tip :*: Tip) go p (Bin _ x l r) = case (go p l, go p r) of ((l1 :*: l2), (r1 :*: r2))- | p x -> join x l1 r1 :*: merge l2 r2- | otherwise -> merge l1 r1 :*: join x l2 r2+ | p x -> link x l1 r1 :*: merge l2 r2+ | otherwise -> merge l1 r1 :*: link x l2 r2 {---------------------------------------------------------------------- Map@@ -825,8 +826,8 @@ go _ t [x] = insertMax x t go s l xs@(x : xss) | not_ordered x xss = fromList' l xs | otherwise = case create s xss of- (r, ys, []) -> go (s `shiftL` 1) (join x l r) ys- (r, _, ys) -> fromList' (join x l r) ys+ (r, ys, []) -> go (s `shiftL` 1) (link x l r) ys+ (r, _, ys) -> fromList' (link x l r) ys -- The create is returning a triple (tree, xs, ys). Both xs and ys -- represent not yet processed elements and only one of them can be nonempty.@@ -843,7 +844,7 @@ (l, [y], zs) -> (insertMax y l, [], zs) (l, ys@(y:yss), _) | not_ordered y yss -> (l, [], ys) | otherwise -> case create (s `shiftR` 1) yss of- (r, zs, ws) -> (join y l r, zs, ws)+ (r, zs, ws) -> (link y l r, zs, ws) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE fromList #-} #endif@@ -888,7 +889,7 @@ STRICT_1_OF_3(go) go _ t [] = t go s l (x : xs) = case create s xs of- (r, ys) -> go (s `shiftL` 1) (join x l r) ys+ (r, ys) -> go (s `shiftL` 1) (link x l r) ys STRICT_1_OF_2(create) create _ [] = (Tip, [])@@ -897,7 +898,7 @@ | otherwise = case create (s `shiftR` 1) xs of res@(_, []) -> res (l, y:ys) -> case create (s `shiftR` 1) ys of- (r, zs) -> (join y l r, zs)+ (r, zs) -> (link y l r, zs) {-------------------------------------------------------------------- Eq converts the set to a list. In a lazy setting, this@@ -1001,7 +1002,7 @@ filterGt (JustS b) t = filter' b t where filter' _ Tip = Tip filter' b' (Bin _ x l r) =- case compare b' x of LT -> join x (filter' b' l) r+ case compare b' x of LT -> link x (filter' b' l) r EQ -> r GT -> filter' b' r #if __GLASGOW_HASKELL__ >= 700@@ -1013,7 +1014,7 @@ filterLt (JustS b) t = filter' b t where filter' _ Tip = Tip filter' b' (Bin _ x l r) =- case compare x b' of LT -> join x l (filter' b' r)+ case compare x b' of LT -> link x l (filter' b' r) EQ -> l GT -> filter' b' l #if __GLASGOW_HASKELL__ >= 700@@ -1032,8 +1033,8 @@ go _ Tip = (Tip :*: Tip) go x (Bin _ y l r) = case compare x y of- LT -> let (lt :*: gt) = go x l in (lt :*: join y gt r)- GT -> let (lt :*: gt) = go x r in (join y l lt :*: gt)+ LT -> let (lt :*: gt) = go x l in (lt :*: link y gt r)+ GT -> let (lt :*: gt) = go x r in (link y l lt :*: gt) EQ -> (l :*: r) #if __GLASGOW_HASKELL__ >= 700 {-# INLINABLE split #-}@@ -1046,10 +1047,10 @@ splitMember x (Bin _ y l r) = case compare x y of LT -> let (lt, found, gt) = splitMember x l- gt' = join y gt r+ gt' = link y gt r in gt' `seq` (lt, found, gt') GT -> let (lt, found, gt) = splitMember x r- lt' = join y l lt+ lt' = link y l lt in lt' `seq` (lt', found, gt) EQ -> (l, True, r) #if __GLASGOW_HASKELL__ >= 700@@ -1163,7 +1164,7 @@ [balance x l r] Restores the balance and size. Assumes that the original tree was balanced and that [l] or [r] has changed by at most one element.- [join x l r] Restores balance and size.+ [link x l r] Restores balance and size. Furthermore, we can construct a new tree from two trees. Both operations assume that all values in [l] < all values in [r] and that [l] and [r]@@ -1173,7 +1174,7 @@ [merge l r] Merges two trees and restores balance. Note: in contrast to Adam's paper, we use (<=) comparisons instead- of (<) comparisons in [join], [merge] and [balance].+ of (<) comparisons in [link], [merge] and [balance]. Quickcheck (on [difference]) showed that this was necessary in order to maintain the invariants. It is quite unsatisfactory that I haven't been able to find out why this is actually the case! Fortunately, it@@ -1181,14 +1182,14 @@ --------------------------------------------------------------------} {--------------------------------------------------------------------- Join+ Link --------------------------------------------------------------------}-join :: a -> Set a -> Set a -> Set a-join x Tip r = insertMin x r-join x l Tip = insertMax x l-join x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)- | delta*sizeL < sizeR = balanceL z (join x l lz) rz- | delta*sizeR < sizeL = balanceR y ly (join x ry r)+link :: a -> Set a -> Set a -> Set a+link x Tip r = insertMin x r+link x l Tip = insertMax x l+link x l@(Bin sizeL y ly ry) r@(Bin sizeR z lz rz)+ | delta*sizeL < sizeR = balanceL z (link x l lz) rz+ | delta*sizeR < sizeL = balanceR y ly (link x ry r) | otherwise = bin x l r @@ -1403,6 +1404,32 @@ go z [] = z go z (x:xs) = let z' = f z x in z' `seq` go z' xs {-# INLINE foldlStrict #-}++-- | /O(1)/. Decompose a set into pieces based on the structure of the underlying+-- tree. This function is useful for consuming a set in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this. However, it is guaranteed that the pieces+-- returned will be in ascending order (all elements in the first subset less than all+-- elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList [1..6]) ==+-- > [fromList [1,2,3],fromList [4],fromList [5,6]]+--+-- > splitRoot empty == []+--+-- Note that the current implementation does not return more than three subsets,+-- but you should not depend on this behaviour because it can change in the+-- future without notice.+splitRoot :: Set a -> [Set a]+splitRoot orig =+ case orig of+ Tip -> []+ Bin _ v l r -> [l, singleton v, r]+{-# INLINE splitRoot #-}+ {-------------------------------------------------------------------- Debugging
containers.cabal view
@@ -1,5 +1,5 @@ name: containers-version: 0.5.3.1+version: 0.5.4.0 license: BSD3 license-file: LICENSE maintainer: fox@ucw.cz
tests/intmap-properties.hs view
@@ -160,6 +160,7 @@ , testProperty "fmap" prop_fmap , testProperty "mapkeys" prop_mapkeys , testProperty "split" prop_splitModel+ , testProperty "splitRoot" prop_splitRoot , testProperty "foldr" prop_foldr , testProperty "foldr'" prop_foldr' , testProperty "foldl" prop_foldl@@ -993,6 +994,16 @@ (l, r) = split n $ fromList xs in toAscList l == sort [(k, v) | (k,v) <- xs, k < n] && toAscList r == sort [(k, v) | (k,v) <- xs, k > n]++prop_splitRoot :: IMap -> Bool+prop_splitRoot s = loop ls && (s == unions ls)+ where+ ls = splitRoot s+ loop [] = True+ loop (s1:rst) = List.null+ [ (x,y) | x <- toList s1+ , y <- toList (unions rst)+ , x > y ] prop_foldr :: Int -> [(Int, Int)] -> Property prop_foldr n ys = length ys > 0 ==>
tests/intset-properties.hs view
@@ -63,6 +63,7 @@ , testProperty "prop_minView" prop_minView , testProperty "prop_split" prop_split , testProperty "prop_splitMember" prop_splitMember+ , testProperty "prop_splitRoot" prop_splitRoot , testProperty "prop_partition" prop_partition , testProperty "prop_filter" prop_filter #if MIN_VERSION_base(4,5,0)@@ -307,6 +308,16 @@ prop_splitMember :: IntSet -> Int -> Bool prop_splitMember s i = case splitMember i s of (s1,t,s2) -> all (<i) (toList s1) && all (>i) (toList s2) && t == i `member` s && i `delete` s == union s1 s2++prop_splitRoot :: IntSet -> Bool+prop_splitRoot s = loop ls && (s == unions ls)+ where+ ls = splitRoot s+ loop [] = True+ loop (s1:rst) = List.null+ [ (x,y) | x <- toList s1+ , y <- toList (unions rst)+ , x > y ] prop_partition :: IntSet -> Int -> Bool prop_partition s i = case partition odd s of
tests/map-properties.hs view
@@ -136,7 +136,8 @@ , testProperty "deleteMin" prop_deleteMin , testProperty "deleteMax" prop_deleteMax , testProperty "split" prop_split- , testProperty "split then join" prop_join+ , testProperty "splitRoot" prop_splitRoot+ , testProperty "split then link" prop_link , testProperty "split then merge" prop_merge , testProperty "union" prop_union , testProperty "union model" prop_unionModel@@ -859,9 +860,19 @@ prop_split k t = let (r,l) = split k t in (valid r, valid l) == (True, True) -prop_join :: Int -> UMap -> Bool-prop_join k t = let (l,r) = split k t- in valid (join k () l r)+prop_splitRoot :: UMap -> Bool+prop_splitRoot s = loop ls && (s == unions ls)+ where+ ls = splitRoot s+ loop [] = True+ loop (s1:rst) = List.null+ [ (x,y) | x <- toList s1+ , y <- toList (unions rst)+ , x > y ]++prop_link :: Int -> UMap -> Bool+prop_link k t = let (l,r) = split k t+ in valid (link k () l r) prop_merge :: Int -> UMap -> Bool prop_merge k t = let (l,r) = split k t
tests/set-properties.hs view
@@ -31,7 +31,7 @@ , testProperty "prop_InsertValid" prop_InsertValid , testProperty "prop_InsertDelete" prop_InsertDelete , testProperty "prop_DeleteValid" prop_DeleteValid- , testProperty "prop_Join" prop_Join+ , testProperty "prop_Link" prop_Link , testProperty "prop_Merge" prop_Merge , testProperty "prop_UnionValid" prop_UnionValid , testProperty "prop_UnionInsert" prop_UnionInsert@@ -64,6 +64,7 @@ , testProperty "prop_minView" prop_minView , testProperty "prop_split" prop_split , testProperty "prop_splitMember" prop_splitMember+ , testProperty "prop_splitRoot" prop_splitRoot , testProperty "prop_partition" prop_partition , testProperty "prop_filter" prop_filter ]@@ -215,10 +216,10 @@ {-------------------------------------------------------------------- Balance --------------------------------------------------------------------}-prop_Join :: Int -> Property-prop_Join x = forValidUnitTree $ \t ->+prop_Link :: Int -> Property+prop_Link x = forValidUnitTree $ \t -> let (l,r) = split x t- in valid (join x l r)+ in valid (link x l r) prop_Merge :: Int -> Property prop_Merge x = forValidUnitTree $ \t ->@@ -358,6 +359,16 @@ prop_splitMember :: Set Int -> Int -> Bool prop_splitMember s i = case splitMember i s of (s1,t,s2) -> all (<i) (toList s1) && all (>i) (toList s2) && t == i `member` s && i `delete` s == union s1 s2++prop_splitRoot :: Set Int -> Bool+prop_splitRoot s = loop ls && (s == unions ls)+ where+ ls = splitRoot s+ loop [] = True+ loop (s1:rst) = List.null+ [ (x,y) | x <- toList s1+ , y <- toList (unions rst)+ , x > y ] prop_partition :: Set Int -> Int -> Bool prop_partition s i = case partition odd s of