From db094c7154065a6752fbc468276d279780361c2e Mon Sep 17 00:00:00 2001 From: meooow25 Date: Mon, 18 Nov 2024 02:42:19 +0530 Subject: [PATCH] Strictness tests for left and right folds * Add new tests and update existing tests to check against lists. This covers all left and right folds on Set, Map, IntSet, IntMap. * Remove the now unnecessary nothunks dependency. --- containers-tests/containers-tests.cabal | 56 ++++---- containers-tests/tests/Utils/IsUnit.hs | 42 ------ containers-tests/tests/Utils/NoThunks.hs | 12 -- containers-tests/tests/Utils/NubSorted.hs | 35 +++++ containers-tests/tests/intmap-strictness.hs | 110 ++++++++++++--- containers-tests/tests/intset-strictness.hs | 102 +++++++------- containers-tests/tests/map-strictness.hs | 141 +++++++++++++++----- containers-tests/tests/set-properties.hs | 17 --- containers-tests/tests/set-strictness.hs | 82 ++++++++++++ 9 files changed, 399 insertions(+), 198 deletions(-) delete mode 100644 containers-tests/tests/Utils/IsUnit.hs delete mode 100644 containers-tests/tests/Utils/NoThunks.hs create mode 100644 containers-tests/tests/Utils/NubSorted.hs create mode 100644 containers-tests/tests/set-strictness.hs diff --git a/containers-tests/containers-tests.cabal b/containers-tests/containers-tests.cabal index e0360b41e..f51e1d168 100644 --- a/containers-tests/containers-tests.cabal +++ b/containers-tests/containers-tests.cabal @@ -70,13 +70,9 @@ library default-language: Haskell2010 -- this is important for testing; may it affect benchmarks? cpp-options: -DTESTING - if impl(ghc >= 8.6) - build-depends: - nothunks - , QuickCheck include-dirs: include - hs-source-dirs: src, tests + hs-source-dirs: src ghc-options: -O2 -Wall if impl(ghc >= 8.6) @@ -117,9 +113,6 @@ library Utils.Containers.Internal.BitQueue Utils.Containers.Internal.BitUtil Utils.Containers.Internal.StrictPair - if impl(ghc >= 8.6.0) - exposed-modules: - Utils.NoThunks other-modules: Utils.Containers.Internal.Prelude @@ -320,12 +313,6 @@ test-suite set-properties BangPatterns CPP - if impl(ghc >= 8.6) - build-depends: - nothunks - other-modules: - Utils.NoThunks - test-suite intmap-lazy-properties import: test-deps, warnings default-language: Haskell2010 @@ -415,14 +402,9 @@ test-suite map-strictness-properties other-modules: Utils.ArbitrarySetMap Utils.MergeFunc + Utils.NubSorted Utils.Strictness - if impl(ghc >= 8.6) - build-depends: - nothunks - other-modules: - Utils.NoThunks - test-suite intmap-strictness-properties import: test-deps, warnings default-language: Haskell2010 @@ -439,15 +421,29 @@ test-suite intmap-strictness-properties ghc-options: -Wall other-modules: - Utils.IsUnit Utils.MergeFunc + Utils.NubSorted Utils.Strictness - if impl(ghc >= 8.6) - build-depends: - nothunks - other-modules: - Utils.NoThunks +test-suite set-strictness-properties + import: test-deps, warnings + default-language: Haskell2010 + hs-source-dirs: tests + main-is: set-strictness.hs + type: exitcode-stdio-1.0 + other-extensions: + BangPatterns + CPP + + build-depends: + ChasingBottoms + + ghc-options: -Wall + + other-modules: + Utils.ArbitrarySetMap + Utils.NubSorted + Utils.Strictness test-suite intset-strictness-properties import: test-deps, warnings @@ -464,11 +460,9 @@ test-suite intset-strictness-properties ghc-options: -Wall - if impl(ghc >= 8.6) - build-depends: - nothunks - other-modules: - Utils.NoThunks + other-modules: + Utils.NubSorted + Utils.Strictness test-suite listutils-properties import: test-deps, warnings diff --git a/containers-tests/tests/Utils/IsUnit.hs b/containers-tests/tests/Utils/IsUnit.hs deleted file mode 100644 index a7dda281e..000000000 --- a/containers-tests/tests/Utils/IsUnit.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifdef __GLASGOW_HASKELL__ -{-# LANGUAGE MagicHash #-} -#endif - -module Utils.IsUnit (isUnit, isUnitSupported) where - -#ifdef __GLASGOW_HASKELL__ -import GHC.Exts -#endif - --- | Check whether the argument is a fully evaluated unit `()`. --- --- Always returns `False` is `isUnitSupported` returns `False`. --- --- Uses `reallyUnsafePtrEquality#`. -isUnit :: () -> Bool - --- | Checks whether `isUnit` is supported by the Haskell implementation. --- --- Currently returns `True` for ghc and `False` for all other implementations. -isUnitSupported :: Bool - -#ifdef __GLASGOW_HASKELL__ - --- simplified from Utils.Containers.Internal.PtrEquality -ptrEq :: a -> a -> Bool -ptrEq x y = case reallyUnsafePtrEquality# x y of - 0# -> False - _ -> True - -isUnit = ptrEq () - -isUnitSupported = True - -#else /* !__GLASGOW_HASKELL__ */ - -isUnit = False - -isUnitSupported = False - -#endif diff --git a/containers-tests/tests/Utils/NoThunks.hs b/containers-tests/tests/Utils/NoThunks.hs deleted file mode 100644 index 28e8c76ea..000000000 --- a/containers-tests/tests/Utils/NoThunks.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Utils.NoThunks (whnfHasNoThunks) where - -import NoThunks.Class (NoThunks, noThunks) -import Test.QuickCheck (Property, counterexample, ioProperty, property) - --- | Check that after evaluating the argument to weak head normal form there --- are no thunks. --- -whnfHasNoThunks :: NoThunks a => a -> Property -whnfHasNoThunks a = ioProperty $ - maybe (property True) ((`counterexample` False) . show) - <$> (noThunks [] $! a) diff --git a/containers-tests/tests/Utils/NubSorted.hs b/containers-tests/tests/Utils/NubSorted.hs new file mode 100644 index 000000000..ac3f2c3c4 --- /dev/null +++ b/containers-tests/tests/Utils/NubSorted.hs @@ -0,0 +1,35 @@ +module Utils.NubSorted + ( + -- NubSorted and NubSortedOnFst + NubSorted(..) + , NubSortedOnFst(..) + ) where + +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.Ord (comparing) +import Test.QuickCheck + +newtype NubSorted a = NubSorted { getNubSorted :: [a] } + deriving Show + +instance (Ord a, Arbitrary a) => Arbitrary (NubSorted a) where + arbitrary = NubSorted . nubSortBy compare <$> arbitrary + shrink = map (NubSorted . nubSortBy compare) . shrink . getNubSorted + +newtype NubSortedOnFst a b = NubSortedOnFst { getNubSortedOnFst :: [(a, b)] } + deriving Show + +instance (Ord a, Arbitrary a, Arbitrary b) + => Arbitrary (NubSortedOnFst a b) where + arbitrary = NubSortedOnFst . nubSortBy (comparing fst) <$> arbitrary + shrink = + map (NubSortedOnFst . nubSortBy (comparing fst)) . + shrink . + getNubSortedOnFst + +nubSortBy :: (a -> a -> Ordering) -> [a] -> [a] +nubSortBy cmp = + map NonEmpty.head . + NonEmpty.groupBy (\x y -> cmp x y == EQ) . + List.sortBy cmp diff --git a/containers-tests/tests/intmap-strictness.hs b/containers-tests/tests/intmap-strictness.hs index 9ec38965b..bc9188930 100644 --- a/containers-tests/tests/intmap-strictness.hs +++ b/containers-tests/tests/intmap-strictness.hs @@ -32,11 +32,9 @@ import qualified Data.IntMap.Merge.Lazy as LMerge import Data.Containers.ListUtils import Utils.MergeFunc (WhenMatchedFunc(..), WhenMissingFunc(..)) +import Utils.NubSorted (NubSortedOnFst(..)) import Utils.Strictness (Bot(..), Func, Func2, Func3, applyFunc, applyFunc2, applyFunc3) -#if __GLASGOW_HASKELL__ >= 806 -import Utils.NoThunks -#endif instance Arbitrary v => Arbitrary (IntMap v) where arbitrary = M.fromList `fmap` arbitrary @@ -56,7 +54,7 @@ apply3 f a b c = apply f (a, b, c) Construction property tests --------------------------------------------------------------------} --- See Note [Test overview] in map-strictness.hs +-- See Note [Overview of construction tests] in map-strictness.hs -- See Note [Testing with lazy functions] in map-strictness.hs @@ -879,15 +877,91 @@ pFromAscListStrict ks where elems = [(k, v) | k <- nubInt ks, v <- [undefined, undefined, ()]] -#if __GLASGOW_HASKELL__ >= 806 -pStrictFoldr' :: IntMap Int -> Property -pStrictFoldr' m = whnfHasNoThunks (M.foldr' (:) [] m) -#endif +{-------------------------------------------------------------------- + Folds +--------------------------------------------------------------------} + +-- See Note [Testing strictness of folds] in map-strictness.hs + +prop_foldrWithKey + :: NubSortedOnFst Key (Bot A) -> Func3 Key A B (Bot B) -> Bot B -> Property +prop_foldrWithKey kvs fun (Bot z) = + isBottom (M.foldrWithKey f z m) === + isBottom (F.foldr (uncurry f) z kvs') + where + kvs' = coerce kvs :: [(Key, A)] + m = L.fromList kvs' + f = coerce (applyFunc3 fun) + +prop_foldr + :: NubSortedOnFst Key (Bot A) -> Func2 A B (Bot B) -> Bot B -> Property +prop_foldr kvs fun (Bot z) = + isBottom (M.foldr f z m) === + isBottom (F.foldr (f . snd) z kvs') + where + kvs' = coerce kvs :: [(Key, A)] + m = L.fromList kvs' + f = coerce (applyFunc2 fun) + +prop_foldlWithKey + :: NubSortedOnFst Key (Bot A) -> Func3 B Key A (Bot B) -> Bot B -> Property +prop_foldlWithKey kvs fun (Bot z) = + isBottom (M.foldlWithKey f z m) === + isBottom (F.foldl (\z' (k,x) -> f z' k x) z kvs') + where + kvs' = coerce kvs :: [(Key, A)] + m = L.fromList kvs' + f = coerce (applyFunc3 fun) + +prop_foldl + :: NubSortedOnFst Key (Bot A) -> Func2 B A (Bot B) -> Bot B -> Property +prop_foldl kvs fun (Bot z) = + isBottom (M.foldl f z m) === + isBottom (F.foldl (\z' (_,x) -> f z' x) z kvs') + where + kvs' = coerce kvs :: [(Key, A)] + m = L.fromList kvs' + f = coerce (applyFunc2 fun) -#if __GLASGOW_HASKELL__ >= 806 -pStrictFoldl' :: IntMap Int -> Property -pStrictFoldl' m = whnfHasNoThunks (M.foldl' (flip (:)) [] m) -#endif +prop_foldrWithKey' + :: NubSortedOnFst Key (Bot A) -> Func3 Key A B (Bot B) -> Bot B -> Property +prop_foldrWithKey' kvs fun (Bot z) = + isBottom (M.foldrWithKey' f z m) === + isBottom (z `seq` F.foldr' (uncurry f) z kvs') + where + kvs' = coerce kvs :: [(Key, A)] + m = L.fromList kvs' + f = coerce (applyFunc3 fun) + +prop_foldr' + :: NubSortedOnFst Key (Bot A) -> Func2 A B (Bot B) -> Bot B -> Property +prop_foldr' kvs fun (Bot z) = + isBottom (M.foldr' f z m) === + isBottom (z `seq` F.foldr' (f . snd) z kvs') + where + kvs' = coerce kvs :: [(Key, A)] + m = L.fromList kvs' + f = coerce (applyFunc2 fun) + +prop_foldlWithKey' + :: NubSortedOnFst Key (Bot A) -> Func3 B Key A (Bot B) -> Bot B -> Property +prop_foldlWithKey' kvs fun (Bot z) = + isBottom (M.foldlWithKey' f z m) === + isBottom (F.foldl' (\z' (k,x) -> f z' k x) z kvs') + where + kvs' = coerce kvs :: [(Key, A)] + m = L.fromList kvs' + f = coerce (applyFunc3 fun) + +prop_foldl' + :: NubSortedOnFst Key (Bot A) -> Func2 B A (Bot B) -> Bot B -> Property +prop_foldl' kvs fun (Bot z) = + isBottom (M.foldl' f z m) === + isBottom (F.foldl' (\z' (_,x) -> f z' x) z kvs') + where + kvs' = coerce kvs :: [(Key, A)] + m = L.fromList kvs' + f = coerce (applyFunc2 fun) ------------------------------------------------------------------------ -- * Test list @@ -918,10 +992,14 @@ tests = pInsertLookupWithKeyValueStrict , testProperty "fromAscList is somewhat value-lazy" pFromAscListLazy , testProperty "fromAscList is somewhat value-strict" pFromAscListStrict -#if __GLASGOW_HASKELL__ >= 806 - , testProperty "strict foldr'" pStrictFoldr' - , testProperty "strict foldl'" pStrictFoldl' -#endif + , testProperty "foldrWithKey" prop_foldrWithKey + , testProperty "foldr" prop_foldr + , testProperty "foldlWithKey" prop_foldlWithKey + , testProperty "foldl" prop_foldl + , testProperty "foldrWithKey'" prop_foldrWithKey' + , testProperty "foldr'" prop_foldr' + , testProperty "foldlWithKey'" prop_foldlWithKey' + , testProperty "foldl'" prop_foldl' ] , testGroup "Construction" [ testPropStrictLazy "singleton" prop_strictSingleton prop_lazySingleton diff --git a/containers-tests/tests/intset-strictness.hs b/containers-tests/tests/intset-strictness.hs index db56ad478..ad4a5bab5 100644 --- a/containers-tests/tests/intset-strictness.hs +++ b/containers-tests/tests/intset-strictness.hs @@ -1,73 +1,81 @@ -{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where -import Prelude hiding (foldl, foldl') +import Data.Coerce (coerce) +import qualified Data.Foldable as F -import Test.ChasingBottoms.IsBottom +import Test.ChasingBottoms.IsBottom (isBottom) import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.QuickCheck (testProperty, Arbitrary (..)) -#if __GLASGOW_HASKELL__ >= 806 -import Test.Tasty.QuickCheck (Property) -#endif +import Test.Tasty.QuickCheck +import Test.QuickCheck.Poly (B) -import Data.IntSet +import Data.IntSet (IntSet) +import qualified Data.IntSet as S -#if __GLASGOW_HASKELL__ >= 806 -import Utils.NoThunks -#endif +import Utils.NubSorted (NubSorted(..)) +import Utils.Strictness (Bot(..), Func2, applyFunc2) +------------------------------------------------------------------------ +-- * Arbitrary -{-------------------------------------------------------------------- - Arbitrary, reasonably balanced trees ---------------------------------------------------------------------} instance Arbitrary IntSet where - arbitrary = do{ xs <- arbitrary - ; return (fromList xs) - } + arbitrary = S.fromList <$> arbitrary + shrink = map S.fromList . shrink . S.toList ------------------------------------------------------------------------ -- * Properties ------------------------------------------------------------------------- --- ** Lazy module - -pFoldlAccLazy :: Int -> Bool -pFoldlAccLazy k = - isn'tBottom $ foldl (\_ x -> x) (bottom :: Int) (singleton k) - -#if __GLASGOW_HASKELL__ >= 806 -pStrictFoldr' :: IntSet -> Property -pStrictFoldr' m = whnfHasNoThunks (foldr' (:) [] m) -#endif +{-------------------------------------------------------------------- + Folds +--------------------------------------------------------------------} -#if __GLASGOW_HASKELL__ >= 806 -pStrictFoldl' :: IntSet -> Property -pStrictFoldl' m = whnfHasNoThunks (foldl' (flip (:)) [] m) -#endif +-- See Note [Testing strictness of folds] in map-strictness.hs + +prop_foldr :: NubSorted Int -> Func2 Int B (Bot B) -> Bot B -> Property +prop_foldr (NubSorted xs) fun (Bot z) = + isBottom (S.foldr f z s) === + isBottom (F.foldr f z xs) + where + s = S.fromList xs + f = coerce (applyFunc2 fun) :: Int -> B -> B + +prop_foldl :: NubSorted Int -> Func2 B Int (Bot B) -> Bot B -> Property +prop_foldl (NubSorted xs) fun (Bot z) = + isBottom (S.foldl f z s) === + isBottom (F.foldl f z xs) + where + s = S.fromList xs + f = coerce (applyFunc2 fun) :: B -> Int -> B + +prop_foldr' :: NubSorted Int -> Func2 Int B (Bot B) -> Bot B -> Property +prop_foldr' (NubSorted xs) fun (Bot z) = + isBottom (S.foldr' f z s) === + isBottom (z `seq` F.foldr' f z xs) + where + s = S.fromList xs + f = coerce (applyFunc2 fun) :: Int -> B -> B + +prop_foldl' :: NubSorted Int -> Func2 B Int (Bot B) -> Bot B -> Property +prop_foldl' (NubSorted xs) fun (Bot z) = + isBottom (S.foldl' f z s) === + isBottom (F.foldl' f z xs) + where + s = S.fromList xs + f = coerce (applyFunc2 fun) :: B -> Int -> B ------------------------------------------------------------------------ -- * Test list tests :: TestTree -tests = - -- Basic interface - testGroup "IntSet" - [ testProperty "foldl is lazy in accumulator" pFoldlAccLazy -#if __GLASGOW_HASKELL__ >= 806 - , testProperty "strict foldr'" pStrictFoldr' - , testProperty "strict foldl'" pStrictFoldl' -#endif - ] +tests = testGroup "IntSet" + [ testProperty "prop_foldr" prop_foldr + , testProperty "prop_foldl" prop_foldl + , testProperty "prop_foldr'" prop_foldr' + , testProperty "prop_foldl'" prop_foldl' + ] ------------------------------------------------------------------------ -- * Test harness main :: IO () main = defaultMain tests - ------------------------------------------------------------------------- --- * Utilities - -isn'tBottom :: a -> Bool -isn'tBottom = not . isBottom diff --git a/containers-tests/tests/map-strictness.hs b/containers-tests/tests/map-strictness.hs index f69f1b3f4..6f1832ad2 100644 --- a/containers-tests/tests/map-strictness.hs +++ b/containers-tests/tests/map-strictness.hs @@ -30,22 +30,18 @@ import Data.Map.Merge.Lazy (WhenMatched, WhenMissing) import qualified Data.Map.Merge.Lazy as LMerge import Data.Set (Set) import qualified Data.Set as Set -import Data.Containers.ListUtils (nubOrd) import Utils.ArbitrarySetMap (setFromList, mapFromKeysList) +import Utils.NubSorted (NubSorted(..), NubSortedOnFst(..)) import Utils.MergeFunc (WhenMatchedFunc(..), WhenMissingFunc(..)) import Utils.Strictness (Bot(..), Func, Func2, Func3, applyFunc, applyFunc2, applyFunc3) -#if __GLASGOW_HASKELL__ >= 806 -import Utils.NoThunks -#endif - instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (Map k v) where arbitrary = do - Sorted xs <- arbitrary - m <- mapFromKeysList (nubOrd xs) + NubSorted xs <- arbitrary + m <- mapFromKeysList xs -- Force the values to WHNF. Should use liftRnf2 when that's available. let !_ = foldr seq () m @@ -54,8 +50,8 @@ instance (Arbitrary k, Arbitrary v, Ord k) => instance (Arbitrary a, Ord a) => Arbitrary (Set a) where arbitrary = do - Sorted xs <- arbitrary - setFromList (nubOrd xs) + NubSorted xs <- arbitrary + setFromList xs apply2 :: Fun (a, b) c -> a -> b -> c apply2 f a b = apply f (a, b) @@ -67,8 +63,8 @@ apply3 f a b c = apply f (a, b, c) Construction property tests --------------------------------------------------------------------} --- Note [Test overview] --- ~~~~~~~~~~~~~~~~~~~~ +-- Note [Overview of construction tests] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- The purpose of these property tests is to ensure that -- @@ -1011,25 +1007,102 @@ pInsertLookupWithKeyValueStrict f k v m not (isBottom $ M.insertLookupWithKey (const3 1) k bottom m) | otherwise = isBottom $ M.insertLookupWithKey (apply3 f) k bottom m -#if __GLASGOW_HASKELL__ >= 806 -pStrictFoldr' :: Map Int Int -> Property -pStrictFoldr' m = whnfHasNoThunks (M.foldr' (:) [] m) -#endif +{-------------------------------------------------------------------- + Folds +--------------------------------------------------------------------} + +-- Note [Testing strictness of folds] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We test the strictness of left and right folds against the corresponding +-- folds on lists. Note that foldr' on lists is not strict in the starting +-- value (GHC #25508), so we force the starting value to match the strictness +-- of Map.foldr' and Map.foldrWithKey'. +-- +-- Caveats: A definition passing a strictness test does not mean it is "proper", +-- for lack of a better term. Strictness is only one aspect of a "proper" +-- definition, which is expected to have other properties such as lazy folds +-- being short-circuiting or strict folds being space-efficient. + +prop_foldrWithKey + :: NubSortedOnFst OrdA (Bot A) -> Func3 OrdA A B (Bot B) -> Bot B -> Property +prop_foldrWithKey (NubSortedOnFst kvs) fun (Bot z) = + isBottom (M.foldrWithKey f z m) === + isBottom (F.foldr (uncurry f) z kvs') + where + kvs' = coerce kvs :: [(OrdA, A)] + m = L.fromList kvs' + f = coerce (applyFunc3 fun) + +prop_foldr + :: NubSortedOnFst OrdA (Bot A) -> Func2 A B (Bot B) -> Bot B -> Property +prop_foldr kvs fun (Bot z) = + isBottom (M.foldr f z m) === + isBottom (F.foldr (f . snd) z kvs') + where + kvs' = coerce kvs :: [(OrdA, A)] + m = L.fromList kvs' + f = coerce (applyFunc2 fun) + +prop_foldlWithKey + :: NubSortedOnFst OrdA (Bot A) -> Func3 B OrdA A (Bot B) -> Bot B -> Property +prop_foldlWithKey (NubSortedOnFst kvs) fun (Bot z) = + isBottom (M.foldlWithKey f z m) === + isBottom (F.foldl (\z' (k,x) -> f z' k x) z kvs') + where + kvs' = coerce kvs :: [(OrdA, A)] + m = L.fromList kvs' + f = coerce (applyFunc3 fun) + +prop_foldl + :: NubSortedOnFst OrdA (Bot A) -> Func2 B A (Bot B) -> Bot B -> Property +prop_foldl (NubSortedOnFst kvs) fun (Bot z) = + isBottom (M.foldl f z m) === + isBottom (F.foldl (\z' (_,x) -> f z' x) z kvs') + where + kvs' = coerce kvs :: [(OrdA, A)] + m = L.fromList kvs' + f = coerce (applyFunc2 fun) + +prop_foldrWithKey' + :: NubSortedOnFst OrdA (Bot A) -> Func3 OrdA A B (Bot B) -> Bot B -> Property +prop_foldrWithKey' (NubSortedOnFst kvs) fun (Bot z) = + isBottom (M.foldrWithKey' f z m) === + isBottom (z `seq` F.foldr' (uncurry f) z kvs') + where + kvs' = coerce kvs :: [(OrdA, A)] + m = L.fromList kvs' + f = coerce (applyFunc3 fun) -#if __GLASGOW_HASKELL__ >= 806 -pStrictFoldl' :: Map Int Int -> Property -pStrictFoldl' m = whnfHasNoThunks (M.foldl' (flip (:)) [] m) -#endif +prop_foldr' + :: NubSortedOnFst OrdA (Bot A) -> Func2 A B (Bot B) -> Bot B -> Property +prop_foldr' kvs fun (Bot z) = + isBottom (M.foldr' f z m) === + isBottom (z `seq` F.foldr' (f . snd) z kvs') + where + kvs' = coerce kvs :: [(OrdA, A)] + m = L.fromList kvs' + f = coerce (applyFunc2 fun) -#if __GLASGOW_HASKELL__ >= 806 -pStrictFoldrWithKey' :: Map Int Int -> Property -pStrictFoldrWithKey' m = whnfHasNoThunks (M.foldrWithKey' (\_ a as -> a : as) [] m) -#endif +prop_foldlWithKey' + :: NubSortedOnFst OrdA (Bot A) -> Func3 B OrdA A (Bot B) -> Bot B -> Property +prop_foldlWithKey' (NubSortedOnFst kvs) fun (Bot z) = + isBottom (M.foldlWithKey' f z m) === + isBottom (F.foldl' (\z' (k,x) -> f z' k x) z kvs') + where + kvs' = coerce kvs :: [(OrdA, A)] + m = L.fromList kvs' + f = coerce (applyFunc3 fun) -#if __GLASGOW_HASKELL__ >= 806 -pStrictFoldlWithKey' :: Map Int Int -> Property -pStrictFoldlWithKey' m = whnfHasNoThunks (M.foldlWithKey' (\as _ a -> a : as) [] m) -#endif +prop_foldl' + :: NubSortedOnFst OrdA (Bot A) -> Func2 B A (Bot B) -> Bot B -> Property +prop_foldl' (NubSortedOnFst kvs) fun (Bot z) = + isBottom (M.foldl' f z m) === + isBottom (F.foldl' (\z' (_,x) -> f z' x) z kvs') + where + kvs' = coerce kvs :: [(OrdA, A)] + m = L.fromList kvs' + f = coerce (applyFunc2 fun) ------------------------------------------------------------------------ -- * Test list @@ -1057,12 +1130,14 @@ tests = pInsertLookupWithKeyKeyStrict , testProperty "insertLookupWithKey is value-strict" pInsertLookupWithKeyValueStrict -#if __GLASGOW_HASKELL__ >= 806 - , testProperty "strict foldr'" pStrictFoldr' - , testProperty "strict foldl'" pStrictFoldl' - , testProperty "strict foldrWithKey'" pStrictFoldrWithKey' - , testProperty "strict foldlWithKey'" pStrictFoldlWithKey' -#endif + , testProperty "foldrWithKey" prop_foldrWithKey + , testProperty "foldr" prop_foldr + , testProperty "foldlWithKey" prop_foldlWithKey + , testProperty "foldl" prop_foldl + , testProperty "foldrWithKey'" prop_foldrWithKey' + , testProperty "foldr'" prop_foldr' + , testProperty "foldlWithKey'" prop_foldlWithKey' + , testProperty "foldl'" prop_foldl' ] , testGroup "Construction" [ testPropStrictLazy "singleton" prop_strictSingleton prop_lazySingleton diff --git a/containers-tests/tests/set-properties.hs b/containers-tests/tests/set-properties.hs index 07b5bfc39..33068ae4a 100644 --- a/containers-tests/tests/set-properties.hs +++ b/containers-tests/tests/set-properties.hs @@ -19,9 +19,6 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE import Utils.ArbitrarySetMap (mkArbSet, setFromList) -#if __GLASGOW_HASKELL__ >= 806 -import Utils.NoThunks (whnfHasNoThunks) -#endif main :: IO () main = defaultMain $ testGroup "set-properties" @@ -109,10 +106,6 @@ main = defaultMain $ testGroup "set-properties" , testProperty "powerSet" prop_powerSet , testProperty "cartesianProduct" prop_cartesianProduct , testProperty "disjointUnion" prop_disjointUnion -#if __GLASGOW_HASKELL__ >= 806 - , testProperty "strict foldr" prop_strictFoldr' - , testProperty "strict foldl" prop_strictFoldl' -#endif , testProperty "eq" prop_eq , testProperty "compare" prop_compare , testProperty "intersections" prop_intersections @@ -695,16 +688,6 @@ isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft _ = False -#if __GLASGOW_HASKELL__ >= 806 -prop_strictFoldr' :: Set Int -> Property -prop_strictFoldr' m = whnfHasNoThunks (foldr' (:) [] m) -#endif - -#if __GLASGOW_HASKELL__ >= 806 -prop_strictFoldl' :: Set Int -> Property -prop_strictFoldl' m = whnfHasNoThunks (foldl' (flip (:)) [] m) -#endif - prop_eq :: Set Int -> Set Int -> Property prop_eq s1 s2 = (s1 == s2) === (toList s1 == toList s2) diff --git a/containers-tests/tests/set-strictness.hs b/containers-tests/tests/set-strictness.hs new file mode 100644 index 000000000..642ec4ca8 --- /dev/null +++ b/containers-tests/tests/set-strictness.hs @@ -0,0 +1,82 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +import Data.Coerce (coerce) +import qualified Data.Foldable as F + +import Test.ChasingBottoms.IsBottom (isBottom) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.QuickCheck +import Test.QuickCheck.Poly (OrdA, B) + +import Data.Set (Set) +import qualified Data.Set as S + +import Utils.ArbitrarySetMap (setFromList) +import Utils.NubSorted (NubSorted(..)) +import Utils.Strictness (Bot(..), Func2, applyFunc2) + +------------------------------------------------------------------------ +-- * Arbitrary + +instance (Arbitrary a, Ord a) => Arbitrary (Set a) where + arbitrary = do + NubSorted xs <- arbitrary + setFromList xs + +------------------------------------------------------------------------ +-- * Properties + +{-------------------------------------------------------------------- + Folds +--------------------------------------------------------------------} + +-- See Note [Testing strictness of folds] in map-strictness.hs + +prop_foldr :: NubSorted OrdA -> Func2 OrdA B (Bot B) -> Bot B -> Property +prop_foldr (NubSorted xs) fun (Bot z) = + isBottom (S.foldr f z s) === + isBottom (F.foldr f z xs) + where + s = S.fromList xs + f = coerce (applyFunc2 fun) :: OrdA -> B -> B + +prop_foldl :: NubSorted OrdA -> Func2 B OrdA (Bot B) -> Bot B -> Property +prop_foldl (NubSorted xs) fun (Bot z) = + isBottom (S.foldl f z s) === + isBottom (F.foldl f z xs) + where + s = S.fromList xs + f = coerce (applyFunc2 fun) :: B -> OrdA -> B + +prop_foldr' :: NubSorted OrdA -> Func2 OrdA B (Bot B) -> Bot B -> Property +prop_foldr' (NubSorted xs) fun (Bot z) = + isBottom (S.foldr' f z s) === + isBottom (z `seq` F.foldr' f z xs) + where + s = S.fromList xs + f = coerce (applyFunc2 fun) :: OrdA -> B -> B + +prop_foldl' :: NubSorted OrdA -> Func2 B OrdA (Bot B) -> Bot B -> Property +prop_foldl' (NubSorted xs) fun (Bot z) = + isBottom (S.foldl' f z s) === + isBottom (F.foldl' f z xs) + where + s = S.fromList xs + f = coerce (applyFunc2 fun) :: B -> OrdA -> B + +------------------------------------------------------------------------ +-- * Test list + +tests :: TestTree +tests = testGroup "Set" + [ testProperty "prop_foldr" prop_foldr + , testProperty "prop_foldl" prop_foldl + , testProperty "prop_foldr'" prop_foldr' + , testProperty "prop_foldl'" prop_foldl' + ] + +------------------------------------------------------------------------ +-- * Test harness + +main :: IO () +main = defaultMain tests