Push EvalP out further

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

@@ -6,6 +6,7 @@ module Reactive.Banana.Prim.Evaluation (
     step
     ) where
 
+import Data.IORef
 import qualified Control.Exception                  as Strict (evaluate)
 import           Control.Monad                                (foldM)
 import           Control.Monad                                (join)
@@ -42,7 +43,7 @@ step (inputs,pulses)
     ((_, (latchUpdates, outputs)), topologyUpdates, os)
             <- runBuildIO (time1, alwaysP)
             $  runEvalP pulses
-            $  evaluatePulses inputs
+            $  wrapEvalP (evaluatePulses inputs)
 
     doit latchUpdates                           -- update latch values from pulses
     doit topologyUpdates                        -- rearrange graph topology
@@ -61,89 +62,96 @@ runEvalOs = sequence_ . map join
     Traversal in dependency order
 ------------------------------------------------------------------------------}
 -- | Update all pulses in the graph, starting from a given set of nodes
-evaluatePulses :: [SomeNode] -> EvalP ()
-evaluatePulses roots = wrapEvalP $ \r -> go r =<< insertNodes r roots Q.empty
+evaluatePulses roots t@(RWS.Tuple (time,_) _ _) = insertNodes time roots Q.empty >>= go
     where
     -- go :: Queue SomeNode -> EvalP ()
