{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
module Reactive.Banana.Prim.Low.Compile where
import Control.Exception (evaluate)
import Data.Functor
import Data.IORef
import Reactive.Banana.Prim.Mid.Combinators (mapP)
import Reactive.Banana.Prim.Low.IO
import qualified Reactive.Banana.Prim.Low.OrderedBag as OB
import Reactive.Banana.Prim.Low.Plumbing
import Reactive.Banana.Prim.Low.Types
compile :: BuildIO a -> Network -> IO (a, Network)
compile :: BuildIO a -> Network -> IO (a, Network)
compile BuildIO a
m Network{Time
nTime :: Network -> Time
nTime :: Time
nTime, OrderedBag Output
nOutputs :: Network -> OrderedBag Output
nOutputs :: OrderedBag Output
nOutputs, Pulse ()
nAlwaysP :: Network -> Pulse ()
nAlwaysP :: Pulse ()
nAlwaysP} = do
(a
a, Action
topology, [Output]
os) <- BuildR -> BuildIO a -> IO (a, Action, [Output])
forall a. BuildR -> BuildIO a -> IO (a, Action, [Output])
runBuildIO (Time
nTime, Pulse ()
nAlwaysP) BuildIO a
m
Action -> IO ()
doit Action
topology
let state2 :: Network
state2 = Network :: Time -> OrderedBag Output -> Pulse () -> Network
Network
{ nTime :: Time
nTime = Time -> Time
next Time
nTime
, nOutputs :: OrderedBag Output
nOutputs = OrderedBag Output -> [Output] -> OrderedBag Output
forall a. (Eq a, Hashable a) => OrderedBag a -> [a] -> OrderedBag a
OB.inserts OrderedBag Output
nOutputs [Output]
os
, Pulse ()
nAlwaysP :: Pulse ()
nAlwaysP :: Pulse ()
nAlwaysP
}
(a, Network) -> IO (a, Network)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,Network
state2)
emptyNetwork :: IO Network
emptyNetwork :: IO Network
emptyNetwork = do
(Pulse ()
alwaysP, Action
_, [Output]
_) <- BuildR -> BuildIO (Pulse ()) -> IO (Pulse (), Action, [Output])
forall a. BuildR -> BuildIO a -> IO (a, Action, [Output])
runBuildIO BuildR
forall a. HasCallStack => a
undefined (BuildIO (Pulse ()) -> IO (Pulse (), Action, [Output]))
-> BuildIO (Pulse ()) -> IO (Pulse (), Action, [Output])
forall a b. (a -> b) -> a -> b
$ String -> EvalP (Maybe ()) -> BuildIO (Pulse ())
forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"alwaysP" (Maybe () -> EvalP (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe () -> EvalP (Maybe ())) -> Maybe () -> EvalP (Maybe ())
forall a b. (a -> b) -> a -> b
$ () -> Maybe ()
forall a. a -> Maybe a
Just ())
Network -> IO Network
forall (f :: * -> *) a. Applicative f => a -> f a
pure Network :: Time -> OrderedBag Output -> Pulse () -> Network
Network
{ nTime :: Time
nTime = Time -> Time
next Time
beginning
, nOutputs :: OrderedBag Output
nOutputs = OrderedBag Output
forall a. OrderedBag a
OB.empty
, nAlwaysP :: Pulse ()
nAlwaysP = Pulse ()
alwaysP
}
interpret :: (Pulse a -> BuildIO (Pulse b)) -> [Maybe a] -> IO [Maybe b]
interpret :: (Pulse a -> BuildIO (Pulse b)) -> [Maybe a] -> IO [Maybe b]
interpret Pulse a -> BuildIO (Pulse b)
f [Maybe a]
xs = do
IORef (Maybe b)
o <- Maybe b -> IO (IORef (Maybe b))
forall a. a -> IO (IORef a)
newIORef Maybe b
forall a. Maybe a
Nothing
let network :: ReaderWriterIOT BuildR BuildW IO (a -> Step)
network = do
(Pulse a
pin, a -> Step
sin) <- Build (Pulse a, a -> Step) -> Build (Pulse a, a -> Step)
forall a. Build a -> Build a
liftBuild Build (Pulse a, a -> Step)
forall a. Build (Pulse a, a -> Step)
newInput
Pulse b
pmid <- Pulse a -> BuildIO (Pulse b)
f Pulse a
pin
Pulse (IO b)
pout <- Build (Pulse (IO b)) -> Build (Pulse (IO b))
forall a. Build a -> Build a
liftBuild (Build (Pulse (IO b)) -> Build (Pulse (IO b)))
-> Build (Pulse (IO b)) -> Build (Pulse (IO b))
forall a b. (a -> b) -> a -> b
$ (b -> IO b) -> Pulse b -> Build (Pulse (IO b))
forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
mapP b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return Pulse b
pmid
Build () -> Build ()
forall a. Build a -> Build a
liftBuild (Build () -> Build ()) -> Build () -> Build ()
forall a b. (a -> b) -> a -> b
$ Pulse (IO b) -> (b -> IO ()) -> Build ()
forall a. Pulse (Future a) -> (a -> IO ()) -> Build ()
addHandler Pulse (IO b)
pout (IORef (Maybe b) -> Maybe b -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe b)
o (Maybe b -> IO ()) -> (b -> Maybe b) -> b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe b
forall a. a -> Maybe a
Just)
(a -> Step) -> ReaderWriterIOT BuildR BuildW IO (a -> Step)
forall (m :: * -> *) a. Monad m => a -> m a
return a -> Step
sin
(a -> Step
sin, Network
state) <- ReaderWriterIOT BuildR BuildW IO (a -> Step)
-> Network -> IO (a -> Step, Network)
forall a. BuildIO a -> Network -> IO (a, Network)
compile ReaderWriterIOT BuildR BuildW IO (a -> Step)
network (Network -> IO (a -> Step, Network))
-> IO Network -> IO (a -> Step, Network)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Network
emptyNetwork
let go :: Maybe a -> Network -> IO (Maybe b, Network)
go Maybe a
Nothing Network
s1 = (Maybe b, Network) -> IO (Maybe b, Network)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b
forall a. Maybe a
Nothing,Network
s1)
go (Just a
a) Network
s1 = do
(IO ()
reactimate,Network
s2) <- a -> Step
sin a
a Network
s1
IO ()
reactimate
Maybe b
ma <- IORef (Maybe b) -> IO (Maybe b)
forall a. IORef a -> IO a
readIORef IORef (Maybe b)
o
IORef (Maybe b) -> Maybe b -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe b)
o Maybe b
forall a. Maybe a
Nothing
(Maybe b, Network) -> IO (Maybe b, Network)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b
ma,Network
s2)
(Maybe a -> Network -> IO (Maybe b, Network))
-> Network -> [Maybe a] -> IO [Maybe b]
forall (m :: * -> *) a s b.
Monad m =>
(a -> s -> m (b, s)) -> s -> [a] -> m [b]
mapAccumM Maybe a -> Network -> IO (Maybe b, Network)
go Network
state [Maybe a]
xs
runSpaceProfile :: Show b => (Pulse a -> BuildIO (Pulse b)) -> [a] -> IO ()
runSpaceProfile :: (Pulse a -> BuildIO (Pulse b)) -> [a] -> IO ()
runSpaceProfile Pulse a -> BuildIO (Pulse b)
f [a]
xs = do
let g :: ReaderWriterIOT BuildR BuildW IO (a -> Step)
g = do
(Pulse a
p1, a -> Step
fire) <- Build (Pulse a, a -> Step) -> Build (Pulse a, a -> Step)
forall a. Build a -> Build a
liftBuild Build (Pulse a, a -> Step)
forall a. Build (Pulse a, a -> Step)
newInput
Pulse b
p2 <- Pulse a -> BuildIO (Pulse b)
f Pulse a
p1
Pulse (IO b)
p3 <- (b -> IO b) -> Pulse b -> Build (Pulse (IO b))
forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
mapP b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return Pulse b
p2
Pulse (IO b) -> (b -> IO ()) -> Build ()
forall a. Pulse (Future a) -> (a -> IO ()) -> Build ()
addHandler Pulse (IO b)
p3 (IO b -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO b -> IO ()) -> (b -> IO b) -> b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> IO b
forall a. a -> IO a
evaluate)
(a -> Step) -> ReaderWriterIOT BuildR BuildW IO (a -> Step)
forall (m :: * -> *) a. Monad m => a -> m a
return a -> Step
fire
(a -> Step
step,Network
network) <- ReaderWriterIOT BuildR BuildW IO (a -> Step)
-> Network -> IO (a -> Step, Network)
forall a. BuildIO a -> Network -> IO (a, Network)
compile ReaderWriterIOT BuildR BuildW IO (a -> Step)
g (Network -> IO (a -> Step, Network))
-> IO Network -> IO (a -> Step, Network)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Network
emptyNetwork
let fire :: a -> Network -> IO ((), Network)
fire a
x Network
s1 = do
(IO ()
outputs, Network
s2) <- a -> Step
step a
x Network
s1
IO ()
outputs
((), Network) -> IO ((), Network)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Network
s2)
(a -> Network -> IO ((), Network)) -> Network -> [a] -> IO ()
forall (m :: * -> *) a s b.
Monad m =>
(a -> s -> m (b, s)) -> s -> [a] -> m ()
mapAccumM_ a -> Network -> IO ((), Network)
fire Network
network [a]
xs
mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m [b]
mapAccumM :: (a -> s -> m (b, s)) -> s -> [a] -> m [b]
mapAccumM a -> s -> m (b, s)
_ s
_ [] = [b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
mapAccumM a -> s -> m (b, s)
f s
s0 (a
x:[a]
xs) = do
(b
b,s
s1) <- a -> s -> m (b, s)
f a
x s
s0
[b]
bs <- (a -> s -> m (b, s)) -> s -> [a] -> m [b]
forall (m :: * -> *) a s b.
Monad m =>
(a -> s -> m (b, s)) -> s -> [a] -> m [b]
mapAccumM a -> s -> m (b, s)
f s
s1 [a]
xs
[b] -> m [b]
forall (m :: * -> *) a. Monad m => a -> m a
return (b
bb -> [b] -> [b]
forall a. a -> [a] -> [a]
:[b]
bs)
mapAccumM_ :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m ()
mapAccumM_ :: (a -> s -> m (b, s)) -> s -> [a] -> m ()
mapAccumM_ a -> s -> m (b, s)
_ s
_ [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mapAccumM_ a -> s -> m (b, s)
f !s
s0 (a
x:[a]
xs) = do
(b
_,s
s1) <- a -> s -> m (b, s)
f a
x s
s0
(a -> s -> m (b, s)) -> s -> [a] -> m ()
forall (m :: * -> *) a s b.
Monad m =>
(a -> s -> m (b, s)) -> s -> [a] -> m ()
mapAccumM_ a -> s -> m (b, s)
f s
s1 [a]
xs