Add foldr' and document the laziness of foldr

Author: Lysxia

src/Data/Text.hs

@@ -98,6 +98,7 @@ module Data.Text
     , foldl1
     , foldl1'
     , foldr
+    , foldr'
     , foldr1
 
     -- ** Special folds
@@ -992,6 +993,22 @@ foldl1' f t = S.foldl1' f (stream t)
 -- | /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.
+--
+-- If the binary operator is strict in its second argument, use 'foldr''
+-- instead.
+--
+-- 'foldr' is lazy like 'Data.List.foldr' for lists: evaluation actually
+-- traverses the 'Text' from left to right, only as far as it needs to.
+--
+-- For example, 'head' can be defined with /O(1)/ complexity using 'foldr':
+--
+-- @
+-- head :: Text -> Char
+-- head = foldr const (error "head empty")
+-- @
+--
+-- Searches from left to right with short-circuiting behavior can
+-- also be defined using 'foldr' (/e.g./, 'any', 'all', 'find', 'elem').
 foldr :: (Char -> a -> a) -> a -> Text -> a
 foldr f z t = S.foldr f z (stream t)
 {-# INLINE foldr #-}
@@ -1002,6 +1019,13 @@ foldr1 :: HasCallStack => (Char -> Char -> Char) -> Text -> Char
 foldr1 f t = S.foldr1 f (stream t)
 {-# INLINE foldr1 #-}
 
+-- | /O(n)/ A strict version of 'foldr'.
+--
+-- 'foldr'' evaluates as a right-to-left traversal using constant stack space.
+foldr' :: (Char -> a -> a) -> a -> Text -> a
+foldr' f z t = S.foldl' (P.flip f) z (reverseStream t)
+{-# INLINE foldr' #-}
+
 -- -----------------------------------------------------------------------------
 -- ** Special folds
 

src/Data/Text/Lazy.hs

@@ -784,6 +784,16 @@ foldl1' f t = S.foldl1' f (stream t)
 -- | /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.
+--
+-- 'foldr' is lazy like 'Data.List.foldr' for lists: evaluation actually
+-- traverses the 'Text' from left to right, only as far as it needs to.
+--
+-- For example, 'head' can be defined with /O(1)/ complexity using 'foldr':
+--
+-- @
+-- head :: Text -> Char
+-- head = foldr const (error "head empty")
+-- @
 foldr :: (Char -> a -> a) -> a -> Text -> a
 foldr f z t = S.foldr f z (stream t)
 {-# INLINE foldr #-}

tests/Tests/Properties/Folds.hs

@@ -8,8 +8,10 @@ module Tests.Properties.Folds
     ) where
 
 import Control.Arrow (second)
+import Control.Exception (ErrorCall, evaluate, try)
 import Data.Word (Word8, Word16)
 import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (testCase, assertFailure)
 import Test.Tasty.QuickCheck (testProperty, Small(..), (===), applyFun, applyFun2)
 import Tests.QuickCheckUtils
 import qualified Data.List as L
@@ -47,13 +49,32 @@ sf_foldr (applyFun -> p) (applyFun2 -> f) z =
     where _types  = f :: Char -> Char -> Char
 t_foldr (applyFun2 -> f) z       = L.foldr f z  `eqP` T.foldr f z
     where _types  = f :: Char -> Char -> Char
+t_foldr' (applyFun2 -> f) z       = L.foldr f z  `eqP` T.foldr' f z
+    where _types  = f :: Char -> Char -> Char
 tl_foldr (applyFun2 -> f) z      = L.foldr f z  `eqPSqrt` TL.foldr f z
     where _types  = f :: Char -> Char -> Char
 sf_foldr1 (applyFun -> p) (applyFun2 -> f) =
     (L.foldr1 f . L.filter p) `eqPSqrt` (S.foldr1 f . S.filter p)
 t_foldr1 (applyFun2 -> f)        = L.foldr1 f   `eqP` T.foldr1 f
 tl_foldr1 (applyFun2 -> f)       = L.foldr1 f   `eqPSqrt` TL.foldr1 f
 
+-- Distinguish foldl/foldr from foldl'/foldr'
+
+fold_apart :: IO ()
+fold_apart = do
+    ok (T.foldr  f () (T.pack "az"))
+    ko (T.foldr' f () (T.pack "az"))
+    ok (T.foldl  (flip f) () (T.pack "za"))
+    ko (T.foldl' (flip f) () (T.pack "za"))
+  where
+    f c _ = if c == 'z' then error "catchme" else ()
+    ok = evaluate
+    ko t = do
+        x <- try (evaluate t)
+        case x :: Either ErrorCall () of
+            Left _ -> pure ()
+            Right _ -> assertFailure "test should have failed but didn't"
+
 -- Special folds
 
 s_concat_s        = (L.concat . unSqrt) `eq` (unpackS . S.unstream . S.concat . map packS . unSqrt)
@@ -187,10 +208,12 @@ testFolds =
       testProperty "tl_foldl1'" tl_foldl1',
       testProperty "sf_foldr" sf_foldr,
       testProperty "t_foldr" t_foldr,
+      testProperty "t_foldr'" t_foldr',
       testProperty "tl_foldr" tl_foldr,
       testProperty "sf_foldr1" sf_foldr1,
       testProperty "t_foldr1" t_foldr1,
       testProperty "tl_foldr1" tl_foldr1,
+      testCase "fold_apart" fold_apart,
 
       testGroup "special" [
         testProperty "s_concat_s" s_concat_s,