Stack safe default folds (#149)

* adjust the foldrDefault and foldlDefault functions to be stack safe

* performance tuning of folding the FreeMonoidTree

* add stack safety tests, and some benchmarks

* update the CHANGELOG

Author: ntwilson

CHANGELOG.md

@@ -11,6 +11,7 @@ New features:
 Bugfixes:
 
 Other improvements:
+- Make `foldrDefault` and `foldlDefault` stack safe (#148)
 
 ## [v6.0.0](https://github.com/purescript/purescript-foldable-traversable/releases/tag/v6.0.0) - 2022-04-27
 

bower.json

@@ -33,6 +33,7 @@
     "purescript-assert": "^6.0.0",
     "purescript-console": "^6.0.0",
     "purescript-integers": "^6.0.0",
-    "purescript-unsafe-coerce": "^6.0.0"
+    "purescript-unsafe-coerce": "^6.0.0",
+    "purescript-minibench": "^4.0.0"
   }
 }

src/Data/Foldable.purs

@@ -75,6 +75,54 @@ class Foldable f where
   foldl :: forall a b. (b -> a -> b) -> b -> f a -> b
   foldMap :: forall a m. Monoid m => (a -> m) -> f a -> m
 
+
+-- | This internal type is used just to implement a stack-safe and performant foldrDefault and foldlDefault.
+-- | It has O(1) append (because foldrDefault and foldlDefault are implemented in terms of foldMap), and 
+-- | an amortized O(1) uncons/unsnoc.  It behaves similarly to a CatList
+data FreeMonoidTree a = Empty | Node a | Append (FreeMonoidTree a) (FreeMonoidTree a)
+
+instance Foldable FreeMonoidTree where 
+  -- these folding implementations could be written more plainly, but are optimized to minimize conditionals.
+  foldl fn = (\a b -> go a b Empty)
+    where
+    go acc lhs rhs = 
+      case lhs of
+        Node a -> go (fn acc a) rhs Empty
+        Append xs ys ->
+          case ys of
+            Empty -> go acc xs rhs
+            _ ->
+              case rhs of
+                Empty -> go acc xs ys
+                _ -> go acc xs (Append ys rhs)
+        Empty ->
+          case rhs of
+            Empty -> acc
+            _ -> go acc rhs Empty
+
+  foldr fn = (\a b -> go a Empty b)
+    where 
+    go acc lhs rhs = 
+      case rhs of 
+        Node a -> go (fn a acc) Empty lhs
+        Append xs ys -> 
+          case xs of 
+            Empty -> go acc lhs ys
+            _ -> 
+              case lhs of 
+                Empty -> go acc xs ys
+                _ -> go acc (Append lhs xs) ys
+        Empty -> 
+          case lhs of 
+            Empty -> acc
+            _ -> go acc Empty lhs
+
+
+  foldMap = foldMapDefaultR
+
+instance Semigroup (FreeMonoidTree a) where append = Append
+instance Monoid (FreeMonoidTree a) where mempty = Empty
+
 -- | A default implementation of `foldr` using `foldMap`.
 -- |
 -- | Note: when defining a `Foldable` instance, this function is unsafe to use
@@ -86,7 +134,7 @@ foldrDefault
   -> b
   -> f a
   -> b
-foldrDefault c u xs = unwrap (foldMap (Endo <<< c) xs) u
+foldrDefault c u xs = foldr c u $ foldMap Node xs
 
 -- | A default implementation of `foldl` using `foldMap`.
 -- |
@@ -99,7 +147,7 @@ foldlDefault
   -> b
   -> f a
   -> b
-foldlDefault c u xs = unwrap (unwrap (foldMap (Dual <<< Endo <<< flip c) xs)) u
+foldlDefault c u xs = foldl c u $ foldMap Node xs
 
 -- | A default implementation of `foldMap` using `foldr`.
 -- |

test/Main.purs

@@ -20,6 +20,7 @@ import Data.Traversable (class Traversable, sequenceDefault, traverse, sequence,
 import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
 import Effect (Effect, foreachE)
 import Effect.Console (log)
+import Performance.Minibench (benchWith)
 import Test.Assert (assert, assert')
 import Unsafe.Coerce (unsafeCoerce)
 
@@ -58,26 +59,38 @@ main = do
   assert $ foldMapDefaultL (\x -> [x]) [1, 2] == [1, 2]
 
   log "Test foldableArray instance is stack safe"
-  testFoldableArrayWith 20000
+  testFoldableArrayWith 20_000
 
   log "Test foldMapDefaultL"
   testFoldableFoldMapDefaultL 20
 
+  log "Test foldMapDefaultL is stack safe"
+  testFoldableFoldMapDefaultL 20_000
+
   log "Test foldMapDefaultR"
   testFoldableFoldMapDefaultR 20
 
+  log "Test foldMapDefaultR is stack safe"
+  testFoldableFoldMapDefaultR 20_000
+
   log "Test foldlDefault"
   testFoldableFoldlDefault 20
 
+  log "Test foldlDefault is stack safe"
+  testFoldableFoldlDefault 20_000
+
   log "Test foldrDefault"
   testFoldableFoldrDefault 20
 
+  log "Test foldrDefault is stack safe"
+  testFoldableFoldrDefault 20_000
+
   foreachE [1,2,3,4,5,10,20] \i -> do
     log $ "Test traversableArray instance with an array of size: " <> show i
     testTraversableArrayWith i
 
   log "Test traversableArray instance is stack safe"
-  testTraversableArrayWith 20000
+  testTraversableArrayWith 20_000
 
   log "Test traverseDefault"
   testTraverseDefault 20
@@ -89,7 +102,7 @@ main = do
   testFoldableWithIndexArrayWith 20
 
   log "Test foldableWithIndexArray instance is stack safe"
-  testFoldableWithIndexArrayWith 20000
+  testFoldableWithIndexArrayWith 20_000
 
   log "Test FoldableWithIndex laws for array instance"
   testFoldableWithIndexLawsOn
@@ -561,3 +574,22 @@ instance bitraversableBTD :: Bitraversable BitraverseDefault where
 instance bitraversableBSD :: Bitraversable BisequenceDefault where
   bitraverse f g (BSD m) = map BSD (bitraverse f g m)
   bisequence m           = bisequenceDefault m
+
+
+benchmarkDefaultFolds :: Effect Unit
+benchmarkDefaultFolds = do
+  let 
+    sm = arrayFrom1UpTo 1_000
+    m = arrayFrom1UpTo 10_000
+    lg = arrayFrom1UpTo 100_000
+    xl = arrayFrom1UpTo 1_000_000
+
+  log "\nbenching 1,000"
+  benchWith 1000 $ \_ -> foldrDefault (+) 0 sm
+  log "\nbenching 10,000"
+  benchWith 1000 $ \_ -> foldrDefault (+) 0 m
+  log "\nbenching 100,000"
+  benchWith 100 $ \_ -> foldrDefault (+) 0 lg
+  log "\nbenching 1,000,000"
+  benchWith 50 $ \_ -> foldrDefault (+) 0 xl
+