{-# 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
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
((()
_, (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
Action -> IO ()
doit Action
topologyUpdates
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
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
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
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
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
IO () -> EvalP ()
rememberLatchUpdate (IO () -> EvalP ()) -> IO () -> EvalP ()
forall a b. (a -> b) -> a -> b
$
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
(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 []
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
else do
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