    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE ExistentialQuantification #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE NoImplicitPrelude #-}
    {-# LANGUAGE Trustworthy #-}

    -- TODO: use the new Windows IO manager
    module GHC.Event.TimerManager
    #if defined(javascript_HOST_ARCH)
        () where
    #else
        ( -- * Types
          TimerManager

          -- * Creation
        , new
        , newWith
        , newDefaultBackend
        , emControl

          -- * Running
        , finished
        , loop
        , step
        , shutdown
        , cleanup
        , wakeManager

          -- * Registering interest in timeout events
        , TimeoutCallback
        , TimeoutKey
        , registerTimeout
        , updateTimeout
        , unregisterTimeout
        ) where

    #include "EventConfig.h"

    ------------------------------------------------------------------------
    -- Imports

    import Control.Exception (finally)
    import Data.Foldable (sequence_)
    import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
                       writeIORef)
    import GHC.Base
    import GHC.Clock (getMonotonicTimeNSec)
    import GHC.Conc.Signal (runHandlers)
    import GHC.Enum (maxBound)
    import GHC.Num (Num(..))
    import GHC.Real (quot, fromIntegral)
    import GHC.Show (Show(..))
    import GHC.Event.Control
    import GHC.Event.Internal (Backend, Event, evtRead, Timeout(..))
    import GHC.Event.Unique (UniqueSource, newSource, newUnique)
    import GHC.Event.TimeOut
    import System.Posix.Types (Fd)

    import qualified GHC.Event.Internal as I
    import qualified GHC.Event.PSQ as Q

    #if defined(HAVE_POLL)
    import qualified GHC.Event.Poll   as Poll
    #else
    # error not implemented for this operating system
    #endif

    ------------------------------------------------------------------------
    -- Types

    data State = Created
               | Running
               | Dying
               | Finished
                 deriving ( State -> State -> Bool
    (State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: State -> State -> Bool
    == :: State -> State -> Bool
    $c/= :: State -> State -> Bool
    /= :: State -> State -> Bool
    Eq   -- ^ @since 4.7.0.0
                          , Int -> State -> ShowS
    [State] -> ShowS
    State -> String
    (Int -> State -> ShowS)
    -> (State -> String) -> ([State] -> ShowS) -> Show State
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> State -> ShowS
    showsPrec :: Int -> State -> ShowS
    $cshow :: State -> String
    show :: State -> String
    $cshowList :: [State] -> ShowS
    showList :: [State] -> ShowS
    Show -- ^ @since 4.7.0.0
                          )

    -- | The event manager state.
    data TimerManager = TimerManager
        { TimerManager -> Backend
    emBackend      :: !Backend
        , TimerManager -> IORef TimeoutQueue
    emTimeouts     :: {-# UNPACK #-} !(IORef TimeoutQueue)
        , TimerManager -> IORef State
    emState        :: {-# UNPACK #-} !(IORef State)
        , TimerManager -> UniqueSource
    emUniqueSource :: {-# UNPACK #-} !UniqueSource
        , TimerManager -> Control
    emControl      :: {-# UNPACK #-} !Control
        }

    ------------------------------------------------------------------------
    -- Creation

    handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
    handleControlEvent :: TimerManager -> Fd -> Event -> IO ()
    handleControlEvent TimerManager
    mgr Fd
    fd Event
    _evt = do
      ControlMessage
    msg <- Control -> Fd -> IO ControlMessage
    readControlMessage (TimerManager -> Control
    emControl TimerManager
    mgr) Fd
    fd
      case ControlMessage
    msg of
        ControlMessage
    CMsgWakeup      -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
        ControlMessage
    CMsgDie         -> IORef State -> State -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef (TimerManager -> IORef State
    emState TimerManager
    mgr) State
    Finished
        CMsgSignal ForeignPtr Word8
    fp Signal
    s -> ForeignPtr Word8 -> Signal -> IO ()
    runHandlers ForeignPtr Word8
    fp Signal
    s

    newDefaultBackend :: IO Backend
    #if defined(HAVE_POLL)
    newDefaultBackend :: IO Backend
    newDefaultBackend = IO Backend
    Poll.new
    #else
    newDefaultBackend = errorWithoutStackTrace "no back end for this platform"
    #endif

    -- | Create a new event manager.
    new :: IO TimerManager
    new :: IO TimerManager
    new = Backend -> IO TimerManager
    newWith (Backend -> IO TimerManager) -> IO Backend -> IO TimerManager
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< IO Backend
    newDefaultBackend

    newWith :: Backend -> IO TimerManager
    newWith :: Backend -> IO TimerManager
    newWith Backend
    be = do
      IORef TimeoutQueue
    timeouts <- TimeoutQueue -> IO (IORef TimeoutQueue)
    forall a. a -> IO (IORef a)
    newIORef TimeoutQueue
    forall v. IntPSQ v
    Q.empty
      Control
    ctrl <- Bool -> IO Control
    newControl Bool
    True
      IORef State
    state <- State -> IO (IORef State)
    forall a. a -> IO (IORef a)
    newIORef State
    Created
      UniqueSource
    us <- IO UniqueSource
    newSource
      Weak (IORef State)
    _ <- IORef State -> IO () -> IO (Weak (IORef State))
    forall a. IORef a -> IO () -> IO (Weak (IORef a))
    mkWeakIORef IORef State
    state (IO () -> IO (Weak (IORef State)))
    -> IO () -> IO (Weak (IORef State))
    forall a b. (a -> b) -> a -> b
    $ do
                   State
    st <- IORef State -> (State -> (State, State)) -> IO State
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef' IORef State
    state ((State -> (State, State)) -> IO State)
    -> (State -> (State, State)) -> IO State
    forall a b. (a -> b) -> a -> b
    $ \State
    s -> (State
    Finished, State
    s)
                   Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (State
    st State -> State -> Bool
    forall a. Eq a => a -> a -> Bool
    /= State
    Finished) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
                     Backend -> IO ()
    I.delete Backend
    be
                     Control -> IO ()
    closeControl Control
    ctrl
      let mgr :: TimerManager
    mgr = TimerManager { emBackend :: Backend
    emBackend = Backend
    be
                             , emTimeouts :: IORef TimeoutQueue
    emTimeouts = IORef TimeoutQueue
    timeouts
                             , emState :: IORef State
    emState = IORef State
    state
                             , emUniqueSource :: UniqueSource
    emUniqueSource = UniqueSource
    us
                             , emControl :: Control
    emControl = Control
    ctrl
                             }
      Bool
    _ <- Backend -> Fd -> Event -> Event -> IO Bool
    I.modifyFd Backend
    be (Control -> Fd
    controlReadFd Control
    ctrl) Event
    forall a. Monoid a => a
    mempty Event
    evtRead
      Bool
    _ <- Backend -> Fd -> Event -> Event -> IO Bool
    I.modifyFd Backend
    be (Control -> Fd
    wakeupReadFd Control
    ctrl) Event
    forall a. Monoid a => a
    mempty Event
    evtRead
      TimerManager -> IO TimerManager
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return TimerManager
    mgr

    -- | Asynchronously shuts down the event manager, if running.
    shutdown :: TimerManager -> IO ()
    shutdown :: TimerManager -> IO ()
    shutdown TimerManager
    mgr = do
      State
    state <- IORef State -> (State -> (State, State)) -> IO State
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef' (TimerManager -> IORef State
    emState TimerManager
    mgr) ((State -> (State, State)) -> IO State)
    -> (State -> (State, State)) -> IO State
    forall a b. (a -> b) -> a -> b
    $ \State
    s -> (State
    Dying, State
    s)
      Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (State
    state State -> State -> Bool
    forall a. Eq a => a -> a -> Bool
    == State
    Running) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Control -> IO ()
    sendDie (TimerManager -> Control
    emControl TimerManager
    mgr)

    finished :: TimerManager -> IO Bool
    finished :: TimerManager -> IO Bool
    finished TimerManager
    mgr = (State -> State -> Bool
    forall a. Eq a => a -> a -> Bool
    == State
    Finished) (State -> Bool) -> IO State -> IO Bool
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    `liftM` IORef State -> IO State
    forall a. IORef a -> IO a
    readIORef (TimerManager -> IORef State
    emState TimerManager
    mgr)

    cleanup :: TimerManager -> IO ()
    cleanup :: TimerManager -> IO ()
    cleanup TimerManager
    mgr = do
      IORef State -> State -> IO ()
    forall a. IORef a -> a -> IO ()
    writeIORef (TimerManager -> IORef State
    emState TimerManager
    mgr) State
    Finished
      Backend -> IO ()
    I.delete (TimerManager -> Backend
    emBackend TimerManager
    mgr)
      Control -> IO ()
    closeControl (TimerManager -> Control
    emControl TimerManager
    mgr)

    ------------------------------------------------------------------------
    -- Event loop

    -- | Start handling events.  This function loops until told to stop,
    -- using 'shutdown'.
    --
    -- /Note/: This loop can only be run once per 'TimerManager', as it
    -- closes all of its control resources when it finishes.
    loop :: TimerManager -> IO ()
    loop :: TimerManager -> IO ()
    loop TimerManager
    mgr = do
      State
    state <- IORef State -> (State -> (State, State)) -> IO State
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef' (TimerManager -> IORef State
    emState TimerManager
    mgr) ((State -> (State, State)) -> IO State)
    -> (State -> (State, State)) -> IO State
    forall a b. (a -> b) -> a -> b
    $ \State
    s -> case State
    s of
        State
    Created -> (State
    Running, State
    s)
        State
    _       -> (State
    s, State
    s)
      case State
    state of
        State
    Created -> IO ()
    go IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO a
    `finally` TimerManager -> IO ()
    cleanup TimerManager
    mgr
        State
    Dying   -> TimerManager -> IO ()
    cleanup TimerManager
    mgr
        State
    _       -> do TimerManager -> IO ()
    cleanup TimerManager
    mgr
                      String -> IO ()
    forall a. String -> a
    errorWithoutStackTrace (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String
    "GHC.Event.Manager.loop: state is already " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
                          State -> String
    forall a. Show a => a -> String
    show State
    state
     where
      go :: IO ()
    go = do Bool
    running <- TimerManager -> IO Bool
    step TimerManager
    mgr
              Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    running IO ()
    go

    step :: TimerManager -> IO Bool
    step :: TimerManager -> IO Bool
    step TimerManager
    mgr = do
      Timeout
    timeout <- IO Timeout
    mkTimeout
      Int
    _ <- Backend -> Maybe Timeout -> (Fd -> Event -> IO ()) -> IO Int
    I.poll (TimerManager -> Backend
    emBackend TimerManager
    mgr) (Timeout -> Maybe Timeout
    forall a. a -> Maybe a
    Just Timeout
    timeout) (TimerManager -> Fd -> Event -> IO ()
    handleControlEvent TimerManager
    mgr)
      State
    state <- IORef State -> IO State
    forall a. IORef a -> IO a
    readIORef (TimerManager -> IORef State
    emState TimerManager
    mgr)
      State
    state State -> IO Bool -> IO Bool
    forall a b. a -> b -> b
    `seq` Bool -> IO Bool
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (State
    state State -> State -> Bool
    forall a. Eq a => a -> a -> Bool
    == State
    Running)
     where

      -- | Call all expired timer callbacks and return the time to the
      -- next timeout.
      mkTimeout :: IO Timeout
      mkTimeout :: IO Timeout
    mkTimeout = do
          Word64
    now <- IO Word64
    getMonotonicTimeNSec
          ([Elem (IO ())]
    expired, Timeout
    timeout) <- IORef TimeoutQueue
    -> (TimeoutQueue -> (TimeoutQueue, ([Elem (IO ())], Timeout)))
    -> IO ([Elem (IO ())], Timeout)
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef' (TimerManager -> IORef TimeoutQueue
    emTimeouts TimerManager
    mgr) ((TimeoutQueue -> (TimeoutQueue, ([Elem (IO ())], Timeout)))
     -> IO ([Elem (IO ())], Timeout))
    -> (TimeoutQueue -> (TimeoutQueue, ([Elem (IO ())], Timeout)))
    -> IO ([Elem (IO ())], Timeout)
    forall a b. (a -> b) -> a -> b
    $ \TimeoutQueue
    tq ->
               let ([Elem (IO ())]
    expired, TimeoutQueue
    tq') = Word64 -> TimeoutQueue -> ([Elem (IO ())], TimeoutQueue)
    forall v. Word64 -> IntPSQ v -> ([Elem v], IntPSQ v)
    Q.atMost Word64
    now TimeoutQueue
    tq
                   timeout :: Timeout
    timeout = case TimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
    forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
    Q.minView TimeoutQueue
    tq' of
                     Maybe (Elem (IO ()), TimeoutQueue)
    Nothing             -> Timeout
    Forever
                     Just (Q.E Key
    _ Word64
    t IO ()
    _, TimeoutQueue
    _) ->
                         -- This value will always be positive since the call
                         -- to 'atMost' above removed any timeouts <= 'now'
                         let t' :: Word64
    t' = Word64
    t Word64 -> Word64 -> Word64
    forall a. Num a => a -> a -> a
    - Word64
    now in Word64
    t' Word64 -> Timeout -> Timeout
    forall a b. a -> b -> b
    `seq` Word64 -> Timeout
    Timeout Word64
    t'
               in (TimeoutQueue
    tq', ([Elem (IO ())]
    expired, Timeout
    timeout))
          [IO ()] -> IO ()
    forall (t :: * -> *) (m :: * -> *) a.
    (Foldable t, Monad m) =>
    t (m a) -> m ()
    sequence_ ([IO ()] -> IO ()) -> [IO ()] -> IO ()
    forall a b. (a -> b) -> a -> b
    $ (Elem (IO ()) -> IO ()) -> [Elem (IO ())] -> [IO ()]
    forall a b. (a -> b) -> [a] -> [b]
    map Elem (IO ()) -> IO ()
    forall a. Elem a -> a
    Q.value [Elem (IO ())]
    expired
          Timeout -> IO Timeout
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Timeout
    timeout

    -- | Wake up the event manager.
    wakeManager :: TimerManager -> IO ()
    wakeManager :: TimerManager -> IO ()
    wakeManager TimerManager
    mgr = Control -> IO ()
    sendWakeup (TimerManager -> Control
    emControl TimerManager
    mgr)

    ------------------------------------------------------------------------
    -- Registering interest in timeout events

    expirationTime :: Int -> IO Q.Prio
    expirationTime :: Int -> IO Word64
    expirationTime Int
    us = do
        Word64
    now <- IO Word64
    getMonotonicTimeNSec
        let expTime :: Word64
    expTime
              -- Currently we treat overflows by clamping to maxBound. If humanity
              -- still exists in 2500 CE we will ned to be a bit more careful here.
              -- See #15158.
              | (Word64
    forall a. Bounded a => a
    maxBound Word64 -> Word64 -> Word64
    forall a. Num a => a -> a -> a
    - Word64
    now) Word64 -> Word64 -> Word64
    forall a. Integral a => a -> a -> a
    `quot` Word64
    1000 Word64 -> Word64 -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    us  = Word64
    forall a. Bounded a => a
    maxBound
              | Bool
    otherwise                                       = Word64
    now Word64 -> Word64 -> Word64
    forall a. Num a => a -> a -> a
    + Word64
    ns
              where ns :: Word64
    ns = Word64
    1000 Word64 -> Word64 -> Word64
    forall a. Num a => a -> a -> a
    * Int -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    us
        Word64 -> IO Word64
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Word64
    expTime

    -- | Register a timeout in the given number of microseconds.  The
    -- returned 'TimeoutKey' can be used to later unregister or update the
    -- timeout.  The timeout is automatically unregistered after the given
    -- time has passed.
    --
    -- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
    -- 2147483647 μs, less than 36 minutes.
    --
    registerTimeout :: TimerManager -> Int -> TimeoutCallback -> IO TimeoutKey
    registerTimeout :: TimerManager -> Int -> IO () -> IO TimeoutKey
    registerTimeout TimerManager
    mgr Int
    us IO ()
    cb = do
      !Key
    key <- UniqueSource -> IO Key
    newUnique (TimerManager -> UniqueSource
    emUniqueSource TimerManager
    mgr)
      if Int
    us Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Int
    0 then IO ()
    cb
        else do
          Word64
    expTime <- Int -> IO Word64
    expirationTime Int
    us

          -- "unsafeInsertNew" is safe - the key must not exist in the PSQ. It
          -- doesn't because we just generated it from a unique supply.
          TimerManager -> TimeoutEdit -> IO ()
    editTimeouts TimerManager
    mgr (Key -> Word64 -> IO () -> TimeoutEdit
    forall v. Key -> Word64 -> v -> IntPSQ v -> IntPSQ v
    Q.unsafeInsertNew Key
    key Word64
    expTime IO ()
    cb)
      TimeoutKey -> IO TimeoutKey
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TimeoutKey -> IO TimeoutKey) -> TimeoutKey -> IO TimeoutKey
    forall a b. (a -> b) -> a -> b
    $ Key -> TimeoutKey
    TK Key
    key

    -- | Unregister an active timeout.
    unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
    unregisterTimeout :: TimerManager -> TimeoutKey -> IO ()
    unregisterTimeout TimerManager
    mgr (TK Key
    key) =
      TimerManager -> TimeoutEdit -> IO ()
    editTimeouts TimerManager
    mgr (Key -> TimeoutEdit
    forall v. Key -> IntPSQ v -> IntPSQ v
    Q.delete Key
    key)

    -- | Update an active timeout to fire in the given number of
    -- microseconds.
    --
    -- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only
    -- 2147483647 μs, less than 36 minutes.
    --
    updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
    updateTimeout :: TimerManager -> TimeoutKey -> Int -> IO ()
    updateTimeout TimerManager
    mgr (TK Key
    key) Int
    us = do
      Word64
    expTime <- Int -> IO Word64
    expirationTime Int
    us
      TimerManager -> TimeoutEdit -> IO ()
    editTimeouts TimerManager
    mgr ((Word64 -> Word64) -> Key -> TimeoutEdit
    forall a. (Word64 -> Word64) -> Key -> PSQ a -> PSQ a
    Q.adjust (Word64 -> Word64 -> Word64
    forall a b. a -> b -> a
    const Word64
    expTime) Key
    key)

    editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
    editTimeouts :: TimerManager -> TimeoutEdit -> IO ()
    editTimeouts TimerManager
    mgr TimeoutEdit
    g = do
      Bool
    wake <- IORef TimeoutQueue
    -> (TimeoutQueue -> (TimeoutQueue, Bool)) -> IO Bool
    forall a b. IORef a -> (a -> (a, b)) -> IO b
    atomicModifyIORef' (TimerManager -> IORef TimeoutQueue
    emTimeouts TimerManager
    mgr) TimeoutQueue -> (TimeoutQueue, Bool)
    f
      Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    wake (TimerManager -> IO ()
    wakeManager TimerManager
    mgr)
      where
        f :: TimeoutQueue -> (TimeoutQueue, Bool)
    f TimeoutQueue
    q = (TimeoutQueue
    q', Bool
    wake)
          where
            q' :: TimeoutQueue
    q' = TimeoutEdit
    g TimeoutQueue
    q
            wake :: Bool
    wake = case TimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
    forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
    Q.minView TimeoutQueue
    q of
                    Maybe (Elem (IO ()), TimeoutQueue)
    Nothing -> Bool
    True
                    Just (Q.E Key
    _ Word64
    t0 IO ()
    _, TimeoutQueue
    _) ->
                      case TimeoutQueue -> Maybe (Elem (IO ()), TimeoutQueue)
    forall v. IntPSQ v -> Maybe (Elem v, IntPSQ v)
    Q.minView TimeoutQueue
    q' of
                        Just (Q.E Key
    _ Word64
    t1 IO ()
    _, TimeoutQueue
    _) ->
                          -- don't wake the manager if the
                          -- minimum element didn't change.
                          Word64
    t0 Word64 -> Word64 -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Word64
    t1
                        Maybe (Elem (IO ()), TimeoutQueue)
    _ -> Bool
    True

    #endif