-    go r q = {-# SCC go #-}
+    go q = {-# SCC go #-}
         case ({-# SCC minView #-} Q.minView q) of
             Nothing         -> return ()
             Just (node, q)  -> do
-                children <- unwrapEvalP r (evaluateNode node)
-                q        <- insertNodes r children q
-                go r q
+                children <- evaluateNode t node
+                q        <- insertNodes time children q
+                go q
 
 -- | Recalculate a given node and return all children nodes
 -- that need to evaluated subsequently.
-evaluateNode :: SomeNode -> EvalP [SomeNode]
-evaluateNode (P p) = {-# SCC evaluateNodeP #-} do
+--evaluateNode :: SomeNode -> EvalP [SomeNode]
+evaluateNode t@(RWS.Tuple _ _ s) (P p) = {-# SCC evaluateNodeP #-} do
     Pulse{..} <- readRef p
-    ma        <- runPulseCalculation _evalP
-    writePulseP _keyP ma
+    ma        <- runPulseCalculation t _evalP
+    unwrapEvalP t (writePulseP _keyP ma)
     case ma of
         Nothing -> return []
-        Just _  -> liftIO $ deRefWeaks _childrenP
-evaluateNode (L lw) = {-# SCC evaluateNodeL #-} do
-    time           <- askTime
+        Just _  -> deRefWeaks _childrenP
+evaluateNode t (L lw) = {-# SCC evaluateNodeL #-} do
+    time           <- unwrapEvalP t askTime
     LatchWrite{..} <- readRef lw
-    mlatch         <- liftIO $ deRefWeak _latchLW -- retrieve destination latch
+    mlatch         <- deRefWeak _latchLW -- retrieve destination latch
     case mlatch of
         Nothing    -> return ()
-        Just latch -> do
+        Just latch -> unwrapEvalP t $ do
             a <- _evalLW                    -- calculate new latch value
             -- liftIO $ Strict.evaluate a      -- see Note [LatchStrictness]
             rememberLatchUpdate $           -- schedule value to be set later
                 modify' latch $ \l ->
                     a `seq` l { _seenL = time, _valueL = a }
     return []
-evaluateNode (O o) = {-# SCC evaluateNodeO #-} do
+evaluateNode t (O o) = {-# SCC evaluateNodeO #-} do
     debug "evaluateNode O"
     Output{..} <- readRef o
-    m          <- _evalO                    -- calculate output action
-    rememberOutput $ (o,m)
+    m          <- unwrapEvalP t _evalO                    -- calculate output action
+    unwrapEvalP t (rememberOutput $ (o,m))
     return []
 
 -- | Insert nodes into the queue
 -- insertNode :: [SomeNode] -> Queue SomeNode -> EvalP (Queue SomeNode)
-insertNodes (RWS.Tuple (time,_) _ _) = {-# SCC insertNodes #-} go
+insertNodes :: Time -> [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
+insertNodes time = {-# SCC insertNodes #-} go
     where
     go []              q = return q
     go (node@(P p):xs) q = do
         Pulse{..} <- readRef p
         if time <= _seenP
-            then go xs q        -- pulse has already been put into the queue once
-            else do             -- pulse needs to be scheduled for evaluation
+            then go xs q      -- pulse has already been put into the queue once
+            else do           -- pulse needs to be scheduled for evaluation
                 put p $! (let p = Pulse{..} in p { _seenP = time })
                 go xs (Q.insert _levelP node q)
     go (node:xs)      q = go xs (Q.insert ground node q)
             -- O and L nodes have only one parent, so
             -- we can insert them at an arbitrary level
 
-runPulseCalculation :: PulseCalculation a -> EvalP (Maybe a)
-runPulseCalculation (PulseMap f p1) = fmap f <$> readPulseP p1
-runPulseCalculation PulseNever = return Nothing
-runPulseCalculation (PulseJoin p1) = join <$> readPulseP p1
-runPulseCalculation (PulseMapIO f p1) = eval =<< readPulseP p1
-  where eval (Just x) = Just <$> liftIO (f x)
-        eval Nothing = return Nothing
-runPulseCalculation (PulseUnionWith f px py) =
-  eval <$> readPulseP px <*> readPulseP py
-  where eval (Just x) (Just y) = Just (f x y)
-        eval (Just x) Nothing = Just x
-        eval Nothing (Just y) = Just y
-        eval Nothing Nothing = Nothing
-runPulseCalculation (PulseApply f x) = fmap <$> readLatchP f <*> readPulseP x
-runPulseCalculation (PulseExecute p1 b) = eval =<< readPulseP p1
-  where eval (Just x) = Just <$> liftBuildP (x b)
-        eval Nothing = return Nothing
-runPulseCalculation (PulseSwitch pp p2) =
-  do mnew <- readPulseP pp
-     case mnew of
-       Nothing -> return ()
-       Just new -> liftBuildP $ p2 `changeParent` new
-     return Nothing
-runPulseCalculation (PulseReadLatch lp) = readPulseP =<< readLatchP lp
-runPulseCalculation (PulseReadPulse p) = readPulseP p
-runPulseCalculation (PulseAlways x) = return $ Just x
-runPulseCalculation (PulseFuture x p1) =
-  fmap . const <$> readLatchFutureP x <*> readPulseP p1
+runPulseCalculation t c =
+  case c of
+    PulseMap f p1 -> fmap f <$> unwrapEvalP t (readPulseP p1)
+    PulseNever -> return Nothing
+    PulseJoin p1 -> unwrapEvalP t (join <$> readPulseP p1)
+    PulseMapIO f p1 ->
+      let eval (Just x) = Just <$> f x
+          eval Nothing = return Nothing
+      in eval =<< unwrapEvalP t (readPulseP p1)
+    PulseUnionWith f px py ->
+      let eval (Just x) (Just y) = Just (f x y)
+          eval (Just x) Nothing = Just x
+          eval Nothing (Just y) = Just y
+          eval Nothing Nothing = Nothing
+      in eval <$> unwrapEvalP t (readPulseP px) <*>
+         unwrapEvalP t (readPulseP py)
+    PulseApply f x ->
+      fmap <$> unwrapEvalP t (readLatchP f) <*> unwrapEvalP t (readPulseP x)
+    PulseExecute p1 b ->
+      let eval (Just x) = Just <$> liftBuildP (x b)
+          eval Nothing = return Nothing
+      in unwrapEvalP t . eval =<< unwrapEvalP t (readPulseP p1)
+    PulseSwitch pp p2 -> do
+      mnew <- unwrapEvalP t (readPulseP pp)
+      case mnew of
+        Nothing -> return ()
+        Just new -> unwrapEvalP t (liftBuildP $ p2 `changeParent` new)
+      return Nothing
+    PulseReadLatch lp ->
+      unwrapEvalP t . readPulseP =<< unwrapEvalP t (readLatchP lp)
+    PulseReadPulse p -> unwrapEvalP t (readPulseP p)
+    PulseAlways x -> return (Just x)
+    PulseFuture x p1 ->
+      fmap . const <$> unwrapEvalP t (readLatchFutureP x) <*>
+      unwrapEvalP t (readPulseP p1)