Make Seq foldl', foldr' strict in the initial value (#1077)

This matches the behavior of strict folds on sets and maps.

Author: meooow25

containers-tests/containers-tests.cabal

@@ -395,12 +395,17 @@ test-suite seq-properties
   hs-source-dirs:   tests
   main-is:          seq-properties.hs
   type:             exitcode-stdio-1.0
+  build-depends:
+      ChasingBottoms
 
   ghc-options:      -O2
   other-extensions:
     BangPatterns
     CPP
 
+  other-modules:
+      Utils.Strictness
+
 test-suite tree-properties
   import: test-deps, warnings
   default-language: Haskell2010

containers-tests/tests/seq-properties.hs

@@ -21,6 +21,7 @@ import Control.Applicative (Applicative(..), liftA2)
 import Control.Arrow ((***))
 import Control.Monad.Trans.State.Strict
 import Data.Array (listArray)
+import Data.Coerce (coerce)
 import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, fold), toList, all, sum, foldl', foldr')
 import Data.Functor ((<$>), (<$))
 import Data.Maybe
@@ -43,8 +44,10 @@ import Control.Monad.Zip (MonadZip (..))
 import Control.DeepSeq (deepseq)
 import Control.Monad.Fix (MonadFix (..))
 import Test.Tasty.HUnit
+import Test.ChasingBottoms.IsBottom (isBottom)
 import qualified Language.Haskell.TH.Syntax as TH
 
+import Utils.Strictness (Bot(..), Func2, applyFunc2)
 
 main :: IO ()
 main = defaultMain $ testGroup "seq-properties"
@@ -56,11 +59,9 @@ main = defaultMain $ testGroup "seq-properties"
        , testProperty "(<$)" prop_constmap
        , testProperty "foldr" prop_foldr
        , testProperty "foldr'" prop_foldr'
-       , testProperty "lazy foldr'" prop_lazyfoldr'
        , testProperty "foldr1" prop_foldr1
        , testProperty "foldl" prop_foldl
        , testProperty "foldl'" prop_foldl'
-       , testProperty "lazy foldl'" prop_lazyfoldl'
        , testProperty "foldl1" prop_foldl1
        , testProperty "(==)" prop_equals
        , testProperty "compare" prop_compare
@@ -156,6 +157,12 @@ main = defaultMain $ testGroup "seq-properties"
        , testProperty "Right view pattern" prop_viewr_pat
        , testProperty "Right view constructor" prop_viewr_con
        , testProperty "stimes" prop_stimes
+       , testGroup "strictness"
+         [ testProperty "foldr" prop_strictness_foldr
+         , testProperty "foldl" prop_strictness_foldl
+         , testProperty "foldr'" prop_strictness_foldr'
+         , testProperty "foldl'" prop_strictness_foldl'
+         ]
        ]
 
 ------------------------------------------------------------------------
@@ -310,16 +317,6 @@ prop_foldr' xs =
     f = (:)
     z = []
 
-prop_lazyfoldr' :: Seq () -> Property
-prop_lazyfoldr' xs =
-    not (null xs) ==>
-    foldr'
-        (\e _ ->
-              e)
-        (error "Data.Sequence.foldr': should be lazy in initial accumulator")
-        xs ===
-    ()
-
 prop_foldr1 :: Seq Int -> Property
 prop_foldr1 xs =
     not (null xs) ==> foldr1 f xs == Data.List.foldr1 f (toList xs)
@@ -339,16 +336,6 @@ prop_foldl' xs =
     f = flip (:)
     z = []
 
-prop_lazyfoldl' :: Seq () -> Property
-prop_lazyfoldl' xs =
-    not (null xs) ==>
-    foldl'
-        (\_ e ->
-              e)
-        (error "Data.Sequence.foldl': should be lazy in initial accumulator")
-        xs ===
-    ()
-
 prop_foldl1 :: Seq Int -> Property
 prop_foldl1 xs =
     not (null xs) ==> foldl1 f xs == Data.List.foldl1 f (toList xs)
@@ -903,6 +890,42 @@ test_mfix = toList resS === resL
     resL :: [Int]
     resL = fmap ($ 12) $ mfix (\f -> [facty f, facty (+1), facty (+2)])
 
