From ccddec54d55baed418fb212f81f183e35c36c1f2 Mon Sep 17 00:00:00 2001
From: Sven Bartscher <sven.bartscher@weltraumschlangen.de>
Date: Wed, 2 May 2018 20:34:48 +0200
Subject: [PATCH] Register handlers on actuate and unregister them on pause

Closes #73
---
 .../src/Reactive/Banana/Frameworks.hs         |  3 +-
 .../Reactive/Banana/Internal/Combinators.hs   | 66 ++++++++++++++++---
 2 files changed, 57 insertions(+), 12 deletions(-)

diff --git a/reactive-banana/src/Reactive/Banana/Frameworks.hs b/reactive-banana/src/Reactive/Banana/Frameworks.hs
index e42e1bc8..420a7590 100644
--- a/reactive-banana/src/Reactive/Banana/Frameworks.hs
+++ b/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.
 --
diff --git a/reactive-banana/src/Reactive/Banana/Internal/Combinators.hs b/reactive-banana/src/Reactive/Banana/Internal/Combinators.hs
index 298b8f1f..e99f28c3 100644
--- a/reactive-banana/src/Reactive/Banana/Internal/Combinators.hs
+++ b/reactive-banana/src/Reactive/Banana/Internal/Combinators.hs
@@ -4,6 +4,7 @@
 {-# LANGUAGE RecursiveDo, FlexibleInstances, NoMonomorphismRestriction #-}
 module Reactive.Banana.Internal.Combinators where
 
+import           Control.Applicative                 (liftA2)
 import           Control.Concurrent.MVar
 import           Control.Event.Handler
 import           Control.Monad
@@ -46,19 +47,49 @@ 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 ()
+    , eventNetworkState :: MVar NetworkState
     }
 
+data NetworkState = NetworkState
+    { actuated           :: Bool
+    , registerHandlers   :: [IO (IO ())]
+    , unregisterHandlers :: [IO ()]
+    }
+
+initialNetworkState :: NetworkState
+initialNetworkState = NetworkState
+  { actuated           = False
+  , registerHandlers   = []
+  , unregisterHandlers = []
+  }
+
+actuate :: EventNetwork -> IO ()
+actuate network = modifyMVar_ (eventNetworkState network) $ \state ->
+  if actuated state
+  then pure state
+  else (\unregs -> state { actuated = True, unregisterHandlers = unregs })
+       -- We intentionally use foldr here to ensure that the register
+       -- calls are made from right (first added) to left (last added)
+       <$> foldr (flip (liftA2 (flip (:)))) (pure []) (registerHandlers state)
+
+pause :: EventNetwork -> IO ()
+pause network = modifyMVar_ (eventNetworkState network) $ \state ->
+  state { actuated = False, unregisterHandlers = [] }
+  -- We use sequence_ here to unregister from left (registered last)
+  -- to right (registered first). The reversal of direction relative
+  -- to actuate is intentional to allow for bracket style dependencies
+  -- between registers and unregisters.
+  <$ when (actuated state) (sequence_ $ unregisterHandlers state)
+
 -- | 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
+    networkState <- newMVar initialNetworkState -- Reference to the network state
+    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 (actuated <$> readMVar networkState) $ do
             s1 <- takeMVar s                    -- read and take lock
             -- pollValues <- sequence polls     -- poll mutable data
             (output, s2) <- f s1                -- calculate new state
@@ -67,8 +98,7 @@ compile setup = do
 
         eventNetwork = EventNetwork
             { runStep = runStep
-            , actuate = writeIORef actuated True
-            , pause   = writeIORef actuated False
+            , eventNetworkState = networkState
             }
 
     (output, s0) <-                             -- compile initial graph
@@ -81,7 +111,23 @@ 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
+    liftIO $ modifyMVar_ (eventNetworkState network) $ \state -> do
+      -- registerer and unregisterers are always pushed onto the left
+      -- of their respective stack. This means handlers registered
+      -- later are further left than those registered earlier further
+      -- right. This is true for both stacks even though registerers
+      -- ar run from first registered (right) to last registered
+      -- (left) whereas unregisterers are run from last registered
+      -- (left) to first registered (right).
+      let registers' = doRegister : registerHandlers state
+      unregisters' <- if actuated state
+                      then (:unregisterHandlers state) <$> doRegister
+                      else pure $ unregisterHandlers state
+      pure $ state
+        { registerHandlers = registers'
+        , unregisterHandlers = unregisters'
+        }
     return $ Prim.fromPure p
 
 addReactimate :: Event (Future (IO ())) -> Moment ()