{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
{-# LANGUAGE BangPatterns #-}
module Reactive.Banana.Prim.Compile where

import Control.Exception (evaluate)
import Control.Monad     (void)
import Data.Functor
import Data.IORef

import           Reactive.Banana.Prim.Combinators
import           Reactive.Banana.Prim.IO
import qualified Reactive.Banana.Prim.OrderedBag  as OB
import           Reactive.Banana.Prim.Plumbing
import           Reactive.Banana.Prim.Types

{-----------------------------------------------------------------------------
   Compilation
------------------------------------------------------------------------------}
-- | Change a 'Network' of pulses and latches by
-- executing a 'BuildIO' action.
compile :: BuildIO a -> Network -> IO (a, Network)
compile :: BuildIO a -> Network -> IO (a, Network)
compile BuildIO a
m Network
state1 = do
    let time1 :: Time
time1    = Network -> Time
nTime Network
state1
        outputs1 :: OrderedBag Output
outputs1 = Network -> OrderedBag Output
nOutputs Network
state1

    Pulse ()
theAlwaysP <- case Network -> Maybe (Pulse ())
nAlwaysP Network
state1 of
        Just Pulse ()
x   -> Pulse () -> IO (Pulse ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pulse ()
x
        Maybe (Pulse ())
Nothing  -> do
            (Pulse ()
x,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 ())
            Pulse () -> IO (Pulse ())
forall (m :: * -> *) a. Monad m => a -> m a
return Pulse ()
x

    (a
a, Action
topology, [Output]
os) <- BuildR -> BuildIO a -> IO (a, Action, [Output])
forall a. BuildR -> BuildIO a -> IO (a, Action, [Output])
runBuildIO (Network -> Time
nTime Network
state1, Pulse ()
theAlwaysP) BuildIO a
m
    Action -> IO ()
doit Action
topology

    let 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 ()
theAlwaysP
            }
    (a, Network) -> IO (a, Network)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,Network
state2)

{-----------------------------------------------------------------------------
    Testing
------------------------------------------------------------------------------}
-- | Simple interpreter for pulse/latch networks.
--
-- Mainly useful for testing functionality
--
-- Note: The result is not computed lazily, for similar reasons
-- that the 'sequence' function does not compute its result lazily.
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) -> Build (Pulse a, a -> Step))
-> Build (Pulse a, a -> Step) -> Build (Pulse a, a -> Step)
forall a b. (a -> b) -> a -> b
$ 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

    -- compile initial network
    (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
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              -- write output
            Maybe b
ma <- IORef (Maybe b) -> IO (Maybe b)
forall a. IORef a -> IO a
readIORef IORef (Maybe b)
o       -- read output
            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         -- run several steps

-- | Execute an FRP network with a sequence of inputs.
-- Make sure that outputs are evaluated, but don't display their values.
--
-- Mainly useful for testing whether there are space leaks.
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) -> Build (Pulse a, a -> Step))
-> Build (Pulse a, a -> Step) -> Build (Pulse a, a -> Step)
forall a b. (a -> b) -> a -> b
$ 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                -- wrap into Future
        Pulse (IO b) -> (b -> IO ()) -> Build ()
forall a. Pulse (Future a) -> (a -> IO ()) -> Build ()
addHandler Pulse (IO b)
p3 (\b
b -> IO b -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO b -> IO ()) -> IO b -> IO ()
forall a b. (a -> b) -> a -> b
$ b -> IO b
forall a. a -> IO a
evaluate b
b)
        (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
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                     -- don't forget to execute 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

-- | 'mapAccum' for a monad.
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)

-- | Strict 'mapAccum' for a monad. Discards results.
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