{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
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)
newtype Timeout = Timeout Unique deriving Timeout -> Timeout -> Bool
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
instance Show Timeout where
show :: Timeout -> String
show Timeout
_ = String
"<<timeout>>"
instance Exception Timeout where
toException :: Timeout -> SomeException
toException = forall e. Exception e => e -> SomeException
asyncExceptionToException
fromException :: SomeException -> Maybe Timeout
fromException = forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException
timeout :: Int -> IO a -> IO (Maybe a)
timeout :: forall a. Int -> IO a -> IO (Maybe a)
timeout Int
n IO a
f
| Int
n forall a. Ord a => a -> a -> Bool
< Int
0 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just IO a
f
| Int
n forall a. Eq a => a -> a -> Bool
== Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
#if !defined(mingw32_HOST_OS)
| Bool
rtsSupportsBoundThreads = do
ThreadId
pid <- IO ThreadId
myThreadId
Timeout
ex <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unique -> Timeout
Timeout IO Unique
newUnique
TimerManager
tm <- IO TimerManager
getSystemTimerManager
MVar ThreadId
lock <- forall a. IO (MVar a)
newEmptyMVar
let handleTimeout :: IO ()
handleTimeout = do
Bool
v <- forall a. MVar a -> IO Bool
isEmptyMVar MVar ThreadId
lock
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
v forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId
forkIOWithUnmask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ do
Bool
v2 <- forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ThreadId
lock forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ThreadId
myThreadId
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
v2 forall a b. (a -> b) -> a -> b
$ forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
pid Timeout
ex
cleanupTimeout :: TimeoutKey -> IO ()
cleanupTimeout TimeoutKey
key = forall a. IO a -> IO a
uninterruptibleMask_ forall a b. (a -> b) -> a -> b
$ do
Bool
v <- forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ThreadId
lock forall a. HasCallStack => a
undefined
if Bool
v then TimerManager -> TimeoutKey -> IO ()
unregisterTimeout TimerManager
tm TimeoutKey
key
else forall a. MVar a -> IO a
takeMVar MVar ThreadId
lock forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ThreadId -> IO ()
killThread
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust (\Timeout
e -> if Timeout
e forall a. Eq a => a -> a -> Bool
== Timeout
ex then forall a. a -> Maybe a
Just () else forall a. Maybe a
Nothing)
(\()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
(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
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just IO a
f))
#endif
| Bool
otherwise = do
ThreadId
pid <- IO ThreadId
myThreadId
Timeout
ex <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unique -> Timeout
Timeout IO Unique
newUnique
forall e b a.
Exception e =>
(e -> Maybe b) -> (b -> IO a) -> IO a -> IO a
handleJust (\Timeout
e -> if Timeout
e forall a. Eq a => a -> a -> Bool
== Timeout
ex then forall a. a -> Maybe a
Just () else forall a. Maybe a
Nothing)
(\()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
(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 b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask ->
forall a. IO a -> IO a
unmask forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
n forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
pid Timeout
ex)
(forall a. IO a -> IO a
uninterruptibleMask_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> IO ()
killThread)
(\ThreadId
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just IO a
f))