{-# LANGUAGE CPP                #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TypeFamilies       #-}

#if  defined(__GLASGOW_HASKELL__) && \
    !defined(mingw32_HOST_OS) && \
    !defined(__GHCJS__) && \
    !defined(js_HOST_ARCH) && \
    !defined(wasm32_HOST_ARCH)
#define GHC_TIMERS_API
#endif

-- | A non-standard interface for timer api.
--
-- This module also provides a polyfill which allows to use timer api also on
-- non-threaded RTS regardless of the architecture \/ OS.  Currently we support
-- `*nix`, `macOS`, `Windows` (and, unofficially `GHCJS`).
--
-- We use it to provide @'Control.Monad.Class.MonadTimer.MonadTimer' 'IO'@
-- instance and to implement a cancellable timers, see
-- 'Control.Monad.Class.MonadTimer.SI.registerDelayCancellable'.
--
-- You can expect we will deprecate it at some point (e.g. once GHC gets
-- a better support for timers especially across different execution
-- environments).
--
module Control.Monad.Class.MonadTimer.NonStandard
  ( TimeoutState (..)
  , newTimeout
  , readTimeout
  , cancelTimeout
  , awaitTimeout
  , NewTimeout
  , ReadTimeout
  , CancelTimeout
  , AwaitTimeout
  ) where

import qualified Control.Concurrent.STM as STM
#ifndef GHC_TIMERS_API
import           Control.Monad (when)
#endif
import           Control.Monad.Class.MonadSTM

#ifdef GHC_TIMERS_API
import qualified GHC.Event as GHC (TimeoutKey, getSystemTimerManager,
                     registerTimeout, unregisterTimeout)
#else
import qualified GHC.Conc.IO as GHC (registerDelay)
#endif


-- | State of a timeout: pending, fired or cancelled.
--
data TimeoutState = TimeoutPending | TimeoutFired | TimeoutCancelled
  deriving (TimeoutState -> TimeoutState -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeoutState -> TimeoutState -> Bool
$c/= :: TimeoutState -> TimeoutState -> Bool
== :: TimeoutState -> TimeoutState -> Bool
$c== :: TimeoutState -> TimeoutState -> Bool
Eq, Eq TimeoutState
TimeoutState -> TimeoutState -> Bool
TimeoutState -> TimeoutState -> Ordering
TimeoutState -> TimeoutState -> TimeoutState
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TimeoutState -> TimeoutState -> TimeoutState
$cmin :: TimeoutState -> TimeoutState -> TimeoutState
max :: TimeoutState -> TimeoutState -> TimeoutState
$cmax :: TimeoutState -> TimeoutState -> TimeoutState
>= :: TimeoutState -> TimeoutState -> Bool
$c>= :: TimeoutState -> TimeoutState -> Bool
> :: TimeoutState -> TimeoutState -> Bool
$c> :: TimeoutState -> TimeoutState -> Bool
<= :: TimeoutState -> TimeoutState -> Bool
$c<= :: TimeoutState -> TimeoutState -> Bool
< :: TimeoutState -> TimeoutState -> Bool
$c< :: TimeoutState -> TimeoutState -> Bool
compare :: TimeoutState -> TimeoutState -> Ordering
$ccompare :: TimeoutState -> TimeoutState -> Ordering
Ord, Int -> TimeoutState -> ShowS
[TimeoutState] -> ShowS
TimeoutState -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeoutState] -> ShowS
$cshowList :: [TimeoutState] -> ShowS
show :: TimeoutState -> String
$cshow :: TimeoutState -> String
showsPrec :: Int -> TimeoutState -> ShowS
$cshowsPrec :: Int -> TimeoutState -> ShowS
Show)


-- | The type of the timeout handle, used with 'newTimeout', 'readTimeout', and
-- 'cancelTimeout'.
--
#ifdef GHC_TIMERS_API
data Timeout = TimeoutIO !(STM.TVar TimeoutState) !GHC.TimeoutKey
#else
data Timeout = TimeoutIO !(STM.TVar (STM.TVar Bool)) !(STM.TVar Bool)
#endif

-- | Create a new timeout which will fire at the given time duration in
-- the future.
--
-- The timeout will start in the 'TimeoutPending' state and either
-- fire at or after the given time leaving it in the 'TimeoutFired' state,
-- or it may be cancelled with 'cancelTimeout', leaving it in the
-- 'TimeoutCancelled' state.
--
-- Timeouts /cannot/ be reset to the pending state once fired or cancelled
-- (as this would be very racy). You should create a new timeout if you need
-- this functionality.
--
-- When native timer manager is supported (on `*nix` systems), it only holds
-- a `TVar` with `TimeoutState` and `GHC.TimeoutKey`.
--
newTimeout :: NewTimeout IO Timeout
type NewTimeout m timeout = Int -> m timeout


