    {-# 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