From bf3fca965d5a6a5a2ff99bff255d0e93bc638397 Mon Sep 17 00:00:00 2001 From: meooow25 Date: Wed, 12 Jul 2023 21:51:51 +0530 Subject: [PATCH 1/4] Consistent property tests for {Set,Map}.fromAscList and friends --- containers-tests/tests/map-properties.hs | 105 +++++++++++++++++++---- containers-tests/tests/set-properties.hs | 40 +++++---- 2 files changed, 114 insertions(+), 31 deletions(-) diff --git a/containers-tests/tests/map-properties.hs b/containers-tests/tests/map-properties.hs index 637b7661c..c91f4fd08 100644 --- a/containers-tests/tests/map-properties.hs +++ b/containers-tests/tests/map-properties.hs @@ -28,6 +28,8 @@ import qualified Prelude import Data.List (nub,sort) import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import Test.Tasty import Test.Tasty.HUnit @@ -184,9 +186,13 @@ main = defaultMain $ testGroup "map-properties" , testProperty "unionWithKeyMerge" prop_unionWithKeyMerge , testProperty "mergeWithKey model" prop_mergeWithKeyModel , testProperty "mergeA effects" prop_mergeA_effects - , testProperty "fromAscList" prop_ordered + , testProperty "fromAscList" prop_fromAscList + , testProperty "fromAscListWith" prop_fromAscListWith + , testProperty "fromAscListWithKey" prop_fromAscListWithKey , testProperty "fromDistinctAscList" prop_fromDistinctAscList - , testProperty "fromDescList" prop_rev_ordered + , testProperty "fromDescList" prop_fromDescList + , testProperty "fromDescListWith" prop_fromDescListWith + , testProperty "fromDescListWithKey" prop_fromDescListWithKey , testProperty "fromDistinctDescList" prop_fromDistinctDescList , testProperty "fromList then toList" prop_list , testProperty "toDescList" prop_descList @@ -1222,17 +1228,24 @@ prop_mergeA_effects xs ys ---------------------------------------------------------------- -prop_ordered :: Property -prop_ordered - = forAll (choose (5,100)) $ \n -> - let xs = [(x,()) | x <- [0..n::Int]] - in fromAscList xs == fromList xs - -prop_rev_ordered :: Property -prop_rev_ordered - = forAll (choose (5,100)) $ \n -> - let xs = [(x,()) | x <- [0..n::Int]] - in fromDescList (reverse xs) == fromList xs +-- fromAscListWith, fromAscListWithKey, fromDescListWith, fromDescListWithKey +-- all effectively perform a left fold over adjacent elements in the input list +-- using some function as long as the keys are equal. +-- +-- The property tests for these functions compare the result against the +-- sequence we would get if we used NE.groupBy instead. We use Magma to check +-- the fold direction (left, not right) and the order of arguments to the fold +-- function (new then old). + +data Magma a + = Inj a + | Magma a :* Magma a + deriving (Eq, Show) + +groupByK :: Eq k => [(k, a)] -> [(k, NonEmpty a)] +groupByK = + List.map (\ys -> (fst (NE.head ys), NE.map snd ys)) . + NE.groupBy ((==) `on` fst) prop_list :: [Int] -> Bool prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- xs])]) @@ -1240,13 +1253,43 @@ prop_list xs = (sort (nub xs) == [x | (x,()) <- toList (fromList [(x,()) | x <- prop_descList :: [Int] -> Bool prop_descList xs = (reverse (sort (nub xs)) == [x | (x,()) <- toDescList (fromList [(x,()) | x <- xs])]) +prop_fromDescList :: [(Int, A)] -> Property +prop_fromDescList xs = + valid t .&&. + toList t === reverse nub_last_down_sort_xs + where + down_sort_xs = List.sortBy (comparing (Down . fst)) xs + t = fromDescList down_sort_xs + nub_last_down_sort_xs = List.map NE.last $ NE.groupBy ((==) `on` fst) down_sort_xs + +prop_fromDescListWith :: [(Int, A)] -> Property +prop_fromDescListWith ys = + valid t .&&. + toList t === reverse combined_down_sort_xs + where + xs = [(kx, Inj x) | (kx,x) <- ys] + down_sort_xs = List.sortBy (comparing (Down . fst)) xs + t = fromDescListWith (:*) down_sort_xs + combined_down_sort_xs = [(kx, Foldable.foldl1 (flip (:*)) x) | (kx,x) <- groupByK down_sort_xs] + +prop_fromDescListWithKey :: [(Int, A)] -> Property +prop_fromDescListWithKey ys = + valid t .&&. + toList t === reverse combined_down_sort_xs + where + xs = [(kx, Inj (Left x)) | (kx,x) <- ys] + down_sort_xs = List.sortBy (comparing (Down . fst)) xs + t = fromDescListWithKey (\kx (Inj (Left x)) acc -> Inj (Right (kx,x)) :* acc) down_sort_xs + combined_down_sort_xs = [ (kx, Foldable.foldl1 (\acc (Inj (Left x)) -> Inj (Right (kx,x)) :* acc) xs) + | (kx,xs) <- groupByK down_sort_xs ] + prop_fromDistinctDescList :: [(Int, A)] -> Property prop_fromDistinctDescList xs = valid t .&&. - toList t === nub_sort_xs + toList t === reverse nub_down_sort_xs where - t = fromDistinctDescList (reverse nub_sort_xs) - nub_sort_xs = List.map List.head $ List.groupBy ((==) `on` fst) $ List.sortBy (comparing fst) xs + t = fromDistinctDescList nub_down_sort_xs + nub_down_sort_xs = List.map NE.last $ NE.groupBy ((==) `on` fst) $ List.sortBy (comparing (Down . fst)) xs prop_ascDescList :: [Int] -> Bool prop_ascDescList xs = toAscList m == reverse (toDescList m) @@ -1259,6 +1302,36 @@ prop_fromList xs t == List.foldr (uncurry insert) empty (zip xs xs) where sort_xs = sort xs +prop_fromAscList :: [(Int, A)] -> Property +prop_fromAscList xs = + valid t .&&. + toList t === nub_last_sort_xs + where + sort_xs = List.sortBy (comparing fst) xs + t = fromAscList sort_xs + nub_last_sort_xs = List.map NE.last $ NE.groupBy ((==) `on` fst) sort_xs + +prop_fromAscListWith :: [(Int, A)] -> Property +prop_fromAscListWith ys = + valid t .&&. + toList t === combined_sort_xs + where + xs = [(kx, Inj x) | (kx,x) <- ys] + sort_xs = List.sortBy (comparing fst) xs + t = fromAscListWith (:*) sort_xs + combined_sort_xs = [(kx, Foldable.foldl1 (flip (:*)) x) | (kx,x) <- groupByK sort_xs] + +prop_fromAscListWithKey :: [(Int, A)] -> Property +prop_fromAscListWithKey ys = + valid t .&&. + toList t === combined_sort_xs + where + xs = [(kx, Inj (Left x)) | (kx,x) <- ys] + sort_xs = List.sortBy (comparing fst) xs + t = fromAscListWithKey (\kx (Inj (Left x)) acc -> Inj (Right (kx,x)) :* acc) sort_xs + combined_sort_xs = [ (kx, Foldable.foldl1 (\acc (Inj (Left x)) -> Inj (Right (kx,x)) :* acc) xs) + | (kx,xs) <- groupByK sort_xs ] + prop_fromDistinctAscList :: [(Int, A)] -> Property prop_fromDistinctAscList xs = valid t .&&. diff --git a/containers-tests/tests/set-properties.hs b/containers-tests/tests/set-properties.hs index 637d772ad..922832593 100644 --- a/containers-tests/tests/set-properties.hs +++ b/containers-tests/tests/set-properties.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} import qualified Data.IntSet as IntSet -import Data.List (nub,sort) +import Data.List (nub, sort, sortBy) import qualified Data.List as List import Data.Monoid (mempty) import Data.Maybe @@ -15,6 +15,7 @@ import Control.Monad.Trans.Class import Control.Monad (liftM, liftM3) import Data.Functor.Identity import Data.Foldable (all) +import Data.Ord (Down(..), comparing) import Control.Applicative (liftA2) #if __GLASGOW_HASKELL__ >= 806 @@ -67,8 +68,9 @@ main = defaultMain $ testGroup "set-properties" , testProperty "prop_DescList" prop_DescList , testProperty "prop_AscDescList" prop_AscDescList , testProperty "prop_fromList" prop_fromList + , testProperty "prop_fromAscList" prop_fromAscList , testProperty "prop_fromDistinctAscList" prop_fromDistinctAscList - , testProperty "prop_fromListDesc" prop_fromListDesc + , testProperty "prop_fromDescList" prop_fromDescList , testProperty "prop_fromDistinctDescList" prop_fromDistinctDescList , testProperty "prop_isProperSubsetOf" prop_isProperSubsetOf , testProperty "prop_isProperSubsetOf2" prop_isProperSubsetOf2 @@ -515,10 +517,18 @@ prop_AscDescList xs = toAscList s == reverse (toDescList s) prop_fromList :: [Int] -> Property prop_fromList xs = - t === fromAscList sort_xs .&&. + valid t .&&. t === List.foldr insert empty xs where t = fromList xs - sort_xs = sort xs + +prop_fromAscList :: [Int] -> Property +prop_fromAscList xs = + valid t .&&. + toList t === nub_sort_xs + where + sort_xs = sort xs + t = fromAscList sort_xs + nub_sort_xs = List.map List.head $ List.group sort_xs prop_fromDistinctAscList :: [Int] -> Property prop_fromDistinctAscList xs = @@ -528,22 +538,22 @@ prop_fromDistinctAscList xs = t = fromDistinctAscList nub_sort_xs nub_sort_xs = List.map List.head $ List.group $ sort xs -prop_fromListDesc :: [Int] -> Property -prop_fromListDesc xs = - t === fromDescList sort_xs .&&. - t === fromDistinctDescList nub_sort_xs .&&. - t === List.foldr insert empty xs - where t = fromList xs - sort_xs = reverse (sort xs) - nub_sort_xs = List.map List.head $ List.group sort_xs +prop_fromDescList :: [Int] -> Property +prop_fromDescList xs = + valid t .&&. + toList t === reverse nub_down_sort_xs + where + down_sort_xs = sortBy (comparing Down) xs + t = fromDescList down_sort_xs + nub_down_sort_xs = List.map List.head $ List.group down_sort_xs prop_fromDistinctDescList :: [Int] -> Property prop_fromDistinctDescList xs = valid t .&&. - toList t === nub_sort_xs + toList t === reverse nub_down_sort_xs where - t = fromDistinctDescList (reverse nub_sort_xs) - nub_sort_xs = List.map List.head $ List.group $ sort xs + t = fromDistinctDescList nub_down_sort_xs + nub_down_sort_xs = List.map List.head $ List.group $ sortBy (comparing Down) xs {-------------------------------------------------------------------- Set operations are like IntSet operations From 1b08c4b0e0d48a8f6c0aa034a3e93007b90a5f7a Mon Sep 17 00:00:00 2001 From: meooow25 Date: Wed, 12 Jul 2023 01:22:05 +0530 Subject: [PATCH 2/4] Add benchmarks for {Set,Map}.fromAscList and friends --- containers-tests/benchmarks/Map.hs | 9 +++++++-- containers-tests/benchmarks/Set.hs | 7 +++++-- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/containers-tests/benchmarks/Map.hs b/containers-tests/benchmarks/Map.hs index b53a4914d..2948eb194 100644 --- a/containers-tests/benchmarks/Map.hs +++ b/containers-tests/benchmarks/Map.hs @@ -21,7 +21,7 @@ main = do m_even = M.fromAscList elems_even :: M.Map Int Int m_odd = M.fromAscList elems_odd :: M.Map Int Int evaluate $ rnf [m, m_even, m_odd] - evaluate $ rnf elems_rev + evaluate $ rnf [elems_rev, elems_asc, elems_desc] defaultMain [ bench "lookup absent" $ whnf (lookup evens) m_odd , bench "lookup present" $ whnf (lookup evens) m_even @@ -89,7 +89,8 @@ main = do , bench "split" $ whnf (M.split (bound `div` 2)) m , bench "fromList" $ whnf M.fromList elems , bench "fromList-desc" $ whnf M.fromList (reverse elems) - , bench "fromAscList" $ whnf M.fromAscList elems + , bench "fromAscList" $ whnf M.fromAscList elems_asc + , bench "fromDescList" $ whnf M.fromDescList elems_desc , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems , bench "fromDistinctAscList:fusion" $ whnf (\n -> M.fromDistinctAscList [(i,i) | i <- [1..n]]) bound , bench "fromDistinctDescList" $ whnf M.fromDistinctDescList elems_rev @@ -102,6 +103,10 @@ main = do elems_even = zip evens evens elems_odd = zip odds odds elems_rev = reverse elems + keys_asc = map (`div` 2) [1..bound] + elems_asc = zip keys_asc values + keys_desc = map (`div` 2) [bound,bound-1..1] + elems_desc = zip keys_desc values keys = [1..bound] evens = [2,4..bound] odds = [1,3..bound] diff --git a/containers-tests/benchmarks/Set.hs b/containers-tests/benchmarks/Set.hs index f65e2a620..add558753 100644 --- a/containers-tests/benchmarks/Set.hs +++ b/containers-tests/benchmarks/Set.hs @@ -14,7 +14,7 @@ main = do s_odd = S.fromAscList elems_odd :: S.Set Int strings_s = S.fromList strings evaluate $ rnf [s, s_even, s_odd] - evaluate $ rnf elems_rev + evaluate $ rnf [elems_rev, elems_asc, elems_desc] defaultMain [ bench "member" $ whnf (member elems) s , bench "insert" $ whnf (ins elems) S.empty @@ -33,9 +33,10 @@ main = do , bench "intersection" $ whnf (S.intersection s) s_even , bench "fromList" $ whnf S.fromList elems , bench "fromList-desc" $ whnf S.fromList (reverse elems) - , bench "fromAscList" $ whnf S.fromAscList elems + , bench "fromAscList" $ whnf S.fromAscList elems_asc , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems , bench "fromDistinctAscList:fusion" $ whnf (\n -> S.fromDistinctAscList [1..n]) bound + , bench "fromDescList" $ whnf S.fromDescList elems_desc , bench "fromDistinctDescList" $ whnf S.fromDistinctDescList elems_rev , bench "fromDistinctDescList:fusion" $ whnf (\n -> S.fromDistinctDescList [n,n-1..1]) bound , bench "disjoint:false" $ whnf (S.disjoint s) s_even @@ -62,6 +63,8 @@ main = do elems_even = [2,4..bound] elems_odd = [1,3..bound] elems_rev = reverse elems + elems_asc = map (`div` 2) [1..bound] + elems_desc = map (`div` 2) [bound,bound-1..1] strings = map show elems member :: [Int] -> S.Set Int -> Int From 61e8e9d8fb1c83c81197843d9299d15389f6fdc7 Mon Sep 17 00:00:00 2001 From: meooow25 Date: Sun, 16 Jul 2023 22:40:14 +0530 Subject: [PATCH 3/4] Fusion benchmarks for {Set,Map}.fromAscList and friends --- containers-tests/benchmarks/Map.hs | 2 ++ containers-tests/benchmarks/Set.hs | 2 ++ 2 files changed, 4 insertions(+) diff --git a/containers-tests/benchmarks/Map.hs b/containers-tests/benchmarks/Map.hs index 2948eb194..527684d4c 100644 --- a/containers-tests/benchmarks/Map.hs +++ b/containers-tests/benchmarks/Map.hs @@ -90,7 +90,9 @@ main = do , bench "fromList" $ whnf M.fromList elems , bench "fromList-desc" $ whnf M.fromList (reverse elems) , bench "fromAscList" $ whnf M.fromAscList elems_asc + , bench "fromAscList:fusion" $ whnf (\n -> M.fromAscList [(i `div` 2, i) | i <- [1..n]]) bound , bench "fromDescList" $ whnf M.fromDescList elems_desc + , bench "fromDescList:fusion" $ whnf (\n -> M.fromDescList [(i `div` 2, i) | i <- [n,n-1..1]]) bound , bench "fromDistinctAscList" $ whnf M.fromDistinctAscList elems , bench "fromDistinctAscList:fusion" $ whnf (\n -> M.fromDistinctAscList [(i,i) | i <- [1..n]]) bound , bench "fromDistinctDescList" $ whnf M.fromDistinctDescList elems_rev diff --git a/containers-tests/benchmarks/Set.hs b/containers-tests/benchmarks/Set.hs index add558753..061e779a7 100644 --- a/containers-tests/benchmarks/Set.hs +++ b/containers-tests/benchmarks/Set.hs @@ -36,7 +36,9 @@ main = do , bench "fromAscList" $ whnf S.fromAscList elems_asc , bench "fromDistinctAscList" $ whnf S.fromDistinctAscList elems , bench "fromDistinctAscList:fusion" $ whnf (\n -> S.fromDistinctAscList [1..n]) bound + , bench "fromAscList:fusion" $ whnf (\n -> S.fromAscList [i `div` 2 | i <- [1..n]]) bound , bench "fromDescList" $ whnf S.fromDescList elems_desc + , bench "fromDescList:fusion" $ whnf (\n -> S.fromDescList [i `div` 2 | i <- [n,n-1..1]]) bound , bench "fromDistinctDescList" $ whnf S.fromDistinctDescList elems_rev , bench "fromDistinctDescList:fusion" $ whnf (\n -> S.fromDistinctDescList [n,n-1..1]) bound , bench "disjoint:false" $ whnf (S.disjoint s) s_even From 92d71397f14f20d1dc64e56ba210c603ddb5d872 Mon Sep 17 00:00:00 2001 From: meooow25 Date: Sun, 16 Jul 2023 22:40:42 +0530 Subject: [PATCH 4/4] Fusion-friendly {Set,Map}.fromAscList and friends --- containers/src/Data/Map/Internal.hs | 117 +++++++++------------ containers/src/Data/Map/Strict/Internal.hs | 98 +++++++++-------- containers/src/Data/Set/Internal.hs | 38 +++++-- 3 files changed, 136 insertions(+), 117 deletions(-) diff --git a/containers/src/Data/Map/Internal.hs b/containers/src/Data/Map/Internal.hs index 8f7523a4e..b86ecbd7d 100644 --- a/containers/src/Data/Map/Internal.hs +++ b/containers/src/Data/Map/Internal.hs @@ -3564,22 +3564,9 @@ foldlFB = foldlWithKey -- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False fromAscList :: Eq k => [(k,a)] -> Map k a -fromAscList xs - = fromDistinctAscList (combineEq xs) - where - -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] - combineEq xs' - = case xs' of - [] -> [] - [x] -> [x] - (x:xx) -> combineEq' x xx - - combineEq' z [] = [z] - combineEq' z@(kz,_) (x@(kx,xx):xs') - | kx==kz = combineEq' (kx,xx) xs' - | otherwise = z:combineEq' x xs' +fromAscList = fromDistinctAscList . combineEq (\_ x _ -> x) #if __GLASGOW_HASKELL__ -{-# INLINABLE fromAscList #-} +{-# INLINE fromAscList #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a map from a descending list in linear time. @@ -3593,21 +3580,9 @@ fromAscList xs -- @since 0.5.8 fromDescList :: Eq k => [(k,a)] -> Map k a -fromDescList xs = fromDistinctDescList (combineEq xs) - where - -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] - combineEq xs' - = case xs' of - [] -> [] - [x] -> [x] - (x:xx) -> combineEq' x xx - - combineEq' z [] = [z] - combineEq' z@(kz,_) (x@(kx,xx):xs') - | kx==kz = combineEq' (kx,xx) xs' - | otherwise = z:combineEq' x xs' +fromDescList = fromDistinctDescList . combineEq (\_ x _ -> x) #if __GLASGOW_HASKELL__ -{-# INLINABLE fromDescList #-} +{-# INLINE fromDescList #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a map from an ascending list in linear time with a combining function for equal keys. @@ -3618,10 +3593,9 @@ fromDescList xs = fromDistinctDescList (combineEq xs) -- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWith f xs - = fromAscListWithKey (\_ x y -> f x y) xs +fromAscListWith f = fromDistinctAscList . combineEq (\_ x y -> f x y) #if __GLASGOW_HASKELL__ -{-# INLINABLE fromAscListWith #-} +{-# INLINE fromAscListWith #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a map from a descending list in linear time with a combining function for equal keys. @@ -3634,10 +3608,9 @@ fromAscListWith f xs -- @since 0.5.8 fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a -fromDescListWith f xs - = fromDescListWithKey (\_ x y -> f x y) xs +fromDescListWith f = fromDistinctDescList . combineEq (\_ x y -> f x y) #if __GLASGOW_HASKELL__ -{-# INLINABLE fromDescListWith #-} +{-# INLINE fromDescListWith #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a map from an ascending list in linear time with a @@ -3650,22 +3623,9 @@ fromDescListWith f xs -- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWithKey f xs - = fromDistinctAscList (combineEq f xs) - where - -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] - combineEq _ xs' - = case xs' of - [] -> [] - [x] -> [x] - (x:xx) -> combineEq' x xx - - combineEq' z [] = [z] - combineEq' z@(kz,zz) (x@(kx,xx):xs') - | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs' - | otherwise = z:combineEq' x xs' +fromAscListWithKey f = fromDistinctAscList . combineEq f #if __GLASGOW_HASKELL__ -{-# INLINABLE fromAscListWithKey #-} +{-# INLINE fromAscListWithKey #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a map from a descending list in linear time with a @@ -3677,24 +3637,51 @@ fromAscListWithKey f xs -- > valid (fromDescListWithKey f [(5,"a"), (5,"b"), (5,"b"), (3,"b")]) == True -- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromDescListWithKey f xs - = fromDistinctDescList (combineEq f xs) - where - -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] - combineEq _ xs' - = case xs' of - [] -> [] - [x] -> [x] - (x:xx) -> combineEq' x xx - - combineEq' z [] = [z] - combineEq' z@(kz,zz) (x@(kx,xx):xs') - | kx==kz = let yy = f kx xx zz in combineEq' (kx,yy) xs' - | otherwise = z:combineEq' x xs' +fromDescListWithKey f = fromDistinctDescList . combineEq f #if __GLASGOW_HASKELL__ -{-# INLINABLE fromDescListWithKey #-} +{-# INLINE fromDescListWithKey #-} -- INLINE for fusion #endif +-- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] +combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] +combineEq f = go + where + go xs = case xs of + [] -> [] + [x] -> [x] + (x:xx) -> go' x xx + go' z [] = [z] + go' z@(kz,zz) (x@(kx,xx):xs') + | kx==kz = let yy = f kx xx zz in go' (kx,yy) xs' + | otherwise = z:go' x xs' + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE[0] combineEq #-} + +data Maybe2 a b = Nothing2 | Just2 a b + +combineEqFB :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] +combineEqFB f xs = + build $ \c n -> + let g (kx,xx) k = GHCExts.oneShot $ \mz -> case mz of + Nothing2 -> k (Just2 kx xx) + Just2 kz zz + | kx == kz -> let yy = f kx xx zz in k (Just2 kx yy) + | otherwise -> (kz,zz) `c` k (Just2 kx xx) + h Nothing2 = n + h (Just2 kz zz) = (kz,zz) `c` n + in Foldable.foldr g h xs Nothing2 +{-# INLINE combineEqFB #-} + +-- Rules: Replace with a fusion friendly version that is a good consumer and +-- good producer. +-- combineEq is only used by from{Asc,Desc}List and friends which fuse with +-- fromDistinct{Asc,Desc}List, so there is no point in having a rewrite-back +-- rule. +{-# RULES +"Data.Map.combineEq" combineEq = combineEqFB + #-} +#endif -- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time. -- /The precondition is not checked./ diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs index 81b4127bb..57145a98e 100644 --- a/containers/src/Data/Map/Strict/Internal.hs +++ b/containers/src/Data/Map/Strict/Internal.hs @@ -432,10 +432,8 @@ import Utils.Containers.Internal.StrictPair import Data.Bits (shiftL, shiftR) #ifdef __GLASGOW_HASKELL__ import Data.Coerce -#endif - -#ifdef __GLASGOW_HASKELL__ import Data.Functor.Identity (Identity (..)) +import qualified GHC.Exts as GHCExts #endif import qualified Data.Foldable as Foldable @@ -1589,10 +1587,9 @@ fromListWithKey f xs -- > valid (fromAscList [(3,"b"), (5,"a"), (5,"b")]) == True -- > valid (fromAscList [(5,"a"), (3,"b"), (5,"b")]) == False fromAscList :: Eq k => [(k,a)] -> Map k a -fromAscList xs - = fromAscListWithKey (\_ x _ -> x) xs +fromAscList = fromDistinctAscList . combineEq (\_ x _ -> x) #if __GLASGOW_HASKELL__ -{-# INLINABLE fromAscList #-} +{-# INLINE fromAscList #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a map from a descending list in linear time. @@ -1603,10 +1600,9 @@ fromAscList xs -- > valid (fromDescList [(5,"a"), (5,"b"), (3,"b")]) == True -- > valid (fromDescList [(5,"a"), (3,"b"), (5,"b")]) == False fromDescList :: Eq k => [(k,a)] -> Map k a -fromDescList xs - = fromDescListWithKey (\_ x _ -> x) xs +fromDescList = fromDistinctDescList . combineEq (\_ x _ -> x) #if __GLASGOW_HASKELL__ -{-# INLINABLE fromDescList #-} +{-# INLINE fromDescList #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a map from an ascending list in linear time with a combining function for equal keys. @@ -1617,10 +1613,9 @@ fromDescList xs -- > valid (fromAscListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False fromAscListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWith f xs - = fromAscListWithKey (\_ x y -> f x y) xs +fromAscListWith f = fromDistinctAscList . combineEq (\_ x y -> f x y) #if __GLASGOW_HASKELL__ -{-# INLINABLE fromAscListWith #-} +{-# INLINE fromAscListWith #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a map from a descending list in linear time with a combining function for equal keys. @@ -1631,10 +1626,9 @@ fromAscListWith f xs -- > valid (fromDescListWith (++) [(5,"a"), (3,"b"), (5,"b")]) == False fromDescListWith :: Eq k => (a -> a -> a) -> [(k,a)] -> Map k a -fromDescListWith f xs - = fromDescListWithKey (\_ x y -> f x y) xs +fromDescListWith f = fromDistinctDescList . combineEq (\_ x y -> f x y) #if __GLASGOW_HASKELL__ -{-# INLINABLE fromDescListWith #-} +{-# INLINE fromDescListWith #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a map from an ascending list in linear time with a @@ -1647,22 +1641,9 @@ fromDescListWith f xs -- > valid (fromAscListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromAscListWithKey f xs - = fromDistinctAscList (combineEq f xs) - where - -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] - combineEq _ xs' - = case xs' of - [] -> [] - [x] -> [x] - (x:xx) -> combineEq' x xx - - combineEq' z [] = [z] - combineEq' z@(kz,zz) (x@(kx,xx):xs') - | kx==kz = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs' - | otherwise = z:combineEq' x xs' +fromAscListWithKey f = fromDistinctAscList . combineEq f #if __GLASGOW_HASKELL__ -{-# INLINABLE fromAscListWithKey #-} +{-# INLINE fromAscListWithKey #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a map from a descending list in linear time with a @@ -1675,24 +1656,53 @@ fromAscListWithKey f xs -- > valid (fromDescListWithKey f [(5,"a"), (3,"b"), (5,"b"), (5,"b")]) == False fromDescListWithKey :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> Map k a -fromDescListWithKey f xs - = fromDistinctDescList (combineEq f xs) - where - -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] - combineEq _ xs' - = case xs' of - [] -> [] - [x] -> [x] - (x:xx) -> combineEq' x xx - - combineEq' z [] = [z] - combineEq' z@(kz,zz) (x@(kx,xx):xs') - | kx==kz = let yy = f kx xx zz in yy `seq` combineEq' (kx,yy) xs' - | otherwise = z:combineEq' x xs' +fromDescListWithKey f = fromDistinctDescList . combineEq f #if __GLASGOW_HASKELL__ {-# INLINABLE fromDescListWithKey #-} #endif +-- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs] +-- Strict in the results of f. +combineEq :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] +combineEq f = go + where + go xs = case xs of + [] -> [] + [x] -> [x] + (x:xx) -> go' x xx + go' z [] = [z] + go' z@(kz,zz) (x@(kx,xx):xs') + | kx==kz = let !yy = f kx xx zz in go' (kx,yy) xs' + | otherwise = z:go' x xs' + +#ifdef __GLASGOW_HASKELL__ +{-# INLINE[0] combineEq #-} + +data Maybe2 a b = Nothing2 | Just2 a b + +combineEqFB :: Eq k => (k -> a -> a -> a) -> [(k,a)] -> [(k,a)] +combineEqFB f xs = + GHCExts.build $ \c n -> + let g (kx,xx) k = GHCExts.oneShot $ \mz -> case mz of + Nothing2 -> k (Just2 kx xx) + Just2 kz zz + | kx == kz -> let !yy = f kx xx zz in k (Just2 kx yy) + | otherwise -> (kz,zz) `c` k (Just2 kx xx) + h Nothing2 = n + h (Just2 kz zz) = (kz,zz) `c` n + in Foldable.foldr g h xs Nothing2 +{-# INLINE combineEqFB #-} + +-- Rules: Replace with a fusion friendly version that is a good consumer and +-- good producer. +-- combineEq is only used by from{Asc,Desc}List and friends which fuse with +-- fromDistinct{Asc,Desc}List, so there is no point in having a rewrite-back +-- rule. +{-# RULES +"Data.Map.Strict.combineEq" combineEq = combineEqFB + #-} +#endif + -- | \(O(n)\). Build a map from an ascending list of distinct elements in linear time. -- /The precondition is not checked./ -- diff --git a/containers/src/Data/Set/Internal.hs b/containers/src/Data/Set/Internal.hs index c132e1f93..44abebdb9 100644 --- a/containers/src/Data/Set/Internal.hs +++ b/containers/src/Data/Set/Internal.hs @@ -1137,9 +1137,9 @@ fromList (x0 : xs0) | not_ordered x0 xs0 = fromList' (Bin 1 x0 Tip Tip) xs0 -- | \(O(n)\). Build a set from an ascending list in linear time. -- /The precondition (input list is ascending) is not checked./ fromAscList :: Eq a => [a] -> Set a -fromAscList xs = fromDistinctAscList (combineEq xs) +fromAscList = fromDistinctAscList . combineEq #if __GLASGOW_HASKELL__ -{-# INLINABLE fromAscList #-} +{-# INLINE fromAscList #-} -- INLINE for fusion #endif -- | \(O(n)\). Build a set from a descending list in linear time. @@ -1147,16 +1147,12 @@ fromAscList xs = fromDistinctAscList (combineEq xs) -- -- @since 0.5.8 fromDescList :: Eq a => [a] -> Set a -fromDescList xs = fromDistinctDescList (combineEq xs) +fromDescList = fromDistinctDescList . combineEq #if __GLASGOW_HASKELL__ -{-# INLINABLE fromDescList #-} +{-# INLINE fromDescList #-} -- INLINE for fusion #endif -- [combineEq xs] combines equal elements with [const] in an ordered list [xs] --- --- TODO: combineEq allocates an intermediate list. It *should* be better to --- make fromAscListBy and fromDescListBy the fundamental operations, and to --- implement the rest using those. combineEq :: Eq a => [a] -> [a] combineEq [] = [] combineEq (x : xs) = combineEq' x xs @@ -1166,6 +1162,32 @@ combineEq (x : xs) = combineEq' x xs | z == y = combineEq' z ys | otherwise = z : combineEq' y ys +#ifdef __GLASGOW_HASKELL__ +{-# INLINE[0] combineEq #-} + +combineEqFB :: Eq a => [a] -> [a] +combineEqFB xs = + build $ \c n -> + let g y k = GHCExts.oneShot $ \mz -> case mz of + Nothing -> k (Just y) + Just z + | z == y -> k (Just z) + | otherwise -> z `c` k (Just y) + h Nothing = n + h (Just z) = z `c` n + in Foldable.foldr g h xs Nothing +{-# INLINE combineEqFB #-} + +-- Rules: Replace with a fusion friendly version that is a good consumer and +-- good producer. +-- combineEq is only used by from{Asc,Desc}List which fuse with +-- fromDistinct{Asc,Desc}List, so there is no point in having a rewrite-back +-- rule. +{-# RULES +"Data.Set.combineEq" combineEq = combineEqFB + #-} +#endif + -- | \(O(n)\). Build a set from an ascending list of distinct elements in linear time. -- /The precondition (input list is strictly ascending) is not checked./