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

import Control.Exception
    ( evaluate )
import Data.Functor
    ( void )
import Data.IORef
    ( newIORef, readIORef, writeIORef )

import qualified Reactive.Banana.Prim.Low.GraphGC as GraphGC
import qualified Reactive.Banana.Prim.Low.OrderedBag as OB
import           Reactive.Banana.Prim.Mid.Combinators (mapP)
import           Reactive.Banana.Prim.Mid.Evaluation (applyDependencyChanges)
import           Reactive.Banana.Prim.Mid.IO
import           Reactive.Banana.Prim.Mid.Plumbing
import           Reactive.Banana.Prim.Mid.Types

{-----------------------------------------------------------------------------
   Compilation
------------------------------------------------------------------------------}
-- | Change a 'Network' of pulses and latches by
-- executing a 'BuildIO' action.
compile :: BuildIO a -> Network -> IO (a, Network)
compile :: forall a. BuildIO a -> Network -> IO (a, Network)
compile BuildIO a
m Network{Time
nTime :: Time
nTime :: Network -> Time
nTime, OrderedBag Output
nOutputs :: OrderedBag Output
nOutputs :: Network -> OrderedBag Output
nOutputs, Pulse ()
nAlwaysP :: Pulse ()
nAlwaysP :: Network -> Pulse ()
nAlwaysP, Dependencies
nGraphGC :: Dependencies
nGraphGC :: Network -> Dependencies
nGraphGC} = do
    (a, dependencyChanges, os) <- BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output])
forall a.
BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output])
runBuildIO (Time
nTime, Pulse ()
nAlwaysP) BuildIO a
m

    applyDependencyChanges dependencyChanges nGraphGC
    let state2 = 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
            , Dependencies
nGraphGC :: Dependencies
nGraphGC :: Dependencies
nGraphGC
            }
    return (a,state2)

emptyNetwork :: IO Network
emptyNetwork :: IO Network
emptyNetwork = do
  (alwaysP, _, _) <- BuildR
-> BuildIO (Pulse ()) -> IO (Pulse (), DependencyChanges, [Output])
forall a.
BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output])
runBuildIO BuildR
forall a. HasCallStack => a
undefined (BuildIO (Pulse ()) -> IO (Pulse (), DependencyChanges, [Output]))
-> BuildIO (Pulse ()) -> IO (Pulse (), DependencyChanges, [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 a. a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO a
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 ())
  nGraphGC <- GraphGC.new
  pure Network
    { nTime    = next beginning
    , nOutputs = OB.empty
    , nAlwaysP = alwaysP
    , nGraphGC
    }

{-----------------------------------------------------------------------------
    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 :: forall a b.
(Pulse a -> BuildIO (Pulse b)) -> [Maybe a] -> IO [Maybe b]
interpret Pulse a -> BuildIO (Pulse b)
f [Maybe a]
xs = do
    o   <- Maybe b -> IO (IORef (Maybe b))
forall a. a -> IO (IORef a)
newIORef Maybe b
forall a. Maybe a
Nothing
    let network = do
            (pin, 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
            pmid       <- f pin
            pout       <- liftBuild $ mapP return pmid
            liftBuild $ addHandler pout (writeIORef o . Just)
            return sin

    -- compile initial network
    (sin, state) <- compile network =<< emptyNetwork

    let go Maybe a
Nothing  Network
s1 = (Maybe b, Network) -> IO (Maybe b, Network)
forall a. a -> IO a
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
            (reactimate,s2) <- a -> Step
sin a
a Network
s1
            reactimate              -- write output
            ma <- readIORef o       -- read output
            writeIORef o Nothing
            return (ma,s2)

    fst <$> mapAccumM go state 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 :: forall b a.
Show b =>
(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
        (p1, 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
        p2 <- f p1
        p3 <- mapP return p2                -- wrap into Future
        addHandler p3 (void . evaluate)
        return fire
    (step,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
x Network
s1 = do
            (outputs, s2) <- a -> Step
step a
x Network
s1
            outputs                     -- don't forget to execute outputs
            return ((), s2)

    mapAccumM_ fire network xs

-- | 'mapAccum' for a monad.
mapAccumM :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m ([b],s)
mapAccumM :: forall (m :: * -> *) a s b.
Monad m =>
(a -> s -> m (b, s)) -> s -> [a] -> m ([b], s)
mapAccumM a -> s -> m (b, s)
f s
s0 = s -> [b] -> [a] -> m ([b], s)
go s
s0 []
  where
    go :: s -> [b] -> [a] -> m ([b], s)
go s
s1 [b]
bs []     = ([b], s) -> m ([b], s)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([b] -> [b]
forall a. [a] -> [a]
reverse [b]
bs,s
s1)
    go s
s1 [b]
bs (a
x:[a]
xs) = do
        (b,s2) <- a -> s -> m (b, s)
f a
x s
s1
        go s2 (b:bs) xs

-- | Strict 'mapAccum' for a monad. Discards results.
mapAccumM_ :: Monad m => (a -> s -> m (b,s)) -> s -> [a] -> m ()
mapAccumM_ :: forall (m :: * -> *) a s b.
Monad m =>
(a -> s -> m (b, s)) -> s -> [a] -> m ()
mapAccumM_ a -> s -> m (b, s)
_ s
_   []     = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
mapAccumM_ a -> s -> m (b, s)
f !s
s0 (a
x:[a]
xs) = do
    (_,s1) <- a -> s -> m (b, s)
f a
x s
s0
    mapAccumM_ f s1 xs