{-----------------------------------------------------------------------------
    reactive-banana
------------------------------------------------------------------------------}
{-# LANGUAGE RecordWildCards, RecursiveDo, BangPatterns, ScopedTypeVariables #-}
module Reactive.Banana.Prim.Plumbing where

import           Control.Monad                                (join)
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import qualified Control.Monad.Trans.RWSIO          as RWS
import qualified Control.Monad.Trans.Reader         as Reader
import qualified Control.Monad.Trans.ReaderWriterIO as RW
import           Data.Function                                (on)
import           Data.Functor
import           Data.IORef
import           Data.List                                    (sortBy)
import           Data.Monoid
import qualified Data.Vault.Lazy                    as Lazy
import           System.IO.Unsafe

import qualified Reactive.Banana.Prim.Dependencies as Deps
import           Reactive.Banana.Prim.Types
import           Reactive.Banana.Prim.Util

{-----------------------------------------------------------------------------
    Build primitive pulses and latches
------------------------------------------------------------------------------}
-- | Make 'Pulse' from evaluation function
newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
name EvalP (Maybe a)
eval = IO (Pulse a) -> Build (Pulse a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Pulse a) -> Build (Pulse a))
-> IO (Pulse a) -> Build (Pulse a)
forall a b. (a -> b) -> a -> b
$ do
    Key (Maybe a)
key <- IO (Key (Maybe a))
forall a. IO (Key a)
Lazy.newKey
    Pulse' a -> IO (Pulse a)
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Pulse' a -> IO (Pulse a)) -> Pulse' a -> IO (Pulse a)
forall a b. (a -> b) -> a -> b
$ Pulse :: forall a.
Key (Maybe a)
-> Time
-> EvalP (Maybe a)
-> [Weak SomeNode]
-> [Weak SomeNode]
-> Level
-> String
-> Pulse' a
Pulse
        { _keyP :: Key (Maybe a)
_keyP      = Key (Maybe a)
key
        , _seenP :: Time
_seenP     = Time
agesAgo
        , _evalP :: EvalP (Maybe a)
_evalP     = EvalP (Maybe a)
eval
        , _childrenP :: [Weak SomeNode]
_childrenP = []
        , _parentsP :: [Weak SomeNode]
_parentsP  = []
        , _levelP :: Level
_levelP    = Level
ground
        , _nameP :: String
_nameP     = String
name
        }

{-
* Note [PulseCreation]

We assume that we do not have to calculate a pulse occurrence
at the moment we create the pulse. Otherwise, we would have
to recalculate the dependencies *while* doing evaluation;
this is a recipe for desaster.

-}

-- | 'Pulse' that never fires.
neverP :: Build (Pulse a)
neverP :: Build (Pulse a)
neverP = IO (Pulse a) -> Build (Pulse a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Pulse a) -> Build (Pulse a))
-> IO (Pulse a) -> Build (Pulse a)
forall a b. (a -> b) -> a -> b
$ do
    Key (Maybe a)
