module FRP.NetWire.Session
(
Session(..),
stepWire,
stepWireDelta,
stepWireTime,
stepWireTime',
withWire,
sessionStart,
sessionStop
)
where
import Control.Applicative
import Control.Concurrent.STM
import Control.Exception.Control
import Control.Monad.IO.Class
import Control.Monad.IO.Control
import Data.IORef
import Data.Time.Clock
import FRP.NetWire.Wire
data Session m a b =
Session {
sessFreeVar :: TVar Bool,
sessStateRef :: IORef (WireState m),
sessTimeRef :: IORef UTCTime,
sessWireRef :: IORef (Wire m a b)
}
sessionStart :: MonadIO m => Wire m a b -> m (Session m a b)
sessionStart w = do
t@(UTCTime td tt) <- liftIO getCurrentTime
ws <- liftIO initWireState
sess <-
td `seq` tt `seq` t `seq` ws `seq`
liftIO $
Session
<$> newTVarIO True
<*> newIORef ws
<*> newIORef t
<*> newIORef w
sess `seq` return sess
sessionStop :: MonadIO m => Session m a b -> m ()
sessionStop sess =
liftIO $ readIORef (sessStateRef sess) >>= cleanupWireState
stepWire ::
MonadControlIO m
=> a
-> Session m a b
-> m (Output b)
stepWire x' sess =
withBlock sess $ do
t <- liftIO getCurrentTime
stepWireTime' t x' sess
stepWireDelta ::
MonadControlIO m
=> NominalDiffTime
-> a
-> Session m a b
-> m (Output b)
stepWireDelta dt x' sess =
withBlock sess $ do
t' <- liftIO (readIORef $ sessTimeRef sess)
let t@(UTCTime td tt) = addUTCTime dt t'
td `seq` tt `seq` t `seq` stepWireTime' t x' sess
stepWireTime ::
MonadControlIO m
=> UTCTime
-> a
-> Session m a b
-> m (Output b)
stepWireTime t' x' sess = withBlock sess (stepWireTime' t' x' sess)
stepWireTime' ::
MonadIO m
=> UTCTime
-> a
-> Session m a b
-> m (Output b)
stepWireTime' t x' sess = do
let Session { sessTimeRef = tRef, sessStateRef = wsRef, sessWireRef = wRef
} = sess
t' <- liftIO (readIORef tRef)
let dt = realToFrac (diffUTCTime t t')
dt `seq` liftIO (writeIORef tRef t)
ws' <- liftIO (readIORef wsRef)
let ws = ws' { wsDTime = dt }
ws `seq` liftIO (writeIORef wsRef ws)
w' <- liftIO (readIORef wRef)
(x, w) <- toGen w' ws x'
w `seq` liftIO (writeIORef wRef w)
return x
withBlock ::
MonadControlIO m
=> Session m a b
-> m c
-> m c
withBlock (Session { sessFreeVar = freeVar }) c = do
liftIO (atomically $ readTVar freeVar >>= check >> writeTVar freeVar False)
c `finally` liftIO (atomically $ writeTVar freeVar True)
withWire ::
MonadControlIO m
=> Wire m a b
-> (Session m a b -> m c)
-> m c
withWire w k = do
sess <- sessionStart w
k sess `finally` sessionStop sess