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

import Control.Monad
    ( join, void )
import Control.Monad.IO.Class
    ( liftIO )
import Data.IORef
    ( newIORef, writeIORef, readIORef )
import Data.Maybe
    ( fromMaybe )
import System.IO.Unsafe
    ( unsafePerformIO, unsafeInterleaveIO )

import qualified Control.Monad.Trans.RWSIO          as RWS
import qualified Control.Monad.Trans.ReaderWriterIO as RW
import qualified Data.Vault.Lazy                    as Lazy

import qualified Reactive.Banana.Prim.Low.Ref as Ref
import           Reactive.Banana.Prim.Mid.Types

{-----------------------------------------------------------------------------
    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 (Pulse a) -> ReaderWriterIOT BuildR BuildW IO (Pulse a)
forall a. IO a -> ReaderWriterIOT BuildR BuildW IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Pulse a) -> ReaderWriterIOT BuildR BuildW IO (Pulse a))
-> IO (Pulse a) -> ReaderWriterIOT BuildR BuildW IO (Pulse a)
forall a b. (a -> b) -> a -> b
$ do
    _key <- IO (Key (Maybe a))
forall a. IO (Key a)
Lazy.newKey
    _nodeP <- Ref.new $ P $ PulseD
        { _keyP      = _key
        , _seenP     = agesAgo
        , _evalP     = eval
        , _nameP     = name
        }
    pure $ Pulse{_key,_nodeP}

{-
* 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 (Pulse a) -> ReaderWriterIOT BuildR BuildW IO (Pulse a)
forall a. IO a -> ReaderWriterIOT BuildR BuildW IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Pulse a) -> ReaderWriterIOT BuildR BuildW IO (Pulse a))
-> IO (Pulse a) -> ReaderWriterIOT BuildR BuildW IO (Pulse a)
forall a b. (a -> b) -> a -> b
$ do
    _key <- IO (Key (Maybe a))
forall a. IO (Key a)
Lazy.newKey
    _nodeP <- Ref.new $ P $ PulseD
        { _keyP      = _key
        , _seenP     = agesAgo
        , _evalP     = pure Nothing
        , _nameP     = "neverP"
        }
    pure $ Pulse{_key,_nodeP}

-- | Return a 'Latch' that has a constant value
pureL :: a -> Latch a
pureL :: forall a. 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
$ LatchD a -> IO (Latch a)
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
Ref.new (LatchD a -> IO (Latch a)) -> LatchD a -> IO (Latch a)
forall a b. (a -> b) -> a -> b
$ Latch
    { _seenL :: Time
_seenL  = Time
beginning
    , _valueL :: a
_valueL = a
a
    , _evalL :: EvalL a
_evalL  = a -> EvalL a
forall a. a -> ReaderWriterIOT () Time IO 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 = do
    latch <- IO (Ref (LatchD a))
-> ReaderWriterIOT BuildR BuildW IO (Ref (LatchD a))
forall a. IO a -> ReaderWriterIOT BuildR BuildW IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Ref (LatchD a))
 -> ReaderWriterIOT BuildR BuildW IO (Ref (LatchD a)))
-> IO (Ref (LatchD a))
-> ReaderWriterIOT BuildR BuildW IO (Ref (LatchD a))
forall a b. (a -> b) -> a -> b
$ mdo
        latch <- Ref.new $ Latch
            { _seenL  = beginning
            , _valueL = a
            , _evalL  = do
                Latch {..} <- Ref.read latch
                RW.tell _seenL  -- indicate timestamp
                return _valueL  -- indicate value
            }
        pure latch

    let
        err        = String -> a
forall a. HasCallStack => String -> a
error String
"incorrect Latch write"

        updateOn :: Pulse a -> Build ()
        updateOn Pulse a
p = do
            w  <- IO (Weak (Ref (LatchD a)))
-> ReaderWriterIOT BuildR BuildW IO (Weak (Ref (LatchD a)))
forall a. IO a -> ReaderWriterIOT BuildR BuildW IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Weak (Ref (LatchD a)))
 -> ReaderWriterIOT BuildR BuildW IO (Weak (Ref (LatchD a))))
