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

import qualified Control.Exception                  as Strict (evaluate)
import           Control.Monad                                (foldM)
import           Control.Monad                                (join)
import           Control.Monad.IO.Class
import qualified Control.Monad.Trans.RWSIO          as RWS
import qualified Control.Monad.Trans.ReaderWriterIO as RW
import           Data.Functor
import           Data.Maybe
import qualified Data.PQueue.Prio.Min               as Q
import qualified Data.Vault.Lazy                    as Lazy
import           System.Mem.Weak

import qualified Reactive.Banana.Prim.OrderedBag as OB
import           Reactive.Banana.Prim.Plumbing
import           Reactive.Banana.Prim.Types
import           Reactive.Banana.Prim.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 -> Maybe (Pulse ())
nAlwaysP = Just Pulse ()
alwaysP   -- we assume that this has been built already
        }
    = {-# SCC step #-} 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 -> Maybe (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 :: Maybe (Pulse ())
nAlwaysP = Pulse () -> Maybe (Pulse ())
forall a. a -> Maybe a
Just 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 = [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([IO ()] -> IO ()) -> ([EvalO] -> [IO ()]) -> [EvalO] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (EvalO -> IO ()) -> [EvalO] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map 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 = {-# SCC go #-}
        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, EvalO) -> EvalP ()) -> (Output, EvalO) -> EvalP ()
forall a b. (a -> b) -> a -> b
$ (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
_) = {-# SCC insertNodes #-} [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 (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 (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