+-- * Strictness tests
+
+-- See Note [Testing strictness of folds] in map-strictness.hs
+
+prop_strictness_foldr :: [A] -> Func2 A B (Bot B) -> Bot B -> Property
+prop_strictness_foldr xs fun (Bot z) =
+  isBottom (foldr f z s) ===
+  isBottom (foldr f z xs)
+  where
+    s = fromList xs
+    f = coerce (applyFunc2 fun) :: A -> B -> B
+
+prop_strictness_foldl :: [A] -> Func2 B A (Bot B) -> Bot B -> Property
+prop_strictness_foldl (xs) fun (Bot z) =
+  isBottom (foldl f z s) ===
+  isBottom (foldl f z xs)
+  where
+    s = fromList xs
+    f = coerce (applyFunc2 fun) :: B -> A -> B
+
+prop_strictness_foldr' :: [A] -> Func2 A B (Bot B) -> Bot B -> Property
+prop_strictness_foldr' xs fun (Bot z) =
+  isBottom (foldr' f z s) ===
+  isBottom (z `seq` foldr' f z xs)
+  where
+    s = fromList xs
+    f = coerce (applyFunc2 fun) :: A -> B -> B
+
+prop_strictness_foldl' :: [A] -> Func2 B A (Bot B) -> Bot B -> Property
+prop_strictness_foldl' xs fun (Bot z) =
+  isBottom (foldl' f z s) ===
+  isBottom (foldl' f z xs)
+  where
+    s = fromList xs
+    f = coerce (applyFunc2 fun) :: B -> A -> B
+
 -- Simple test monad
 
 data M a = Action Int a

containers/src/Data/Sequence/Internal.hs

@@ -1147,16 +1147,16 @@ instance Foldable FingerTree where
         foldlNodeN f z t = foldl f z t
     {-# INLINE foldl #-}
 
-    foldr' _ z' EmptyT = z'
-    foldr' f' z' (Single x') = f' x' z'
-    foldr' f' z' (Deep _ pr' m' sf') =
+    foldr' _  !z' EmptyT = z'
+    foldr' f' !z' (Single x') = f' x' z'
+    foldr' f' !z' (Deep _ pr' m' sf') =
         (foldrDigit' f' $! (foldrTree' (foldrNode' f') $! (foldrDigit' f' z') sf') m') pr'
       where
         foldrTree' :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b
-        foldrTree' _ z EmptyT = z
-        foldrTree' f z (Single x) = f x $! z
-        foldrTree' f z (Deep _ pr m sf) =
-            (foldr' f $! (foldrTree' (foldrNodeN' f) $! (foldr' f $! z) sf) m) pr
+        foldrTree' _ !z EmptyT = z
+        foldrTree' f !z (Single x) = f x z
+        foldrTree' f !z (Deep _ pr m sf) =
+            (foldr' f $! (foldrTree' (foldrNodeN' f) $! foldr' f z sf) m) pr
 
         foldrDigit' :: (a -> b -> b) -> b -> Digit a -> b
         foldrDigit' f z t = foldr' f z t
@@ -1168,17 +1168,17 @@ instance Foldable FingerTree where
         foldrNodeN' f t z = foldr' f z t
     {-# INLINE foldr' #-}
 
-    foldl' _ z' EmptyT = z'
-    foldl' f' z' (Single x') = f' z' x'
-    foldl' f' z' (Deep _ pr' m' sf') =
+    foldl' _  !z' EmptyT = z'
+    foldl' f' !z' (Single x') = f' z' x'
+    foldl' f' !z' (Deep _ pr' m' sf') =
         (foldlDigit' f' $!
          (foldlTree' (foldlNode' f') $! (foldlDigit' f' z') pr') m')
             sf'
       where
         foldlTree' :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b
-        foldlTree' _ z EmptyT = z
-        foldlTree' f z (Single xs) = f z xs
-        foldlTree' f z (Deep _ pr m sf) =
+        foldlTree' _ !z EmptyT = z
+        foldlTree' f !z (Single xs) = f z xs
+        foldlTree' f !z (Deep _ pr m sf) =
             (foldl' f $! (foldlTree' (foldl' f) $! foldl' f z pr) m) sf
 
         foldlDigit' :: (b -> a -> b) -> b -> Digit a -> b
@@ -1276,16 +1276,16 @@ instance Foldable Digit where
     foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
     {-# INLINE foldl #-}
 
-    foldr' f z (One a) = f a z
-    foldr' f z (Two a b) = f a $! f b z
-    foldr' f z (Three a b c) = f a $! f b $! f c z
-    foldr' f z (Four a b c d) = f a $! f b $! f c $! f d z
+    foldr' f !z (One a) = f a z
+    foldr' f !z (Two a b) = f a $! f b z
+    foldr' f !z (Three a b c) = f a $! f b $! f c z
+    foldr' f !z (Four a b c d) = f a $! f b $! f c $! f d z
     {-# INLINE foldr' #-}
 
-    foldl' f z (One a) = f z a
-    foldl' f z (Two a b) = (f $! f z a) b
-    foldl' f z (Three a b c) = (f $! (f $! f z a) b) c
-    foldl' f z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d
+    foldl' f !z (One a) = f z a
+    foldl' f !z (Two a b) = (f $! f z a) b
+    foldl' f !z (Three a b c) = (f $! (f $! f z a) b) c
+    foldl' f !z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d
     {-# INLINE foldl' #-}
 
     foldr1 _ (One a) = a
@@ -1374,12 +1374,12 @@ instance Foldable Node where
     foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
     {-# INLINE foldl #-}
 
-    foldr' f z (Node2 _ a b) = f a $! f b z
-    foldr' f z (Node3 _ a b c) = f a $! f b $! f c z
+    foldr' f !z (Node2 _ a b) = f a $! f b z
+    foldr' f !z (Node3 _ a b c) = f a $! f b $! f c z
     {-# INLINE foldr' #-}
 
-    foldl' f z (Node2 _ a b) = (f $! f z a) b
-    foldl' f z (Node3 _ a b c) = (f $! (f $! f z a) b) c
+    foldl' f !z (Node2 _ a b) = (f $! f z a) b
+    foldl' f !z (Node3 _ a b c) = (f $! (f $! f z a) b) c
     {-# INLINE foldl' #-}
 
 instance Functor Node where