{-# 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 :: Network -> Time
nTime :: Time
nTime, OrderedBag Output
nOutputs :: Network -> OrderedBag Output
nOutputs :: OrderedBag Output
nOutputs, Pulse ()
nAlwaysP :: Network -> Pulse ()
nAlwaysP :: Pulse ()
nAlwaysP, Dependencies
nGraphGC :: Network -> Dependencies
nGraphGC :: Dependencies
nGraphGC} = do
    (a
a, DependencyChanges
dependencyChanges, [Output]
os) <- forall a.
BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output])
runBuildIO (Time
nTime, Pulse ()
nAlwaysP) BuildIO a
m

    DependencyChanges -> Dependencies -> IO ()
applyDependencyChanges DependencyChanges
dependencyChanges Dependencies
nGraphGC
    let state2 :: Network
state2 = Network
            { nTime :: Time
nTime    = Time -> Time
next Time
nTime
            , nOutputs :: OrderedBag Output
nOutputs = 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
            }
    forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,Network
state2)

emptyNetwork :: IO Network
emptyNetwork :: IO Network
emptyNetwork = do
  (Pulse ()
alwaysP, DependencyChanges
_, [Output]
_) <- forall a.
BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output])
runBuildIO forall a. HasCallStack => a
undefined forall a b. (a -> b) -> a -> b
$ forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
"alwaysP" (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ())
  Dependencies
nGraphGC <- forall v. IO (GraphGC v)
GraphGC.new
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Network
    { nTime :: Time
nTime    = Time -> Time
next Time
beginning
    , nOutputs :: OrderedBag Output
nOutputs = forall a. OrderedBag a
OB.empty
    , nAlwaysP :: Pulse ()
nAlwaysP = Pulse ()
alwaysP
    , Dependencies
nGraphGC :: Dependencies
nGraphGC :: Dependencies
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
    IORef (Maybe b)
o   <- forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
    let network :: ReaderWriterIOT BuildR BuildW IO (a -> Step)
network = do
            (Pulse a
pin, a -> Step
sin) <- forall a. Build a -> Build a
liftBuild forall a. Build (Pulse a, a -> Step)
newInput
            Pulse b
pmid       <- Pulse a -> BuildIO (Pulse b)
f Pulse a
pin
            Pulse (IO b)
pout       <- forall a. Build a -> Build a
liftBuild forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
mapP forall (m :: * -> *) a. Monad m => a -> m a
return Pulse b
pmid
            forall a. Build a -> Build a
liftBuild forall a b. (a -> b) -> a -> b
$ forall a. Pulse (Future a) -> (a -> IO ()) -> BuildIO ()
addHandler Pulse (IO b)
pout (forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe b)
o forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)
            forall (m :: * -> *) a. Monad m => a -> m a
return a -> Step
sin

    -- compile initial network
    (a -> Step
sin, Network
state) <- forall a. BuildIO a -> Network -> IO (a, Network)
compile ReaderWriterIOT BuildR BuildW 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (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 <- forall a. IORef a -> IO a
readIORef IORef (Maybe b)
o       -- read output
            forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe b)
o forall a. Maybe a
Nothing
            forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b
ma,Network
s2)

    forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a s b.
Monad m =>
(a -> s -> m (b, s)) -> s -> [a] -> m ([b], s)
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 :: 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
        (Pulse a
p1, a -> Step
fire) <- forall a. Build a -> Build a
liftBuild forall a. Build (Pulse a, a -> Step)
newInput
        Pulse b
p2 <- Pulse a -> BuildIO (Pulse b)
f Pulse a
p1
        Pulse (IO b)
p3 <- forall a b. (a -> b) -> Pulse a -> Build (Pulse b)
mapP forall (m :: * -> *) a. Monad m => a -> m a
return Pulse b
p2                -- wrap into Future
        forall a. Pulse (Future a) -> (a -> IO ()) -> BuildIO ()
addHandler Pulse (IO b)
p3 (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> IO a
evaluate)
        forall (m :: * -> *) a. Monad m => a -> m a
return a -> Step
fire
    (a -> Step
step,Network
network) <- forall a. BuildIO a -> Network -> IO (a, Network)
compile ReaderWriterIOT BuildR BuildW IO (a -> Step)
g 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                     -- don't forget to execute outputs
            forall (m :: * -> *) a. Monad m => a -> m a
return ((), Network
s2)

    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],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 []     = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> [a]
reverse [b]
bs,s
s1)
    go s
s1 [b]
bs (a
x:[a]
xs) = do
        (b
b,s
s2) <- a -> s -> m (b, s)
f a
x s
s1
        s -> [b] -> [a] -> m ([b], s)
go s
s2 (b
bforall a. a -> [a] -> [a]
:[b]
bs) [a]
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
_   []     = 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
    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