-> IO (Weak (Ref (LatchD a)))
-> ReaderWriterIOT BuildR BuildW IO (Weak (Ref (LatchD a)))
forall a b. (a -> b) -> a -> b
$ Ref (LatchD a)
-> Ref (LatchD a) -> Maybe (IO ()) -> IO (Weak (Ref (LatchD a)))
forall k v. Ref k -> v -> Maybe (IO ()) -> IO (Weak v)
Ref.mkWeak Ref (LatchD a)
latch Ref (LatchD a)
latch Maybe (IO ())
forall a. Maybe a
Nothing
            lw <- liftIO $ Ref.new $ L $ LatchWriteD
                { _evalLW  = fromMaybe err <$> readPulseP p
                , _latchLW = w
                }
            -- writer is alive only as long as the latch is alive
            _  <- liftIO $ Ref.mkWeak latch lw Nothing
            _nodeP p `addChild` lw

    return (updateOn, 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 (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 <- Ref.new $ Latch
        { _seenL  = agesAgo
        , _valueL = error "Undefined value of a cached latch."
        , _evalL  = do
            Latch{..} <- liftIO $ Ref.read latch
            -- calculate current value (lazy!) with timestamp
            (a,time)  <- RW.listen eval
            liftIO $ if time <= _seenL
                then return _valueL     -- return old value
                else do                 -- update value
                    let _seenL  = Time
time
                    let _valueL = a
a
                    a `seq` Ref.put latch (Latch {..})
                    return a
        }
    return 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
    o <- IO Output -> ReaderWriterIOT BuildR BuildW IO Output
forall a. IO a -> ReaderWriterIOT BuildR BuildW IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Output -> ReaderWriterIOT BuildR BuildW IO Output)
-> IO Output -> ReaderWriterIOT BuildR BuildW IO Output
forall a b. (a -> b) -> a -> b
$ SomeNodeD -> IO Output
forall (m :: * -> *) a. MonadIO m => a -> m (Ref a)
Ref.new (SomeNodeD -> IO Output) -> SomeNodeD -> IO Output
forall a b. (a -> b) -> a -> b
$ OutputD -> SomeNodeD
O (OutputD -> SomeNodeD) -> OutputD -> SomeNodeD
forall a b. (a -> b) -> a -> b
$ Output
        { _evalO :: EvalP EvalO
_evalO = EvalO -> Maybe EvalO -> EvalO
forall a. a -> Maybe a -> a
fromMaybe (IO () -> EvalO
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> EvalO) -> IO () -> EvalO
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (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
        }
    _nodeP p `addChild` o
    RW.tell $ BuildW (mempty, [o], mempty, mempty)

{-----------------------------------------------------------------------------
    Build monad
------------------------------------------------------------------------------}
runBuildIO :: BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output])
runBuildIO :: forall a.
BuildR -> BuildIO a -> IO (a, DependencyChanges, [Output])
runBuildIO BuildR
i BuildIO a
m = do
    (a, BuildW (topologyUpdates, os, liftIOLaters, _)) <- 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
    doit liftIOLaters          -- execute late IOs
    return (a,topologyUpdates,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, BuildW (w1, w2, w3, 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 -> BuildW -> BuildW
forall a. Semigroup a => a -> a -> a
<> (DependencyChanges, [Output], EvalLW, Maybe (Build ())) -> BuildW
BuildW (DependencyChanges
w1,[Output]
w2,EvalLW
w3,Maybe (Build ())
forall a. Monoid a => a
mempty)
        w'' <- case 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildW
w'
        return (a,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
$ (DependencyChanges, [Output], EvalLW, Maybe (Build ())) -> BuildW
BuildW (DependencyChanges
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
    ref <- IO (IORef a) -> ReaderWriterIOT BuildR BuildW IO (IORef a)
forall a. IO a -> ReaderWriterIOT BuildR BuildW IO 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."
    buildLater $ m >>= liftIO . writeIORef ref
    liftIO $ unsafeInterleaveIO $ readIORef 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 = BuildR -> Time
forall a b. (a, b) -> a
fst (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 = BuildR -> Pulse ()
forall a b. (a, b) -> b
snd (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 :: forall a. Latch a -> Build a
readLatchB = IO a -> ReaderWriterIOT BuildR BuildW IO a
forall a. IO a -> ReaderWriterIOT BuildR BuildW IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderWriterIOT BuildR BuildW IO a)
-> (Latch a -> IO a)
-> Latch a
-> ReaderWriterIOT BuildR 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 -> Output
forall a. Pulse a -> Output
_nodeP Pulse parent
parent Output -> Output -> Build ()
`addChild` Pulse child -> Output
forall a. Pulse a -> Output
_nodeP 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 a. IO a -> ReaderWriterIOT BuildR BuildW IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Build ()) -> IO () -> Build ()
forall a b. (a -> b) -> a -> b
$ IO (Weak Output) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak Output) -> IO ()) -> IO (Weak Output) -> IO ()
forall a b. (a -> b) -> a -> b
$
    Output -> Output -> Maybe (IO ()) -> IO (Weak Output)
forall k v. Ref k -> v -> Maybe (IO ()) -> IO (Weak v)
Ref.mkWeak (Pulse child -> Output
forall a. Pulse a -> Output
_nodeP Pulse child
child) (Pulse parent -> Output
forall a. Pulse a -> Output
_nodeP Pulse parent
parent) Maybe (IO ())
forall a. Maybe a
Nothing

addChild :: SomeNode -> SomeNode -> Build ()
addChild :: Output -> Output -> Build ()
addChild Output
parent Output
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
$ (DependencyChanges, [Output], EvalLW, Maybe (Build ())) -> BuildW
BuildW ([Output -> Output -> DependencyChange Output Output
forall parent child.
parent -> child -> DependencyChange parent child
InsertEdge Output
parent Output
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
pulse0 Pulse parent
parent0 =
    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
$ (DependencyChanges, [Output], EvalLW, Maybe (Build ())) -> BuildW
BuildW ([Output -> Output -> DependencyChange Output Output
forall parent child.
child -> parent -> DependencyChange parent child
ChangeParentTo Output
pulse Output
parent], [Output]
forall a. Monoid a => a
mempty, EvalLW
forall a. Monoid a => a
mempty, Maybe (Build ())
forall a. Monoid a => a
mempty)
   where
     pulse :: Output
pulse = Pulse child -> Output
forall a. Pulse a -> Output
_nodeP Pulse child
pulse0
     parent :: Output
parent = Pulse parent -> Output
forall a. Pulse a -> Output
_nodeP Pulse parent
parent0

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
$ (DependencyChanges, [Output], EvalLW, Maybe (Build ())) -> BuildW
BuildW (DependencyChanges
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{..} <- Latch a -> IO (LatchD a)
forall (m :: * -> *) a. MonadIO m => Ref a -> m a
Ref.read Latch a
latch
    liftIO $ fst <$> RW.runReaderWriterIOT _evalL ()

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

{-----------------------------------------------------------------------------
    EvalP monad
------------------------------------------------------------------------------}
runEvalP :: Lazy.Vault -> EvalP a -> Build (a, EvalPW)
runEvalP :: forall a. Vault -> EvalP a -> Build (a, EvalPW)
runEvalP Vault
s1 EvalP a
m = (BuildR -> IO ((a, EvalPW), BuildW))
-> ReaderWriterIOT BuildR BuildW IO (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))
 -> ReaderWriterIOT BuildR BuildW IO (a, EvalPW))
-> (BuildR -> IO ((a, EvalPW), BuildW))
-> ReaderWriterIOT BuildR BuildW IO (a, EvalPW)
forall a b. (a -> b) -> a -> b
$ \BuildR
r2 -> do
    (a,_,(w1,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
    return ((a,w1), w2)

liftBuildP :: Build a -> EvalP a
liftBuildP :: forall a. Build a -> EvalP a
liftBuildP Build a
m = (BuildR -> Vault -> IO (a, Vault, (EvalPW, BuildW)))
-> RWSIOT BuildR (EvalPW, 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 ((BuildR -> Vault -> IO (a, Vault, (EvalPW, BuildW)))
 -> RWSIOT BuildR (EvalPW, BuildW) Vault IO a)
-> (BuildR -> Vault -> IO (a, Vault, (EvalPW, BuildW)))
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO a
forall a b. (a -> b) -> a -> b
$ \BuildR
r2 Vault
s -> do
    (a,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
    return (a,s,(mempty,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 :: forall a. Pulse a -> EvalP (Maybe a)
readPulseP Pulse{Key (Maybe a)
_key :: forall a. Pulse a -> Key (Maybe a)
_key :: Key (Maybe a)
_key} =
    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)
_key (Vault -> Maybe a)
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO Vault
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (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 :: forall a. Key (Maybe a) -> Maybe a -> EvalP ()
writePulseP Key (Maybe a)
key Maybe a
a = do
    s <- RWSIOT BuildR (EvalPW, BuildW) Vault IO Vault
forall (m :: * -> *) r w s. MonadIO m => RWSIOT r w s m s
RWS.get
    RWS.put $ Lazy.insert key a 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 = Future a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Future a)
forall a. a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Future a -> RWSIOT BuildR (EvalPW, BuildW) Vault IO (Future a))
-> (Latch a -> Future a)
-> Latch a
-> RWSIOT BuildR (EvalPW, BuildW) Vault IO (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 () -> 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 = (EvalPW, 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