Add tests for bounded network size, automating #261

reactive-banana/reactive-banana.cabal

@@ -93,6 +93,7 @@ Test-Suite tests
     main-is:            reactive-banana-tests.hs
     other-modules:      Reactive.Banana.Test.High.Combinators,
                         Reactive.Banana.Test.High.Plumbing,
+                        Reactive.Banana.Test.High.Space,
                         Reactive.Banana.Test.Low.Gen,
                         Reactive.Banana.Test.Low.Graph,
                         Reactive.Banana.Test.Low.GraphGC

reactive-banana/tests/Reactive/Banana/Test/High/Space.hs

@@ -0,0 +1,89 @@
+{-# LANGUAGE RecursiveDo #-}
+{-----------------------------------------------------------------------------
+    reactive-banana
+------------------------------------------------------------------------------}
+-- | Exemplar tests for space usage and garbage collection.
+module Reactive.Banana.Test.High.Space
+    ( tests
+    ) where
+
+import Control.Monad
+    ( forM )
+import Test.Tasty
+    ( testGroup, TestTree )
+import Test.Tasty.QuickCheck
+    ( testProperty )
+
+import qualified Test.QuickCheck as Q
+import qualified Test.QuickCheck.Monadic as Q
+
+import qualified Control.Exception as Memory
+import qualified Control.Concurrent as System
+import qualified System.Mem as System
+
+import Reactive.Banana
+import Reactive.Banana.Frameworks
+
+tests :: TestTree
+tests = testGroup "Space usage, high level"
+    [ testGroup "Network size stays bounded"
+        [ testBoundedNetworkSize "execute" execute1
+        , testBoundedNetworkSize "execute accum, issue #261" executeAccumE1
+        ]
+    ]
+
+{-----------------------------------------------------------------------------
+    Tests
+------------------------------------------------------------------------------}
+execute1 :: Event Int -> MomentIO (Event (Event Int))
+execute1 e = execute $ (\i -> liftIO $ Memory.evaluate (i <$ e)) <$> e
+
+executeAccumE1 :: Event Int -> MomentIO (Event (Event ()))
+executeAccumE1 e = execute (accumE () never <$ e)
+
+{-----------------------------------------------------------------------------
+    Test harness
+------------------------------------------------------------------------------}
+-- | Execute an FRP network with a sequence of inputs
+-- with intermittend of garbage collection and record network sizes.
+runNetworkSizes
+    :: (Event Int -> MomentIO (Event ignore))
+    -> Int -> IO [Int]
+runNetworkSizes f n = do
+    (network, fire) <- setup
+    run network fire
+  where
+    setup = do
+        (ah, fire) <- newAddHandler
+        network <- compile $ do
+            ein  <- fromAddHandler ah
+            eout <- f ein
+            reactimate $ pure () <$ eout
+        performSufficientGC
+        actuate network
+        pure (network, fire)
+
+    run network fire = forM [1..n] $ \i -> do
+        fire i
+        performSufficientGC
+        System.yield
+        getSize network
+
+-- | Test whether the network size stays bounded.
+testBoundedNetworkSize
+    :: String
+    -> (Event Int -> MomentIO (Event ignore))
+    -> TestTree
+testBoundedNetworkSize name f = testProperty name $
+    Q.once $ Q.monadicIO $ do
+        sizes <- liftIO $ runNetworkSizes f n
+        Q.monitor
+            $ Q.counterexample "network size grows"
+            . Q.counterexample ("network sizes: " <> show sizes)
+        Q.assert $ isBounded sizes
+  where
+    n = 20 :: Int
+    isBounded sizes = sizes !! 3 >= sizes !! (n-1)
+
+performSufficientGC :: IO ()
+performSufficientGC = System.performMinorGC

reactive-banana/tests/Reactive/Banana/Test/Low/GraphGC.hs

@@ -67,7 +67,7 @@ prop_performGC =
     let g = Q.mkGraph g0
         expected = Graph.collectGarbage roots g
     in  Q.cover 10 (Graph.size g == Graph.size expected)
-            "no vertices unreachable"
+            "no   vertices unreachable"
         $ Q.cover 75 (Graph.size g > Graph.size expected)
             "some vertices unreachable"
         $ Q.cover 15 (Graph.size g > 2*Graph.size expected)

reactive-banana/tests/reactive-banana-tests.hs

@@ -6,16 +6,18 @@ module Main where
 import Test.Tasty
     ( defaultMain, testGroup )
 
-import qualified Reactive.Banana.Test.Low.Graph as Low.Graph
-import qualified Reactive.Banana.Test.Low.GraphGC as Low.GraphGC
-import qualified Reactive.Banana.Test.High.Combinators as High.Combinators
+import qualified Reactive.Banana.Test.Low.Graph
+import qualified Reactive.Banana.Test.Low.GraphGC
+import qualified Reactive.Banana.Test.High.Combinators
+import qualified Reactive.Banana.Test.High.Space
 
 main = defaultMain $ testGroup "reactive-banana"
     [ testGroup "Low-level"
-        [ Low.Graph.tests
-        , Low.GraphGC.tests
+        [ Reactive.Banana.Test.Low.Graph.tests
+        , Reactive.Banana.Test.Low.GraphGC.tests
         ]
     , testGroup "High-level"
-        [ High.Combinators.tests
+        [ Reactive.Banana.Test.High.Combinators.tests
+        , Reactive.Banana.Test.High.Space.tests
         ]
     ]