Merge branch 'HeinrichApfelmus/space-switchAccumE'

In this branch, we fix a space leak in `switchP` where old pulses would not be disconnected from the network. The reason was that `GraphGC.clearPredecessors` was accidentally not called because `do` notation was picking up the reader monad `(→) r` instead of the `IO` monad. :O

reactive-banana/src/Reactive/Banana/Prim/Mid/Combinators.hs

@@ -137,22 +137,25 @@ executeP p1 b = do
     eval Nothing  = return Nothing
 
 switchP :: Pulse a -> Pulse (Pulse a) -> Build (Pulse a)
-switchP p pp = mdo
+switchP p pp = do
+    -- track the latest Pulse in a Latch
     lp <- stepperL p pp
-    let
-        -- switch to a new parent
+
+    -- fetch the latest Pulse value
+    pout <- newPulse "switchP_out" (readPulseP =<< readLatchP lp)
+
+    let -- switch the Pulse `pout` to a new parent,
+        -- keeping track of the new dependencies.
         switch = do
             mnew <- readPulseP pp
             case mnew of
-                Nothing  -> return ()
-                Just new -> liftBuildP $ p2 `changeParent` new
-            return Nothing
-        -- fetch value from old parent
-        eval = readPulseP =<< readLatchP lp
-
-    p1 <- newPulse "switchP_in" switch :: Build (Pulse ())
-    p1 `dependOn` pp
-    p2 <- newPulse "switchP_out" eval
-    p2 `dependOn` p
-    p2 `keepAlive` p1
-    return p2
+                Nothing  -> pure ()
+                Just new -> liftBuildP $ pout `changeParent` new
+            pure Nothing
+
+    pin <- newPulse "switchP_in" switch :: Build (Pulse ())
+    pin  `dependOn` pp
+
+    pout `dependOn` p       -- initial dependency
+    pout `keepAlive` pin    -- keep switches happening
+    pure pout

reactive-banana/src/Reactive/Banana/Prim/Mid/Evaluation.hs

@@ -69,11 +69,11 @@ applyDependencyChanges changes g = do
 
 applyDependencyChange
     :: DependencyChange SomeNode SomeNode -> Dependencies -> IO ()
-applyDependencyChange (InsertEdge parent child) =
-    GraphGC.insertEdge (parent, child)
-applyDependencyChange (ChangeParentTo child parent) = do
-    _ <- GraphGC.clearPredecessors child
-    GraphGC.insertEdge (parent, child)
+applyDependencyChange (InsertEdge parent child) g =
+    GraphGC.insertEdge (parent, child) g
+applyDependencyChange (ChangeParentTo child parent) g = do
+    GraphGC.clearPredecessors child g
+    GraphGC.insertEdge (parent, child) g
 
 {-----------------------------------------------------------------------------
     Traversal in dependency order

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

@@ -26,8 +26,9 @@ tests :: TestTree
 tests = testGroup "Space usage, high level"
     [ testGroup "Network size stays bounded"
         [ testBoundedNetworkSize "execute" execute1
-        , testBoundedNetworkSize "execute accumE, issue #261" executeAccumE1
         , testBoundedNetworkSize "observe accumE, issue #261" observeAccumE1
+        , testBoundedNetworkSize "execute accumE, issue #261" executeAccumE1
+        , testBoundedNetworkSize "switch accumE, issue #261" switchAccumE1
         ]
     ]
 
@@ -37,11 +38,17 @@ tests = testGroup "Space usage, high level"
 execute1 :: Event Int -> MomentIO (Event (Event Int))
 execute1 e = execute $ (\i -> liftIO $ Memory.evaluate (i <$ e)) <$> e
 
+observeAccumE1 :: Event Int -> MomentIO (Event (Event ()))
+observeAccumE1 e = pure $ observeE (accumE () never <$ e)
+
 executeAccumE1 :: Event Int -> MomentIO (Event (Event ()))
 executeAccumE1 e = execute (accumE () (id <$ e) <$ e)
 
-observeAccumE1 :: Event Int -> MomentIO (Event (Event ()))
-observeAccumE1 e = pure $ observeE (accumE () never <$ e)
+switchAccumE1 :: Event Int -> MomentIO (Event ())
+switchAccumE1 e = do
+    let e2 :: Event (Event ())
+        e2 = observeE (accumE () (id <$ e) <$ e)
+    switchE never e2
 
 {-----------------------------------------------------------------------------
     Test harness

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

@@ -27,7 +27,8 @@ import qualified Reactive.Banana.Prim.Mid as Prim
 tests :: TestTree
 tests = testGroup "Space usage, mid level"
     [ testGroup "Network size stays bounded"
-        [ testBoundedNetworkSize "executeP accumL, issue #261" executeAccum1
+        [ testBoundedNetworkSize "executeP accumL" executeAccum1
+        , testBoundedNetworkSize "switchP executeP accumL" switchAccum1
         ]
     ]
 
@@ -45,6 +46,11 @@ executeAccum1 p1 = do
         (_, pi) <- Prim.accumL i piId
         pure pi
 
+switchAccum1 :: Pulse Int -> Build (Pulse Int)
+switchAccum1 p1 = do
+    p2 <- executeAccum1 p1
+    Prim.switchP p1 p2
+
 {-----------------------------------------------------------------------------
     Test harness
 ------------------------------------------------------------------------------}

reactive-banana/tests/space.hs

@@ -13,9 +13,11 @@ import qualified Reactive.Banana.Test.High.Space as High
 main :: IO ()
 main = do
     say "Running..."
-    -- void $ High.runNetworkSizes High.executeAccumE1 [1..30000]
+    -- void $ High.runNetworkSizes High.executeAccumE1 [1..20000]
+    -- void $ High.runNetworkSizes High.switchAccumE1 [1..10000]
     -- void $ High.runNetworkSizes High.observeAccumE1 [1..10000]
-    void $ runMidNetwork Mid.executeAccum1 [1..50000]
+    -- void $ runMidNetwork Mid.executeAccum1 [1..50000]
+    void $ runMidNetwork Mid.switchAccum1 [1..20000]
     say "Done"
 
 say :: String -> IO ()