{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
module Reactive.Banana.Prim.Mid.Evaluation
    ( step
    , applyDependencyChanges
    ) where

import Control.Monad
    ( join )
import Control.Monad.IO.Class
    ( liftIO )

import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC
import qualified Reactive.Banana.Prim.Low.OrderedBag as OB
import qualified Reactive.Banana.Prim.Low.Ref as Ref
import           Reactive.Banana.Prim.Mid.Plumbing
import           Reactive.Banana.Prim.Mid.Types

{-----------------------------------------------------------------------------
    Evaluation step
------------------------------------------------------------------------------}
-- | Evaluate all the pulses in the graph,
-- Rebuild the graph as necessary and update the latch values.
step :: Inputs -> Step
step :: Inputs -> Step
step ([Output]
inputs,Vault
pulses)
        Network{ nTime :: Network -> Time
nTime = Time
time1
        , nOutputs :: Network -> OrderedBag Output
nOutputs = OrderedBag Output
outputs1
        , nAlwaysP :: Network -> Pulse ()
nAlwaysP = Pulse ()
alwaysP
        , Dependencies
nGraphGC :: Network -> Dependencies
nGraphGC :: Dependencies
nGraphGC
        }
    = do

    -- evaluate pulses
    ((()
_, (EvalLW
latchUpdates, [(Output, EvalO)]
outputs)), DependencyChanges
dependencyChanges, [Output]
os)
            <- forall a.
BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output])
runBuildIO (Time
time1, Pulse ()
alwaysP)
            forall a b. (a -> b) -> a -> b
$  forall a. Vault -> EvalP a -> Build (a, EvalPW)
runEvalP Vault
pulses
            forall a b. (a -> b) -> a -> b
$  [Output] -> Dependencies -> EvalP ()
evaluatePulses [Output]
inputs Dependencies
nGraphGC

    EvalLW -> IO ()
doit EvalLW
latchUpdates                          -- update latch values from pulses
    DependencyChanges -> Dependencies -> IO ()
applyDependencyChanges DependencyChanges
dependencyChanges   -- rearrange graph topology
        Dependencies
nGraphGC
    forall v. GraphGC v -> IO ()
GraphGC.removeGarbage Dependencies
nGraphGC             -- remove unreachable pulses
    let actions :: [(Output, EvalO)]
        actions :: [(Output, EvalO)]
actions = forall a b.
(Eq a, Hashable a) =>
[(a, b)] -> OrderedBag a -> [(a, b)]
OB.inOrder [(Output, EvalO)]
outputs OrderedBag Output
outputs1  -- EvalO actions in proper order

        state2 :: Network
        !state2 :: Network
state2 = Network
            { nTime :: Time
nTime    = Time -> Time
next Time
time1
            , nOutputs :: OrderedBag Output
nOutputs = forall a. (Eq a, Hashable a) => OrderedBag a -> [a] -> OrderedBag a
OB.inserts OrderedBag Output
outputs1 [Output]
os
            , nAlwaysP :: Pulse ()
nAlwaysP = Pulse ()
alwaysP
            , Dependencies
nGraphGC :: Dependencies
nGraphGC :: Dependencies
nGraphGC
            }
    forall (m :: * -> *) a. Monad m => a -> m a
return ([EvalO] -> IO ()
runEvalOs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Output, EvalO)]
actions, Network
state2)

runEvalOs :: [EvalO] -> IO ()
runEvalOs :: [EvalO] -> IO ()
runEvalOs = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join

{-----------------------------------------------------------------------------
    Dependency changes
------------------------------------------------------------------------------}
-- | Apply all dependency changes to the 'GraphGC'.
applyDependencyChanges :: DependencyChanges -> Dependencies -> IO ()
applyDependencyChanges :: DependencyChanges -> Dependencies -> IO ()
applyDependencyChanges DependencyChanges
changes Dependencies
g = do
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [DependencyChange Output Output -> Dependencies -> IO ()
applyDependencyChange DependencyChange Output Output
c Dependencies
g | c :: DependencyChange Output Output
c@(InsertEdge Output
_ Output
_) <- DependencyChanges
changes]
    forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [DependencyChange Output Output -> Dependencies -> IO ()
applyDependencyChange DependencyChange Output Output
c Dependencies
g | c :: DependencyChange Output Output
c@(ChangeParentTo Output
_ Output
_) <- DependencyChanges
changes]

applyDependencyChange
    :: DependencyChange SomeNode SomeNode -> Dependencies -> IO ()
applyDependencyChange :: DependencyChange Output Output -> Dependencies -> IO ()
applyDependencyChange (InsertEdge Output
parent Output
child) Dependencies
g =
    forall v. (Ref v, Ref v) -> GraphGC v -> IO ()
