{-# 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 :: Dependencies
nGraphGC :: Network -> Dependencies
nGraphGC
        }
    = do

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

    doit latchUpdates                          -- update latch values from pulses
    applyDependencyChanges dependencyChanges   -- rearrange graph topology
        nGraphGC
    GraphGC.removeGarbage nGraphGC             -- remove unreachable pulses
    let actions :: [(Output, EvalO)]
        actions = [(Output, EvalO)] -> OrderedBag Output -> [(Output, EvalO)]
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
            { nTime :: Time
nTime    = Time -> Time
next Time
time1
            , nOutputs :: OrderedBag Output
nOutputs = OrderedBag Output -> [Output] -> OrderedBag Output
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
            }
    return (runEvalOs $ map snd actions, state2)

runEvalOs :: [EvalO] -> IO ()
runEvalOs :: [EvalO] -> IO ()
runEvalOs = (EvalO -> IO ()) -> [EvalO] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ EvalO -> IO ()
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
    [IO ()] -> IO ()
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]
    [IO ()] -> IO ()
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 =
    (Output, Output) -> Dependencies -> IO ()
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
    Output -> Dependencies -> IO ()
forall v. Ref v -> GraphGC v -> IO ()
GraphGC.clearPredecessors Output
child Dependencies
g
    (Output, Output) -> Dependencies -> IO ()
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
    action <- IO (EvalP ()) -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (EvalP ())
forall a. IO a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EvalP ())
 -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (EvalP ()))
-> IO (EvalP ())
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (EvalP ())
forall a b. (a -> b) -> a -> b
$ [Output]
-> (WeakRef SomeNodeD
    -> RWSIOT BuildR (EvalPW, BuildW) Vault IO Step)
-> Dependencies
-> IO (EvalP ())
forall (m :: * -> *) v.
Monad m =>
[Ref v] -> (WeakRef v -> m Step) -> GraphGC v -> IO (m ())
GraphGC.walkSuccessors_ [Output]
inputs WeakRef SomeNodeD -> RWSIOT BuildR (EvalPW, BuildW) Vault IO Step
evaluateWeakNode Dependencies
g
    action

evaluateWeakNode :: Ref.WeakRef SomeNodeD -> EvalP GraphGC.Step
evaluateWeakNode :: WeakRef SomeNodeD -> RWSIOT BuildR (EvalPW, BuildW) Vault IO Step
evaluateWeakNode WeakRef SomeNodeD
w = do
    mnode <- IO (Maybe Output)
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe Output)
forall a. IO a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Output)
 -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe Output))
-> IO (Maybe Output)
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe Output)
forall a b. (a -> b) -> a -> b
$ WeakRef SomeNodeD -> IO (Maybe Output)
forall v. Weak v -> IO (Maybe v)
Ref.deRefWeak WeakRef SomeNodeD
w
    case mnode of
        Maybe Output
Nothing -> Step -> RWSIOT BuildR (EvalPW, BuildW) Vault IO Step
forall a. a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Step
GraphGC.Stop
        Just Output
node -> Output -> RWSIOT BuildR (EvalPW, BuildW) Vault IO 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 -> RWSIOT BuildR (EvalPW, BuildW) Vault IO Step
evaluateNode Output
someNode = do
    node <- Output -> RWSIOT BuildR (EvalPW, BuildW) Vault IO SomeNodeD
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
Ref.read Output
someNode
    case node of
        P PulseD{EvalP (Maybe a)
_evalP :: EvalP (Maybe a)
_evalP :: forall a. PulseD a -> EvalP (Maybe a)
_evalP,Key (Maybe a)
_keyP :: Key (Maybe a)
_keyP :: forall a. PulseD a -> Key (Maybe a)
_keyP} -> {-# SCC evaluateNodeP #-} do
            ma <- EvalP (Maybe a)
_evalP
            writePulseP _keyP ma
            pure $ case ma of
                Maybe a
Nothing -> Step
GraphGC.Stop
                Just a
_  -> Step
GraphGC.Next
        L LatchWriteD
lw -> {-# SCC evaluateLatchWrite #-} do
            LatchWriteD -> EvalP ()
evaluateLatchWrite LatchWriteD
lw
            Step -> RWSIOT BuildR (EvalPW, BuildW) Vault IO Step
forall a. a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Step
GraphGC.Stop
        O OutputD
o -> {-# SCC evaluateNodeO #-} do
            m <- OutputD -> EvalP EvalO
_evalO OutputD
o -- calculate output action
            rememberOutput (someNode,m)
            pure GraphGC.Stop

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