{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}

module System.TimeManager.Internal where

import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)
import Data.IORef (IORef, readIORef)
import Data.Word (Word64)

#if defined(mingw32_HOST_OS)
import qualified System.TimeManager.Windows as EV
#else
import qualified GHC.Event as EV
#endif

----------------------------------------------------------------

-- | A timeout manager
newtype Manager = Manager Int

isNoManager :: Manager -> Bool
isNoManager :: Manager -> Bool
isNoManager (Manager Int
0) = Bool
True
isNoManager Manager
_ = Bool
False

----------------------------------------------------------------

-- | An action (callback) to be performed on timeout.
type TimeoutAction = IO ()

-- | A handle used by a timeout manager.
data Handle = Handle
    { Handle -> Int
handleTimeout :: Int
    , Handle -> TimeoutAction
handleAction :: TimeoutAction
    , Handle -> TimerManager
handleTimerManager :: ~TimerManager
    -- ^ The system timer manager the timeout key was registered with.
    --   Cached so that per-request operations don't re-fetch it.
    , Handle -> Lock
handleLock :: Lock
    -- ^ Used by 'resume', 'pause' and 'cancel' to determine race conditions.
    --
    -- /We intentionally do not use an @MVar HandleState@ for performance reasons./
    -- /The lock only has to be grabbed to avoid race conditions./
    , Handle -> IORef HandleState
handleState :: ~(IORef HandleState)
    -- ^ The current state. Used to decide whether a timeout is still going,
    -- paused, or completely terminated.
    --
    -- /We intentionally do not use an @MVar HandleState@ for performance reasons./
    , Handle -> IORef Word64
handleLastRenewed :: ~(IORef Word64)
    -- ^ Monotonic time (in nanoseconds) when the timeout was last
    --   registered or updated.
    , Handle -> Word64
handleMinRenewGap :: Word64
    -- ^ 'tickle' is a no-op unless at least this many nanoseconds have
    --   passed since the last renewal.
    }

-- | Makes sure the function is only run when there's a key to act on.
withTimeoutKey :: Handle -> (EV.TimeoutKey -> IO ()) -> IO ()
withTimeoutKey :: Handle -> (TimeoutKey -> TimeoutAction) -> TimeoutAction
withTimeoutKey Handle
h TimeoutKey -> TimeoutAction
keyF = do
    HandleState
st <- IORef HandleState -> IO HandleState
forall a. IORef a -> IO a
readIORef (IORef HandleState -> IO HandleState)
-> IORef HandleState -> IO HandleState
forall a b. (a -> b) -> a -> b
$ Handle -> IORef HandleState
handleState Handle
h
    case HandleState
st of
        Paused TimeoutKey
key -> TimeoutKey -> TimeoutAction
keyF TimeoutKey
key
        Active TimeoutKey
key -> TimeoutKey -> TimeoutAction
keyF TimeoutKey
key
        HandleState
_ -> () -> TimeoutAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Makes sure the function is only run when the state is 'Active'.
withActiveTimeoutKey :: Handle -> (EV.TimeoutKey -> IO ()) -> IO ()
withActiveTimeoutKey :: Handle -> (TimeoutKey -> TimeoutAction) -> TimeoutAction
withActiveTimeoutKey Handle
h TimeoutKey -> TimeoutAction
keyF = do
    HandleState
st <- IORef HandleState -> IO HandleState
forall a. IORef a -> IO a
readIORef (IORef HandleState -> IO HandleState)
-> IORef HandleState -> IO HandleState
forall a b. (a -> b) -> a -> b
$ Handle -> IORef HandleState
handleState Handle
h
    case HandleState
st of
        Active TimeoutKey
key -> TimeoutKey -> TimeoutAction
keyF TimeoutKey
key
        HandleState
_ -> () -> TimeoutAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Used to avoid race conditions in situations when the state has to be changed.
type Lock = MVar ()

newLock :: IO Lock
newLock :: IO Lock
newLock = () -> IO Lock
forall a. a -> IO (MVar a)
newMVar ()

withLock :: Lock -> IO a -> IO a
withLock :: forall a. Lock -> IO a -> IO a
withLock Lock
lock IO a
action =
    -- Not sure whether this should be 'modifyMVarMasked' or not.
    Lock -> (() -> IO ((), a)) -> IO a
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar Lock
lock ((() -> IO ((), a)) -> IO a) -> (() -> IO ((), a)) -> IO a
forall a b. (a -> b) -> a -> b
$ \()
l -> do
        a
a <- IO a
action
        ((), a) -> IO ((), a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (()
l, a
a)

-- | Tracking the state of a handle.
data HandleState
    = -- Timeout is primed to run
      Active EV.TimeoutKey
    | -- Timeout is paused, but still running
      -- ('resume' will set it back to 'Active' and 'tickle')
      Paused EV.TimeoutKey
    | -- Action ran, but timeout was paused, so it is resumable
      -- ('resume' will reregister the action)
      Stopped
    | -- Action was cancelled or run. 'register' is needed to start a new timeout.
      Terminated

isEmptyHandle :: Handle -> Bool
isEmptyHandle :: Handle -> Bool
isEmptyHandle Handle{Int
TimeoutAction
Word64
Lock
IORef Word64
IORef HandleState
TimerManager
handleTimeout :: Handle -> Int
handleAction :: Handle -> TimeoutAction
handleTimerManager :: Handle -> TimerManager
handleLock :: Handle -> Lock
handleState :: Handle -> IORef HandleState
handleLastRenewed :: Handle -> IORef Word64
handleMinRenewGap :: Handle -> Word64
handleTimeout :: Int
handleAction :: TimeoutAction
handleTimerManager :: TimerManager
handleLock :: Lock
handleState :: IORef HandleState
handleLastRenewed :: IORef Word64
handleMinRenewGap :: Word64
..} = Int
handleTimeout Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

withNonEmptyHandle :: Handle -> IO () -> IO ()
withNonEmptyHandle :: Handle -> TimeoutAction -> TimeoutAction
withNonEmptyHandle Handle
h TimeoutAction
act =
    if Handle -> Bool
isEmptyHandle Handle
h then () -> TimeoutAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else TimeoutAction
act

#if defined(mingw32_HOST_OS)
type TimerManager = EV.Manager

getTimerManager :: IO TimerManager
getTimerManager = EV.getSystemManager
#else
type TimerManager = EV.TimerManager

getTimerManager :: IO TimerManager
getTimerManager :: IO TimerManager
getTimerManager = IO TimerManager
EV.getSystemTimerManager
#endif