GraphGC.insertEdge (Output
parent, Output
child) Dependencies
g
applyDependencyChange (ChangeParentTo Output
child Output
parent) Dependencies
g = do
    forall v. Ref v -> GraphGC v -> IO ()
GraphGC.clearPredecessors Output
child Dependencies
g
    forall v. (Ref v, Ref v) -> GraphGC v -> IO ()
GraphGC.insertEdge (Output
parent, Output
child) Dependencies
g

{-----------------------------------------------------------------------------
    Traversal in dependency order
------------------------------------------------------------------------------}
-- | Update all pulses in the graph, starting from a given set of nodes
evaluatePulses :: [SomeNode] -> Dependencies -> EvalP ()
evaluatePulses :: [Output] -> Dependencies -> EvalP ()
evaluatePulses [Output]
inputs Dependencies
g = do
    EvalP ()
action <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) v.
Monad m =>
[Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m ())
GraphGC.walkSuccessors_ [Output]
inputs WeakRef SomeNodeD -> EvalP Step
evaluateWeakNode Dependencies
g
    EvalP ()
action

evaluateWeakNode :: Ref.WeakRef SomeNodeD -> EvalP GraphGC.Step
evaluateWeakNode :: WeakRef SomeNodeD -> EvalP Step
evaluateWeakNode WeakRef SomeNodeD
w = do
    Maybe Output
mnode <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall v. Weak v -> IO (Maybe v)
Ref.deRefWeak WeakRef SomeNodeD
w
    case Maybe Output
mnode of
        Maybe Output
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Step
GraphGC.Stop
        Just Output
node -> Output -> EvalP Step
evaluateNode Output
node

-- | Recalculate a given node and return all children nodes
-- that need to evaluated subsequently.
evaluateNode :: SomeNode -> EvalP GraphGC.Step
evaluateNode :: Output -> EvalP Step
evaluateNode Output
someNode = do
    SomeNodeD
node <- forall (m :: * -> *) a. MonadIO m => Ref a -> m a
Ref.read Output
someNode
    case SomeNodeD
node of
        P PulseD{EvalP (Maybe a)
_evalP :: forall a. PulseD a -> EvalP (Maybe a)
_evalP :: EvalP (Maybe a)
_evalP,Key (Maybe a)
_keyP :: forall a. PulseD a -> Key (Maybe a)
_keyP :: Key (Maybe a)
_keyP} -> {-# SCC evaluateNodeP #-} do
            Maybe a
ma <- EvalP (Maybe a)
_evalP
            forall a. Key (Maybe a) -> Maybe a -> EvalP ()
writePulseP Key (Maybe a)
_keyP Maybe a
ma
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe a
ma of
                Maybe a
Nothing -> Step
GraphGC.Stop
                Just a
_  -> Step
GraphGC.Next
        L LatchWriteD
lw -> {-# SCC evaluateLatchWrite #-} do
            LatchWriteD -> EvalP ()
evaluateLatchWrite LatchWriteD
lw
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Step
GraphGC.Stop
        O OutputD
o -> {-# SCC evaluateNodeO #-} do
            EvalO
m <- OutputD -> EvalP EvalO
_evalO OutputD
o -- calculate output action
            (Output, EvalO) -> EvalP ()
rememberOutput (Output
someNode,EvalO
m)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Step
GraphGC.Stop

evaluateLatchWrite :: LatchWriteD -> EvalP ()
evaluateLatchWrite :: LatchWriteD -> EvalP ()
evaluateLatchWrite LatchWriteD{EvalP a
_evalLW :: ()
_evalLW :: EvalP a
_evalLW,Weak (Latch a)
_latchLW :: ()
_latchLW :: Weak (Latch a)
_latchLW} = do
    Time
time   <- EvalP Time
askTime
    Maybe (Latch a)
mlatch <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall v. Weak v -> IO (Maybe v)
Ref.deRefWeak Weak (Latch a)
_latchLW -- retrieve destination latch
    case Maybe (Latch a)
mlatch of
        Maybe (Latch a)
Nothing    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Latch a
latch -> do
            a
a <- EvalP a
_evalLW                    -- calculate new latch value
            -- liftIO $ Strict.evaluate a   -- see Note [LatchStrictness]
            IO () -> EvalP ()
rememberLatchUpdate forall a b. (a -> b) -> a -> b
$           -- schedule value to be set later
                forall (m :: * -> *) a. MonadIO m => Ref a -> (a -> a) -> m ()
Ref.modify' Latch a
latch forall a b. (a -> b) -> a -> b
$ \LatchD a
l ->
                    a
a seq :: forall a b. a -> b -> b
`seq` LatchD a
l { _seenL :: Time
_seenL = Time
time, _valueL :: a
_valueL = a
a }