-- |
-- 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,

      -- * Testing wires
      testWire,
      testWireStr,

      -- * Low level
      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


-- | 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.
    }


-- | Start a wire session.

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


-- | Clean up a wire session.

sessionStop :: Session m a b -> IO ()
sessionStop sess =
    readIORef (sessStateRef sess) >>= cleanupWireState


-- | 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


-- | Interface to 'testWireStr' accepting all 'Show' instances as the
-- output type.

testWire ::
    forall a b m. (MonadControlIO m, Show b)
    => Int         -- ^ Show output once each this number of frames.
    -> m a         -- ^ Input generator.
    -> Wire m a b  -- ^ Your wire.
    -> m ()
testWire fpp getInput w' = testWireStr fpp getInput (w' >>> arr show)


-- | This function provides a convenient way to test wires.  It wraps a
-- default loop around your wire, which just displays the output on your
-- stdout in a single line (it uses an ANSI escape sequence to clear the
-- line).  It uses real time.

testWireStr ::
    forall a m. MonadControlIO m
    => Int              -- ^ Show output once each this number of frames.
    -> m a              -- ^ Input generator.
    -> Wire m a String  -- ^ Wire to evolve.
    -> 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


-- | 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, MonadIO sm)
    => Wire sm a b              -- ^ Initial wire of the session.
    -> (Session sm a b -> m c)  -- ^ Continuation, which receives the
                                -- session data.
    -> m c                      -- ^ Continuation's result.
withWire w k = do
    sess <- liftIO (sessionStart w)
    k sess `finally` liftIO (sessionStop sess)