module FRP.NetWire.Session
(
Session(..),
stepWire,
stepWireDelta,
stepWireTime,
stepWireTime',
withWire,
testWire,
testWireStr,
sessionStart,
sessionStop
)
where
import Control.Applicative
import Control.Arrow
import Control.Concurrent.STM
import Control.Exception.Control
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.IO.Control
import Data.IORef
import Data.Time.Clock
import FRP.NetWire.Wire
import System.IO
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 -> IO (Session m a b)
sessionStart w = do
t@(UTCTime td tt) <- getCurrentTime
ws <- 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 :: Session m a b -> IO ()
sessionStop sess =
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
testWire ::
forall a b m. (MonadControlIO m, Show b)
=> Int
-> m a
-> Wire m a b
-> m ()
testWire fpp getInput w' = testWireStr fpp getInput (w' >>> arr show)
testWireStr ::
forall a m. MonadControlIO m
=> Int
-> m a
-> Wire m a String
-> m ()
testWireStr fpp getInput w' =
withWire w' (loop 0)
where
loop :: Int -> Session m a String -> m ()
loop n' sess = do
let n = let n = succ n' in if n >= fpp then 0 else n
x' <- getInput
mx <- stepWire x' sess
when (n' == 0) . liftIO $ do
putStr "\r\027[K"
case mx of
Left ex -> putStr (show ex)
Right str -> putStr str
hFlush stdout
n `seq` loop n sess
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, MonadIO sm)
=> Wire sm a b
-> (Session sm a b -> m c)
-> m c
withWire w k = do
sess <- liftIO (sessionStart w)
k sess `finally` liftIO (sessionStop sess)