{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
module Reactive.Banana.Prim.Low.Evaluation (
    step
    ) where

import Control.Monad ( join )
import           Control.Monad.IO.Class
import qualified Control.Monad.Trans.RWSIO          as RWS
import qualified Data.PQueue.Prio.Min               as Q
import qualified Data.Vault.Lazy                    as Lazy
import           System.Mem.Weak

import qualified Reactive.Banana.Prim.Low.OrderedBag as OB
import           Reactive.Banana.Prim.Low.Plumbing
import           Reactive.Banana.Prim.Low.Types
import           Reactive.Banana.Prim.Low.Util

type Queue = Q.MinPQueue Level

{-----------------------------------------------------------------------------
    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 ([SomeNode]
inputs,Vault
pulses)
        Network{ nTime :: Network -> Time
nTime = Time
time1
        , nOutputs :: Network -> OrderedBag Output
nOutputs = OrderedBag Output
outputs1
        , nAlwaysP :: Network -> Pulse ()
nAlwaysP = Pulse ()
alwaysP
        }
    = do

    -- evaluate pulses
    ((()
_, (Action
latchUpdates, [(Output, EvalO)]
outputs)), Action
topologyUpdates, [Output]
os)
            <- BuildR
-> BuildIO ((), EvalPW) -> IO (((), EvalPW), Action, [Output])
forall a. BuildR -> BuildIO a -> IO (a, Action, [Output])
runBuildIO (Time
time1, Pulse ()
alwaysP)
            (BuildIO ((), EvalPW) -> IO (((), EvalPW), Action, [Output]))
-> BuildIO ((), EvalPW) -> IO (((), EvalPW), Action, [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
$  [SomeNode] -> EvalP ()
evaluatePulses [SomeNode]
inputs

    Action -> IO ()
doit Action
latchUpdates                           -- update latch values from pulses
    Action -> IO ()
doit Action
topologyUpdates                        -- rearrange graph topology
    let actions :: [(Output, EvalO)]
        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
state2 = Network :: Time -> OrderedBag Output -> Pulse () -> Network
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
            }
    (IO (), Network) -> IO (IO (), Network)
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvalO] -> IO ()
runEvalOs ([EvalO] -> IO ()) -> [EvalO] -> IO ()
forall a b. (a -> b) -> a -> b
$ ((Output, EvalO) -> EvalO) -> [(Output, EvalO)] -> [EvalO]
forall a b. (a -> b) -> [a] -> [b]
map (Output, EvalO) -> EvalO
forall a b. (a, b) -> b
snd [(Output, EvalO)]
actions, Network
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

{-----------------------------------------------------------------------------
    Traversal in dependency order
------------------------------------------------------------------------------}
-- | Update all pulses in the graph, starting from a given set of nodes
evaluatePulses :: [SomeNode] -> EvalP ()
evaluatePulses :: [SomeNode] -> EvalP ()
evaluatePulses [SomeNode]
roots = (Tuple BuildR (EvalPW, BuildW) Vault -> IO ()) -> EvalP ()
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
wrapEvalP ((Tuple BuildR (EvalPW, BuildW) Vault -> IO ()) -> EvalP ())
-> (Tuple BuildR (EvalPW, BuildW) Vault -> IO ()) -> EvalP ()
forall a b. (a -> b) -> a -> b
$ \Tuple BuildR (EvalPW, BuildW) Vault
r -> Tuple BuildR (EvalPW, BuildW) Vault -> Queue SomeNode -> IO ()
go Tuple BuildR (EvalPW, BuildW) Vault
r (Queue SomeNode -> IO ()) -> IO (Queue SomeNode) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Tuple BuildR (EvalPW, BuildW) Vault
-> [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
insertNodes Tuple BuildR (EvalPW, BuildW) Vault
r [SomeNode]
roots Queue SomeNode
forall k a. MinPQueue k a
Q.empty
    where
    go :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> Queue SomeNode -> IO ()
    go :: Tuple BuildR (EvalPW, BuildW) Vault -> Queue SomeNode -> IO ()
go Tuple BuildR (EvalPW, BuildW) Vault
r Queue SomeNode
q =
        case ({-# SCC minView #-} Queue SomeNode -> Maybe (SomeNode, Queue SomeNode)
forall k a. Ord k => MinPQueue k a -> Maybe (a, MinPQueue k a)
Q.minView Queue SomeNode
q) of
            Maybe (SomeNode, Queue SomeNode)
Nothing         -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just (SomeNode
node, Queue SomeNode
q)  -> do
                [SomeNode]
children <- Tuple BuildR (EvalPW, BuildW) Vault
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO [SomeNode]
-> IO [SomeNode]
forall r w s (m :: * -> *) a.
Tuple r w s -> RWSIOT r w s m a -> m a
unwrapEvalP Tuple BuildR (EvalPW, BuildW) Vault
r (SomeNode -> RWSIOT BuildR (EvalPW, BuildW) Vault IO [SomeNode]
evaluateNode SomeNode
node)
                Queue SomeNode
q        <- Tuple BuildR (EvalPW, BuildW) Vault
-> [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
insertNodes Tuple BuildR (EvalPW, BuildW) Vault
r [SomeNode]
children Queue SomeNode
q
                Tuple BuildR (EvalPW, BuildW) Vault -> Queue SomeNode -> IO ()
go Tuple BuildR (EvalPW, BuildW) Vault
r Queue SomeNode
q

-- | Recalculate a given node and return all children nodes
-- that need to evaluated subsequently.
evaluateNode :: SomeNode -> EvalP [SomeNode]
evaluateNode :: SomeNode -> RWSIOT BuildR (EvalPW, BuildW) Vault IO [SomeNode]
evaluateNode (P Pulse a
p) = {-# SCC evaluateNodeP #-} do
    Pulse{Level
String
[Weak SomeNode]
Key (Maybe a)
EvalP (Maybe a)
Time
_nameP :: forall a. Pulse' a -> String
_levelP :: forall a. Pulse' a -> Level
_parentsP :: forall a. Pulse' a -> [Weak SomeNode]
_childrenP :: forall a. Pulse' a -> [Weak SomeNode]
_evalP :: forall a. Pulse' a -> EvalP (Maybe a)
_seenP :: forall a. Pulse' a -> Time
_keyP :: forall a. Pulse' a -> Key (Maybe a)
_nameP :: String
_levelP :: Level
_parentsP :: [Weak SomeNode]
_childrenP :: [Weak SomeNode]
_evalP :: EvalP (Maybe a)
_seenP :: Time
_keyP :: Key (Maybe a)
..} <- Pulse a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Pulse' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Pulse a
p
    Maybe a
ma        <- EvalP (Maybe a)
_evalP
    Key (Maybe a) -> Maybe a -> EvalP ()
forall a. Key (Maybe a) -> Maybe a -> EvalP ()
writePulseP Key (Maybe a)
_keyP Maybe a
ma
    case Maybe a
ma of
        Maybe a
Nothing -> [SomeNode] -> RWSIOT BuildR (EvalPW, BuildW) Vault IO [SomeNode]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just a
_  -> IO [SomeNode] -> RWSIOT BuildR (EvalPW, BuildW) Vault IO [SomeNode]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [SomeNode]
 -> RWSIOT BuildR (EvalPW, BuildW) Vault IO [SomeNode])
-> IO [SomeNode]
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO [SomeNode]
forall a b. (a -> b) -> a -> b
$ [Weak SomeNode] -> IO [SomeNode]
forall v. [Weak v] -> IO [v]
deRefWeaks [Weak SomeNode]
_childrenP
evaluateNode (L LatchWrite
lw) = {-# SCC evaluateNodeL #-} do
    Time
time           <- EvalP Time
askTime
    LatchWrite{Weak (Latch a)
EvalP a
_latchLW :: ()
_evalLW :: ()
_latchLW :: Weak (Latch a)
_evalLW :: EvalP a
..} <- LatchWrite -> RWSIOT BuildR (EvalPW, BuildW) Vault IO LatchWrite'
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef LatchWrite
lw
    Maybe (Latch a)
mlatch         <- IO (Maybe (Latch a))
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe (Latch a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Latch a))
 -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe (Latch a)))
-> IO (Maybe (Latch a))
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe (Latch a))
forall a b. (a -> b) -> a -> b
$ Weak (Latch a) -> IO (Maybe (Latch a))
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak (Latch a)
_latchLW -- retrieve destination latch
    case Maybe (Latch a)
mlatch of
        Maybe (Latch a)
Nothing    -> () -> EvalP ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Latch a
latch -> do
            a
a <- EvalP a
_evalLW                    -- calculate new latch value
            -- liftIO $ Strict.evaluate a      -- see Note [LatchStrictness]
            IO () -> EvalP ()
rememberLatchUpdate (IO () -> EvalP ()) -> IO () -> EvalP ()
forall a b. (a -> b) -> a -> b
$           -- schedule value to be set later
                Latch a -> (Latch' a -> Latch' a) -> IO ()
forall (m :: * -> *) a. MonadIO m => Ref a -> (a -> a) -> m ()
modify' Latch a
latch ((Latch' a -> Latch' a) -> IO ())
-> (Latch' a -> Latch' a) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Latch' a
l ->
                    a
a a -> Latch' a -> Latch' a
`seq` Latch' a
l { _seenL :: Time
_seenL = Time
time, _valueL :: a
_valueL = a
a }
    [SomeNode] -> RWSIOT BuildR (EvalPW, BuildW) Vault IO [SomeNode]
forall (m :: * -> *) a. Monad m => a -> m a
return []
evaluateNode (O Output
o) = {-# SCC evaluateNodeO #-} do
    String -> EvalP ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"evaluateNode O"
    Output{EvalP EvalO
_evalO :: Output' -> EvalP EvalO
_evalO :: EvalP EvalO
..} <- Output -> RWSIOT BuildR (EvalPW, BuildW) Vault IO Output'
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Output
o
    EvalO
m          <- EvalP EvalO
_evalO                    -- calculate output action
    (Output, EvalO) -> EvalP ()
rememberOutput (Output
o,EvalO
m)
    [SomeNode] -> RWSIOT BuildR (EvalPW, BuildW) Vault IO [SomeNode]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Insert nodes into the queue
insertNodes :: RWS.Tuple BuildR (EvalPW, BuildW) Lazy.Vault -> [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
insertNodes :: Tuple BuildR (EvalPW, BuildW) Vault
-> [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
insertNodes (RWS.Tuple (Time
time,Pulse ()
_) IORef (EvalPW, BuildW)
_ IORef Vault
_) = [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
go
    where
    go :: [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
    go :: [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
go []              Queue SomeNode
q = Queue SomeNode -> IO (Queue SomeNode)
forall (m :: * -> *) a. Monad m => a -> m a
return Queue SomeNode
q
    go (node :: SomeNode
node@(P Pulse a
p):[SomeNode]
xs) Queue SomeNode
q = do
        Pulse{Level
String
[Weak SomeNode]
Key (Maybe a)
EvalP (Maybe a)
Time
_nameP :: String
_levelP :: Level
_parentsP :: [Weak SomeNode]
_childrenP :: [Weak SomeNode]
_evalP :: EvalP (Maybe a)
_seenP :: Time
_keyP :: Key (Maybe a)
_nameP :: forall a. Pulse' a -> String
_levelP :: forall a. Pulse' a -> Level
_parentsP :: forall a. Pulse' a -> [Weak SomeNode]
_childrenP :: forall a. Pulse' a -> [Weak SomeNode]
_evalP :: forall a. Pulse' a -> EvalP (Maybe a)
_seenP :: forall a. Pulse' a -> Time
_keyP :: forall a. Pulse' a -> Key (Maybe a)
..} <- Pulse a -> IO (Pulse' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Pulse a
p
        if Time
time Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
_seenP
            then [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
go [SomeNode]
xs Queue SomeNode
q        -- pulse has already been put into the queue once
            else do             -- pulse needs to be scheduled for evaluation
                Pulse a -> Pulse' a -> IO ()
forall (m :: * -> *) a. MonadIO m => Ref a -> a -> m ()
put Pulse a
p (Pulse' a -> IO ()) -> Pulse' a -> IO ()
forall a b. (a -> b) -> a -> b
$! (let p :: Pulse' a
p = Pulse :: forall a.
Key (Maybe a)
-> Time
-> EvalP (Maybe a)
-> [Weak SomeNode]
-> [Weak SomeNode]
-> Level
-> String
-> Pulse' a
Pulse{Level
String
[Weak SomeNode]
Key (Maybe a)
EvalP (Maybe a)
Time
_nameP :: String
_levelP :: Level
_parentsP :: [Weak SomeNode]
_childrenP :: [Weak SomeNode]
_evalP :: EvalP (Maybe a)
_seenP :: Time
_keyP :: Key (Maybe a)
_nameP :: String
_levelP :: Level
_parentsP :: [Weak SomeNode]
_childrenP :: [Weak SomeNode]
_evalP :: EvalP (Maybe a)
_seenP :: Time
_keyP :: Key (Maybe a)
..} in Pulse' a
p { _seenP :: Time
_seenP = Time
time })
                [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
go [SomeNode]
xs (Queue SomeNode -> IO (Queue SomeNode))
-> Queue SomeNode -> IO (Queue SomeNode)
forall a b. (a -> b) -> a -> b
$! Level -> SomeNode -> Queue SomeNode -> Queue SomeNode
forall k a. Ord k => k -> a -> MinPQueue k a -> MinPQueue k a
Q.insert Level
_levelP SomeNode
node Queue SomeNode
q
    go (SomeNode
node:[SomeNode]
xs)      Queue SomeNode
q = [SomeNode] -> Queue SomeNode -> IO (Queue SomeNode)
go [SomeNode]
xs (Queue SomeNode -> IO (Queue SomeNode))
-> Queue SomeNode -> IO (Queue SomeNode)
forall a b. (a -> b) -> a -> b
$! Level -> SomeNode -> Queue SomeNode -> Queue SomeNode
forall k a. Ord k => k -> a -> MinPQueue k a -> MinPQueue k a
Q.insert Level
ground SomeNode
node Queue SomeNode
q
            -- O and L nodes have only one parent, so
            -- we can insert them at an arbitrary level