key <- IO (Key (Maybe a))
forall a. IO (Key a)
Lazy.newKey
    Pulse' a -> IO (Pulse a)
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Pulse' a -> IO (Pulse a)) -> Pulse' a -> IO (Pulse a)
forall a b. (a -> b) -> a -> b
$ Pulse :: forall a.
Key (Maybe a)
-> Time
-> EvalP (Maybe a)
-> [Weak SomeNode]
-> [Weak SomeNode]
-> Level
-> String
-> Pulse' a
Pulse
        { _keyP :: Key (Maybe a)
_keyP      = Key (Maybe a)
key
        , _seenP :: Time
_seenP     = Time
agesAgo
        , _evalP :: EvalP (Maybe a)
_evalP     = Maybe a -> EvalP (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        , _childrenP :: [Weak SomeNode]
_childrenP = []
        , _parentsP :: [Weak SomeNode]
_parentsP  = []
        , _levelP :: Level
_levelP    = Level
ground
        , _nameP :: String
_nameP     = String
"neverP"
        }

-- | Return a 'Latch' that has a constant value
pureL :: a -> Latch a
pureL :: a -> Latch a
pureL a
a = IO (Latch a) -> Latch a
forall a. IO a -> a
unsafePerformIO (IO (Latch a) -> Latch a) -> IO (Latch a) -> Latch a
forall a b. (a -> b) -> a -> b
$ Latch' a -> IO (Latch a)
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Latch' a -> IO (Latch a)) -> Latch' a -> IO (Latch a)
forall a b. (a -> b) -> a -> b
$ Latch :: forall a. Time -> a -> EvalL a -> Latch' a
Latch
    { _seenL :: Time
_seenL  = Time
beginning
    , _valueL :: a
_valueL = a
a
    , _evalL :: EvalL a
_evalL  = a -> EvalL a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
    }

-- | Make new 'Latch' that can be updated by a 'Pulse'
newLatch :: forall a. a -> Build (Pulse a -> Build (), Latch a)
newLatch :: a -> Build (Pulse a -> Build (), Latch a)
newLatch a
a = mdo
    Latch a
latch <- IO (Latch a) -> ReaderWriterIOT BuildR BuildW IO (Latch a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Latch a) -> ReaderWriterIOT BuildR BuildW IO (Latch a))
-> IO (Latch a) -> ReaderWriterIOT BuildR BuildW IO (Latch a)
forall a b. (a -> b) -> a -> b
$ Latch' a -> IO (Latch a)
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Latch' a -> IO (Latch a)) -> Latch' a -> IO (Latch a)
forall a b. (a -> b) -> a -> b
$ Latch :: forall a. Time -> a -> EvalL a -> Latch' a
Latch
        { _seenL :: Time
_seenL  = Time
beginning
        , _valueL :: a
_valueL = a
a
        , _evalL :: EvalL a
_evalL  = do
            Latch {a
EvalL a
Time
_evalL :: EvalL a
_valueL :: a
_seenL :: Time
_evalL :: forall a. Latch' a -> EvalL a
_valueL :: forall a. Latch' a -> a
_seenL :: forall a. Latch' a -> Time
..} <- Latch a -> ReaderWriterIOT () Time IO (Latch' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Latch a
latch
            Time -> ReaderWriterIOT () Time IO ()
forall (m :: * -> *) w r.
(MonadIO m, Monoid w) =>
w -> ReaderWriterIOT r w m ()
RW.tell Time
_seenL  -- indicate timestamp
            a -> EvalL a
forall (m :: * -> *) a. Monad m => a -> m a
return a
_valueL  -- indicate value
        }
    let
        err :: a
err        = String -> a
forall a. HasCallStack => String -> a
error String
"incorrect Latch write"

        updateOn :: Pulse a -> Build ()
        updateOn :: Pulse a -> Build ()
updateOn Pulse a
p = do
            Weak (Latch a)
w  <- IO (Weak (Latch a))
-> ReaderWriterIOT BuildR BuildW IO (Weak (Latch a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Weak (Latch a))
 -> ReaderWriterIOT BuildR BuildW IO (Weak (Latch a)))
-> IO (Weak (Latch a))
-> ReaderWriterIOT BuildR BuildW IO (Weak (Latch a))
forall a b. (a -> b) -> a -> b
$ Latch a -> Latch a -> IO (Weak (Latch a))
forall (m :: * -> *) a value.
MonadIO m =>
Ref a -> value -> m (Weak value)
mkWeakRefValue Latch a
latch Latch a
latch
            Ref LatchWrite'
lw <- IO (Ref LatchWrite')
-> ReaderWriterIOT BuildR BuildW IO (Ref LatchWrite')
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ref LatchWrite')
 -> ReaderWriterIOT BuildR BuildW IO (Ref LatchWrite'))
-> IO (Ref LatchWrite')
-> ReaderWriterIOT BuildR BuildW IO (Ref LatchWrite')
forall a b. (a -> b) -> a -> b
$ LatchWrite' -> IO (Ref LatchWrite')
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (LatchWrite' -> IO (Ref LatchWrite'))
-> LatchWrite' -> IO (Ref LatchWrite')
forall a b. (a -> b) -> a -> b
$ LatchWrite :: forall a. EvalP a -> Weak (Latch a) -> LatchWrite'
LatchWrite
                { _evalLW :: EvalP a
_evalLW  = a -> (a -> a) -> Maybe a -> a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
forall a. a
err a -> a
forall a. a -> a
id (Maybe a -> a)
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe a) -> EvalP a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pulse a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe a)
forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse a
p
                , _latchLW :: Weak (Latch a)
_latchLW = Weak (Latch a)
w
                }
            -- writer is alive only as long as the latch is alive
            Weak (Ref LatchWrite')
_  <- IO (Weak (Ref LatchWrite'))
-> ReaderWriterIOT BuildR BuildW IO (Weak (Ref LatchWrite'))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Weak (Ref LatchWrite'))
 -> ReaderWriterIOT BuildR BuildW IO (Weak (Ref LatchWrite')))
-> IO (Weak (Ref LatchWrite'))
-> ReaderWriterIOT BuildR BuildW IO (Weak (Ref LatchWrite'))
forall a b. (a -> b) -> a -> b
$ Latch a -> Ref LatchWrite' -> IO (Weak (Ref LatchWrite'))
forall (m :: * -> *) a value.
MonadIO m =>
Ref a -> value -> m (Weak value)
mkWeakRefValue Latch a
latch Ref LatchWrite'
lw
            (Pulse a -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse a
p) SomeNode -> SomeNode -> Build ()
`addChild` (Ref LatchWrite' -> SomeNode
L Ref LatchWrite'
lw)

    (Pulse a -> Build (), Latch a)
-> Build (Pulse a -> Build (), Latch a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pulse a -> Build ()
updateOn, Latch a
latch)

-- | Make a new 'Latch' that caches a previous computation.
cachedLatch :: EvalL a -> Latch a
cachedLatch :: EvalL a -> Latch a
cachedLatch EvalL a
eval = IO (Latch a) -> Latch a
forall a. IO a -> a
unsafePerformIO (IO (Latch a) -> Latch a) -> IO (Latch a) -> Latch a
forall a b. (a -> b) -> a -> b
$ mdo
    Latch a
latch <- Latch' a -> IO (Latch a)
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Latch' a -> IO (Latch a)) -> Latch' a -> IO (Latch a)
forall a b. (a -> b) -> a -> b
$ Latch :: forall a. Time -> a -> EvalL a -> Latch' a
Latch
        { _seenL :: Time
_seenL  = Time
agesAgo
        , _valueL :: a
_valueL = String -> a
forall a. HasCallStack => String -> a
error String
"Undefined value of a cached latch."
        , _evalL :: EvalL a
_evalL  = do
            Latch{a
EvalL a
Time
_evalL :: EvalL a
_valueL :: a
_seenL :: Time
_evalL :: forall a. Latch' a -> EvalL a
_valueL :: forall a. Latch' a -> a
_seenL :: forall a. Latch' a -> Time
..} <- IO (Latch' a) -> ReaderWriterIOT () Time IO (Latch' a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Latch' a) -> ReaderWriterIOT () Time IO (Latch' a))
-> IO (Latch' a) -> ReaderWriterIOT () Time IO (Latch' a)
forall a b. (a -> b) -> a -> b
$ Latch a -> IO (Latch' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Latch a
latch
            -- calculate current value (lazy!) with timestamp
            (a
a,Time
time)  <- EvalL a -> ReaderWriterIOT () Time IO (a, Time)
forall (m :: * -> *) w r a.
(MonadIO m, Monoid w) =>
ReaderWriterIOT r w m a -> ReaderWriterIOT r w m (a, w)
RW.listen EvalL a
eval
            IO a -> EvalL a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> EvalL a) -> IO a -> EvalL a
forall a b. (a -> b) -> a -> b
$ if Time
time Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
_seenL
                then a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
_valueL     -- return old value
                else do                 -- update value
                    let _seenL :: Time
_seenL  = Time
time
                    let _valueL :: a
_valueL = a
a
                    a
a a -> IO () -> IO ()
`seq` Latch a -> Latch' a -> IO ()
forall (m :: * -> *) a. MonadIO m => Ref a -> a -> m ()
put Latch a
latch (Latch :: forall a. Time -> a -> EvalL a -> Latch' a
Latch {a
EvalL a
Time
_valueL :: a
_seenL :: Time
_evalL :: EvalL a
_evalL :: EvalL a
_valueL :: a
_seenL :: Time
..})
                    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        }
    Latch a -> IO (Latch a)
forall (m :: * -> *) a. Monad m => a -> m a
return Latch a
latch

-- | Add a new output that depends on a 'Pulse'.
--
-- TODO: Return function to unregister the output again.
addOutput :: Pulse EvalO -> Build ()
addOutput :: Pulse EvalO -> Build ()
addOutput Pulse EvalO
p = do
    Ref Output'
o <- IO (Ref Output') -> ReaderWriterIOT BuildR BuildW IO (Ref Output')
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ref Output')
 -> ReaderWriterIOT BuildR BuildW IO (Ref Output'))
-> IO (Ref Output')
-> ReaderWriterIOT BuildR BuildW IO (Ref Output')
forall a b. (a -> b) -> a -> b
$ Output' -> IO (Ref Output')
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Output' -> IO (Ref Output')) -> Output' -> IO (Ref Output')
forall a b. (a -> b) -> a -> b
$ Output :: EvalP EvalO -> Output'
Output
        { _evalO :: EvalP EvalO
_evalO = EvalO -> (EvalO -> EvalO) -> Maybe EvalO -> EvalO
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO () -> EvalO
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> EvalO) -> IO () -> EvalO
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug String
"nop") EvalO -> EvalO
forall a. a -> a
id (Maybe EvalO -> EvalO)
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe EvalO)
-> EvalP EvalO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pulse EvalO
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Maybe EvalO)
forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse EvalO
p
        }
    (Pulse EvalO -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse EvalO
p) SomeNode -> SomeNode -> Build ()
`addChild` (Ref Output' -> SomeNode
O Ref Output'
o)
    BuildW -> Build ()
forall (m :: * -> *) w r.
(MonadIO m, Monoid w) =>
w -> ReaderWriterIOT r w m ()
RW.tell (BuildW -> Build ()) -> BuildW -> Build ()
forall a b. (a -> b) -> a -> b
$ (DependencyBuilder, [Ref Output'], Action, Maybe (Build ()))
-> BuildW
BuildW (DependencyBuilder
forall a. Monoid a => a
mempty, [Ref Output'
o], Action
forall a. Monoid a => a
mempty, Maybe (Build ())
forall a. Monoid a => a
mempty)

{-----------------------------------------------------------------------------
    Build monad
------------------------------------------------------------------------------}
runBuildIO :: BuildR -> BuildIO a -> IO (a, Action, [Output])
runBuildIO :: BuildR -> BuildIO a -> IO (a, Action, [Ref Output'])
runBuildIO BuildR
i BuildIO a
m = {-# SCC runBuild #-} do
        (a
a, BuildW (DependencyBuilder
topologyUpdates, [Ref Output']
os, Action
liftIOLaters, Maybe (Build ())
_)) <- BuildW -> BuildIO a -> IO (a, BuildW)
forall a. BuildW -> BuildIO a -> IO (a, BuildW)
unfold BuildW
forall a. Monoid a => a
mempty BuildIO a
m
        Action -> IO ()
doit (Action -> IO ()) -> Action -> IO ()
forall a b. (a -> b) -> a -> b
$ Action
liftIOLaters          -- execute late IOs
        (a, Action, [Ref Output']) -> IO (a, Action, [Ref Output'])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,IO () -> Action
Action (IO () -> Action) -> IO () -> Action
forall a b. (a -> b) -> a -> b
$ DependencyBuilder -> IO ()
Deps.buildDependencies DependencyBuilder
topologyUpdates,[Ref Output']
os)
    where
    -- Recursively execute the  buildLater  calls.
    unfold :: BuildW -> BuildIO a -> IO (a, BuildW)
    unfold :: BuildW -> BuildIO a -> IO (a, BuildW)
unfold BuildW
w BuildIO a
m = do
        (a
a, BuildW (DependencyBuilder
w1, [Ref Output']
w2, Action
w3, Maybe (Build ())
later)) <- BuildIO a -> BuildR -> IO (a, BuildW)
forall (m :: * -> *) w r a.
(MonadIO m, Monoid w) =>
ReaderWriterIOT r w m a -> r -> m (a, w)
RW.runReaderWriterIOT BuildIO a
m BuildR
i
        let w' :: BuildW
w' = BuildW
w BuildW -> BuildW -> BuildW
forall a. Semigroup a => a -> a -> a
<> (DependencyBuilder, [Ref Output'], Action, Maybe (Build ()))
-> BuildW
BuildW (DependencyBuilder
w1,[Ref Output']
w2,Action
w3,Maybe (Build ())
forall a. Monoid a => a
mempty)
        BuildW
w'' <- case Maybe (Build ())
later of
            Just Build ()
m  -> ((), BuildW) -> BuildW
forall a b. (a, b) -> b
snd (((), BuildW) -> BuildW) -> IO ((), BuildW) -> IO BuildW
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuildW -> Build () -> IO ((), BuildW)
forall a. BuildW -> BuildIO a -> IO (a, BuildW)
unfold BuildW
w' Build ()
m
            Maybe (Build ())
Nothing -> BuildW -> IO BuildW
forall (m :: * -> *) a. Monad m => a -> m a
return BuildW
w'
        (a, BuildW) -> IO (a, BuildW)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,BuildW
w'')

buildLater :: Build () -> Build ()
buildLater :: Build () -> Build ()
buildLater Build ()
x = BuildW -> Build ()
forall (m :: * -> *) w r.
(MonadIO m, Monoid w) =>
w -> ReaderWriterIOT r w m ()
RW.tell (BuildW -> Build ()) -> BuildW -> Build ()
forall a b. (a -> b) -> a -> b
$ (DependencyBuilder, [Ref Output'], Action, Maybe (Build ()))
-> BuildW
BuildW (DependencyBuilder
forall a. Monoid a => a
mempty, [Ref Output']
forall a. Monoid a => a
mempty, Action
forall a. Monoid a => a
mempty, Build () -> Maybe (Build ())
forall a. a -> Maybe a
Just Build ()
x)

-- | Pretend to return a value right now,
-- but do not actually calculate it until later.
--
-- NOTE: Accessing the value before it's written leads to an error.
--
-- FIXME: Is there a way to have the value calculate on demand?
buildLaterReadNow :: Build a -> Build a
buildLaterReadNow :: Build a -> Build a
buildLaterReadNow Build a
m = do
    IORef a
ref <- IO (IORef a) -> ReaderWriterIOT BuildR BuildW IO (IORef a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef a) -> ReaderWriterIOT BuildR BuildW IO (IORef a))
-> IO (IORef a) -> ReaderWriterIOT BuildR BuildW IO (IORef a)
forall a b. (a -> b) -> a -> b
$ a -> IO (IORef a)
forall a. a -> IO (IORef a)
newIORef (a -> IO (IORef a)) -> a -> IO (IORef a)
forall a b. (a -> b) -> a -> b
$
        String -> a
forall a. HasCallStack => String -> a
error String
"buildLaterReadNow: Trying to read before it is written."
    Build () -> Build ()
buildLater (Build () -> Build ()) -> Build () -> Build ()
forall a b. (a -> b) -> a -> b
$ Build a
m Build a -> (a -> Build ()) -> Build ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> Build ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Build ()) -> (a -> IO ()) -> a -> Build ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef a
ref
    IO a -> Build a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Build a) -> IO a -> Build a
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
unsafeInterleaveIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ IORef a -> IO a
forall a. IORef a -> IO a
readIORef IORef a
ref

liftBuild :: Build a -> BuildIO a
liftBuild :: Build a -> Build a
liftBuild = Build a -> Build a
forall a. a -> a
id

getTimeB :: Build Time
getTimeB :: Build Time
getTimeB = (\(Time
x,Pulse ()
_) -> Time
x) (BuildR -> Time)
-> ReaderWriterIOT BuildR BuildW IO BuildR -> Build Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderWriterIOT BuildR BuildW IO BuildR
forall (m :: * -> *) r w. Monad m => ReaderWriterIOT r w m r
RW.ask

alwaysP :: Build (Pulse ())
alwaysP :: Build (Pulse ())
alwaysP = (\(Time
_,Pulse ()
x) -> Pulse ()
x) (BuildR -> Pulse ())
-> ReaderWriterIOT BuildR BuildW IO BuildR -> Build (Pulse ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderWriterIOT BuildR BuildW IO BuildR
forall (m :: * -> *) r w. Monad m => ReaderWriterIOT r w m r
RW.ask

readLatchB :: Latch a -> Build a
readLatchB :: Latch a -> Build a
readLatchB = IO a -> Build a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Build a) -> (Latch a -> IO a) -> Latch a -> Build a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Latch a -> IO a
forall a. Latch a -> IO a
readLatchIO

dependOn :: Pulse child -> Pulse parent -> Build ()
dependOn :: Pulse child -> Pulse parent -> Build ()
dependOn Pulse child
child Pulse parent
parent = (Pulse parent -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse parent
parent) SomeNode -> SomeNode -> Build ()
`addChild` (Pulse child -> SomeNode
forall a. Pulse a -> SomeNode
P Pulse child
child)

keepAlive :: Pulse child -> Pulse parent -> Build ()
keepAlive :: Pulse child -> Pulse parent -> Build ()
keepAlive Pulse child
child Pulse parent
parent = IO () -> Build ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Build ()) -> IO () -> Build ()
forall a b. (a -> b) -> a -> b
$ Pulse child -> Pulse parent -> IO (Weak (Pulse parent))
forall (m :: * -> *) a value.
MonadIO m =>
Ref a -> value -> m (Weak value)
mkWeakRefValue Pulse child
child Pulse parent
parent IO (Weak (Pulse parent)) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

addChild :: SomeNode -> SomeNode -> Build ()
addChild :: SomeNode -> SomeNode -> Build ()
addChild SomeNode
parent SomeNode
child =
    BuildW -> Build ()
forall (m :: * -> *) w r.
(MonadIO m, Monoid w) =>
w -> ReaderWriterIOT r w m ()
RW.tell (BuildW -> Build ()) -> BuildW -> Build ()
forall a b. (a -> b) -> a -> b
$ (DependencyBuilder, [Ref Output'], Action, Maybe (Build ()))
-> BuildW
BuildW (SomeNode -> SomeNode -> DependencyBuilder
Deps.addChild SomeNode
parent SomeNode
child, [Ref Output']
forall a. Monoid a => a
mempty, Action
forall a. Monoid a => a
mempty, Maybe (Build ())
forall a. Monoid a => a
mempty)

changeParent :: Pulse child -> Pulse parent -> Build ()
changeParent :: Pulse child -> Pulse parent -> Build ()
changeParent Pulse child
node Pulse parent
parent =
    BuildW -> Build ()
forall (m :: * -> *) w r.
(MonadIO m, Monoid w) =>
w -> ReaderWriterIOT r w m ()
RW.tell (BuildW -> Build ()) -> BuildW -> Build ()
forall a b. (a -> b) -> a -> b
$ (DependencyBuilder, [Ref Output'], Action, Maybe (Build ()))
-> BuildW
BuildW (Pulse child -> Pulse parent -> DependencyBuilder
forall a b. Pulse a -> Pulse b -> DependencyBuilder
Deps.changeParent Pulse child
node Pulse parent
parent, [Ref Output']
forall a. Monoid a => a
mempty, Action
forall a. Monoid a => a
mempty, Maybe (Build ())
forall a. Monoid a => a
mempty)

liftIOLater :: IO () -> Build ()
liftIOLater :: IO () -> Build ()
liftIOLater IO ()
x = BuildW -> Build ()
forall (m :: * -> *) w r.
(MonadIO m, Monoid w) =>
w -> ReaderWriterIOT r w m ()
RW.tell (BuildW -> Build ()) -> BuildW -> Build ()
forall a b. (a -> b) -> a -> b
$ (DependencyBuilder, [Ref Output'], Action, Maybe (Build ()))
-> BuildW
BuildW (DependencyBuilder
forall a. Monoid a => a
mempty, [Ref Output']
forall a. Monoid a => a
mempty, IO () -> Action
Action IO ()
x, Maybe (Build ())
forall a. Monoid a => a
mempty)

{-----------------------------------------------------------------------------
    EvalL monad
------------------------------------------------------------------------------}
-- | Evaluate a latch (-computation) at the latest time,
-- but discard timestamp information.
readLatchIO :: Latch a -> IO a
readLatchIO :: Latch a -> IO a
readLatchIO Latch a
latch = do
    Latch{a
EvalL a
Time
_evalL :: EvalL a
_valueL :: a
_seenL :: Time
_evalL :: forall a. Latch' a -> EvalL a
_valueL :: forall a. Latch' a -> a
_seenL :: forall a. Latch' a -> Time
..} <- Latch a -> IO (Latch' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Latch a
latch
    IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ (a, Time) -> a
forall a b. (a, b) -> a
fst ((a, Time) -> a) -> IO (a, Time) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalL a -> () -> IO (a, Time)
forall (m :: * -> *) w r a.
(MonadIO m, Monoid w) =>
ReaderWriterIOT r w m a -> r -> m (a, w)
RW.runReaderWriterIOT EvalL a
_evalL ()

getValueL :: Latch a -> EvalL a
getValueL :: Latch a -> EvalL a
getValueL Latch a
latch = do
    Latch{a
EvalL a
Time
_evalL :: EvalL a
_valueL :: a
_seenL :: Time
_evalL :: forall a. Latch' a -> EvalL a
_valueL :: forall a. Latch' a -> a
_seenL :: forall a. Latch' a -> Time
..} <- Latch a -> ReaderWriterIOT () Time IO (Latch' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Latch a
latch
    EvalL a
_evalL

{-----------------------------------------------------------------------------
    EvalP monad
------------------------------------------------------------------------------}
runEvalP :: Lazy.Vault -> EvalP a -> Build (a, EvalPW)
runEvalP :: Vault -> EvalP a -> Build (a, EvalPW)
runEvalP Vault
s1 EvalP a
m = (BuildR -> IO ((a, EvalPW), BuildW)) -> Build (a, EvalPW)
forall (m :: * -> *) w r a.
(MonadIO m, Monoid w) =>
(r -> IO (a, w)) -> ReaderWriterIOT r w m a
RW.readerWriterIOT ((BuildR -> IO ((a, EvalPW), BuildW)) -> Build (a, EvalPW))
-> (BuildR -> IO ((a, EvalPW), BuildW)) -> Build (a, EvalPW)
forall a b. (a -> b) -> a -> b
$ \BuildR
r2 -> do
    (a
a,Vault
_,(EvalPW
w1,BuildW
w2)) <- EvalP a -> BuildR -> Vault -> IO (a, Vault, (EvalPW, BuildW))
forall (m :: * -> *) w r s a.
(MonadIO m, Monoid w) =>
RWSIOT r w s m a -> r -> s -> m (a, s, w)
RWS.runRWSIOT EvalP a
m BuildR
r2 Vault
s1
    ((a, EvalPW), BuildW) -> IO ((a, EvalPW), BuildW)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
a,EvalPW
w1), BuildW
w2)

liftBuildP :: Build a -> EvalP a
liftBuildP :: Build a -> EvalP a
liftBuildP Build a
m = (BuildR -> Vault -> IO (a, Vault, (EvalPW, BuildW))) -> EvalP a
forall (m :: * -> *) w r s a.
(MonadIO m, Monoid w) =>
(r -> s -> IO (a, s, w)) -> RWSIOT r w s m a
RWS.rwsT ((BuildR -> Vault -> IO (a, Vault, (EvalPW, BuildW))) -> EvalP a)
-> (BuildR -> Vault -> IO (a, Vault, (EvalPW, BuildW))) -> EvalP a
forall a b. (a -> b) -> a -> b
$ \BuildR
r2 Vault
s -> do
    (a
a,BuildW
w2) <- Build a -> BuildR -> IO (a, BuildW)
forall (m :: * -> *) w r a.
(MonadIO m, Monoid w) =>
ReaderWriterIOT r w m a -> r -> m (a, w)
RW.runReaderWriterIOT Build a
m BuildR
r2
    (a, Vault, (EvalPW, BuildW)) -> IO (a, Vault, (EvalPW, BuildW))
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,Vault
s,(EvalPW
forall a. Monoid a => a
mempty,BuildW
w2))

askTime :: EvalP Time
askTime :: EvalP Time
askTime = BuildR -> Time
forall a b. (a, b) -> a
fst (BuildR -> Time)
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO BuildR -> EvalP Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWSIOT BuildR (EvalPW, BuildW) Vault IO BuildR
forall (m :: * -> *) r w s. Monad m => RWSIOT r w s m r
RWS.ask

readPulseP :: Pulse a -> EvalP (Maybe a)
readPulseP :: Pulse a -> EvalP (Maybe a)
readPulseP Pulse a
p = do
    Pulse{Level
String
[Weak SomeNode]
Key (Maybe a)
EvalP (Maybe a)
Time
_nameP :: String
_levelP :: Level
_parentsP :: [Weak SomeNode]
_childrenP :: [Weak SomeNode]
_evalP :: EvalP (Maybe a)
_seenP :: Time
_keyP :: Key (Maybe a)
_nameP :: forall a. Pulse' a -> String
_levelP :: forall a. Pulse' a -> Level
_parentsP :: forall a. Pulse' a -> [Weak SomeNode]
_childrenP :: forall a. Pulse' a -> [Weak SomeNode]
_evalP :: forall a. Pulse' a -> EvalP (Maybe a)
_seenP :: forall a. Pulse' a -> Time
_keyP :: forall a. Pulse' a -> Key (Maybe a)
..} <- Pulse a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Pulse' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Pulse a
p
    Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a)
-> (Vault -> Maybe (Maybe a)) -> Vault -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key (Maybe a) -> Vault -> Maybe (Maybe a)
forall a. Key a -> Vault -> Maybe a
Lazy.lookup Key (Maybe a)
_keyP (Vault -> Maybe a)
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO Vault -> EvalP (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWSIOT BuildR (EvalPW, BuildW) Vault IO Vault
forall (m :: * -> *) r w s. MonadIO m => RWSIOT r w s m s
RWS.get

writePulseP :: Lazy.Key (Maybe a) -> Maybe a -> EvalP ()
writePulseP :: Key (Maybe a) -> Maybe a -> EvalP ()
writePulseP Key (Maybe a)
key Maybe a
a = do
    Vault
s <- RWSIOT BuildR (EvalPW, BuildW) Vault IO Vault
forall (m :: * -> *) r w s. MonadIO m => RWSIOT r w s m s
RWS.get
    Vault -> EvalP ()
forall (m :: * -> *) s r w. MonadIO m => s -> RWSIOT r w s m ()
RWS.put (Vault -> EvalP ()) -> Vault -> EvalP ()
forall a b. (a -> b) -> a -> b
$ Key (Maybe a) -> Maybe a -> Vault -> Vault
forall a. Key a -> a -> Vault -> Vault
Lazy.insert Key (Maybe a)
key Maybe a
a Vault
s

readLatchP :: Latch a -> EvalP a
readLatchP :: Latch a -> EvalP a
readLatchP = Build a -> EvalP a
forall a. Build a -> EvalP a
liftBuildP (Build a -> EvalP a) -> (Latch a -> Build a) -> Latch a -> EvalP a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Latch a -> Build a
forall a. Latch a -> Build a
readLatchB

readLatchFutureP :: Latch a -> EvalP (Future a)
readLatchFutureP :: Latch a -> EvalP (Future a)
readLatchFutureP = Future a -> EvalP (Future a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Future a -> EvalP (Future a))
-> (Latch a -> Future a) -> Latch a -> EvalP (Future a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Latch a -> Future a
forall a. Latch a -> IO a
readLatchIO

rememberLatchUpdate :: IO () -> EvalP ()
rememberLatchUpdate :: IO () -> EvalP ()
rememberLatchUpdate IO ()
x = (EvalPW, BuildW) -> EvalP ()
forall (m :: * -> *) w r s.
(MonadIO m, Monoid w) =>
w -> RWSIOT r w s m ()
RWS.tell ((IO () -> Action
Action IO ()
x,[(Ref Output', EvalO)]
forall a. Monoid a => a
mempty),BuildW
forall a. Monoid a => a
mempty)

rememberOutput :: (Output, EvalO) -> EvalP ()
rememberOutput :: (Ref Output', EvalO) -> EvalP ()
rememberOutput (Ref Output', EvalO)
x = (EvalPW, BuildW) -> EvalP ()
forall (m :: * -> *) w r s.
(MonadIO m, Monoid w) =>
w -> RWSIOT r w s m ()
RWS.tell ((Action
forall a. Monoid a => a
mempty,[(Ref Output', EvalO)
x]),BuildW
forall a. Monoid a => a
mempty)

-- worker wrapper to break sharing and support better inlining
unwrapEvalP :: RWS.Tuple r w s -> RWS.RWSIOT r w s m a -> m a
unwrapEvalP :: Tuple r w s -> RWSIOT r w s m a -> m a
unwrapEvalP Tuple r w s
r RWSIOT r w s m a
m = RWSIOT r w s m a -> Tuple r w s -> m a
forall r w s (m :: * -> *) a.
RWSIOT r w s m a -> Tuple r w s -> m a
RWS.run RWSIOT r w s m a
m Tuple r w s
r

wrapEvalP :: (RWS.Tuple r w s -> m a) -> RWS.RWSIOT r w s m a
wrapEvalP :: (Tuple r w s -> m a) -> RWSIOT r w s m a
wrapEvalP Tuple r w s -> m a
m = (Tuple r w s -> m a) -> RWSIOT r w s m a
forall r w s (m :: * -> *) a.
(Tuple r w s -> m a) -> RWSIOT r w s m a
RWS.R Tuple r w s -> m a
m