-- | Read the current state of a timeout. This does not block, but returns
-- the current state. It is your responsibility to use 'retry' to wait.
--
-- Alternatively you may wish to use the convenience utility 'awaitTimeout'
-- to wait for just the fired or cancelled outcomes.
--
-- You should consider the cancelled state if you plan to use 'cancelTimeout'.
--
readTimeout :: ReadTimeout IO Timeout
type ReadTimeout m timeout = timeout -> STM m TimeoutState 


-- | Cancel a timeout (unless it has already fired), putting it into the
-- 'TimeoutCancelled' state. Code reading and acting on the timeout state
-- need to handle such cancellation appropriately.
--
-- It is safe to race this concurrently against the timer firing. It will
-- have no effect if the timer fires first.
--
cancelTimeout :: CancelTimeout IO Timeout
type CancelTimeout m timeout = timeout -> m ()

-- | Returns @True@ when the timeout is fired, or @False@ if it is cancelled.
awaitTimeout :: AwaitTimeout IO Timeout
type AwaitTimeout m timeout = timeout -> STM m Bool


#ifdef GHC_TIMERS_API

readTimeout :: ReadTimeout IO Timeout
readTimeout (TimeoutIO TVar TimeoutState
var TimeoutKey
_key) = forall a. TVar a -> STM a
STM.readTVar TVar TimeoutState
var

newTimeout :: NewTimeout IO Timeout
newTimeout = \Int
d -> do
    TVar TimeoutState
var <- forall a. a -> IO (TVar a)
STM.newTVarIO TimeoutState
TimeoutPending
    TimerManager
mgr <- IO TimerManager
GHC.getSystemTimerManager
    TimeoutKey
key <- TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
GHC.registerTimeout TimerManager
mgr Int
d (forall a. STM a -> IO a
STM.atomically (TVar TimeoutState -> STM ()
timeoutAction TVar TimeoutState
var))
    forall (m :: * -> *) a. Monad m => a -> m a
return (TVar TimeoutState -> TimeoutKey -> Timeout
TimeoutIO TVar TimeoutState
var TimeoutKey
key)
  where
    timeoutAction :: TVar TimeoutState -> STM ()
timeoutAction TVar TimeoutState
var = do
      TimeoutState
x <- forall a. TVar a -> STM a
STM.readTVar TVar TimeoutState
var
      case TimeoutState
x of
        TimeoutState
TimeoutPending   -> forall a. TVar a -> a -> STM ()
STM.writeTVar TVar TimeoutState
var TimeoutState
TimeoutFired
        TimeoutState
TimeoutFired     -> forall a. HasCallStack => String -> a
error String
"MonadTimer(IO): invariant violation"
        TimeoutState
TimeoutCancelled -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

cancelTimeout :: CancelTimeout IO Timeout
cancelTimeout (TimeoutIO TVar TimeoutState
var TimeoutKey
key) = do
    forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ do
      TimeoutState
x <- forall a. TVar a -> STM a
STM.readTVar TVar TimeoutState
var
      case TimeoutState
x of
        TimeoutState
TimeoutPending   -> forall a. TVar a -> a -> STM ()
STM.writeTVar TVar TimeoutState
var TimeoutState
TimeoutCancelled
        TimeoutState
TimeoutFired     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        TimeoutState
TimeoutCancelled -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TimerManager
mgr <- IO TimerManager
GHC.getSystemTimerManager
    TimerManager -> TimeoutKey -> TimeoutCallback
GHC.unregisterTimeout TimerManager
mgr TimeoutKey
key

#else

readTimeout (TimeoutIO timeoutvarvar cancelvar) = do
  canceled <- STM.readTVar cancelvar
  fired    <- STM.readTVar =<< STM.readTVar timeoutvarvar
  case (canceled, fired) of
    (True, _)  -> return TimeoutCancelled
    (_, False) -> return TimeoutPending
    (_, True)  -> return TimeoutFired

newTimeout d = do
  timeoutvar    <- GHC.registerDelay d
  timeoutvarvar <- STM.newTVarIO timeoutvar
  cancelvar     <- STM.newTVarIO False
  return (TimeoutIO timeoutvarvar cancelvar)

cancelTimeout (TimeoutIO timeoutvarvar cancelvar) =
  STM.atomically $ do
    fired <- STM.readTVar =<< STM.readTVar timeoutvarvar
    when (not fired) $ STM.writeTVar cancelvar True

#endif

awaitTimeout :: AwaitTimeout IO Timeout
awaitTimeout Timeout
t  = do TimeoutState
s <- ReadTimeout IO Timeout
readTimeout Timeout
t
                     case TimeoutState
s of
                       TimeoutState
TimeoutPending   -> forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                       TimeoutState
TimeoutFired     -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                       TimeoutState
TimeoutCancelled -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False