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