Add (provisional) getSize function

HeinrichApfelmus · Dec 29, 2022 · e4bc279 · e4bc279
1 parent 5a1775a
commit e4bc279
Show file tree

Hide file tree

Showing 5 changed files with 23 additions and 5 deletions.
diff --git a/reactive-banana/src/Reactive/Banana/Frameworks.hs b/reactive-banana/src/Reactive/Banana/Frameworks.hs
@@ -33,7 +33,7 @@ module Reactive.Banana.Frameworks (
     interpretFrameworks, newEvent, mapEventIO, newBehavior,
 
     -- * Running event networks
-    EventNetwork, actuate, pause,
+    EventNetwork, actuate, pause, getSize,
 
     ) where
 
@@ -332,6 +332,12 @@ actuate = Prim.actuate . unEN
 pause :: EventNetwork -> IO ()
 pause   = Prim.pause . unEN
 
+-- | PROVISIONAL.
+-- Measure of the number of events in the event network.
+-- Useful for understanding space usage.
+getSize :: EventNetwork -> IO Int
+getSize = Prim.getSize . unEN
+
 {-----------------------------------------------------------------------------
     Utilities
 ------------------------------------------------------------------------------}

diff --git a/reactive-banana/src/Reactive/Banana/Prim/High/Combinators.hs b/reactive-banana/src/Reactive/Banana/Prim/High/Combinators.hs
@@ -45,24 +45,27 @@ interpret f = Prim.interpret $ \pulse -> runReaderT (g pulse) undefined
 -- | Data type representing an event network.
 data EventNetwork = EventNetwork
     { actuated :: IORef Bool
+    , size :: IORef Int
     , s :: MVar Prim.Network
     }
 
-
 runStep :: EventNetwork -> Prim.Step -> IO ()
-runStep EventNetwork{ actuated, s } f = whenFlag actuated $ do
+runStep EventNetwork{ actuated, s, size } f = whenFlag actuated $ do
     output <- mask $ \restore -> do
         s1 <- takeMVar s                   -- read and take lock
         -- pollValues <- sequence polls    -- poll mutable data
         (output, s2) <-
             restore (f s1)                 -- calculate new state
                 `onException` putMVar s s1 -- on error, restore the original state
         putMVar s s2                       -- write state
+        writeIORef size =<< Prim.getSize s2
         return output
     output                                 -- run IO actions afterwards
   where
     whenFlag flag action = readIORef flag >>= \b -> when b action
 
+getSize :: EventNetwork -> IO Int
+getSize EventNetwork{size} = readIORef size
 
 actuate :: EventNetwork -> IO ()
 actuate EventNetwork{ actuated } = writeIORef actuated True
@@ -75,12 +78,14 @@ compile :: Moment () -> IO EventNetwork
 compile setup = do
     actuated <- newIORef False                   -- flag to set running status
     s        <- newEmptyMVar                     -- setup callback machinery
+    size     <- newIORef 0
 
-    let eventNetwork = EventNetwork{ actuated, s }
+    let eventNetwork = EventNetwork{ actuated, s, size }
 
     (_output, s0) <-                             -- compile initial graph
         Prim.compile (runReaderT setup eventNetwork) =<< Prim.emptyNetwork
     putMVar s s0                                -- set initial state
+    writeIORef size =<< Prim.getSize s0
 
     return eventNetwork
 

diff --git a/reactive-banana/src/Reactive/Banana/Prim/Low/GraphGC.hs b/reactive-banana/src/Reactive/Banana/Prim/Low/GraphGC.hs
@@ -6,6 +6,7 @@
 module Reactive.Banana.Prim.Low.GraphGC
     ( GraphGC
     , listReachableVertices
+    , getSize
     , new
     , insertEdge
     , clearPredecessors
@@ -92,6 +93,9 @@ new = GraphGC <$> newIORef newGraphD <*> STM.newTQueueIO
         , references = Map.empty
         }
 
+getSize :: GraphGC v -> IO Int
+getSize GraphGC{graphRef} = Graph.size . graph <$> readIORef graphRef
+
 -- | List all vertices that are reachable and have at least
 -- one edge incident on them.
 -- TODO: Is that really what the function does?

diff --git a/reactive-banana/src/Reactive/Banana/Prim/Mid.hs b/reactive-banana/src/Reactive/Banana/Prim/Mid.hs
@@ -9,7 +9,7 @@ module Reactive.Banana.Prim.Mid (
     -- have a look at "Reactive.Banana" instead.
 
     -- * Evaluation
-    Step, Network, emptyNetwork,
+    Step, Network, emptyNetwork, getSize,
 
     -- * Build FRP networks
     Build, liftIOLater, BuildIO, liftBuild, buildLater, buildLaterReadNow, compile,

diff --git a/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs b/reactive-banana/src/Reactive/Banana/Prim/Mid/Types.hs
@@ -33,6 +33,9 @@ data Network = Network
     , nGraphGC        :: Dependencies
     }
 
+getSize :: Network -> IO Int
+getSize = GraphGC.getSize . nGraphGC
+
 type Dependencies  = GraphGC.GraphGC SomeNodeD
 type Inputs        = ([SomeNode], Lazy.Vault)
 type EvalNetwork a = Network -> IO (a, Network)