    {-# LANGUAGE CPP, DeriveDataTypeable, NoImplicitPrelude #-}

    #if __GLASGOW_HASKELL__ >= 704
    {-# LANGUAGE Safe #-}
    #endif

    -- | Wait arbitrarily long for an IO computation to finish.
    module Control.Concurrent.Timeout ( timeout, Timeout, timeoutWithPred ) where

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

    -- from base:
    import Control.Concurrent       ( forkIOWithUnmask, myThreadId, throwTo, killThread )
    import Control.Exception        ( Exception, bracket, handleJust )
    import Control.Monad            ( return, (>>), fmap )
    import Data.Bool                ( Bool(False), otherwise )
    import Data.Eq                  ( Eq, (==) )
    import Data.Function            ( (.), const)
    import Data.Maybe               ( Maybe(Nothing, Just) )
    import Data.Ord                 ( (<) )
    import Data.Typeable            ( Typeable )
    import Data.Unique              ( Unique, newUnique )
    import Prelude                  ( Integer )
    import System.IO                ( IO )
    import Text.Show                ( Show, show )

    #if __GLASGOW_HASKELL__ < 700
    import Prelude                  ( fromInteger )
    import Control.Monad            ( (>>=), fail )
    #endif

    #ifdef __HADDOCK_VERSION__
    import Data.Int                 ( Int )
    import System.IO                ( hGetBuf, hPutBuf, hWaitForInput )
    import qualified System.Timeout ( timeout )
    #endif

    -- from unbounded-delays (this package):
    import Control.Concurrent.Thread.Delay ( delay )

    -------------------------------------------------------------------------------
    -- Long delays and timeouts
    -------------------------------------------------------------------------------

    {-
    The following code was mostly copied from the module System.Timeout in the
    package base-4.2.0.0.

    (c) The University of Glasgow 2007
    -}

    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
    $c== :: Timeout -> Timeout -> Bool
    == :: Timeout -> Timeout -> Bool
    $c/= :: Timeout -> Timeout -> Bool
    /= :: Timeout -> Timeout -> Bool
    Eq, Typeable)

    instance Show Timeout where
        show :: Timeout -> String
    show Timeout
    _ = String
    "<<timeout>>"

    instance Exception Timeout

    {-|
    Like @System.Timeout.'System.Timeout.timeout'@, but not bounded by an 'Int'.
    (..)
    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\".

    If the computation has not terminated after @n@ microseconds, it is interrupted
    by an asynchronous exception. The function passed to @f@ can be used to detect
    whether it was interrupted by this timeout or some other exception.

    The design of this combinator was guided by the objective that @timeout n (const 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.  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.
    -}
    timeoutWithPred :: Integer -> ((Timeout -> Bool) -> IO α) -> IO (Maybe α)
    timeoutWithPred :: forall α. Integer -> ((Timeout -> Bool) -> IO α) -> IO (Maybe α)
    timeoutWithPred Integer
    n (Timeout -> Bool) -> IO α
    f
        | Integer
    n Integer -> Integer -> Bool
    forall a. Ord a => a -> a -> Bool
    < Integer
    0     = (α -> Maybe α) -> IO α -> IO (Maybe α)
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap α -> Maybe α
    forall a. a -> Maybe a
    Just ((Timeout -> Bool) -> IO α
    f (Bool -> Timeout -> Bool
    forall a b. a -> b -> a
    const Bool
    False))
        | Integer
    n Integer -> Integer -> Bool
    forall a. Eq a => a -> a -> Bool
    == Integer
    0    = Maybe α -> IO (Maybe α)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe α
    forall a. Maybe a
    Nothing
        | Bool
    otherwise = do
            pid <- IO ThreadId
    myThreadId
            ex  <- fmap Timeout newUnique
            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 α -> IO (Maybe α)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe α
    forall a. Maybe a
    Nothing)
                       (bracket (forkIOWithUnmask (\forall a. IO a -> IO a
    unmask -> IO () -> IO ()
    forall a. IO a -> IO a
    unmask (Integer -> IO ()
    delay Integer
    n IO () -> IO () -> IO ()
    forall a b. IO a -> IO b -> IO b
    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)))
                                (killThread)
                                (\ThreadId
    _ -> (α -> Maybe α) -> IO α -> IO (Maybe α)
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap α -> Maybe α
    forall a. a -> Maybe a
    Just ((Timeout -> Bool) -> IO α
    f (Timeout -> Timeout -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Timeout
    ex)))
                       )

    {-|
    Like 'timeoutWithPred', but does not expose the 'Timeout' exception to the called action.
    -}
    timeout :: Integer -> IO α -> IO (Maybe α)
    timeout :: forall α. Integer -> IO α -> IO (Maybe α)
    timeout Integer
    n = Integer -> ((Timeout -> Bool) -> IO α) -> IO (Maybe α)
    forall α. Integer -> ((Timeout -> Bool) -> IO α) -> IO (Maybe α)
    timeoutWithPred Integer
    n (((Timeout -> Bool) -> IO α) -> IO (Maybe α))
    -> (IO α -> (Timeout -> Bool) -> IO α) -> IO α -> IO (Maybe α)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IO α -> (Timeout -> Bool) -> IO α
    forall a b. a -> b -> a
    const