From 46c2e550fa28ceb04e6d1a2872f947f5926845d7 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Sun, 16 Nov 2025 17:21:55 +0000 Subject: [PATCH 1/4] remove unneeded Bot instances --- containers-tests/tests/Utils/Strictness.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/containers-tests/tests/Utils/Strictness.hs b/containers-tests/tests/Utils/Strictness.hs index eead2666b..755745170 100644 --- a/containers-tests/tests/Utils/Strictness.hs +++ b/containers-tests/tests/Utils/Strictness.hs @@ -27,12 +27,6 @@ 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 46f25aa29b2a0773f8c750e1fc9a8af93d230d5e Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Sun, 16 Nov 2025 18:08:40 +0000 Subject: [PATCH 2/4] check maps are well constructed in fromSetA action order props --- containers-tests/tests/intmap-properties.hs | 8 ++++++-- containers-tests/tests/map-properties.hs | 8 ++++++-- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 561c3bd4c..2df625d96 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -1705,12 +1705,16 @@ prop_fromSet keys funF = prop_fromSetA_action_order :: [Int] -> Fun Int A -> Property prop_fromSetA_action_order keys funF = - let iSet = IntSet.fromList keys + let set = IntSet.fromList keys + setList = IntSet.toList set f = apply funF action = \k -> let v = f k in tell [v] $> v - in execWriter (fromSetA action iSet) === List.map f (IntSet.toList iSet) + (writtenMap, writtenOutput) = runWriter (fromSetA action set) + in + writtenOutput === List.map f setList .&&. + toList writtenMap === fmap (id &&& f) setList 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 d1e5a8e1e..f0c175c6a 100644 --- a/containers-tests/tests/map-properties.hs +++ b/containers-tests/tests/map-properties.hs @@ -1727,12 +1727,16 @@ prop_fromSet keys funF = prop_fromSetA_action_order :: [OrdA] -> Fun OrdA B -> Property prop_fromSetA_action_order keys funF = - let iSet = Set.fromList keys + let set = Set.fromList keys + setList = Set.toList set f = apply funF action = \k -> let v = f k in tell [v] $> v - in execWriter (fromSetA action iSet) === List.map f (Set.toList iSet) + (writtenMap, writtenOutput) = runWriter (fromSetA action set) + in + writtenOutput === List.map f setList .&&. + toList writtenMap === fmap (id &&& f) setList prop_fromArgSet :: [(OrdA, B)] -> Property prop_fromArgSet ys = From 93d9a4ae53449f484b1525ff5dfe9e60156f9dd5 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Sun, 16 Nov 2025 18:31:07 +0000 Subject: [PATCH 3/4] use liftA3 instead of other applicative operations --- containers/src/Data/Map/Internal.hs | 5 +---- containers/src/Data/Map/Strict/Internal.hs | 6 ++---- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/containers/src/Data/Map/Internal.hs b/containers/src/Data/Map/Internal.hs index 398e1e9cb..28b517a5b 100644 --- a/containers/src/Data/Map/Internal.hs +++ b/containers/src/Data/Map/Internal.hs @@ -3551,10 +3551,7 @@ 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) = - flip (Bin sz x) - <$> fromSetA f l - <*> f x - <*> fromSetA f r + liftA3 (flip (Bin sz x)) (fromSetA f l) (f x) (fromSetA f r) #if __GLASGOW_HASKELL__ {-# INLINABLE fromSetA #-} #else diff --git a/containers/src/Data/Map/Strict/Internal.hs b/containers/src/Data/Map/Strict/Internal.hs index de7edf82f..d4060881d 100644 --- a/containers/src/Data/Map/Strict/Internal.hs +++ b/containers/src/Data/Map/Strict/Internal.hs @@ -1482,10 +1482,8 @@ 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) = - flip (Bin sz x $!) - <$> fromSetA f l - <*> f x - <*> fromSetA f r + liftA3 (flip (Bin sz x $!)) (fromSetA f l) (f x) (fromSetA f r) + #if __GLASGOW_HASKELL__ {-# INLINABLE fromSetA #-} #else From 0b474aaadbd7529384efeecf9a6a434d6ccf95b6 Mon Sep 17 00:00:00 2001 From: L0neGamer Date: Mon, 17 Nov 2025 17:56:06 +0000 Subject: [PATCH 4/4] add validity to `fromSet` testing --- containers-tests/tests/intmap-properties.hs | 6 +++++- containers-tests/tests/map-properties.hs | 6 +++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 2df625d96..4f129588d 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -1701,7 +1701,10 @@ prop_keysSet keys = prop_fromSet :: [Int] -> Fun Int A -> Property prop_fromSet keys funF = let f = apply funF - in fromSet f (IntSet.fromList keys) === fromList (fmap (id &&& f) keys) + m = fromSet f (IntSet.fromList keys) + in + valid m .&&. + m === fromList (fmap (id &&& f) keys) prop_fromSetA_action_order :: [Int] -> Fun Int A -> Property prop_fromSetA_action_order keys funF = @@ -1713,6 +1716,7 @@ prop_fromSetA_action_order keys funF = in tell [v] $> v (writtenMap, writtenOutput) = runWriter (fromSetA action set) in + valid writtenMap .&&. writtenOutput === List.map f setList .&&. toList writtenMap === fmap (id &&& f) setList diff --git a/containers-tests/tests/map-properties.hs b/containers-tests/tests/map-properties.hs index f0c175c6a..a05d8ce8c 100644 --- a/containers-tests/tests/map-properties.hs +++ b/containers-tests/tests/map-properties.hs @@ -1723,7 +1723,10 @@ prop_argSet xs = prop_fromSet :: [OrdA] -> Fun OrdA B -> Property prop_fromSet keys funF = let f = apply funF - in fromSet f (Set.fromList keys) === fromList (fmap (id &&& f) keys) + m = fromSet f (Set.fromList keys) + in + valid m .&&. + m === fromList (fmap (id &&& f) keys) prop_fromSetA_action_order :: [OrdA] -> Fun OrdA B -> Property prop_fromSetA_action_order keys funF = @@ -1735,6 +1738,7 @@ prop_fromSetA_action_order keys funF = in tell [v] $> v (writtenMap, writtenOutput) = runWriter (fromSetA action set) in + valid writtenMap .&&. writtenOutput === List.map f setList .&&. toList writtenMap === fmap (id &&& f) setList