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

import           Control.Monad                                (join)
import           Control.Monad.IO.Class
import qualified Control.Monad.Trans.RWSIO          as RWS
import qualified Control.Monad.Trans.ReaderWriterIO as RW
import           Data.Functor
import           Data.IORef
import qualified Data.Vault.Lazy                    as Lazy
import           System.IO.Unsafe

import qualified Reactive.Banana.Prim.Low.Dependencies as Deps
import           Reactive.Banana.Prim.Low.Types
import           Reactive.Banana.Prim.Low.Util
import Data.Maybe (fromMaybe)

{-----------------------------------------------------------------------------
    Build primitive pulses and latches
------------------------------------------------------------------------------}
-- | Make 'Pulse' from evaluation function
newPulse :: String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse :: forall a. String -> EvalP (Maybe a) -> Build (Pulse a)
newPulse String
name EvalP (Maybe a)
eval = IO (Ref (Pulse' a))
-> ReaderWriterIOT (Time, Pulse ()) BuildW IO (Ref (Pulse' a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ref (Pulse' a))
 -> ReaderWriterIOT (Time, Pulse ()) BuildW IO (Ref (Pulse' a)))
-> IO (Ref (Pulse' a))
-> ReaderWriterIOT (Time, Pulse ()) BuildW IO (Ref (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 (Ref (Pulse' a))
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Pulse' a -> IO (Ref (Pulse' a)))
-> Pulse' a -> IO (Ref (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 :: forall a. Build (Pulse a)
neverP = IO (Ref (Pulse' a))
-> ReaderWriterIOT (Time, Pulse ()) BuildW IO (Ref (Pulse' a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ref (Pulse' a))
 -> ReaderWriterIOT (Time, Pulse ()) BuildW IO (Ref (Pulse' a)))
-> IO (Ref (Pulse' a))
-> ReaderWriterIOT (Time, Pulse ()) BuildW IO (Ref (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 (Ref (Pulse' a))
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Pulse' a -> IO (Ref (Pulse' a)))
-> Pulse' a -> IO (Ref (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 :: forall a. a -> Latch a
pureL a
a = IO (Ref (Latch' a)) -> Ref (Latch' a)
forall a. IO a -> a
unsafePerformIO (IO (Ref (Latch' a)) -> Ref (Latch' a))
-> IO (Ref (Latch' a)) -> Ref (Latch' a)
forall a b. (a -> b) -> a -> b
$ Latch' a -> IO (Ref (Latch' a))
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Latch' a -> IO (Ref (Latch' a)))
-> Latch' a -> IO (Ref (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 :: forall a. a -> Build (Pulse a -> Build (), Latch a)
newLatch a
a = mdo
    Latch a
latch <- IO (Latch a)
-> ReaderWriterIOT (Time, Pulse ()) BuildW IO (Latch a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Latch a)
 -> ReaderWriterIOT (Time, Pulse ()) BuildW IO (Latch a))
-> IO (Latch a)
-> ReaderWriterIOT (Time, Pulse ()) 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 (Time, Pulse ()) BuildW IO (Weak (Latch a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Weak (Latch a))
 -> ReaderWriterIOT (Time, Pulse ()) BuildW IO (Weak (Latch a)))
-> IO (Weak (Latch a))
-> ReaderWriterIOT (Time, Pulse ()) 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 (Time, Pulse ()) BuildW IO (Ref LatchWrite')
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ref LatchWrite')
 -> ReaderWriterIOT (Time, Pulse ()) BuildW IO (Ref LatchWrite'))
-> IO (Ref LatchWrite')
-> ReaderWriterIOT (Time, Pulse ()) 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 -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
forall {a}. a
err (Maybe a -> a)
-> RWSIOT
     (Time, Pulse ())
     ((EvalLW, [(Output, EvalO)]), BuildW)
     Vault
     IO
     (Maybe a)
-> EvalP a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pulse a
-> RWSIOT
     (Time, Pulse ())
     ((EvalLW, [(Output, EvalO)]), 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
     (Time, Pulse ()) BuildW IO (Weak (Ref LatchWrite'))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Weak (Ref LatchWrite'))
 -> ReaderWriterIOT
      (Time, Pulse ()) BuildW IO (Weak (Ref LatchWrite')))
-> IO (Weak (Ref LatchWrite'))
-> ReaderWriterIOT
     (Time, Pulse ()) 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 :: forall a. EvalL a -> Latch a
cachedLatch EvalL a
eval = IO (Ref (Latch' a)) -> Ref (Latch' a)
forall a. IO a -> a
unsafePerformIO (IO (Ref (Latch' a)) -> Ref (Latch' a))
-> IO (Ref (Latch' a)) -> Ref (Latch' a)
forall a b. (a -> b) -> a -> b
$ mdo
    Ref (Latch' a)
latch <- Latch' a -> IO (Ref (Latch' a))
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Latch' a -> IO (Ref (Latch' a)))
-> Latch' a -> IO (Ref (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
$ Ref (Latch' a) -> IO (Latch' a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
readRef Ref (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` Ref (Latch' a) -> Latch' a -> IO ()
forall (m :: * -> *) a. MonadIO m => Ref a -> a -> m ()
put Ref (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
        }
    Ref (Latch' a) -> IO (Ref (Latch' a))
forall (m :: * -> *) a. Monad m => a -> m a
return Ref (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
    Output
o <- IO Output -> ReaderWriterIOT (Time, Pulse ()) BuildW IO Output
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Output -> ReaderWriterIOT (Time, Pulse ()) BuildW IO Output)
-> IO Output -> ReaderWriterIOT (Time, Pulse ()) BuildW IO Output
forall a b. (a -> b) -> a -> b
$ Output' -> IO Output
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
newRef (Output' -> IO Output) -> Output' -> IO Output
forall a b. (a -> b) -> a -> b
$ Output :: EvalP EvalO -> Output'
Output
        { _evalO :: EvalP EvalO
_evalO = EvalO -> Maybe EvalO -> EvalO
forall a. a -> Maybe a -> a
fromMaybe (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") (Maybe EvalO -> EvalO)
-> RWSIOT
     (Time, Pulse ())
     ((EvalLW, [(Output, EvalO)]), BuildW)
     Vault
     IO
     (Maybe EvalO)
-> EvalP EvalO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pulse EvalO
-> RWSIOT
     (Time, Pulse ())
     ((EvalLW, [(Output, EvalO)]), 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` Output -> SomeNode
O 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, [Output], EvalLW, Maybe (Build ())) -> BuildW
BuildW (DependencyBuilder
forall a. Monoid a => a
mempty, [Output
o], EvalLW
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 :: forall a. (Time, Pulse ()) -> BuildIO a -> IO (a, EvalLW, [Output])
runBuildIO (Time, Pulse ())
i BuildIO a
m = do
        (a
a, BuildW (DependencyBuilder
topologyUpdates, [Output]
os, EvalLW
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
        EvalLW -> IO ()
doit EvalLW
liftIOLaters          -- execute late IOs
        (a, EvalLW, [Output]) -> IO (a, EvalLW, [Output])
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,IO () -> EvalLW
Action (IO () -> EvalLW) -> IO () -> EvalLW
forall a b. (a -> b) -> a -> b
$ DependencyBuilder -> IO ()
Deps.buildDependencies DependencyBuilder
topologyUpdates,[Output]
os)
    where
    -- Recursively execute the  buildLater  calls.
    unfold :: BuildW -> BuildIO a -> IO (a, BuildW)
    unfold :: forall a. BuildW -> BuildIO a -> IO (a, BuildW)
unfold BuildW
w BuildIO a
m = do
        (a
a, BuildW (DependencyBuilder
w1, [Output]
w2, EvalLW
w3, Maybe (Build ())
later)) <- BuildIO a -> (Time, Pulse ()) -> 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 (Time, Pulse ())
i
        let w' :: BuildW
w' = BuildW
w BuildW -> BuildW -> BuildW
forall a. Semigroup a => a -> a -> a
<> (DependencyBuilder, [Output], EvalLW, Maybe (Build ())) -> BuildW
BuildW (DependencyBuilder
w1,[Output]
w2,EvalLW
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, [Output], EvalLW, Maybe (Build ())) -> BuildW
BuildW (DependencyBuilder
forall a. Monoid a => a
mempty, [Output]
forall a. Monoid a => a
mempty, EvalLW
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 :: forall a. Build a -> Build a
buildLaterReadNow Build a
m = do
    IORef a
ref <- IO (IORef a)
-> ReaderWriterIOT (Time, Pulse ()) BuildW IO (IORef a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef a)
 -> ReaderWriterIOT (Time, Pulse ()) BuildW IO (IORef a))
-> IO (IORef a)
-> ReaderWriterIOT (Time, Pulse ()) 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 :: forall a. Build a -> Build a
liftBuild = Build a -> Build a
forall a. a -> a
id

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

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

readLatchB :: Latch a -> Build a
readLatchB :: forall a. Latch a -> Build a
readLatchB = IO a -> ReaderWriterIOT (Time, Pulse ()) BuildW IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderWriterIOT (Time, Pulse ()) BuildW IO a)
-> (Latch a -> IO a)
-> Latch a
-> ReaderWriterIOT (Time, Pulse ()) BuildW IO 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 :: forall child parent. 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 :: forall child parent. 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
$ IO (Weak (Pulse parent)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak (Pulse parent)) -> IO ())
-> IO (Weak (Pulse parent)) -> IO ()
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

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, [Output], EvalLW, Maybe (Build ())) -> BuildW
BuildW (SomeNode -> SomeNode -> DependencyBuilder
Deps.addChild SomeNode
parent SomeNode
child, [Output]
forall a. Monoid a => a
mempty, EvalLW
forall a. Monoid a => a
mempty, Maybe (Build ())
forall a. Monoid a => a
mempty)

changeParent :: Pulse child -> Pulse parent -> Build ()
changeParent :: forall child parent. 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, [Output], EvalLW, 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, [Output]
forall a. Monoid a => a
mempty, EvalLW
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, [Output], EvalLW, Maybe (Build ())) -> BuildW
BuildW (DependencyBuilder
forall a. Monoid a => a
mempty, [Output]
forall a. Monoid a => a
mempty, IO () -> EvalLW
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 :: forall a. 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 :: forall a. 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 :: forall a.
Vault -> EvalP a -> Build (a, (EvalLW, [(Output, EvalO)]))
runEvalP Vault
s1 EvalP a
m = ((Time, Pulse ()) -> IO ((a, (EvalLW, [(Output, EvalO)])), BuildW))
-> ReaderWriterIOT
     (Time, Pulse ()) BuildW IO (a, (EvalLW, [(Output, EvalO)]))
forall (m :: * -> *) w r a.
(MonadIO m, Monoid w) =>
(r -> IO (a, w)) -> ReaderWriterIOT r w m a
RW.readerWriterIOT (((Time, Pulse ())
  -> IO ((a, (EvalLW, [(Output, EvalO)])), BuildW))
 -> ReaderWriterIOT
      (Time, Pulse ()) BuildW IO (a, (EvalLW, [(Output, EvalO)])))
-> ((Time, Pulse ())
    -> IO ((a, (EvalLW, [(Output, EvalO)])), BuildW))
-> ReaderWriterIOT
     (Time, Pulse ()) BuildW IO (a, (EvalLW, [(Output, EvalO)]))
forall a b. (a -> b) -> a -> b
$ \(Time, Pulse ())
r2 -> do
    (a
a,Vault
_,((EvalLW, [(Output, EvalO)])
w1,BuildW
w2)) <- EvalP a
-> (Time, Pulse ())
-> Vault
-> IO (a, Vault, ((EvalLW, [(Output, EvalO)]), 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 (Time, Pulse ())
r2 Vault
s1
    ((a, (EvalLW, [(Output, EvalO)])), BuildW)
-> IO ((a, (EvalLW, [(Output, EvalO)])), BuildW)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
a,(EvalLW, [(Output, EvalO)])
w1), BuildW
w2)

liftBuildP :: Build a -> EvalP a
liftBuildP :: forall a. Build a -> EvalP a
liftBuildP Build a
m = ((Time, Pulse ())
 -> Vault -> IO (a, Vault, ((EvalLW, [(Output, EvalO)]), BuildW)))
-> RWSIOT
     (Time, Pulse ()) ((EvalLW, [(Output, EvalO)]), BuildW) Vault IO 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 (((Time, Pulse ())
  -> Vault -> IO (a, Vault, ((EvalLW, [(Output, EvalO)]), BuildW)))
 -> RWSIOT
      (Time, Pulse ()) ((EvalLW, [(Output, EvalO)]), BuildW) Vault IO a)
-> ((Time, Pulse ())
    -> Vault -> IO (a, Vault, ((EvalLW, [(Output, EvalO)]), BuildW)))
-> RWSIOT
     (Time, Pulse ()) ((EvalLW, [(Output, EvalO)]), BuildW) Vault IO a
forall a b. (a -> b) -> a -> b
$ \(Time, Pulse ())
r2 Vault
s -> do
    (a
a,BuildW
w2) <- Build a -> (Time, Pulse ()) -> 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 (Time, Pulse ())
r2
    (a, Vault, ((EvalLW, [(Output, EvalO)]), BuildW))
-> IO (a, Vault, ((EvalLW, [(Output, EvalO)]), BuildW))
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a,Vault
s,((EvalLW, [(Output, EvalO)])
forall a. Monoid a => a
mempty,BuildW
w2))

askTime :: EvalP Time
askTime :: EvalP Time
askTime = (Time, Pulse ()) -> Time
forall a b. (a, b) -> a
fst ((Time, Pulse ()) -> Time)
-> RWSIOT
     (Time, Pulse ())
     ((EvalLW, [(Output, EvalO)]), BuildW)
     Vault
     IO
     (Time, Pulse ())
-> EvalP Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWSIOT
  (Time, Pulse ())
  ((EvalLW, [(Output, EvalO)]), BuildW)
  Vault
  IO
  (Time, Pulse ())
forall (m :: * -> *) r w s. Monad m => RWSIOT r w s m r
RWS.ask

readPulseP :: Pulse a -> EvalP (Maybe a)
readPulseP :: forall a. 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
     (Time, Pulse ())
     ((EvalLW, [(Output, EvalO)]), 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
     (Time, Pulse ())
     ((EvalLW, [(Output, EvalO)]), BuildW)
     Vault
     IO
     Vault
-> EvalP (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWSIOT
  (Time, Pulse ())
  ((EvalLW, [(Output, EvalO)]), 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 :: forall a. Key (Maybe a) -> Maybe a -> EvalP ()
writePulseP Key (Maybe a)
key Maybe a
a = do
    Vault
s <- RWSIOT
  (Time, Pulse ())
  ((EvalLW, [(Output, EvalO)]), 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 :: forall a. 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 :: forall a. Latch a -> EvalP (Future a)
readLatchFutureP = IO a
-> RWSIOT
     (Time, Pulse ())
     ((EvalLW, [(Output, EvalO)]), BuildW)
     Vault
     IO
     (IO a)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO a
 -> RWSIOT
      (Time, Pulse ())
      ((EvalLW, [(Output, EvalO)]), BuildW)
      Vault
      IO
      (IO a))
-> (Latch a -> IO a)
-> Latch a
-> RWSIOT
     (Time, Pulse ())
     ((EvalLW, [(Output, EvalO)]), BuildW)
     Vault
     IO
     (IO a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Latch a -> IO a
forall a. Latch a -> IO a
readLatchIO

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

rememberOutput :: (Output, EvalO) -> EvalP ()
rememberOutput :: (Output, EvalO) -> EvalP ()
rememberOutput (Output, EvalO)
x = ((EvalLW, [(Output, EvalO)]), BuildW) -> EvalP ()
forall (m :: * -> *) w r s.
(MonadIO m, Monoid w) =>
w -> RWSIOT r w s m ()
RWS.tell ((EvalLW
forall a. Monoid a => a
mempty,[(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 :: forall r w s (m :: * -> *) a.
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 :: forall r w s (m :: * -> *) a.
(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