Session.hs

-- |
-- Module:     FRP.NetWire.Session
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Wire sessions.

module FRP.NetWire.Session
    ( -- * Sessions
      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


-- | Reactive sessions with the given time type.

data Session a b =
    Session {
      sessFreeVar  :: TVar Bool,             -- ^ False, if in use.
      sessStateRef :: IORef (WireState IO),  -- ^ State of the last instant.
      sessTimeRef  :: IORef UTCTime,         -- ^ Time of the last instant.
      sessWireRef  :: IORef (Wire IO a b)    -- ^ Wire for the next instant.
    }


-- | Feed the given input value into the reactive system performing the
-- next instant using real time.

stepWire :: a -> Session a b -> IO (Output b)
stepWire x' sess =
    withBlock sess $ do
        t <- getCurrentTime
        stepWireTime' t x' sess


-- | Feed the given input value into the reactive system performing the
-- next instant using the given time delta.

stepWireDelta :: NominalDiffTime -> a -> Session a b -> IO (Output 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


-- | Feed the given input value into the reactive system performing the
-- next instant, which is at the given time.  This function is
-- thread-safe.

stepWireTime :: UTCTime -> a -> Session a b -> IO (Output b)
stepWireTime t' x' sess = withBlock sess (stepWireTime' t' x' sess)


-- | Feed the given input value into the reactive system performing the
-- next instant, which is at the given time.  This function is *not*
-- thread-safe.

stepWireTime' :: UTCTime -> a -> Session a b -> IO (Output b)
stepWireTime' t x' sess = do
    let Session { sessTimeRef = tRef, sessStateRef = wsRef, sessWireRef = wRef
                } = sess

    -- Time delta.
    t' <- readIORef tRef
    let dt = realToFrac (diffUTCTime t t')
    dt `seq` writeIORef tRef t

    -- Wire state.
    ws' <- readIORef wsRef
    let ws = ws' { wsDTime = dt }
    ws `seq` writeIORef wsRef ws

    -- Wire.
    w' <- readIORef wRef
    (x, w) <- toGen w' ws x'
    w `seq` writeIORef wRef w

    return x


-- | Perform an interlocked step function.

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)


-- | Initialize a reactive session and pass it to the given
-- continuation.

withWire :: Wire IO 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)