From b04c607f7828b658a4502078240aed35b478ec4f Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Tue, 28 Oct 2025 13:29:41 +0000 Subject: [PATCH 01/26] implement fromSetA --- containers/src/Data/IntMap/Internal.hs | 27 ++++++--- containers/src/Data/IntMap/Lazy.hs | 1 + containers/src/Data/IntMap/Strict.hs | 1 + containers/src/Data/IntMap/Strict/Internal.hs | 58 +++++++++++++------ containers/src/Data/Map/Internal.hs | 18 +++++- containers/src/Data/Map/Lazy.hs | 1 + containers/src/Data/Map/Strict.hs | 1 + containers/src/Data/Map/Strict/Internal.hs | 22 ++++++- 8 files changed, 98 insertions(+), 31 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 6cd047625..a4dc61cd2 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -109,6 +109,8 @@ module Data.IntMap.Internal ( -- * Construction , empty , singleton + , fromSet + , fromSetA -- ** Insertion , insert @@ -221,7 +223,6 @@ module Data.IntMap.Internal ( , keys , assocs , keysSet - , fromSet -- ** Lists , toList @@ -3309,9 +3310,18 @@ keysSet (Bin p l r) -- > fromSet undefined Data.IntSet.empty == empty fromSet :: (Key -> a) -> IntSet -> IntMap a -fromSet _ IntSet.Nil = Nil -fromSet f (IntSet.Bin p l r) = Bin p (fromSet f l) (fromSet f r) -fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) +fromSet f = runIdentity . fromSetA (pure . f) + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key +-- computes its value, while within an 'Applicative' context. +-- +-- > fromSetA (\k -> pure $ replicate k 'a') (Data.IntSet.fromList [3, 5]) == pure (fromList [(5,"aaaaa"), (3,"aaa")]) +-- > fromSetA undefined Data.IntSet.empty == pure empty + +fromSetA :: Applicative f => (Key -> f a) -> IntSet -> f (IntMap a) +fromSetA _ IntSet.Nil = pure Nil +fromSetA f (IntSet.Bin p l r) = liftA2 (Bin p) (fromSetA f l) (fromSetA f r) +fromSetA f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) where -- This is slightly complicated, as we to convert the dense -- representation of IntSet into tree representation of IntMap. @@ -3322,7 +3332,7 @@ fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) -- create a Bin node, otherwise exactly one of them is nonempty -- and we construct the IntMap from that half. buildTree g !prefix !bmask bits = case bits of - 0 -> Tip prefix (g prefix) + 0 -> Tip prefix <$> (g prefix) _ -> case bits `iShiftRL` 1 of bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 -> @@ -3330,9 +3340,10 @@ fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 -> buildTree g prefix bmask bits2 | otherwise -> - Bin (Prefix (prefix .|. bits2)) - (buildTree g prefix bmask bits2) - (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) + liftA2 + (Bin (Prefix (prefix .|. bits2))) + (buildTree g prefix bmask bits2) + (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) {-------------------------------------------------------------------- Lists diff --git a/containers/src/Data/IntMap/Lazy.hs b/containers/src/Data/IntMap/Lazy.hs index e6be3148e..d49491669 100644 --- a/containers/src/Data/IntMap/Lazy.hs +++ b/containers/src/Data/IntMap/Lazy.hs @@ -103,6 +103,7 @@ module Data.IntMap.Lazy ( , empty , singleton , fromSet + , fromSetA -- ** From Unordered Lists , fromList diff --git a/containers/src/Data/IntMap/Strict.hs b/containers/src/Data/IntMap/Strict.hs index 91c083152..41b0a587b 100644 --- a/containers/src/Data/IntMap/Strict.hs +++ b/containers/src/Data/IntMap/Strict.hs @@ -121,6 +121,7 @@ module Data.IntMap.Strict ( , empty , singleton , fromSet + , fromSetA -- ** From Unordered Lists , fromList diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 85dd7d63f..e13307584 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -64,6 +64,7 @@ module Data.IntMap.Strict.Internal ( , empty , singleton , fromSet + , fromSetA -- ** From Unordered Lists , fromList @@ -330,6 +331,7 @@ import qualified Data.IntSet.Internal as IntSet import Utils.Containers.Internal.BitUtil (iShiftRL, shiftLL, shiftRL) import Utils.Containers.Internal.StrictPair import qualified Data.Foldable as Foldable +import Data.Functor.Identity (Identity (..)) {-------------------------------------------------------------------- Construction @@ -1056,25 +1058,43 @@ mapEitherWithKey f0 t0 = toPair $ go f0 t0 -- > fromSet undefined Data.IntSet.empty == empty fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a -fromSet _ IntSet.Nil = Nil -fromSet f (IntSet.Bin p l r) = Bin p (fromSet f l) (fromSet f r) -fromSet f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) - where -- This is slightly complicated, as we to convert the dense - -- representation of IntSet into tree representation of IntMap. - -- - -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'. - -- We split bmask into halves corresponding to left and right subtree. - -- If they are both nonempty, we create a Bin node, otherwise exactly - -- one of them is nonempty and we construct the IntMap from that half. - buildTree g !prefix !bmask bits = case bits of - 0 -> Tip prefix $! g prefix - _ -> case bits `iShiftRL` 1 of - bits2 | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 -> - buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2 - | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 -> - buildTree g prefix bmask bits2 - | otherwise -> - Bin (Prefix (prefix .|. bits2)) (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) +fromSet f = runIdentity . fromSetA f' + where + f' k = let fk = f k in fk `seq` pure fk + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key +-- computes its value, while within an 'Applicative' context. +-- +-- This can only be as strict as the 'Applicative' allows it to be. +-- +-- > fromSetA (\k -> pure $ replicate k 'a') (Data.IntSet.fromList [3, 5]) == pure (fromList [(5,"aaaaa"), (3,"aaa")]) +-- > fromSetA undefined Data.IntSet.empty == pure empty + +fromSetA :: Applicative f => (Key -> f a) -> IntSet.IntSet -> f (IntMap a) +fromSetA _ IntSet.Nil = pure Nil +fromSetA f (IntSet.Bin p l r) = liftA2 (Bin p) (fromSetA f l) (fromSetA f r) +fromSetA f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) + where + -- This is slightly complicated, as we to convert the dense + -- representation of IntSet into tree representation of IntMap. + -- + -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'. + -- We split bmask into halves corresponding to left and right subtree. + -- If they are both nonempty, we create a Bin node, otherwise exactly + -- one of them is nonempty and we construct the IntMap from that half. + buildTree g !prefix !bmask bits = case bits of + 0 -> (Tip prefix $!) <$> g prefix + _ -> case bits `iShiftRL` 1 of + bits2 + | bmask .&. ((1 `shiftLL` bits2) - 1) == 0 -> + buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2 + | (bmask `shiftRL` bits2) .&. ((1 `shiftLL` bits2) - 1) == 0 -> + buildTree g prefix bmask bits2 + | otherwise -> + liftA2 + (Bin (Prefix (prefix .|. bits2))) + (buildTree g prefix bmask bits2) + (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) {-------------------------------------------------------------------- Lists diff --git a/containers/src/Data/Map/Internal.hs b/containers/src/Data/Map/Internal.hs index 40181416f..840c55572 100644 --- a/containers/src/Data/Map/Internal.hs +++ b/containers/src/Data/Map/Internal.hs @@ -270,6 +270,7 @@ module Data.Map.Internal ( , keysSet , argSet , fromSet + , fromSetA , fromArgSet -- ** Lists @@ -3535,8 +3536,21 @@ argSet (Bin sz kx x l r) = Set.Bin sz (Arg kx x) (argSet l) (argSet r) -- > fromSet undefined Data.Set.empty == empty fromSet :: (k -> a) -> Set.Set k -> Map k a -fromSet _ Set.Tip = Tip -fromSet f (Set.Bin sz x l r) = Bin sz x (f x) (fromSet f l) (fromSet f r) +fromSet f = runIdentity . fromSetA (pure . f) + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key +-- computes its value in an 'Applicative' context. +-- +-- > fromSetA (\k -> pure $ replicate k 'a') (Data.Set.fromList [3, 5]) == pure (fromList [(5,"aaaaa"), (3,"aaa")]) +-- > fromSetA undefined Data.Set.empty == pure empty + +fromSetA :: Applicative f => (k -> f a) -> Set.Set k -> f (Map k a) +fromSetA _ Set.Tip = pure Tip +fromSetA f (Set.Bin sz x l r) = + Bin sz x + <$> f x + <*> fromSetA f l + <*> fromSetA f r -- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's. -- diff --git a/containers/src/Data/Map/Lazy.hs b/containers/src/Data/Map/Lazy.hs index 56ca3c536..f1c4c984d 100644 --- a/containers/src/Data/Map/Lazy.hs +++ b/containers/src/Data/Map/Lazy.hs @@ -106,6 +106,7 @@ module Data.Map.Lazy ( , empty , singleton , fromSet + , fromSetA , fromArgSet -- ** From Unordered Lists diff --git a/containers/src/Data/Map/Strict.hs b/containers/src/Data/Map/Strict.hs index de0fb18c4..9715ad388 100644 --- a/containers/src/Data/Map/Strict.hs +++ b/containers/src/Data/Map/Strict.hs @@ -120,6 +120,7 @@ module Data.Map.Strict , empty , singleton , fromSet + , fromSetA , fromArgSet -- ** From Unordered Lists diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs index d70977e38..cc622a3dc 100644 --- a/containers/src/Data/Map/Strict/Internal.hs +++ b/containers/src/Data/Map/Strict/Internal.hs @@ -214,6 +214,7 @@ module Data.Map.Strict.Internal , keysSet , argSet , fromSet + , fromSetA , fromArgSet -- ** Lists @@ -1455,8 +1456,25 @@ mapKeysWith c f m = -- > fromSet undefined Data.Set.empty == empty fromSet :: (k -> a) -> Set.Set k -> Map k a -fromSet _ Set.Tip = Tip -fromSet f (Set.Bin sz x l r) = case f x of v -> v `seq` Bin sz x v (fromSet f l) (fromSet f r) +fromSet f = runIdentity . fromSetA f' + where + f' k = let fk = f k in fk `seq` pure fk + +-- | \(O(n)\). Build a map from a set of keys and a function which for each key +-- computes its value in an 'Applicative' context. +-- +-- This can only be as strict as the 'Applicative' allows it to be. +-- +-- > fromSetA (\k -> pure $ replicate k 'a') (Data.Set.fromList [3, 5]) == pure (fromList [(5,"aaaaa"), (3,"aaa")]) +-- > fromSetA undefined Data.Set.empty == pure empty + +fromSetA :: Applicative f => (k -> f a) -> Set.Set k -> f (Map k a) +fromSetA _ Set.Tip = pure Tip +fromSetA f (Set.Bin sz x l r) = + (Bin sz x $!) + <$> f x + <*> fromSetA f l + <*> fromSetA f r -- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's. -- From 69b5be21f61ea4a0ddd1207cfed5688d635cbd46 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Tue, 28 Oct 2025 23:07:21 +0000 Subject: [PATCH 02/26] remove guard since Identity is always needed now --- containers/src/Data/Map/Strict/Internal.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs index cc622a3dc..d92b9f954 100644 --- a/containers/src/Data/Map/Strict/Internal.hs +++ b/containers/src/Data/Map/Strict/Internal.hs @@ -421,9 +421,7 @@ import Utils.Containers.Internal.StrictPair import Data.Coerce #endif -#ifdef __GLASGOW_HASKELL__ import Data.Functor.Identity (Identity (..)) -#endif import qualified Data.Foldable as Foldable From 29cacf7cbdbd0a294ca3919da688588054961011 Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 11:29:12 +0000 Subject: [PATCH 03/26] inline since seq does nothing --- containers/src/Data/IntMap/Strict/Internal.hs | 4 +--- containers/src/Data/Map/Strict/Internal.hs | 4 +--- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index e13307584..d2597f917 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -1058,9 +1058,7 @@ mapEitherWithKey f0 t0 = toPair $ go f0 t0 -- > fromSet undefined Data.IntSet.empty == empty fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a -fromSet f = runIdentity . fromSetA f' - where - f' k = let fk = f k in fk `seq` pure fk +fromSet f = runIdentity . fromSetA (pure . f) -- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value, while within an 'Applicative' context. diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs index d92b9f954..24e8a0128 100644 --- a/containers/src/Data/Map/Strict/Internal.hs +++ b/containers/src/Data/Map/Strict/Internal.hs @@ -1454,9 +1454,7 @@ mapKeysWith c f m = -- > fromSet undefined Data.Set.empty == empty fromSet :: (k -> a) -> Set.Set k -> Map k a -fromSet f = runIdentity . fromSetA f' - where - f' k = let fk = f k in fk `seq` pure fk +fromSet f = runIdentity . fromSetA (pure . f) -- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value in an 'Applicative' context. From 6b918a4c8128c45722e64dcd5e8a4a0d0469dccf Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 11:29:22 +0000 Subject: [PATCH 04/26] correct effect order --- containers/src/Data/IntMap/Internal.hs | 4 +++- containers/src/Data/IntMap/Strict/Internal.hs | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index a4dc61cd2..fdb9c52c1 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -3320,7 +3320,9 @@ fromSet f = runIdentity . fromSetA (pure . f) fromSetA :: Applicative f => (Key -> f a) -> IntSet -> f (IntMap a) fromSetA _ IntSet.Nil = pure Nil -fromSetA f (IntSet.Bin p l r) = liftA2 (Bin p) (fromSetA f l) (fromSetA f r) +fromSetA f (IntSet.Bin p l r) + | signBranch p = liftA2 (flip (Bin p)) (fromSetA f r) (fromSetA f l) + | otherwise = liftA2 (Bin p) (fromSetA f l) (fromSetA f r) fromSetA f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) where -- This is slightly complicated, as we to convert the dense diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index d2597f917..b9dbc1eeb 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -1070,7 +1070,9 @@ fromSet f = runIdentity . fromSetA (pure . f) fromSetA :: Applicative f => (Key -> f a) -> IntSet.IntSet -> f (IntMap a) fromSetA _ IntSet.Nil = pure Nil -fromSetA f (IntSet.Bin p l r) = liftA2 (Bin p) (fromSetA f l) (fromSetA f r) +fromSetA f (IntSet.Bin p l r) + | signBranch p = liftA2 (flip (Bin p)) (fromSetA f r) (fromSetA f l) + | otherwise = liftA2 (Bin p) (fromSetA f l) (fromSetA f r) fromSetA f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) where -- This is slightly complicated, as we to convert the dense From 005275503f420d852f60293545f7acec571e0c7f Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 11:34:54 +0000 Subject: [PATCH 05/26] use coercions where possible to avoid allocating --- containers/src/Data/IntMap/Internal.hs | 4 ++++ containers/src/Data/IntMap/Strict/Internal.hs | 8 ++++++++ containers/src/Data/Map/Internal.hs | 4 ++++ containers/src/Data/Map/Strict/Internal.hs | 4 ++++ 4 files changed, 20 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index fdb9c52c1..59272b52d 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -3310,7 +3310,11 @@ keysSet (Bin p l r) -- > fromSet undefined Data.IntSet.empty == empty fromSet :: (Key -> a) -> IntSet -> IntMap a +#ifdef __GLASGOW_HASKELL__ +fromSet f = runIdentity . fromSetA (coerce f) +#else fromSet f = runIdentity . fromSetA (pure . f) +#endif -- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value, while within an 'Applicative' context. diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index b9dbc1eeb..f12a10f4b 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -333,6 +333,10 @@ import Utils.Containers.Internal.StrictPair import qualified Data.Foldable as Foldable import Data.Functor.Identity (Identity (..)) +#ifdef __GLASGOW_HASKELL__ +import Data.Coerce +#endif + {-------------------------------------------------------------------- Construction --------------------------------------------------------------------} @@ -1058,7 +1062,11 @@ mapEitherWithKey f0 t0 = toPair $ go f0 t0 -- > fromSet undefined Data.IntSet.empty == empty fromSet :: (Key -> a) -> IntSet.IntSet -> IntMap a +#ifdef __GLASGOW_HASKELL__ +fromSet f = runIdentity . fromSetA (coerce f) +#else fromSet f = runIdentity . fromSetA (pure . f) +#endif -- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value, while within an 'Applicative' context. diff --git a/containers/src/Data/Map/Internal.hs b/containers/src/Data/Map/Internal.hs index 840c55572..a1dd44013 100644 --- a/containers/src/Data/Map/Internal.hs +++ b/containers/src/Data/Map/Internal.hs @@ -3536,7 +3536,11 @@ argSet (Bin sz kx x l r) = Set.Bin sz (Arg kx x) (argSet l) (argSet r) -- > fromSet undefined Data.Set.empty == empty fromSet :: (k -> a) -> Set.Set k -> Map k a +#ifdef __GLASGOW_HASKELL__ +fromSet f = runIdentity . fromSetA (coerce f) +#else fromSet f = runIdentity . fromSetA (pure . f) +#endif -- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value in an 'Applicative' context. diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs index 24e8a0128..dccbc6f74 100644 --- a/containers/src/Data/Map/Strict/Internal.hs +++ b/containers/src/Data/Map/Strict/Internal.hs @@ -1454,7 +1454,11 @@ mapKeysWith c f m = -- > fromSet undefined Data.Set.empty == empty fromSet :: (k -> a) -> Set.Set k -> Map k a +#ifdef __GLASGOW_HASKELL__ +fromSet f = runIdentity . fromSetA (coerce f) +#else fromSet f = runIdentity . fromSetA (pure . f) +#endif -- | \(O(n)\). Build a map from a set of keys and a function which for each key -- computes its value in an 'Applicative' context. From 2d3f137f0b614a5c2150406e3c06682bf4d9105a Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 12:06:28 +0000 Subject: [PATCH 06/26] strictness prop tests --- containers-tests/tests/intmap-strictness.hs | 13 +++++++++++++ containers-tests/tests/map-strictness.hs | 13 +++++++++++++ 2 files changed, 26 insertions(+) diff --git a/containers-tests/tests/intmap-strictness.hs b/containers-tests/tests/intmap-strictness.hs index 90a189c8e..3a0b00dca 100644 --- a/containers-tests/tests/intmap-strictness.hs +++ b/containers-tests/tests/intmap-strictness.hs @@ -20,6 +20,7 @@ import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck import Test.QuickCheck.Poly (A, B, C) import Test.QuickCheck.Function (apply) +import Data.Tuple (Solo (..), getSolo) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -70,11 +71,22 @@ prop_strictFromSet fun set = where f = coerce (applyFunc fun) :: Key -> A +prop_strictFromSetA :: Func Key (Bot A) -> IntSet -> Property +prop_strictFromSetA fun set = + isBottom (getSolo (M.fromSetA f set)) === any (isBottom . getSolo . f) (IntSet.toList set) + where + f = MkSolo . coerce (applyFunc fun) :: Key -> Solo A + prop_lazyFromSet :: Func Key (Bot A) -> IntSet -> Property prop_lazyFromSet fun set = isNotBottomProp (L.fromSet f set) where f = coerce (applyFunc fun) :: Key -> A +prop_lazyFromSetA :: Func Key (Bot A) -> IntSet -> Property +prop_lazyFromSetA fun set = isNotBottomProp (getSolo (L.fromSetA f set)) + where + f = MkSolo . coerce (applyFunc fun) :: Key -> Solo A + prop_strictFromList :: [(Key, Bot A)] -> Property prop_strictFromList kvs = isBottom (M.fromList kvs') === any (isBottom . snd) kvs' @@ -1015,6 +1027,7 @@ tests = , testGroup "Construction" [ testPropStrictLazy "singleton" prop_strictSingleton prop_lazySingleton , testPropStrictLazy "fromSet" prop_strictFromSet prop_lazyFromSet + , testPropStrictLazy "fromSetA" prop_strictFromSetA prop_lazyFromSetA , testPropStrictLazy "fromList" prop_strictFromList prop_lazyFromList , testPropStrictLazy "fromListWith" prop_strictFromListWith prop_lazyFromListWith , testPropStrictLazy "fromListWithKey" prop_strictFromListWithKey prop_lazyFromListWithKey diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs index f6e4630c8..53cbd5664 100644 --- a/containers-tests/tests/map-strictness.hs +++ b/containers-tests/tests/map-strictness.hs @@ -21,6 +21,7 @@ import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck import Test.QuickCheck.Function import Test.QuickCheck.Poly (A, B, C, OrdA, OrdB) +import Data.Tuple (Solo (..), getSolo) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M @@ -134,11 +135,22 @@ prop_strictFromSet fun set = where f = coerce (applyFunc fun) :: OrdA -> A +prop_strictFromSetA :: Func OrdA (Bot A) -> Set OrdA -> Property +prop_strictFromSetA fun set = + isBottom (getSolo (M.fromSetA f set)) === any (isBottom . getSolo . f) (Set.toList set) + where + f = MkSolo . coerce (applyFunc fun) :: OrdA -> Solo A + prop_lazyFromSet :: Func OrdA (Bot A) -> Set OrdA -> Property prop_lazyFromSet fun set = isNotBottomProp (L.fromSet f set) where f = coerce (applyFunc fun) :: OrdA -> A +prop_lazyFromSetA :: Func OrdA (Bot A) -> Set OrdA -> Property +prop_lazyFromSetA fun set = isNotBottomProp (getSolo (L.fromSetA f set)) + where + f = MkSolo . coerce (applyFunc fun) :: OrdA -> Solo A + prop_strictFromArgSet :: Func OrdA (Bot A) -> Set OrdA -> Property prop_strictFromArgSet fun set = isBottom (M.fromArgSet set') === @@ -1153,6 +1165,7 @@ tests = , testGroup "Construction" [ testPropStrictLazy "singleton" prop_strictSingleton prop_lazySingleton , testPropStrictLazy "fromSet" prop_strictFromSet prop_lazyFromSet + , testPropStrictLazy "fromSetA" prop_strictFromSetA prop_lazyFromSetA , testPropStrictLazy "fromArgSet" prop_strictFromArgSet prop_lazyFromArgSet , testPropStrictLazy "fromList" prop_strictFromList prop_lazyFromList , testPropStrictLazy "fromListWith" prop_strictFromListWith prop_lazyFromListWith From 570b815de86d21967d61cc1077377386a1bb872b Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 12:26:59 +0000 Subject: [PATCH 07/26] verify evaluation order of applicative actions in tests --- containers-tests/tests/intmap-properties.hs | 14 ++++++++++++++ containers-tests/tests/map-properties.hs | 13 +++++++++++++ 2 files changed, 27 insertions(+) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 613ed1eb2..e639a5e06 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -15,6 +15,7 @@ import IntMapValidity (hasPrefix, hasPrefixSimple, valid) import Control.Applicative (Applicative(..)) import Control.Monad ((<=<)) +import Control.Monad.Trans.Writer.Lazy import qualified Data.Either as Either import qualified Data.Foldable as Foldable import Data.Monoid @@ -23,6 +24,7 @@ import qualified Data.Maybe as Maybe (mapMaybe) import Data.Ord import Data.Foldable (foldMap) import Data.Function +import Data.Functor import Data.Traversable (Traversable(traverse), foldMapDefault) import Prelude hiding (lookup, null, map, filter, foldr, foldl, foldl') import qualified Prelude (map, filter) @@ -212,6 +214,7 @@ main = defaultMain $ testGroup "intmap-properties" prop_FoldableTraversableCompat , testProperty "keysSet" prop_keysSet , testProperty "fromSet" prop_fromSet + , testProperty "fromSetA eval order" prop_fromSetA_action_order , testProperty "restrictKeys" prop_restrictKeys , testProperty "withoutKeys" prop_withoutKeys , testProperty "traverseWithKey identity" prop_traverseWithKey_identity @@ -1698,6 +1701,17 @@ prop_fromSet ys = let xs = List.nubBy ((==) `on` fst) ys in fromSet (\k -> fromJust $ List.lookup k xs) (IntSet.fromList $ List.map fst xs) == fromList xs +prop_fromSetA_action_order :: [(Int, Int)] -> Bool +prop_fromSetA_action_order ys = + let iSet = IntSet.fromList (fst <$> ys) + lookupYs = List.nubBy ((==) `on` fst) ys + doLookup k = fromJust $ List.lookup k lookupYs + action = \k -> + let v = doLookup k + in tell [v] $> v + xs = IntSet.toList iSet + in execWriter (fromSetA action iSet) == List.map doLookup xs + newtype Identity a = Identity a deriving (Eq, Show) diff --git a/containers-tests/tests/map-properties.hs b/containers-tests/tests/map-properties.hs index a585391c4..80deaf650 100644 --- a/containers-tests/tests/map-properties.hs +++ b/containers-tests/tests/map-properties.hs @@ -23,6 +23,7 @@ import qualified Data.Maybe as Maybe (mapMaybe) import Data.Ord import Data.Semigroup (Arg(..)) import Data.Function +import Data.Functor import qualified Data.Foldable as Foldable import qualified Data.Bifoldable as Bifoldable import Prelude hiding (lookup, null, map, filter, foldr, foldl, foldl', take, drop, splitAt) @@ -256,6 +257,7 @@ main = defaultMain $ testGroup "map-properties" , testProperty "keysSet" prop_keysSet , testProperty "argSet" prop_argSet , testProperty "fromSet" prop_fromSet + , testProperty "fromSetA eval order" prop_fromSetA_action_order , testProperty "fromArgSet" prop_fromArgSet , testProperty "takeWhileAntitone" prop_takeWhileAntitone , testProperty "dropWhileAntitone" prop_dropWhileAntitone @@ -1721,6 +1723,17 @@ prop_fromSet ys = let xs = List.nubBy ((==) `on` fst) ys in fromSet (\k -> fromJust $ List.lookup k xs) (Set.fromList $ List.map fst xs) == fromList xs +prop_fromSetA_action_order :: [(Int, Int)] -> Bool +prop_fromSetA_action_order ys = + let oSet = Set.fromList (fst <$> ys) + lookupYs = List.nubBy ((==) `on` fst) ys + doLookup k = fromJust $ List.lookup k lookupYs + action = \k -> + let v = doLookup k + in tell [v] $> v + xs = Set.toList oSet + in execWriter (fromSetA action oSet) == List.map doLookup xs + prop_fromArgSet :: [(Int, Int)] -> Bool prop_fromArgSet ys = let xs = List.nubBy ((==) `on` fst) ys From a68385da124c67e11e3029c3019b31ff2fc4ca38 Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 12:27:17 +0000 Subject: [PATCH 08/26] fix ordering issue in map's fromSetA --- containers/src/Data/Map/Internal.hs | 6 +++--- containers/src/Data/Map/Strict/Internal.hs | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/containers/src/Data/Map/Internal.hs b/containers/src/Data/Map/Internal.hs index a1dd44013..3d76dd16f 100644 --- a/containers/src/Data/Map/Internal.hs +++ b/containers/src/Data/Map/Internal.hs @@ -3551,9 +3551,9 @@ fromSet f = runIdentity . fromSetA (pure . f) fromSetA :: Applicative f => (k -> f a) -> Set.Set k -> f (Map k a) fromSetA _ Set.Tip = pure Tip fromSetA f (Set.Bin sz x l r) = - Bin sz x - <$> f x - <*> fromSetA f l + flip (Bin sz x) + <$> fromSetA f l + <*> f x <*> fromSetA f r -- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's. diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs index dccbc6f74..b54efe8ed 100644 --- a/containers/src/Data/Map/Strict/Internal.hs +++ b/containers/src/Data/Map/Strict/Internal.hs @@ -1471,9 +1471,9 @@ fromSet f = runIdentity . fromSetA (pure . f) fromSetA :: Applicative f => (k -> f a) -> Set.Set k -> f (Map k a) fromSetA _ Set.Tip = pure Tip fromSetA f (Set.Bin sz x l r) = - (Bin sz x $!) - <$> f x - <*> fromSetA f l + flip (Bin sz x $!) + <$> fromSetA f l + <*> f x <*> fromSetA f r -- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's. From e6b84ff7283a5874e2085143bc591b81fc82f907 Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 13:24:25 +0000 Subject: [PATCH 09/26] use Property and Fun instead of lists of pairs --- containers-tests/tests/intmap-properties.hs | 30 ++++++++-------- containers-tests/tests/map-properties.hs | 39 ++++++++++----------- 2 files changed, 34 insertions(+), 35 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index e639a5e06..4d1a052ed 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} #ifdef STRICT import Data.IntMap.Strict as Data.IntMap @@ -14,6 +15,7 @@ import Data.IntSet.Internal.IntTreeCommons (Prefix(..), nomatch) import IntMapValidity (hasPrefix, hasPrefixSimple, valid) import Control.Applicative (Applicative(..)) +import Control.Arrow ((&&&)) import Control.Monad ((<=<)) import Control.Monad.Trans.Writer.Lazy import qualified Data.Either as Either @@ -1692,25 +1694,23 @@ prop_FoldableTraversableCompat :: Fun A [B] -> IntMap A -> Property prop_FoldableTraversableCompat fun m = foldMap f m === foldMapDefault f m where f = apply fun -prop_keysSet :: [(Int, Int)] -> Bool -prop_keysSet xs = - keysSet (fromList xs) == IntSet.fromList (List.map fst xs) +prop_keysSet :: [Int] -> Property +prop_keysSet keys = + keysSet (fromList (fmap (, ()) keys)) === IntSet.fromList keys -prop_fromSet :: [(Int, Int)] -> Bool -prop_fromSet ys = - let xs = List.nubBy ((==) `on` fst) ys - in fromSet (\k -> fromJust $ List.lookup k xs) (IntSet.fromList $ List.map fst xs) == fromList xs +prop_fromSet :: [Int] -> Fun Int A -> Property +prop_fromSet keys funF = + let f = applyFun funF + in fromSet f (IntSet.fromList keys) === fromList (fmap (id &&& f) keys) -prop_fromSetA_action_order :: [(Int, Int)] -> Bool -prop_fromSetA_action_order ys = - let iSet = IntSet.fromList (fst <$> ys) - lookupYs = List.nubBy ((==) `on` fst) ys - doLookup k = fromJust $ List.lookup k lookupYs +prop_fromSetA_action_order :: [Int] -> Fun Int A -> Property +prop_fromSetA_action_order keys funF = + let iSet = IntSet.fromList keys + f = applyFun funF action = \k -> - let v = doLookup k + let v = f k in tell [v] $> v - xs = IntSet.toList iSet - in execWriter (fromSetA action iSet) == List.map doLookup xs + in execWriter (fromSetA action iSet) === List.map f (IntSet.toList iSet) newtype Identity a = Identity a deriving (Eq, Show) diff --git a/containers-tests/tests/map-properties.hs b/containers-tests/tests/map-properties.hs index 80deaf650..2914c1364 100644 --- a/containers-tests/tests/map-properties.hs +++ b/containers-tests/tests/map-properties.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} #ifdef STRICT import Data.Map.Strict as Data.Map @@ -11,6 +12,7 @@ import Data.Map.Internal (Map, link2, link) import Data.Map.Internal.Debug (showTree, showTreeWith, balanced) import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>), (<|>)) +import Control.Arrow ((&&&)) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Class import Control.Monad.Trans.Writer.Lazy @@ -1710,34 +1712,31 @@ prop_bifoldl' ck cv n m = Bifoldable.bifoldl' ck' cv' n m === Foldable.foldl' c' cv' = curry (apply cv) acc `c'` (k,v) = (acc `ck'` k) `cv'` v -prop_keysSet :: [(Int, Int)] -> Bool -prop_keysSet xs = - keysSet (fromList xs) == Set.fromList (List.map fst xs) +prop_keysSet :: [OrdA] -> Property +prop_keysSet keys = + keysSet (fromList (fmap (, ()) keys)) === Set.fromList keys -prop_argSet :: [(Int, Int)] -> Bool +prop_argSet :: [(OrdA, B)] -> Property prop_argSet xs = - argSet (fromList xs) == Set.fromList (List.map (uncurry Arg) xs) + argSet (fromList xs) === Set.fromList (List.map (uncurry Arg) xs) -prop_fromSet :: [(Int, Int)] -> Bool -prop_fromSet ys = - let xs = List.nubBy ((==) `on` fst) ys - in fromSet (\k -> fromJust $ List.lookup k xs) (Set.fromList $ List.map fst xs) == fromList xs +prop_fromSet :: [OrdA] -> Fun OrdA B -> Property +prop_fromSet keys funF = + let f = applyFun funF + in fromSet f (Set.fromList keys) === fromList (fmap (id &&& f) keys) -prop_fromSetA_action_order :: [(Int, Int)] -> Bool -prop_fromSetA_action_order ys = - let oSet = Set.fromList (fst <$> ys) - lookupYs = List.nubBy ((==) `on` fst) ys - doLookup k = fromJust $ List.lookup k lookupYs +prop_fromSetA_action_order :: [OrdA] -> Fun OrdA B -> Property +prop_fromSetA_action_order keys funF = + let iSet = Set.fromList keys + f = applyFun funF action = \k -> - let v = doLookup k + let v = f k in tell [v] $> v - xs = Set.toList oSet - in execWriter (fromSetA action oSet) == List.map doLookup xs + in execWriter (fromSetA action iSet) === List.map f (Set.toList iSet) -prop_fromArgSet :: [(Int, Int)] -> Bool +prop_fromArgSet :: [(OrdA, B)] -> Property prop_fromArgSet ys = - let xs = List.nubBy ((==) `on` fst) ys - in fromArgSet (Set.fromList $ List.map (uncurry Arg) xs) == fromList xs + fromArgSet (Set.fromList $ List.map (uncurry Arg) ys) === fromList ys prop_eq :: Map Int A -> Map Int A -> Property prop_eq m1 m2 = (m1 == m2) === (toList m1 == toList m2) From d0c76d4518019af8c1bda1bc2f0be5fa4fc1b64a Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 13:51:29 +0000 Subject: [PATCH 10/26] use apply instead of applyFun --- containers-tests/tests/intmap-properties.hs | 4 ++-- containers-tests/tests/map-properties.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 4d1a052ed..561c3bd4c 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -1700,13 +1700,13 @@ prop_keysSet keys = prop_fromSet :: [Int] -> Fun Int A -> Property prop_fromSet keys funF = - let f = applyFun funF + let f = apply funF in fromSet f (IntSet.fromList keys) === fromList (fmap (id &&& f) keys) prop_fromSetA_action_order :: [Int] -> Fun Int A -> Property prop_fromSetA_action_order keys funF = let iSet = IntSet.fromList keys - f = applyFun funF + f = apply funF action = \k -> let v = f k in tell [v] $> v diff --git a/containers-tests/tests/map-properties.hs b/containers-tests/tests/map-properties.hs index 2914c1364..d1e5a8e1e 100644 --- a/containers-tests/tests/map-properties.hs +++ b/containers-tests/tests/map-properties.hs @@ -1722,13 +1722,13 @@ prop_argSet xs = prop_fromSet :: [OrdA] -> Fun OrdA B -> Property prop_fromSet keys funF = - let f = applyFun funF + let f = apply funF in fromSet f (Set.fromList keys) === fromList (fmap (id &&& f) keys) prop_fromSetA_action_order :: [OrdA] -> Fun OrdA B -> Property prop_fromSetA_action_order keys funF = let iSet = Set.fromList keys - f = applyFun funF + f = apply funF action = \k -> let v = f k in tell [v] $> v From 5ff0726538acdd41e6db698378bbc7a855ecea6a Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 14:15:21 +0000 Subject: [PATCH 11/26] add useful instances for Bot so it can be used elsewhere --- containers-tests/tests/Utils/Strictness.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/containers-tests/tests/Utils/Strictness.hs b/containers-tests/tests/Utils/Strictness.hs index 755745170..eead2666b 100644 --- a/containers-tests/tests/Utils/Strictness.hs +++ b/containers-tests/tests/Utils/Strictness.hs @@ -27,6 +27,12 @@ instance Arbitrary a => Arbitrary (Bot a) where , (4, Bot <$> arbitrary) ] +instance CoArbitrary a => CoArbitrary (Bot a) where + coarbitrary (Bot x) = coarbitrary x + +instance Function a => Function (Bot a) where + function = functionMap (\(Bot x) -> x) Bot + {-------------------------------------------------------------------- Lazy functions --------------------------------------------------------------------} From 0959161e5826a15e9ab15a4103be1ad0faf4fbb0 Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 14:15:33 +0000 Subject: [PATCH 12/26] remove some coercions --- containers-tests/tests/intmap-strictness.hs | 8 ++++---- containers-tests/tests/map-strictness.hs | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/containers-tests/tests/intmap-strictness.hs b/containers-tests/tests/intmap-strictness.hs index 3a0b00dca..3c8c15a99 100644 --- a/containers-tests/tests/intmap-strictness.hs +++ b/containers-tests/tests/intmap-strictness.hs @@ -69,23 +69,23 @@ prop_strictFromSet :: Func Key (Bot A) -> IntSet -> Property prop_strictFromSet fun set = isBottom (M.fromSet f set) === any (isBottom . f) (IntSet.toList set) where - f = coerce (applyFunc fun) :: Key -> A + f = applyFunc fun prop_strictFromSetA :: Func Key (Bot A) -> IntSet -> Property prop_strictFromSetA fun set = isBottom (getSolo (M.fromSetA f set)) === any (isBottom . getSolo . f) (IntSet.toList set) where - f = MkSolo . coerce (applyFunc fun) :: Key -> Solo A + f = MkSolo . applyFunc fun prop_lazyFromSet :: Func Key (Bot A) -> IntSet -> Property prop_lazyFromSet fun set = isNotBottomProp (L.fromSet f set) where - f = coerce (applyFunc fun) :: Key -> A + f = applyFunc fun prop_lazyFromSetA :: Func Key (Bot A) -> IntSet -> Property prop_lazyFromSetA fun set = isNotBottomProp (getSolo (L.fromSetA f set)) where - f = MkSolo . coerce (applyFunc fun) :: Key -> Solo A + f = MkSolo . applyFunc fun prop_strictFromList :: [(Key, Bot A)] -> Property prop_strictFromList kvs = diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs index 53cbd5664..f8848bd0c 100644 --- a/containers-tests/tests/map-strictness.hs +++ b/containers-tests/tests/map-strictness.hs @@ -133,23 +133,23 @@ prop_strictFromSet :: Func OrdA (Bot A) -> Set OrdA -> Property prop_strictFromSet fun set = isBottom (M.fromSet f set) === any (isBottom . f) (Set.toList set) where - f = coerce (applyFunc fun) :: OrdA -> A + f = applyFunc fun prop_strictFromSetA :: Func OrdA (Bot A) -> Set OrdA -> Property prop_strictFromSetA fun set = isBottom (getSolo (M.fromSetA f set)) === any (isBottom . getSolo . f) (Set.toList set) where - f = MkSolo . coerce (applyFunc fun) :: OrdA -> Solo A + f = MkSolo . applyFunc fun prop_lazyFromSet :: Func OrdA (Bot A) -> Set OrdA -> Property prop_lazyFromSet fun set = isNotBottomProp (L.fromSet f set) where - f = coerce (applyFunc fun) :: OrdA -> A + f = applyFunc fun prop_lazyFromSetA :: Func OrdA (Bot A) -> Set OrdA -> Property prop_lazyFromSetA fun set = isNotBottomProp (getSolo (L.fromSetA f set)) where - f = MkSolo . coerce (applyFunc fun) :: OrdA -> Solo A + f = MkSolo . applyFunc fun prop_strictFromArgSet :: Func OrdA (Bot A) -> Set OrdA -> Property prop_strictFromArgSet fun set = From eb33e4a291cf25c224d85d3ecef1325d82103fc5 Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 16:28:06 +0000 Subject: [PATCH 13/26] use OneTuple to get Solo --- containers-tests/containers-tests.cabal | 1 + containers-tests/tests/intmap-strictness.hs | 2 +- containers-tests/tests/map-strictness.hs | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index 02d64b3a1..c0a4c3027 100644 --- a/containers-tests/containers-tests.cabal +++ b/containers-tests/containers-tests.cabal @@ -47,6 +47,7 @@ common test-deps import: deps build-depends: containers-tests + , OneTuple , QuickCheck >=2.7.1 , tasty , tasty-hunit diff --git a/containers-tests/tests/intmap-strictness.hs b/containers-tests/tests/intmap-strictness.hs index 3c8c15a99..c40c5f0ce 100644 --- a/containers-tests/tests/intmap-strictness.hs +++ b/containers-tests/tests/intmap-strictness.hs @@ -17,10 +17,10 @@ import Data.Ord (comparing) import Test.ChasingBottoms.IsBottom import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.QuickCheck (testProperty) +import Data.Tuple.Solo (Solo (MkSolo), getSolo) import Test.QuickCheck import Test.QuickCheck.Poly (A, B, C) import Test.QuickCheck.Function (apply) -import Data.Tuple (Solo (..), getSolo) import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs index f8848bd0c..12acb7982 100644 --- a/containers-tests/tests/map-strictness.hs +++ b/containers-tests/tests/map-strictness.hs @@ -15,13 +15,13 @@ import qualified Data.List.NonEmpty as NE import Data.Ord (Down(..), comparing) import Data.Maybe (catMaybes, mapMaybe) import Data.Semigroup (Arg(..)) +import Data.Tuple.Solo (Solo (MkSolo), getSolo) import Test.ChasingBottoms.IsBottom (bottom, isBottom) import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.QuickCheck (testProperty) import Test.QuickCheck import Test.QuickCheck.Function import Test.QuickCheck.Poly (A, B, C, OrdA, OrdB) -import Data.Tuple (Solo (..), getSolo) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M From 69d86dab6116eacf78c98fddc5abeaac70277e6e Mon Sep 17 00:00:00 2001 From: Benjamin McRae Date: Wed, 29 Oct 2025 16:28:26 +0000 Subject: [PATCH 14/26] inline MkSolo usages when needed --- containers-tests/tests/intmap-strictness.hs | 4 ++-- containers-tests/tests/map-strictness.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/containers-tests/tests/intmap-strictness.hs b/containers-tests/tests/intmap-strictness.hs index c40c5f0ce..d778bead7 100644 --- a/containers-tests/tests/intmap-strictness.hs +++ b/containers-tests/tests/intmap-strictness.hs @@ -73,9 +73,9 @@ prop_strictFromSet fun set = prop_strictFromSetA :: Func Key (Bot A) -> IntSet -> Property prop_strictFromSetA fun set = - isBottom (getSolo (M.fromSetA f set)) === any (isBottom . getSolo . f) (IntSet.toList set) + isBottom (getSolo (M.fromSetA (MkSolo . f) set)) === any (isBottom . f) (IntSet.toList set) where - f = MkSolo . applyFunc fun + f = applyFunc fun prop_lazyFromSet :: Func Key (Bot A) -> IntSet -> Property prop_lazyFromSet fun set = isNotBottomProp (L.fromSet f set) diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs index 12acb7982..83b097eaf 100644 --- a/containers-tests/tests/map-strictness.hs +++ b/containers-tests/tests/map-strictness.hs @@ -137,9 +137,9 @@ prop_strictFromSet fun set = prop_strictFromSetA :: Func OrdA (Bot A) -> Set OrdA -> Property prop_strictFromSetA fun set = - isBottom (getSolo (M.fromSetA f set)) === any (isBottom . getSolo . f) (Set.toList set) + isBottom (getSolo (M.fromSetA (MkSolo . f) set)) === any (isBottom . f) (Set.toList set) where - f = MkSolo . applyFunc fun + f = applyFunc fun prop_lazyFromSet :: Func OrdA (Bot A) -> Set OrdA -> Property prop_lazyFromSet fun set = isNotBottomProp (L.fromSet f set) From e1d178ba58333c842e4a03f7b527d998f8150051 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 29 Oct 2025 21:22:06 +0000 Subject: [PATCH 15/26] assert additional strictness properties --- containers-tests/tests/intmap-strictness.hs | 18 ++++++++++++++++-- containers-tests/tests/map-strictness.hs | 14 ++++++++++++++ 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/containers-tests/tests/intmap-strictness.hs b/containers-tests/tests/intmap-strictness.hs index d778bead7..8cc9473e7 100644 --- a/containers-tests/tests/intmap-strictness.hs +++ b/containers-tests/tests/intmap-strictness.hs @@ -8,8 +8,9 @@ import Data.Bifunctor (bimap) import Data.Coerce (coerce) import Data.Either (partitionEithers) import qualified Data.Foldable as F -import Data.Functor.Identity (Identity(..)) import Data.Function (on) +import Data.Functor.Compose +import Data.Functor.Identity (Identity(..)) import qualified Data.List as List import qualified Data.List.NonEmpty as NE import Data.Maybe (catMaybes, mapMaybe) @@ -85,7 +86,19 @@ prop_lazyFromSet fun set = isNotBottomProp (L.fromSet f set) prop_lazyFromSetA :: Func Key (Bot A) -> IntSet -> Property prop_lazyFromSetA fun set = isNotBottomProp (getSolo (L.fromSetA f set)) where - f = MkSolo . applyFunc fun + f = MkSolo . applyFunc fun + +prop_fromSetA_equiv_strictness :: Func Int (Bot A) -> IntSet -> Property +prop_fromSetA_equiv_strictness fun set = + -- strict fromSetA is the same as lazy and then forcing + bottomOn (M.fromSetA f set) (fmap forceValues (L.fromSetA f set)) .&&. + -- strict fromSetA is the same as lazy fromSetA composed with strictly applied + -- wrapper + bottomOn (M.fromSetA f set) (fmap getSolo . getCompose $ L.fromSetA (Compose . fmap (MkSolo $!) . f) set) + where + forceValues xs = foldr (\ !_ r -> r) () xs `seq` xs + bottomOn = on (===) (isBottom . getSolo) + f = MkSolo . applyFunc fun prop_strictFromList :: [(Key, Bot A)] -> Property prop_strictFromList kvs = @@ -1028,6 +1041,7 @@ tests = [ testPropStrictLazy "singleton" prop_strictSingleton prop_lazySingleton , testPropStrictLazy "fromSet" prop_strictFromSet prop_lazyFromSet , testPropStrictLazy "fromSetA" prop_strictFromSetA prop_lazyFromSetA + , testProperty "fromSetA equivalences" prop_fromSetA_equiv_strictness , testPropStrictLazy "fromList" prop_strictFromList prop_lazyFromList , testPropStrictLazy "fromListWith" prop_strictFromListWith prop_lazyFromListWith , testPropStrictLazy "fromListWithKey" prop_strictFromListWithKey prop_lazyFromListWithKey diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs index 83b097eaf..e5fe5dd47 100644 --- a/containers-tests/tests/map-strictness.hs +++ b/containers-tests/tests/map-strictness.hs @@ -9,6 +9,7 @@ import Data.Coerce (coerce) import Data.Either (partitionEithers) import Data.Foldable as F import Data.Function (on) +import Data.Functor.Compose (Compose (..)) import Data.Functor.Identity (Identity(..)) import qualified Data.List as List import qualified Data.List.NonEmpty as NE @@ -151,6 +152,18 @@ prop_lazyFromSetA fun set = isNotBottomProp (getSolo (L.fromSetA f set)) where f = MkSolo . applyFunc fun +prop_fromSetA_equiv_strictness :: Func OrdA (Bot A) -> Set OrdA -> Property +prop_fromSetA_equiv_strictness fun set = + -- strict fromSetA is the same as lazy and then forcing + bottomOn (M.fromSetA f set) (fmap forceValues (L.fromSetA f set)) .&&. + -- strict fromSet is the same as lazy fromSetA with a strict function, + -- and unwrapping the container + bottomOn (M.fromSetA f set) (fmap getSolo . getCompose $ L.fromSetA (Compose . fmap (MkSolo $!) . f) set) + where + forceValues xs = foldr (\ !_ r -> r) () xs `seq` xs + bottomOn = on (===) (isBottom . getSolo) + f = MkSolo . applyFunc fun + prop_strictFromArgSet :: Func OrdA (Bot A) -> Set OrdA -> Property prop_strictFromArgSet fun set = isBottom (M.fromArgSet set') === @@ -1166,6 +1179,7 @@ tests = [ testPropStrictLazy "singleton" prop_strictSingleton prop_lazySingleton , testPropStrictLazy "fromSet" prop_strictFromSet prop_lazyFromSet , testPropStrictLazy "fromSetA" prop_strictFromSetA prop_lazyFromSetA + , testProperty "fromSetA equivalences" prop_fromSetA_equiv_strictness , testPropStrictLazy "fromArgSet" prop_strictFromArgSet prop_lazyFromArgSet , testPropStrictLazy "fromList" prop_strictFromList prop_lazyFromList , testPropStrictLazy "fromListWith" prop_strictFromListWith prop_lazyFromListWith From a10287b6c79fabb86660f97cbaf137ae0737426b Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 29 Oct 2025 21:22:54 +0000 Subject: [PATCH 16/26] comment on additional strictness properties --- containers/src/Data/IntMap/Strict/Internal.hs | 11 +++++++++++ containers/src/Data/Map/Strict/Internal.hs | 11 +++++++++++ 2 files changed, 22 insertions(+) diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index f12a10f4b..01b8d8596 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -1075,6 +1075,17 @@ fromSet f = runIdentity . fromSetA (pure . f) -- -- > fromSetA (\k -> pure $ replicate k 'a') (Data.IntSet.fromList [3, 5]) == pure (fromList [(5,"aaaaa"), (3,"aaa")]) -- > fromSetA undefined Data.IntSet.empty == pure empty +-- +-- The following strictness properties hold: +-- +-- > fromSetA f = fmap forceValues . Data.Map.Lazy.fromSetA f +-- > where +-- > forceValues xs = foldr (\ !_ r -> r) () xs `seq` xs +-- +-- > fromSetA f = +-- > fmap getSolo . +-- > getCompose . +-- > Data.Map.Lazy.fromSetA (Compose . fmap (MkSolo $!) . f) fromSetA :: Applicative f => (Key -> f a) -> IntSet.IntSet -> f (IntMap a) fromSetA _ IntSet.Nil = pure Nil diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs index b54efe8ed..54c87298e 100644 --- a/containers/src/Data/Map/Strict/Internal.hs +++ b/containers/src/Data/Map/Strict/Internal.hs @@ -1467,6 +1467,17 @@ fromSet f = runIdentity . fromSetA (pure . f) -- -- > fromSetA (\k -> pure $ replicate k 'a') (Data.Set.fromList [3, 5]) == pure (fromList [(5,"aaaaa"), (3,"aaa")]) -- > fromSetA undefined Data.Set.empty == pure empty +-- +-- The following strictness properties hold: +-- +-- > fromSetA f = fmap forceValues . Data.Map.Lazy.fromSetA f +-- > where +-- > forceValues xs = foldr (\ !_ r -> r) () xs `seq` xs +-- +-- > fromSetA f = +-- > fmap getSolo . +-- > getCompose . +-- > Data.Map.Lazy.fromSetA (Compose . fmap (MkSolo $!) . f) fromSetA :: Applicative f => (k -> f a) -> Set.Set k -> f (Map k a) fromSetA _ Set.Tip = pure Tip From df8252dbba673d5ab81bb1c90006fe6f25cf45a9 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 29 Oct 2025 21:36:48 +0000 Subject: [PATCH 17/26] add benchmarks for fromSet --- containers-tests/benchmarks/IntMap.hs | 1 + containers-tests/benchmarks/Map.hs | 10 ++++++++++ 2 files changed, 11 insertions(+) diff --git a/containers-tests/benchmarks/IntMap.hs b/containers-tests/benchmarks/IntMap.hs index c3f5522f0..9f1af689b 100644 --- a/containers-tests/benchmarks/IntMap.hs +++ b/containers-tests/benchmarks/IntMap.hs @@ -80,6 +80,7 @@ main = do whnf (\n -> M.fromAscList (unitValues [1..n])) bound , bench "minView" $ whnf (maybe 0 (\((k,v), m) -> k+v+M.size m) . M.minViewWithKey) (M.fromList $ zip [1..10] [1..10]) + , bench "fromSet" $ whnf (M.fromSet pred) s_random2 , bench "spanAntitone" $ whnf (M.spanAntitone ( M.fromDistinctAscList [(i,i) | i <- [1..n]]) bound , bench "fromDistinctDescList" $ whnf M.fromDistinctDescList elems_distinct_desc , bench "fromDistinctDescList:fusion" $ whnf (\n -> M.fromDistinctDescList [(i,i) | i <- [n,n-1..1]]) bound + , bench "fromSet" $ whnf (M.fromSet pred) s_random , bench "minView" $ whnf (\m' -> case M.minViewWithKey m' of {Nothing -> 0; Just ((k,v),m'') -> k+v+M.size m''}) (M.fromAscList $ zip [1..10::Int] [100..110::Int]) , bench "eq" $ whnf (\m' -> m' == m') m -- worst case, compares everything , bench "compare" $ whnf (\m' -> compare m' m') m -- worst case, compares everything @@ -152,6 +158,7 @@ main = do values = [1..bound] sumkv k v1 v2 = k + v1 + v2 consPair k v xs = (k, v) : xs + keys_random = take bound (randoms gen) add3 :: Int -> Int -> Int -> Int add3 x y z = x + y + z @@ -239,3 +246,6 @@ atAltNoRules f xs m = foldl' (\m k -> runIdent (alterF (Ident . f) k m)) m xs maybeDel :: Int -> Maybe Int maybeDel n | n `mod` 3 == 0 = Nothing | otherwise = Just n + +gen :: StdGen +gen = mkStdGen 90 From 33a10c343b69b1d9fba366f89f46375d346d5575 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 29 Oct 2025 21:37:44 +0000 Subject: [PATCH 18/26] add benchmarks for fromSetA --- containers-tests/benchmarks/IntMap.hs | 5 +++++ containers-tests/benchmarks/Map.hs | 5 +++++ containers-tests/containers-tests.cabal | 1 + 3 files changed, 11 insertions(+) diff --git a/containers-tests/benchmarks/IntMap.hs b/containers-tests/benchmarks/IntMap.hs index 9f1af689b..efeff97d9 100644 --- a/containers-tests/benchmarks/IntMap.hs +++ b/containers-tests/benchmarks/IntMap.hs @@ -9,6 +9,7 @@ import qualified Data.IntMap as M import qualified Data.IntMap.Strict as MS import qualified Data.IntSet as S import Data.Maybe (fromMaybe) +import Data.Tuple.Solo (Solo (MkSolo), getSolo) import Data.Word (Word8) import System.Random (StdGen, mkStdGen, random, randoms) import Prelude hiding (lookup) @@ -81,6 +82,10 @@ main = do , bench "minView" $ whnf (maybe 0 (\((k,v), m) -> k+v+M.size m) . M.minViewWithKey) (M.fromList $ zip [1..10] [1..10]) , bench "fromSet" $ whnf (M.fromSet pred) s_random2 + , bench "Lazy.fromSetA outer" $ whnf (M.fromSetA (MkSolo . pred)) s_random2 + , bench "Strict.fromSetA outer" $ whnf (MS.fromSetA (MkSolo . pred)) s_random2 + , bench "Lazy.fromSetA inner" $ whnf (getSolo . M.fromSetA (MkSolo . pred)) s_random2 + , bench "Strict.fromSetA inner" $ whnf (getSolo . MS.fromSetA (MkSolo . pred)) s_random2 , bench "spanAntitone" $ whnf (M.spanAntitone ( M.fromDistinctDescList [(i,i) | i <- [n,n-1..1]]) bound , bench "fromSet" $ whnf (M.fromSet pred) s_random + , bench "Lazy.fromSetA outer" $ whnf (M.fromSetA (MkSolo . pred)) s_random + , bench "Strict.fromSetA outer" $ whnf (MS.fromSetA (MkSolo . pred)) s_random + , bench "Lazy.fromSetA inner" $ whnf (getSolo . M.fromSetA (MkSolo . pred)) s_random + , bench "Strict.fromSetA inner" $ whnf (getSolo . MS.fromSetA (MkSolo . pred)) s_random , bench "minView" $ whnf (\m' -> case M.minViewWithKey m' of {Nothing -> 0; Just ((k,v),m'') -> k+v+M.size m''}) (M.fromAscList $ zip [1..10::Int] [100..110::Int]) , bench "eq" $ whnf (\m' -> m' == m') m -- worst case, compares everything , bench "compare" $ whnf (\m' -> compare m' m') m -- worst case, compares everything diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index c0a4c3027..72fd3c72a 100644 --- a/containers-tests/containers-tests.cabal +++ b/containers-tests/containers-tests.cabal @@ -59,6 +59,7 @@ common benchmark-deps build-depends: containers-tests , deepseq >=1.1.0.0 && <1.6 + , OneTuple , tasty-bench >=0.3.1 && <0.5 -- Flags recommended by tasty-bench From 7cb450810f5038622de2850a80b32ff27c0d11cf Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 29 Oct 2025 21:44:05 +0000 Subject: [PATCH 19/26] add to gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 1cf3c3857..623eee846 100644 --- a/.gitignore +++ b/.gitignore @@ -10,10 +10,12 @@ **/dist-newstyle/* GNUmakefile dist-install +dist-mcabal ghc.mk .stack-work .cabal-sandbox/ cabal.sandbox.config +cabal.project.local /benchmarks/bench-Map /benchmarks/bench-Set /benchmarks/bench-IntSet From fc3bb524b956bc7110b233d4e2ad8c874f9fa6fa Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Wed, 29 Oct 2025 23:40:27 +0000 Subject: [PATCH 20/26] add benchmark script --- .gitignore | 2 ++ bench.sh | 68 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 70 insertions(+) create mode 100755 bench.sh diff --git a/.gitignore b/.gitignore index 623eee846..c835d32de 100644 --- a/.gitignore +++ b/.gitignore @@ -24,3 +24,5 @@ cabal.project.local /benchmarks/SetOperations/bench-* /result /TAGS + +benchmark_tmp diff --git a/bench.sh b/bench.sh new file mode 100755 index 000000000..1d56dc736 --- /dev/null +++ b/bench.sh @@ -0,0 +1,68 @@ +#! /bin/bash + +exitWith () { + echo "$1" + exit $(($2)) +} + +if [ -n "$(git status --porcelain)" ]; then + echo "there are changes, exiting benchmark script"; + exit 1 +fi + +CURR=`git rev-parse --abbrev-ref HEAD` + +if [ "$CURR" == "master" ] +then + exitWith "current branch is master, ending benchmarking" -1 +fi + +BENCHMARKS=( + intmap-benchmarks + intset-benchmarks + map-benchmarks + tree-benchmarks + sequence-benchmarks + set-benchmarks + graph-benchmarks + set-operations-intmap + set-operations-intset + set-operations-map + set-operations-set + lookupge-intmap + lookupge-map +) + +BENCHMARK_TMP="benchmark_tmp" + +mkdir -p $BENCHMARK_TMP + +git checkout master + +cabal build all || exitWith "master build errored" 2 + +MASTER_BENCH_LOG="$BENCHMARK_TMP/bench-master.log" +echo -n > $MASTER_BENCH_LOG + +for BENCHMARK in "${BENCHMARKS[@]}" +do + echo "running $BENCHMARK on master" + (cabal bench $BENCHMARK --benchmark-options="--csv $BENCHMARK.csv" >> $MASTER_BENCH_LOG 2>&1) || + exitWith "benchmark $BENCHMARK failed to run on master, exiting" 3 +done + +git checkout $CURR + +cabal build all || exitWith "$CURR build errored" 4 + +CURR_BENCH_LOG="$BENCHMARK_TMP/bench-$CURR.log" +echo -n > $CURR_BENCH_LOG + +for BENCHMARK in "${BENCHMARKS[@]}" +do + echo "running $BENCHMARK on $CURR" + (cabal bench $BENCHMARK --benchmark-options="--csv $BENCHMARK-$CURR.csv --baseline $BENCHMARK.csv" >> $CURR_BENCH_LOG 2>&1) || + exitWith "benchmark $BENCHMARK failed to run on $CURR, exiting" 5 +done + +mv containers-tests/*.csv $BENCHMARK_TMP/ From efe1735e6e7d0479eefe8ff26877b959d825ac5e Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Thu, 30 Oct 2025 19:14:54 +0000 Subject: [PATCH 21/26] bump bounds --- containers-tests/benchmarks/IntMap.hs | 2 +- containers-tests/benchmarks/Map.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/containers-tests/benchmarks/IntMap.hs b/containers-tests/benchmarks/IntMap.hs index efeff97d9..81ac3e1ba 100644 --- a/containers-tests/benchmarks/IntMap.hs +++ b/containers-tests/benchmarks/IntMap.hs @@ -129,7 +129,7 @@ main = do ] -------------------------------------------------------- - !bound = 2^12 + !bound = 2^14 keys = [1..bound] keys' = fmap (+ 1000000) keys keys'' = fmap (* 2) [1..bound] diff --git a/containers-tests/benchmarks/Map.hs b/containers-tests/benchmarks/Map.hs index 881b4e0c4..f88d8978e 100644 --- a/containers-tests/benchmarks/Map.hs +++ b/containers-tests/benchmarks/Map.hs @@ -147,7 +147,7 @@ main = do , bench "mapKeysWith:desc" $ whnf (M.mapKeysWith (+) (negate . (`div` 2))) m ] where - bound = 2^12 + bound = 2^14 elems = shuffle elems_distinct_asc elems_even = zip evens evens elems_odd = zip odds odds From d9623e425f8b413c895987c0eb21b5357f9ae8a0 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Thu, 30 Oct 2025 20:20:19 +0000 Subject: [PATCH 22/26] add inline pragmas --- containers/src/Data/IntMap/Internal.hs | 5 +++++ containers/src/Data/IntMap/Strict/Internal.hs | 5 +++++ containers/src/Data/Map/Internal.hs | 5 +++++ containers/src/Data/Map/Strict/Internal.hs | 5 +++++ 4 files changed, 20 insertions(+) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 59272b52d..6535f5f85 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -3350,6 +3350,11 @@ fromSetA f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) (Bin (Prefix (prefix .|. bits2))) (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) +#if __GLASGOW_HASKELL__ +{-# INLINABLE fromSetA #-} +#else +{-# INLINE fromSetA #-} +#endif {-------------------------------------------------------------------- Lists diff --git a/containers/src/Data/IntMap/Strict/Internal.hs b/containers/src/Data/IntMap/Strict/Internal.hs index 01b8d8596..aba93fa49 100644 --- a/containers/src/Data/IntMap/Strict/Internal.hs +++ b/containers/src/Data/IntMap/Strict/Internal.hs @@ -1114,6 +1114,11 @@ fromSetA f (IntSet.Tip kx bm) = buildTree f kx bm (IntSet.suffixBitMask + 1) (Bin (Prefix (prefix .|. bits2))) (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` bits2) bits2) +#if __GLASGOW_HASKELL__ +{-# INLINABLE fromSetA #-} +#else +{-# INLINE fromSetA #-} +#endif {-------------------------------------------------------------------- Lists diff --git a/containers/src/Data/Map/Internal.hs b/containers/src/Data/Map/Internal.hs index 3d76dd16f..398e1e9cb 100644 --- a/containers/src/Data/Map/Internal.hs +++ b/containers/src/Data/Map/Internal.hs @@ -3555,6 +3555,11 @@ fromSetA f (Set.Bin sz x l r) = <$> fromSetA f l <*> f x <*> fromSetA f r +#if __GLASGOW_HASKELL__ +{-# INLINABLE fromSetA #-} +#else +{-# INLINE fromSetA #-} +#endif -- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's. -- diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs index 54c87298e..de7edf82f 100644 --- a/containers/src/Data/Map/Strict/Internal.hs +++ b/containers/src/Data/Map/Strict/Internal.hs @@ -1486,6 +1486,11 @@ fromSetA f (Set.Bin sz x l r) = <$> fromSetA f l <*> f x <*> fromSetA f r +#if __GLASGOW_HASKELL__ +{-# INLINABLE fromSetA #-} +#else +{-# INLINE fromSetA #-} +#endif -- | \(O(n)\). Build a map from a set of elements contained inside 'Arg's. -- From e3f8d2a0d04e519a6e2d557e83a1a5bb88923ed0 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Thu, 30 Oct 2025 20:24:23 +0000 Subject: [PATCH 23/26] adjust `on` style --- containers-tests/tests/intmap-strictness.hs | 2 +- containers-tests/tests/map-strictness.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/containers-tests/tests/intmap-strictness.hs b/containers-tests/tests/intmap-strictness.hs index 8cc9473e7..e09bcad41 100644 --- a/containers-tests/tests/intmap-strictness.hs +++ b/containers-tests/tests/intmap-strictness.hs @@ -97,7 +97,7 @@ prop_fromSetA_equiv_strictness fun set = bottomOn (M.fromSetA f set) (fmap getSolo . getCompose $ L.fromSetA (Compose . fmap (MkSolo $!) . f) set) where forceValues xs = foldr (\ !_ r -> r) () xs `seq` xs - bottomOn = on (===) (isBottom . getSolo) + bottomOn = (===) `on` isBottom . getSolo f = MkSolo . applyFunc fun prop_strictFromList :: [(Key, Bot A)] -> Property diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs index e5fe5dd47..6cce8ccdd 100644 --- a/containers-tests/tests/map-strictness.hs +++ b/containers-tests/tests/map-strictness.hs @@ -161,7 +161,7 @@ prop_fromSetA_equiv_strictness fun set = bottomOn (M.fromSetA f set) (fmap getSolo . getCompose $ L.fromSetA (Compose . fmap (MkSolo $!) . f) set) where forceValues xs = foldr (\ !_ r -> r) () xs `seq` xs - bottomOn = on (===) (isBottom . getSolo) + bottomOn = (===) `on` isBottom . getSolo f = MkSolo . applyFunc fun prop_strictFromArgSet :: Func OrdA (Bot A) -> Set OrdA -> Property From c8f192bbb8e884972060dea422e5e54a9a769bf7 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Sat, 1 Nov 2025 14:55:02 +0000 Subject: [PATCH 24/26] add to changelog --- containers/changelog.md | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/containers/changelog.md b/containers/changelog.md index 8f53bbbce..21560b8a3 100644 --- a/containers/changelog.md +++ b/containers/changelog.md @@ -8,7 +8,10 @@ ([#1135](https://github.com/haskell/containers/pull/1135)) * Add `mapMaybe` for `Seq`, `Set` and `IntSet`. (Phil Hazelden) - ([#1159](https://github.com/haskell/containers/pull/1159) + ([#1159](https://github.com/haskell/containers/pull/1159)) + +* Add `fromSetA` for `Map` and `IntMap`. (L0neGamer) + ([#1163](https://github.com/haskell/containers/pull/1163)) ### Performance improvements From 0295d5cfa53a2662804c6583384258922592b58e Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Sat, 1 Nov 2025 15:02:38 +0000 Subject: [PATCH 25/26] comment benchmarking script --- bench.sh | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/bench.sh b/bench.sh index 1d56dc736..b2fcf1eda 100755 --- a/bench.sh +++ b/bench.sh @@ -1,5 +1,9 @@ #! /bin/bash +# convenience script to run all benchmarks for the master branch and for the +# starting branch, and compare the before and after in the output file +# bench-$CURR_BRANCH_NAME.out, in `benchmark_tmp/` + exitWith () { echo "$1" exit $(($2)) From 8ba0cff073e4d8c48a7cb6e62f27a030945c4876 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Sat, 1 Nov 2025 15:05:33 +0000 Subject: [PATCH 26/26] explain use of benchmarking script --- CONTRIBUTING.md | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index c8dd3df7b..230936aad 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -59,6 +59,17 @@ To do so on Windows 10 or higher, follow these steps: 2. Enable git symlinks: `git config --global core.symlinks true`. 3. Clone the repository again once git is properly configured. +### Benchmarking script + +To run the all benchmarks of your branch against master, you can run the script +`./bench.sh` while on your feature branch. + +This first builds and benchmarks against the master branch, and then builds and +benchmarks on your branch, and compares between them. + +You can also fiddle with the script as long as the changes are reflected in your +local master branch and run less than the full suite of benchmarks. + ## Sending Pull Requests When you send a pull request, please: