    {-# LANGUAGE CPP #-}
    {-# LANGUAGE Safe #-}

    -------------------------------------------------------------------------------
    -- |
    -- Module      :  System.Timeout
    -- Copyright   :  (c) The University of Glasgow 2007
    -- License     :  BSD-style (see the file libraries/base/LICENSE)
    --
    -- Maintainer  :  libraries@haskell.org
    -- Stability   :  experimental
    -- Portability :  non-portable
    --
    -- Attach a timeout event to arbitrary 'IO' computations.
    --
    -------------------------------------------------------------------------------
    -- TODO: Inspect is still suitable.
    module System.Timeout ( Timeout, timeout ) where

    #if !defined(mingw32_HOST_OS)
    import Control.Monad
    import GHC.Event           (getSystemTimerManager,
                                registerTimeout, unregisterTimeout)
    #endif

    import Control.Concurrent
    import Control.Exception   (Exception(..), handleJust, bracket,
                                uninterruptibleMask_,
                                asyncExceptionToException,
                                asyncExceptionFromException)
    import Data.Unique         (Unique, newUnique)

    -- $setup
    -- >>> import Prelude
    -- >>> import Control.Concurrent (threadDelay)

    -- An internal type that is thrown as a dynamic exception to
    -- interrupt the running IO computation when the timeout has
    -- expired.

    -- | An exception thrown to a thread by 'timeout' to interrupt a timed-out
    -- computation.
    --
    -- @since 4.0
    newtype Timeout = Timeout Unique deriving Timeout -> Timeout -> Bool
    (Timeout -> Timeout -> Bool)
    -> (Timeout -> Timeout -> Bool) -> Eq Timeout
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: Timeout -> Timeout -> Bool
    $c/= :: Timeout -> Timeout -> Bool
    == :: Timeout -> Timeout -> Bool
    $c== :: Timeout -> Timeout -> Bool
    Eq

    -- | @since 4.0
    instance Show Timeout where
        show :: Timeout -> String
    show Timeout
    _ = String
    "<<timeout>>"

    -- Timeout is a child of SomeAsyncException
    -- | @since 4.7.0.0
    instance Exception Timeout where
      toException :: Timeout -> SomeException
    toException = Timeout -> SomeException
    forall e. Exception e => e -> SomeException
    asyncExceptionToException
      fromException :: SomeException -> Maybe Timeout
    fromException = SomeException -> Maybe Timeout
    forall e. Exception e => SomeException -> Maybe e
    asyncExceptionFromException

    -- |Wrap an 'IO' computation to time out and return @Nothing@ in case no result
    -- is available within @n@ microseconds (@1\/10^6@ seconds). In case a result
    -- is available before the timeout expires, @Just a@ is returned. A negative
    -- timeout interval means \"wait indefinitely\". When specifying long timeouts,
    -- be careful not to exceed @maxBound :: Int@.
    --
    -- >>> timeout 1000000 (threadDelay 1000 *> pure "finished on time")
    -- Just "finished on time"
    --
    -- >>> timeout 10000 (threadDelay 100000 *> pure "finished on time")
    -- Nothing
    --
    -- The design of this combinator was guided by the objective that @timeout n f@
    -- should behave exactly the same as @f@ as long as @f@ doesn't time out. This
    -- means that @f@ has the same 'myThreadId' it would have without the timeout
    -- wrapper. Any exceptions @f@ might throw cancel the timeout and propagate
    -- further up. It also possible for @f@ to receive exceptions thrown to it by
    -- another thread.
    --
    -- A tricky implementation detail is the question of how to abort an @IO@
    -- computation. This combinator relies on asynchronous exceptions internally
    -- (namely throwing the computation the 'Timeout' exception).  The technique
    -- works very well for computations executing inside of the Haskell runtime
    -- system, but it doesn't work at all for non-Haskell code.  Foreign function
    -- calls, for example, cannot be timed out with this combinator simply because
    -- an arbitrary C function cannot receive asynchronous exceptions. When
    -- @timeout@ is used to wrap an FFI call that blocks, no timeout event can be
    -- delivered until the FFI call returns, which pretty much negates the purpose
    -- of the combinator. In practice, however, this limitation is less severe than
    -- it may sound. Standard I\/O functions like 'System.IO.hGetBuf',
    -- 'System.IO.hPutBuf', Network.Socket.accept, or 'System.IO.hWaitForInput'
    -- appear to be blocking, but they really don't because the runtime system uses
    -- scheduling mechanisms like @select(2)@ to perform asynchronous I\/O, so it
    -- is possible to interrupt standard socket I\/O or file I\/O using this
    -- combinator.
    ---
    -- Note that 'timeout' cancels the computation by throwing it the 'Timeout'
    -- exception. Consequently blanket exception handlers (e.g. catching
    -- 'SomeException') within the computation will break the timeout behavior.
    timeout :: Int -> IO a -> IO (Maybe a)
    timeout :: forall a. Int -> IO a -> IO (Maybe a)
    timeout Int
    n IO a
    f
        | Int
    n Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    <  Int
    0    = (a -> Maybe a) -> IO a -> IO (Maybe a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap a -> Maybe a
    forall a. a -> Maybe a
    Just IO a
    f
        | Int
    n Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0    = Maybe a -> IO (Maybe a)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe a
    forall a. Maybe a
    Nothing
    #if !defined(mingw32_HOST_OS)
        | Bool
    rtsSupportsBoundThreads = do
            -- In the threaded RTS, we use the Timer Manager to delay the
            -- (fairly expensive) 'forkIO' call until the timeout has expired.
            --
            -- An additional thread is required for the actual delivery of
            -- the Timeout exception because killThread (or another throwTo)
            -- is the only way to reliably interrupt a throwTo in flight.
            ThreadId
    pid <- IO ThreadId
    myThreadId
            Timeout
    ex  <- (Unique -> Timeout) -> IO Unique -> IO Timeout
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Unique -> Timeout
    Timeout IO Unique
    newUnique
            TimerManager
    tm  <- IO TimerManager
    getSystemTimerManager
            -- 'lock' synchronizes the timeout handler and the main thread:
            --  * the main thread can disable the handler by writing to 'lock';
            --  * the handler communicates the spawned thread's id through 'lock'.
            -- These two cases are mutually exclusive.
            MVar ThreadId
    lock <- IO (MVar ThreadId)
    forall a. IO (MVar a)
    newEmptyMVar
            let handleTimeout :: IO ()
    handleTimeout = do
                    Bool
    v <- MVar ThreadId -> IO Bool
    forall a. MVar a -> IO Bool
    isEmptyMVar MVar ThreadId
    lock
                    Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    v (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ IO ThreadId -> IO ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
    forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
    -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
    forall a b. (a -> b) -> a -> b
    $ \forall a. IO a -> IO a
    unmask -> IO () -> IO ()
    forall a. IO a -> IO a
    unmask (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
                        Bool
    v2 <- MVar ThreadId -> ThreadId -> IO Bool
    forall a. MVar a -> a -> IO Bool
    tryPutMVar MVar ThreadId
    lock (ThreadId -> IO Bool) -> IO ThreadId -> IO Bool
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< IO ThreadId
    myThreadId
                        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    v2 (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ThreadId -> Timeout -> IO ()
    forall e. Exception e => ThreadId -> e -> IO ()
    throwTo ThreadId
    pid Timeout
    ex
                cleanupTimeout :: TimeoutKey -> IO ()
    cleanupTimeout TimeoutKey
    key = IO () -> IO ()
    forall a. IO a -> IO a
    uninterruptibleMask_ (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
                    Bool
    v <- MVar ThreadId -> ThreadId -> IO Bool
    forall a. MVar a -> a -> IO Bool
    tryPutMVar MVar ThreadId
    lock ThreadId
    forall a. HasCallStack => a
    undefined
                    if Bool
    v then TimerManager -> TimeoutKey -> IO ()
    unregisterTimeout TimerManager
    tm TimeoutKey
    key
                         else MVar ThreadId -> IO ThreadId
    forall a. MVar a -> IO a
    takeMVar MVar ThreadId
    lock IO ThreadId -> (ThreadId -> IO ()) -> IO ()
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= ThreadId -> IO ()
    killThread
            (Timeout -> Maybe ())
    -> (() -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
    forall e b a.
    Exception e =>
    (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
    handleJust (\Timeout
    e -> if Timeout
    e Timeout -> Timeout -> Bool
    forall a. Eq a => a -> a -> Bool
    == Timeout
    ex then () -> Maybe ()
    forall a. a -> Maybe a
    Just () else Maybe ()
    forall a. Maybe a
    Nothing)
                       (\()
    _ -> Maybe a -> IO (Maybe a)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe a
    forall a. Maybe a
    Nothing)
                       (IO TimeoutKey
    -> (TimeoutKey -> IO ())
    -> (TimeoutKey -> IO (Maybe a))
    -> IO (Maybe a)
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket (TimerManager -> Int -> IO () -> IO TimeoutKey
    registerTimeout TimerManager
    tm Int
    n IO ()
    handleTimeout)
                                TimeoutKey -> IO ()
    cleanupTimeout
                                (\TimeoutKey
    _ -> (a -> Maybe a) -> IO a -> IO (Maybe a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap a -> Maybe a
    forall a. a -> Maybe a
    Just IO a
    f))
    #endif
        | Bool
    otherwise = do
            ThreadId
    pid <- IO ThreadId
    myThreadId
            Timeout
    ex  <- (Unique -> Timeout) -> IO Unique -> IO Timeout
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Unique -> Timeout
    Timeout IO Unique
    newUnique
            (Timeout -> Maybe ())
    -> (() -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
    forall e b a.
    Exception e =>
    (e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
    handleJust (\Timeout
    e -> if Timeout
    e Timeout -> Timeout -> Bool
    forall a. Eq a => a -> a -> Bool
    == Timeout
    ex then () -> Maybe ()
    forall a. a -> Maybe a
    Just () else Maybe ()
    forall a. Maybe a
    Nothing)
                       (\()
    _ -> Maybe a -> IO (Maybe a)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe a
    forall a. Maybe a
    Nothing)
                       (IO ThreadId
    -> (ThreadId -> IO ())
    -> (ThreadId -> IO (Maybe a))
    -> IO (Maybe a)
    forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
    bracket (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
    forkIOWithUnmask (((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId)
    -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
    forall a b. (a -> b) -> a -> b
    $ \forall a. IO a -> IO a
    unmask ->
                                     IO () -> IO ()
    forall a. IO a -> IO a
    unmask (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Int -> IO ()
    threadDelay Int
    n IO () -> IO () -> IO ()
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> ThreadId -> Timeout -> IO ()
    forall e. Exception e => ThreadId -> e -> IO ()
    throwTo ThreadId
    pid Timeout
    ex)
                                (IO () -> IO ()
    forall a. IO a -> IO a
    uninterruptibleMask_ (IO () -> IO ()) -> (ThreadId -> IO ()) -> ThreadId -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ThreadId -> IO ()
    killThread)
                                (\ThreadId
    _ -> (a -> Maybe a) -> IO a -> IO (Maybe a)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap a -> Maybe a
    forall a. a -> Maybe a
    Just IO a
    f))
            -- #7719 explains why we need uninterruptibleMask_ above.