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

@@ -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

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

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