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.Control
import Control.Monad.IO.Class
import Control.Monad.IO.Control
import Data.IORef
import Data.Time.Clock
import FRP.NetWire.Wire


-- | Reactive sessions with the given input and output types over the
-- given monad.  The monad must have a 'MonadControlIO' instance to be
-- usable with the stepping functions.

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


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

stepWire ::
    MonadControlIO m
    => a              -- ^ Input value.
    -> Session m a b  -- ^ Session to step.
    -> m (Output b)   -- ^ System's output.
stepWire x' sess =
    withBlock sess $ do
        t <- liftIO getCurrentTime
        stepWireTime' t x' sess


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

stepWireDelta ::
    MonadControlIO m
    => NominalDiffTime  -- ^ Time delta.
    -> a                -- ^ Input value.
    -> Session m a b    -- ^ Session to step.
    -> m (Output b)     -- ^ System's output.
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


-- | 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 ::
    MonadControlIO m
    => UTCTime        -- ^ Absolute time of the instant to perform.
    -> a              -- ^ Input value.
    -> Session m a b  -- ^ Session to step.
    -> m (Output b)   -- ^ System's output.
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' ::
    MonadIO m
    => UTCTime        -- ^ Absolute time of the instant to perform.
    -> a              -- ^ Input value.
    -> Session m a b  -- ^ Session to step.
    -> m (Output b)   -- ^ System's output.
stepWireTime' t x' sess = do
    let Session { sessTimeRef = tRef, sessStateRef = wsRef, sessWireRef = wRef
                } = sess

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

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

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

    return x


-- | Perform an interlocked step function.

withBlock ::
    MonadControlIO m
    => Session m a b  -- ^ The session to mark as locked for the
                      -- duration of the given computation.
    -> m c            -- ^ Computation to perform.
    -> m c            -- ^ Result.
withBlock (Session { sessFreeVar = freeVar }) c = do
    liftIO (atomically $ readTVar freeVar >>= check >> writeTVar freeVar False)
    c `finally` liftIO (atomically $ writeTVar freeVar True)


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

withWire ::
    MonadControlIO m
    => Wire m a b              -- ^ Initial wire of the session.
    -> (Session m a b -> m c)  -- ^ Continuation, which receives the
                               -- session data.
    -> m c                     -- ^ Continuation's result.
withWire w k = 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

    seq sess (k sess)
        `finally`
        (liftIO $ readIORef (sessStateRef sess) >>= cleanupWireState)