Register handlers on actuate and unregister them on pause

Closes HeinrichApfelmus#73

reactive-banana/src/Reactive/Banana/Frameworks.hs

@@ -318,8 +318,7 @@ actuate :: EventNetwork -> IO ()
 actuate = Prim.actuate . unEN
 
 -- | Pause an event network.
--- Immediately stop producing output.
--- (In a future version, it will also unregister all event handlers for inputs.)
+-- Immediately stop producing output and unregister all input handlers.
 -- Hence, the network stops responding to input events,
 -- but it's state will be preserved.
 --

reactive-banana/src/Reactive/Banana/Internal/Combinators.hs

@@ -14,6 +14,7 @@ import           Control.Monad.Trans.Reader
 import           Data.Functor
 import           Data.Functor.Identity
 import           Data.IORef
+import           Data.Maybe (isJust)
 import qualified Reactive.Banana.Prim        as Prim
 import           Reactive.Banana.Prim.Cached
 
@@ -46,19 +47,33 @@ interpret f = Prim.interpret $ \pulse -> runReaderT (g pulse) undefined
 ------------------------------------------------------------------------------}
 -- | Data type representing an event network.
 data EventNetwork = EventNetwork
-    { runStep :: Prim.Step -> IO ()
-    , actuate :: IO ()
-    , pause   :: IO ()
+    { runStep          :: Prim.Step -> IO ()
+    , enInputRegisters :: MVar ([IO (IO ())], Maybe [IO ()])
     }
 
+actuate :: EventNetwork -> IO ()
+actuate network = do
+  (inputRegisters, inputUnregistersM) <- takeMVar $ enInputRegisters network
+  inputUnregisters' <-
+    case inputUnregistersM of
+      Just inputUnregisters -> pure inputUnregisters
+      Nothing -> sequenceA inputRegisters
+  putMVar (enInputRegisters network) (inputRegisters, Just inputUnregisters')
+
+pause :: EventNetwork -> IO ()
+pause network = do
+  (inputRegisters, inputUnregistersM) <- takeMVar $ enInputRegisters network
+  mapM_ sequenceA inputUnregistersM
+  putMVar (enInputRegisters network) (inputRegisters, Nothing)
+
 -- | Compile to an event network.
 compile :: Moment () -> IO EventNetwork
 compile setup = do
-    actuated <- newIORef False                   -- flag to set running status
-    s        <- newEmptyMVar                     -- setup callback machinery
+    inputRegisters <- newMVar ([], Nothing)     -- Actions for (un)registering input handlers
+    s              <- newEmptyMVar              -- setup callback machinery
     let
-        whenFlag flag action = readIORef flag >>= \b -> when b action
-        runStep f            = whenFlag actuated $ do
+        whenM cond action = cond >>= \b -> when b action
+        runStep f            = whenM (isJust . snd <$> readMVar inputRegisters) $ do
             s1 <- takeMVar s                    -- read and take lock
             -- pollValues <- sequence polls     -- poll mutable data
             (output, s2) <- f s1                -- calculate new state
@@ -67,8 +82,7 @@ compile setup = do
 
         eventNetwork = EventNetwork
             { runStep = runStep
-            , actuate = writeIORef actuated True
-            , pause   = writeIORef actuated False
+            , enInputRegisters = inputRegisters
             }
 
     (output, s0) <-                             -- compile initial graph
@@ -81,7 +95,12 @@ fromAddHandler :: AddHandler a -> Moment (Event a)
 fromAddHandler addHandler = do
     (p, fire) <- liftBuild $ Prim.newInput
     network   <- ask
-    liftIO $ register addHandler $ runStep network . fire
+    let doRegister = register addHandler $ runStep network . fire
+    (registers, unregistersM) <- liftIO $ takeMVar $ enInputRegisters network
+    let registers' = doRegister : registers
+    unregistersM' <- liftIO $ traverse (\unregisters -> doRegister >>= pure . (:unregisters))
+                       unregistersM
+    liftIO $ putMVar (enInputRegisters network) (registers', unregistersM')
     return $ Prim.fromPure p
 
 addReactimate :: Event (Future (IO ())) -> Moment ()