    {-# LANGUAGE CPP #-}
    {-# OPTIONS_GHC -Wno-missing-signatures #-}
    -- |
    -- Module:      Control.Concurrent.STM.Delay
    -- Copyright:   (c) Joseph Adams 2012
    -- License:     BSD3
    -- Maintainer:  joeyadams3.14159@gmail.com
    -- Portability: Requires GHC 7+
    --
    -- One-shot timer whose duration can be updated.  Think of it as an enhanced
    -- version of 'registerDelay'.
    --
    -- This uses "GHC.Event" when available (GHC 7.2+, @-threaded@, non-Windows OS).
    -- Otherwise, it falls back to forked threads and 'threadDelay'.
    module Control.Concurrent.STM.Delay (
        -- * Managing delays
        Delay,
        newDelay,
        updateDelay,
        cancelDelay,

        -- * Waiting for expiration
        waitDelay,
        tryWaitDelay,
        tryWaitDelayIO,

        -- * Example
        -- $example
    ) where

    import Control.Concurrent
    import Control.Concurrent.STM
    import Control.Exception        (mask_)
    import Control.Monad

    #if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS
    import qualified GHC.Event as Ev
    #endif

    -- | A 'Delay' is an updatable timer that rings only once.
    data Delay = Delay
        { Delay -> TVar Bool
    delayVar    :: !(TVar Bool)
        , Delay -> Int -> IO ()
    delayUpdate :: !(Int -> IO ())
        , Delay -> IO ()
    delayCancel :: !(IO ())
        }

    instance Eq Delay where
        == :: Delay -> Delay -> Bool
    (==) Delay
    a Delay
    b = Delay -> TVar Bool
    delayVar Delay
    a TVar Bool -> TVar Bool -> Bool
    forall a. Eq a => a -> a -> Bool
    == Delay -> TVar Bool
    delayVar Delay
    b

    -- | Create a new 'Delay' that will ring in the given number of microseconds.
    newDelay :: Int -> IO Delay
    newDelay :: Int -> IO Delay
    newDelay Int
    t
      | Int
    t Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0 = Int -> IO Delay
    getDelayImpl Int
    t

      -- Special case zero timeout, so user can create an
      -- already-rung 'Delay' efficiently.
      | Bool
    otherwise = do
            var <- Bool -> IO (TVar Bool)
    forall a. a -> IO (TVar a)
    newTVarIO Bool
    True
            return Delay
                { delayVar    = var
                , delayUpdate = \Int
    _t -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                , delayCancel = return ()
                }

    -- | Set an existing 'Delay' to ring in the given number of microseconds
    -- (from the time 'updateDelay' is called), rather than when it was going to
    -- ring.  If the 'Delay' has already rung, do nothing.
    updateDelay :: Delay -> Int -> IO ()
    updateDelay :: Delay -> Int -> IO ()
    updateDelay = Delay -> Int -> IO ()
    delayUpdate

    -- | Set a 'Delay' so it will never ring, even if 'updateDelay' is used later.
    -- If the 'Delay' has already rung, do nothing.
    cancelDelay :: Delay -> IO ()
    cancelDelay :: Delay -> IO ()
    cancelDelay = Delay -> IO ()
    delayCancel

    -- | Block until the 'Delay' rings.  If the 'Delay' has already rung,
    -- return immediately.
    waitDelay :: Delay -> STM ()
    waitDelay :: Delay -> STM ()
    waitDelay Delay
    delay = do
        expired <- Delay -> STM Bool
    tryWaitDelay Delay
    delay
        if expired then return ()
                   else retry

    -- | Non-blocking version of 'waitDelay'.
    -- Return 'True' if the 'Delay' has rung.
    tryWaitDelay :: Delay -> STM Bool
    tryWaitDelay :: Delay -> STM Bool
    tryWaitDelay = TVar Bool -> STM Bool
    forall a. TVar a -> STM a
    readTVar (TVar Bool -> STM Bool)
    -> (Delay -> TVar Bool) -> Delay -> STM Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Delay -> TVar Bool
    delayVar

    -- | Faster version of @'atomically' . 'tryWaitDelay'@.  See 'readTVarIO'.
    --
    -- Since 0.1.1
    tryWaitDelayIO :: Delay -> IO Bool
    tryWaitDelayIO :: Delay -> IO Bool
    tryWaitDelayIO = TVar Bool -> IO Bool
    forall a. TVar a -> IO a
    readTVarIO (TVar Bool -> IO Bool) -> (Delay -> TVar Bool) -> Delay -> IO Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Delay -> TVar Bool
    delayVar

    ------------------------------------------------------------------------
    -- Drivers

    getDelayImpl :: Int -> IO Delay
    #if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS
    getDelayImpl :: Int -> IO Delay
    getDelayImpl Int
    t0 = do
        m <- IO (Maybe EventManager)
    Ev.getSystemEventManager
        case m of
            Maybe EventManager
    Nothing -> Int -> IO Delay
    implThread Int
    t0
            Just EventManager
    _ -> do
                mgr <- IO TimerManager
    Ev.getSystemTimerManager
                implEvent mgr t0
    #elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS
    getDelayImpl t0 = do
        m <- Ev.getSystemEventManager
        case m of
            Nothing  -> implThread t0
            Just mgr -> implEvent mgr t0
    #else
    getDelayImpl = implThread
    #endif

    #if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS
    -- | Use the timeout API in "GHC.Event" via TimerManager
    --implEvent :: Ev.TimerManager -> Int -> IO Delay
    implEvent :: TimerManager -> Int -> IO Delay
    implEvent TimerManager
    mgr Int
    t0 = do
        var <- Bool -> IO (TVar Bool)
    forall a. a -> IO (TVar a)
    newTVarIO Bool
    False
        k <- Ev.registerTimeout mgr t0 $ atomically $ writeTVar var True
        return Delay
            { delayVar    = var
            , delayUpdate = Ev.updateTimeout mgr k
            , delayCancel = Ev.unregisterTimeout mgr k
            }
    #elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS
    -- | Use the timeout API in "GHC.Event"
    implEvent :: Ev.EventManager -> Int -> IO Delay
    implEvent mgr t0 = do
        var <- newTVarIO False
        k <- Ev.registerTimeout mgr t0 $ atomically $ writeTVar var True
        return Delay
            { delayVar    = var
            , delayUpdate = Ev.updateTimeout mgr k
            , delayCancel = Ev.unregisterTimeout mgr k
            }
    #endif

    -- | Use threads and threadDelay:
    --
    --  [init]
    --      Fork a thread to wait the given length of time, then set the TVar.
    --
    --  [delayUpdate]
    --      Stop the existing thread and (unless the delay has been canceled)
    --      fork a new thread.
    --
    --  [delayCancel]
    --      Stop the existing thread, if any.
    implThread :: Int -> IO Delay
    implThread :: Int -> IO Delay
    implThread Int
    t0 = do
        var <- Bool -> IO (TVar Bool)
    forall a. a -> IO (TVar a)
    newTVarIO Bool
    False
        let new Int
    t = Int -> IO () -> IO TimeoutThread
    forkTimeoutThread Int
    t (IO () -> IO TimeoutThread) -> IO () -> IO TimeoutThread
    forall a b. (a -> b) -> a -> b
    $ STM () -> IO ()
    forall a. STM a -> IO a
    atomically (STM () -> IO ()) -> STM () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ TVar Bool -> Bool -> STM ()
    forall a. TVar a -> a -> STM ()
    writeTVar TVar Bool
    var Bool
    True
        mv <- new t0 >>= newMVar . Just
        return Delay
            { delayVar    = var
            , delayUpdate = replaceThread mv . fmap Just . new
            , delayCancel = replaceThread mv $ return Nothing
            }

    replaceThread :: MVar (Maybe TimeoutThread)
                  -> IO (Maybe TimeoutThread)
                  -> IO ()
    replaceThread :: MVar (Maybe TimeoutThread) -> IO (Maybe TimeoutThread) -> IO ()
    replaceThread MVar (Maybe TimeoutThread)
    mv IO (Maybe TimeoutThread)
    new =
      IO (IO ()) -> IO ()
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ IO (IO ()) -> IO (IO ())
    forall a. IO a -> IO a
    mask_ (IO (IO ()) -> IO (IO ())) -> IO (IO ()) -> IO (IO ())
    forall a b. (a -> b) -> a -> b
    $ do
        m <- MVar (Maybe TimeoutThread) -> IO (Maybe TimeoutThread)
    forall a. MVar a -> IO a
    takeMVar MVar (Maybe TimeoutThread)
    mv
        case m of
            Maybe TimeoutThread
    Nothing -> do
                -- Don't create a new timer thread after the 'Delay' has
                -- been canceled.  Otherwise, the behavior is inconsistent
                -- with GHC.Event.
                MVar (Maybe TimeoutThread) -> Maybe TimeoutThread -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar (Maybe TimeoutThread)
    mv Maybe TimeoutThread
    forall a. Maybe a
    Nothing
                IO () -> IO (IO ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (() -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ())
            Just TimeoutThread
    tt -> do
                m' <- TimeoutThread -> IO (Maybe (IO ()))
    stopTimeoutThread TimeoutThread
    tt
                case m' of
                    Maybe (IO ())
    Nothing -> do
                        -- Timer already rang (or will ring very soon).
                        -- Don't start a new timer thread, as it would
                        -- waste resources and have no externally
                        -- observable effect.
                        MVar (Maybe TimeoutThread) -> Maybe TimeoutThread -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar (Maybe TimeoutThread)
    mv Maybe TimeoutThread
    forall a. Maybe a
    Nothing
                        IO () -> IO (IO ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
    forall a b. (a -> b) -> a -> b
    $ () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                    Just IO ()
    kill -> do
                        IO (Maybe TimeoutThread)
    new IO (Maybe TimeoutThread) -> (Maybe TimeoutThread -> IO ()) -> IO ()
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= MVar (Maybe TimeoutThread) -> Maybe TimeoutThread -> IO ()
    forall a. MVar a -> a -> IO ()
    putMVar MVar (Maybe TimeoutThread)
    mv
                        IO () -> IO (IO ())
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return IO ()
    kill

    ------------------------------------------------------------------------
    -- TimeoutThread

    data TimeoutThread = TimeoutThread !ThreadId !(MVar ())

    -- | Fork a thread to perform an action after the given number of
    -- microseconds.
    --
    -- 'forkTimeoutThread' is non-interruptible.
    forkTimeoutThread :: Int -> IO () -> IO TimeoutThread
    forkTimeoutThread :: Int -> IO () -> IO TimeoutThread
    forkTimeoutThread Int
    t IO ()
    io = do
        mv <- () -> IO (MVar ())
    forall a. a -> IO (MVar a)
    newMVar ()
        tid <- compat_forkIOUnmasked $ do
            threadDelay t
            m <- tryTakeMVar mv
            -- If m is Just, this thread will not be interrupted,
            -- so no need for a 'mask' between the tryTakeMVar and the action.
            case m of
                Maybe ()
    Nothing -> () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                Just ()
    _  -> IO ()
    io
        return (TimeoutThread tid mv)

    -- | Prevent the 'TimeoutThread' from performing its action.  If it's too late,
    -- return 'Nothing'.  Otherwise, return an action (namely, 'killThread') for
    -- cleaning up the underlying thread.
    --
    -- 'stopTimeoutThread' has a nice property: it is /non-interruptible/.
    -- This means that, in an exception 'mask', it will not poll for exceptions.
    -- See "Control.Exception" for more info.
    --
    -- However, the action returned by 'stopTimeoutThread' /does/ poll for
    -- exceptions.  That's why 'stopTimeoutThread' returns this action rather than
    -- simply doing it.  This lets the caller do it outside of a critical section.
    stopTimeoutThread :: TimeoutThread -> IO (Maybe (IO ()))
    stopTimeoutThread :: TimeoutThread -> IO (Maybe (IO ()))
    stopTimeoutThread (TimeoutThread ThreadId
    tid MVar ()
    mv) =
        Maybe (IO ()) -> (() -> Maybe (IO ())) -> Maybe () -> Maybe (IO ())
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Maybe (IO ())
    forall a. Maybe a
    Nothing (\()
    _ -> IO () -> Maybe (IO ())
    forall a. a -> Maybe a
    Just (ThreadId -> IO ()
    killThread ThreadId
    tid)) (Maybe () -> Maybe (IO ())) -> IO (Maybe ()) -> IO (Maybe (IO ()))
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` MVar () -> IO (Maybe ())
    forall a. MVar a -> IO (Maybe a)
    tryTakeMVar MVar ()
    mv

    ------------------------------------------------------------------------
    -- Compatibility

    compat_forkIOUnmasked :: IO () -> IO ThreadId
    #if MIN_VERSION_base(4,4,0)
    compat_forkIOUnmasked :: IO () -> IO ThreadId
    compat_forkIOUnmasked IO ()
    io = ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
    forkIOWithUnmask (\forall a. IO a -> IO a
    _ -> IO ()
    io)
    #else
    compat_forkIOUnmasked = forkIOUnmasked
    #endif

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

    {- $example
    Suppose we are managing a network connection, and want to time it out if no
    messages are received in over five minutes.  We'll create a 'Delay', and an
    action to \"bump\" it:

    @
      let timeoutInterval = 5 * 60 * 1000000 :: 'Int'
      delay <- 'newDelay' timeoutInterval
      let bump = 'updateDelay' delay timeoutInterval
    @

    This way, the 'Delay' will ring if it is not bumped for longer than
    five minutes.

    Now we fork the receiver thread:

    @
      dead <- 'newEmptyTMVarIO'
      _ <- 'forkIO' $
        ('forever' $ do
             msg <- recvMessage
             bump
             handleMessage msg
         ) \`finally\` 'atomically' ('putTMVar' dead ())
    @

    Finally, we wait for the delay to ring, or for the receiver thread to fail due
    to an exception:

    @
      'atomically' $ 'waitDelay' delay \`orElse\` 'readTMVar' dead
    @

    Warning:

     * If /handleMessage/ blocks, the 'Delay' may ring due to @handleMessage@
       taking too long, rather than just @recvMessage@ taking too long.

     * The loop will continue to run until you do something to stop it.

    It might be simpler to use "System.Timeout" instead:

    @
      m <- 'System.Timeout.timeout' timeoutInterval recvMessage
      case m of
          Nothing  -> 'fail' \"timed out\"
          Just msg -> handleMessage msg
    @

    However, using a 'Delay' has the following advantages:

     * If @recvMessage@ makes a blocking FFI call (e.g. network I/O on Windows),
       'System.Timeout.timeout' won't work, since it uses an asynchronous
       exception, and FFI calls can't be interrupted with async exceptions.
       The 'Delay' approach lets you handle the timeout in another thread,
       while the FFI call is still blocked.

     * 'updateDelay' is more efficient than 'System.Timeout.timeout' when
       "GHC.Event" is available.
    -}