Skip to content

Commit

Permalink
Make Seq foldl', foldr' strict in the initial value (#1077)
Browse files Browse the repository at this point in the history 
This matches the behavior of strict folds on sets and maps.
  • Loading branch information
@meooow25
meooow25 authored Dec 5, 2024
1 parent 118f689 commit 89b39f6
Show file tree
Hide file tree
Showing 3 changed files with 75 additions and 47 deletions.
5 changes: 5 additions & 0 deletions containers-tests/containers-tests.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
67 changes: 45 additions & 22 deletions containers-tests/tests/seq-properties.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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"
Expand All @@ -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
Expand Down Expand Up @@ -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'
]
]

------------------------------------------------------------------------
Expand Down Expand Up @@ -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)
Expand All @@ -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)
Expand Down Expand Up @@ -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
Expand Down
50 changes: 25 additions & 25 deletions containers/src/Data/Sequence/Internal.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 89b39f6

Please sign in to comment.