Add foldlM

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.

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.

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.

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" [