From 8e0875797e251c68ad2a3fa2a95df2cb59674c23 Mon Sep 17 00:00:00 2001 From: Jaro Reinders Date: Mon, 30 Oct 2023 21:49:27 +0100 Subject: [PATCH 1/3] Add foldlM --- src/Data/Text.hs | 6 ++++++ src/Data/Text/Internal/Fusion/Common.hs | 15 +++++++++++++++ src/Data/Text/Lazy.hs | 7 +++++++ 3 files changed, 28 insertions(+) diff --git a/src/Data/Text.hs b/src/Data/Text.hs index 347fc5a33..991a13ef0 100644 --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -103,6 +103,7 @@ module Data.Text , foldr , foldr' , foldr1 + , foldlM -- ** Special folds , concat @@ -994,6 +995,11 @@ foldl1' :: HasCallStack => (Char -> Char -> Char) -> Text -> Char foldl1' f t = S.foldl1' f (stream t) {-# INLINE foldl1' #-} +-- | /O(n)/ A monadic version of 'foldl'. +foldlM :: Monad m => (a -> Char -> m a) -> a -> Text -> m a +foldlM f z t = S.foldlM f z (stream t) +{-# INLINE foldlM #-} + -- | /O(n)/ 'foldr', applied to a binary operator, a starting value -- (typically the right-identity of the operator), and a 'Text', -- reduces the 'Text' using the binary operator, from right to left. diff --git a/src/Data/Text/Internal/Fusion/Common.hs b/src/Data/Text/Internal/Fusion/Common.hs index 16b9f61c3..0ee7cbb87 100644 --- a/src/Data/Text/Internal/Fusion/Common.hs +++ b/src/Data/Text/Internal/Fusion/Common.hs @@ -77,6 +77,7 @@ module Data.Text.Internal.Fusion.Common , foldl1' , foldr , foldr1 + , foldlM -- ** Special folds , concat @@ -689,6 +690,20 @@ foldl1' f (Stream next s0 _len) = loop0_foldl1' s0 Yield x s' -> loop_foldl1' (f z x) s' {-# INLINE [0] foldl1' #-} +-- | A monadic version of foldl. +-- +-- __Properties__ +-- +-- @ 'foldlM' f z0 . 'Data.Text.Internal.Fusion.stream' = 'Data.Text.foldlM' f z0 @ +foldlM :: P.Monad m => (b -> Char -> m b) -> b -> Stream Char -> m b +foldlM f z0 (Stream next s0 _len) = loop_foldlM z0 s0 + where + loop_foldlM !z !s = case next s of + Done -> P.pure z + Skip s' -> loop_foldlM z s' + Yield x s' -> f z x P.>>= \z' -> loop_foldlM z' s' +{-# INLINE [0] foldlM #-} + -- | 'foldr', applied to a binary operator, a starting value (typically the -- right-identity of the operator), and a stream, reduces the stream using the -- binary operator, from right to left. diff --git a/src/Data/Text/Lazy.hs b/src/Data/Text/Lazy.hs index de4017d84..a9bab612e 100644 --- a/src/Data/Text/Lazy.hs +++ b/src/Data/Text/Lazy.hs @@ -101,6 +101,7 @@ module Data.Text.Lazy , foldl1' , foldr , foldr1 + , foldlM -- ** Special folds , concat @@ -815,6 +816,12 @@ foldl1' :: HasCallStack => (Char -> Char -> Char) -> Text -> Char foldl1' f t = S.foldl1' f (stream t) {-# INLINE foldl1' #-} +-- | /O(n)/ A monadic version of 'foldl'. +-- +foldlM :: Monad m => (a -> Char -> m a) -> a -> Text -> m a +foldlM f z t = S.foldlM f z (stream t) +{-# INLINE foldlM #-} + -- | /O(n)/ 'foldr', applied to a binary operator, a starting value -- (typically the right-identity of the operator), and a 'Text', -- reduces the 'Text' using the binary operator, from right to left. From bd31efe2f553421e99f766795b4997601848a680 Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Wed, 13 Mar 2024 01:32:58 +0100 Subject: [PATCH 2/3] Rename foldlM to foldlM' --- src/Data/Text.hs | 10 +++++----- src/Data/Text/Internal/Fusion/Common.hs | 18 +++++++++--------- src/Data/Text/Lazy.hs | 10 +++++----- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Data/Text.hs b/src/Data/Text.hs index 991a13ef0..c14abf6ef 100644 --- a/src/Data/Text.hs +++ b/src/Data/Text.hs @@ -103,7 +103,7 @@ module Data.Text , foldr , foldr' , foldr1 - , foldlM + , foldlM' -- ** Special folds , concat @@ -995,10 +995,10 @@ foldl1' :: HasCallStack => (Char -> Char -> Char) -> Text -> Char foldl1' f t = S.foldl1' f (stream t) {-# INLINE foldl1' #-} --- | /O(n)/ A monadic version of 'foldl'. -foldlM :: Monad m => (a -> Char -> m a) -> a -> Text -> m a -foldlM f z t = S.foldlM f z (stream t) -{-# INLINE foldlM #-} +-- | /O(n)/ A monadic version of 'foldl''. +foldlM' :: Monad m => (a -> Char -> m a) -> a -> Text -> m a +foldlM' f z t = S.foldlM' f z (stream t) +{-# INLINE foldlM' #-} -- | /O(n)/ 'foldr', applied to a binary operator, a starting value -- (typically the right-identity of the operator), and a 'Text', diff --git a/src/Data/Text/Internal/Fusion/Common.hs b/src/Data/Text/Internal/Fusion/Common.hs index 0ee7cbb87..f7e17af5e 100644 --- a/src/Data/Text/Internal/Fusion/Common.hs +++ b/src/Data/Text/Internal/Fusion/Common.hs @@ -77,7 +77,7 @@ module Data.Text.Internal.Fusion.Common , foldl1' , foldr , foldr1 - , foldlM + , foldlM' -- ** Special folds , concat @@ -690,19 +690,19 @@ foldl1' f (Stream next s0 _len) = loop0_foldl1' s0 Yield x s' -> loop_foldl1' (f z x) s' {-# INLINE [0] foldl1' #-} --- | A monadic version of foldl. +-- | A monadic version of 'foldl'. -- -- __Properties__ -- --- @ 'foldlM' f z0 . 'Data.Text.Internal.Fusion.stream' = 'Data.Text.foldlM' f z0 @ -foldlM :: P.Monad m => (b -> Char -> m b) -> b -> Stream Char -> m b -foldlM f z0 (Stream next s0 _len) = loop_foldlM z0 s0 +-- @ 'foldlM'' f z0 . 'Data.Text.Internal.Fusion.stream' = 'Data.Text.foldlM'' f z0 @ +foldlM' :: P.Monad m => (b -> Char -> m b) -> b -> Stream Char -> m b +foldlM' f z0 (Stream next s0 _len) = loop_foldlM' z0 s0 where - loop_foldlM !z !s = case next s of + loop_foldlM' !z !s = case next s of Done -> P.pure z - Skip s' -> loop_foldlM z s' - Yield x s' -> f z x P.>>= \z' -> loop_foldlM z' s' -{-# INLINE [0] foldlM #-} + Skip s' -> loop_foldlM' z s' + Yield x s' -> f z x P.>>= \z' -> loop_foldlM' z' s' +{-# INLINE [0] foldlM' #-} -- | 'foldr', applied to a binary operator, a starting value (typically the -- right-identity of the operator), and a stream, reduces the stream using the diff --git a/src/Data/Text/Lazy.hs b/src/Data/Text/Lazy.hs index a9bab612e..41e6885da 100644 --- a/src/Data/Text/Lazy.hs +++ b/src/Data/Text/Lazy.hs @@ -101,7 +101,7 @@ module Data.Text.Lazy , foldl1' , foldr , foldr1 - , foldlM + , foldlM' -- ** Special folds , concat @@ -816,11 +816,11 @@ foldl1' :: HasCallStack => (Char -> Char -> Char) -> Text -> Char foldl1' f t = S.foldl1' f (stream t) {-# INLINE foldl1' #-} --- | /O(n)/ A monadic version of 'foldl'. +-- | /O(n)/ A monadic version of 'foldl''. -- -foldlM :: Monad m => (a -> Char -> m a) -> a -> Text -> m a -foldlM f z t = S.foldlM f z (stream t) -{-# INLINE foldlM #-} +foldlM' :: Monad m => (a -> Char -> m a) -> a -> Text -> m a +foldlM' f z t = S.foldlM' f z (stream t) +{-# INLINE foldlM' #-} -- | /O(n)/ 'foldr', applied to a binary operator, a starting value -- (typically the right-identity of the operator), and a 'Text', From 6f8c4ca1a4ea8a55a00d2b9b478fbeed0e50d237 Mon Sep 17 00:00:00 2001 From: Li-yao Xia Date: Wed, 13 Mar 2024 01:33:18 +0100 Subject: [PATCH 3/3] Add tests for foldlM' --- tests/Tests/Properties/Folds.hs | 45 +++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/tests/Tests/Properties/Folds.hs b/tests/Tests/Properties/Folds.hs index f3ba60f8a..17a88c209 100644 --- a/tests/Tests/Properties/Folds.hs +++ b/tests/Tests/Properties/Folds.hs @@ -1,14 +1,23 @@ -- | Test folds, scans, and unfolds +{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +#ifdef MIN_VERSION_tasty_inspection_testing +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-} +#endif + module Tests.Properties.Folds ( testFolds ) where import Control.Arrow (second) import Control.Exception (ErrorCall, evaluate, try) +import Data.Functor.Identity (Identity(..)) +import Control.Monad.Trans.State (runState, state) import Data.Word (Word8, Word16) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, assertFailure, assertBool) @@ -21,6 +30,11 @@ import qualified Data.Text.Internal.Fusion.Common as S import qualified Data.Text.Lazy as TL import qualified Data.Char as Char +#ifdef MIN_VERSION_tasty_inspection_testing +import Test.Tasty.Inspection (inspectTest, (==~)) +import GHC.Exts (inline) +#endif + -- Folds sf_foldl (applyFun -> p) (applyFun2 -> f) z = @@ -193,6 +207,32 @@ tl_unfoldrN n m = (L.take i . L.unfoldr (unf j)) `eq` where i = fromIntegral (n :: Word16) j = fromIntegral (m :: Word16) +-- Monadic folds + +-- Parametric polymorphism allows us to only test foldlM' specialized to +-- one function in the state monad (called @logger@ in the following tests) +-- that just logs the arguments it was applied to and produces a fresh +-- accumulator. That alone determines the general behavior of foldlM' with an +-- arbitrary function in any monad. +-- Reference: "Testing Polymorphic Properties" by Bernardy et al. +-- https://publications.lib.chalmers.se/records/fulltext/local_99387.pdf + +t_foldlM' = (\l -> (length l, zip [0 ..] l)) `eqP` (fmap reverse . (`runState` []) . T.foldlM' logger 0) + where logger i c = state (\cs -> (length cs + 1, (i, c) : cs)) -- list in reverse order +tl_foldlM' = (\l -> (length l, zip [0 ..] l)) `eqP` (fmap reverse . (`runState` []) . TL.foldlM' logger 0) + where logger i c = state (\cs -> (length cs + 1, (i, c) : cs)) -- list in reverse order + +#ifdef MIN_VERSION_tasty_inspection_testing +-- As a sanity check for performance, the simplified Core +-- foldlM' specialized to Identity is the same as foldl'. + +_S_foldl'_from_foldlM' :: (a -> Char -> a) -> a -> S.Stream Char -> a +_S_foldl'_from_foldlM' f x = runIdentity . S.foldlM' (\i c -> Identity (f i c)) x + +_S_foldl' :: (a -> Char -> a) -> a -> S.Stream Char -> a +_S_foldl' = inline S.foldl' +#endif + isAscii_border :: IO () isAscii_border = do let text = T.drop 2 $ T.pack "XX1234δΊ”" @@ -221,6 +261,11 @@ testFolds = testProperty "sf_foldr1" sf_foldr1, testProperty "t_foldr1" t_foldr1, testProperty "tl_foldr1" tl_foldr1, + testProperty "t_foldlM'" t_foldlM', + testProperty "tl_foldlM'" tl_foldlM', +#ifdef MIN_VERSION_tasty_inspection_testing + $(inspectTest ('_S_foldl'_from_foldlM' ==~ '_S_foldl')), +#endif testCase "fold_apart" fold_apart, testGroup "special" [