{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | An alternative implementation of 'System.Timeout.timeout' for platforms -- (i.e. Windows) where the standard implementation is too expensive. -- -- The implementation provided here is for the special case where only one -- timeout is active at once. A concurrent implementation would be possible -- but is not currently needed. -- module Network.Mux.Timeout ( TimeoutFn , withTimeoutSerial , withTimeoutSerialNative , withTimeoutSerialAlternative ) where import Control.Concurrent.Class.MonadSTM import Control.Exception (asyncExceptionFromException, asyncExceptionToException) import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI (MonadTimer, registerDelay) import qualified Control.Monad.Class.MonadTimer.SI as MonadTimer -- | The type of the 'System.Timeout.timeout' function. -- type TimeoutFn m = forall a. DiffTime -> m a -> m (Maybe a) -- | A 'System.Timeout.timeout' that is reasonably efficient for all platforms. -- -- On Unix it uses exactly 'System.Timeout.timeout' and on Windows it uses -- 'withTimeoutSerialAlternative'. -- -- > withTimeoutSerial $ \timeout -> -- > -- now use timeout as one would use System.Timeout.timeout -- > -- but not concurrently! -- -- The implementation has a serial constraint: the body action that calls -- @timeout@ can /only do so from one thread at once/. -- withTimeoutSerial, withTimeoutSerialNative :: forall m b. (MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => (TimeoutFn m -> m b) -> m b #if defined(mingw32_HOST_OS) withTimeoutSerial = withTimeoutSerialAlternative #else withTimeoutSerial :: forall (m :: * -> *) b. (MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => (TimeoutFn m -> m b) -> m b withTimeoutSerial = forall (m :: * -> *) b. (MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => (TimeoutFn m -> m b) -> m b withTimeoutSerialNative #endif -- | This version simply passes the native platform's 'MonadTimer.timeout'. -- withTimeoutSerialNative :: forall (m :: * -> *) b. (MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => (TimeoutFn m -> m b) -> m b withTimeoutSerialNative TimeoutFn m -> m b body = TimeoutFn m -> m b body forall (m :: * -> *) a. MonadTimer m => DiffTime -> m a -> m (Maybe a) MonadTimer.timeout -- | An alternative implementation of 'System.Timeout.timeout' for platforms -- where the standard implementation is too expensive. -- -- > withTimeoutSerial $ \timeout -> -- > -- now use timeout as one would use System.Timeout.timeout -- > -- but not concurrently! -- -- This implementation has a serial constraint: the body action that calls -- @timeout@ can /only do so from one thread at once/. -- -- Further details for the curious: -- -- the problem with @System.Timeout.timeout@ is that (as of base 4.12) it has -- two implementations, one for Unix with the threaded RTS, and one for all -- other configurations. -- -- The Unix threaded RTS implementation is rather clever and very fast. In the -- normal case of no timeout, it only has to allocate a timer entry. Only in -- the case the timeout occurs does it allocate a 'forkIO' thread to do the -- potentially-blocking operation of sending the asynchronous exception to -- interrupt the action under timeout. -- -- The implementation for all other configurations has to allocate a 'forkIO' -- thread up front, whether or not the timeout fires. This is fine for many -- applications but not for network timers which have to be created and -- altered\/cancelled with very high frequency. -- -- The implementation here only relies upon 'threadDelay' which has an -- efficient implementation on all platforms. It uses a separate monitoring -- thread which will throw an exception to terminate the action if the -- timeout expires. This is why it uses the \"with\" style: because it keeps -- a monitoring thread over a region of execution that may use many timeouts. -- The cost of allocating this thread is amortised over all the timeouts used. -- -- This implementation is simplified by the constraint that the timeouts only -- be used serially. In addition, it has the limitation that timeouts may not -- always be detected promptly: e.g. a 10s timeout on an action that finishes -- immediately, followed by a 5s timeout on an action will only actually be -- interrupted after 10s. So it's possible that action with the 5s timeout runs -- for up to 10s. This is ok for many applications provided that the variance -- in timeouts is not too large and the timeouts don't need to be too tight. -- withTimeoutSerialAlternative :: forall m b. (MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => (TimeoutFn m -> m b) -> m b withTimeoutSerialAlternative :: forall (m :: * -> *) b. (MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => (TimeoutFn m -> m b) -> m b withTimeoutSerialAlternative TimeoutFn m -> m b body = do -- State shared between the timeouts and the monitoring thread. MonitorState m monitorState <- forall (m :: * -> *). MonadSTM m => m (MonitorState m) newMonitorState -- Run the monitoring thread but ensure it terminates when the body is done. forall (m :: * -> *) a b. MonadAsync m => m a -> (Async m a -> m b) -> m b withAsync (forall (m :: * -> *). (MonadFork m, MonadSTM m, MonadMonotonicTime m, MonadTimer m, MonadThrow (STM m)) => MonitorState m -> m () monitoringThread MonitorState m monitorState) forall a b. (a -> b) -> a -> b $ \Async m () _ -> -- Run the body and pass it the @timeout@ function. TimeoutFn m -> m b body (forall (m :: * -> *) a. (MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => MonitorState m -> DiffTime -> m a -> m (Maybe a) timeout MonitorState m monitorState) -- | The state shared between the timeouts and the monitoring thread. -- data MonitorState m = MonitorState { -- written by timeout combinator, read and reset by monitoring thread forall (m :: * -> *). MonitorState m -> TVar m (NextTimeout m) nextTimeoutVar :: !(TVar m (NextTimeout m)), -- written by monitoring thread, read by timeout combinator forall (m :: * -> *). MonitorState m -> TVar m Time curDeadlineVar :: !(TVar m Time), -- written by timeout combinator, read and reset by monitoring thread forall (m :: * -> *). MonitorState m -> TVar m Bool deadlineResetVar :: !(TVar m Bool) } data NextTimeout m = NoNextTimeout | NextTimeout !(ThreadId m) -- Which thread to interrupt !Time -- When to interrupt it !(TVar m TimeoutState) -- Synchronisation state newMonitorState :: MonadSTM m => m (MonitorState m) newMonitorState :: forall (m :: * -> *). MonadSTM m => m (MonitorState m) newMonitorState = do TVar m (NextTimeout m) nextTimeoutVar <- forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a) newTVarIO forall (m :: * -> *). NextTimeout m NoNextTimeout TVar m Time curDeadlineVar <- forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a) newTVarIO (DiffTime -> Time Time DiffTime 0) TVar m Bool deadlineResetVar <- forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a) newTVarIO Bool False forall (m :: * -> *) a. Monad m => a -> m a return MonitorState{TVar m Bool TVar m Time TVar m (NextTimeout m) deadlineResetVar :: TVar m Bool curDeadlineVar :: TVar m Time nextTimeoutVar :: TVar m (NextTimeout m) deadlineResetVar :: TVar m Bool curDeadlineVar :: TVar m Time nextTimeoutVar :: TVar m (NextTimeout m) ..} -- | An update to the shared monitor state to set a new timer. -- setNewTimer :: MonadSTM m => MonitorState m -> ThreadId m -> Time -> TVar m TimeoutState -> m () setNewTimer :: forall (m :: * -> *). MonadSTM m => MonitorState m -> ThreadId m -> Time -> TVar m TimeoutState -> m () setNewTimer MonitorState{TVar m (NextTimeout m) nextTimeoutVar :: TVar m (NextTimeout m) nextTimeoutVar :: forall (m :: * -> *). MonitorState m -> TVar m (NextTimeout m) nextTimeoutVar, TVar m Time curDeadlineVar :: TVar m Time curDeadlineVar :: forall (m :: * -> *). MonitorState m -> TVar m Time curDeadlineVar, TVar m Bool deadlineResetVar :: TVar m Bool deadlineResetVar :: forall (m :: * -> *). MonitorState m -> TVar m Bool deadlineResetVar} !ThreadId m tid !Time deadline !TVar m TimeoutState stateVar = forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically forall a b. (a -> b) -> a -> b $ do forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m (NextTimeout m) nextTimeoutVar (forall (m :: * -> *). ThreadId m -> Time -> TVar m TimeoutState -> NextTimeout m NextTimeout ThreadId m tid Time deadline TVar m TimeoutState stateVar) Time curDeadline <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m Time curDeadlineVar -- If the timer deadline has moved backwards, notify the monitor thread -- so it can wake up and grab the next timeout forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Time deadline forall a. Ord a => a -> a -> Bool < Time curDeadline) forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m Bool deadlineResetVar Bool True -- | A potentially blocking wait read side, so can block. -- readNextTimeout :: MonadSTM m => MonitorState m -> m (ThreadId m, Time, TVar m TimeoutState) readNextTimeout :: forall (m :: * -> *). MonadSTM m => MonitorState m -> m (ThreadId m, Time, TVar m TimeoutState) readNextTimeout MonitorState{TVar m (NextTimeout m) nextTimeoutVar :: TVar m (NextTimeout m) nextTimeoutVar :: forall (m :: * -> *). MonitorState m -> TVar m (NextTimeout m) nextTimeoutVar, TVar m Time curDeadlineVar :: TVar m Time curDeadlineVar :: forall (m :: * -> *). MonitorState m -> TVar m Time curDeadlineVar, TVar m Bool deadlineResetVar :: TVar m Bool deadlineResetVar :: forall (m :: * -> *). MonitorState m -> TVar m Bool deadlineResetVar} = do forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically forall a b. (a -> b) -> a -> b $ do NextTimeout m nextTimeout <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m (NextTimeout m) nextTimeoutVar case NextTimeout m nextTimeout of NextTimeout m NoNextTimeout -> forall (m :: * -> *) a. MonadSTM m => STM m a retry NextTimeout ThreadId m tid Time deadline TVar m TimeoutState stateVar -> do -- We've picked up the next timeout so reset to empty forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m (NextTimeout m) nextTimeoutVar forall (m :: * -> *). NextTimeout m NoNextTimeout -- Update the current deadline var so the 'setNewTimer' can see what -- the current deadline we're waiting on is, so it can see if it -- ever needs to wake us up if it sets up a new timer with an earlier -- deadline. forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m Time curDeadlineVar Time deadline forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m Bool deadlineResetVar Bool False forall (m :: * -> *) a. Monad m => a -> m a return (ThreadId m tid, Time deadline, TVar m TimeoutState stateVar) -- | Three normal states of the timeout, plus one pseudo state. We use these -- states to provide proper communication between the action thread and the -- monitoring thread. -- -- The valid transitions are from 'TimeoutPending' to 'TimeoutCancelled', and -- from 'TimeoutPending' to 'TimeoutFired'. Additionally there is a transition -- from 'TimeoutFired' to 'TimeoutTerminated'. -- data TimeoutState = TimeoutPending | TimeoutCancelled | TimeoutFired | TimeoutTerminated -- | Exception used by 'withTimeoutSerial' to terminate the action when the -- timeout occurs. -- data TimeoutException = TimeoutException deriving Int -> TimeoutException -> ShowS [TimeoutException] -> ShowS TimeoutException -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TimeoutException] -> ShowS $cshowList :: [TimeoutException] -> ShowS show :: TimeoutException -> String $cshow :: TimeoutException -> String showsPrec :: Int -> TimeoutException -> ShowS $cshowsPrec :: Int -> TimeoutException -> ShowS Show instance Exception TimeoutException where toException :: TimeoutException -> SomeException toException = forall e. Exception e => e -> SomeException asyncExceptionToException fromException :: SomeException -> Maybe TimeoutException fromException = forall e. Exception e => SomeException -> Maybe e asyncExceptionFromException -- | The @timeout@ action we pass to the body in 'withTimeoutSerial'. -- timeout :: forall m a. (MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => MonitorState m -> DiffTime -> m a -> m (Maybe a) timeout :: forall (m :: * -> *) a. (MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => MonitorState m -> DiffTime -> m a -> m (Maybe a) timeout MonitorState m _ DiffTime delay m a action | DiffTime delay forall a. Ord a => a -> a -> Bool < DiffTime 0 = forall a. a -> Maybe a Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> m a action timeout MonitorState m _ DiffTime delay m a _ | DiffTime delay forall a. Eq a => a -> a -> Bool == DiffTime 0 = forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing timeout MonitorState m monitorState DiffTime delay m a action = -- We have to be very careful with async exceptions of course. forall (m :: * -> *) b. MonadMask m => ((forall a. m a -> m a) -> m b) -> m b mask forall a b. (a -> b) -> a -> b $ \forall a. m a -> m a restore -> do -- Set up the timeout and pass it over to the monitoring thread. -- This overwrites any previous timeout. ThreadId m tid <- forall (m :: * -> *). MonadThread m => m (ThreadId m) myThreadId TVar m TimeoutState timeoutStateVar <- forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a) newTVarIO TimeoutState TimeoutPending Time now <- forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime let deadline :: Time deadline = DiffTime -> Time -> Time addTime DiffTime delay Time now forall (m :: * -> *). MonadSTM m => MonitorState m -> ThreadId m -> Time -> TVar m TimeoutState -> m () setNewTimer MonitorState m monitorState ThreadId m tid Time deadline TVar m TimeoutState timeoutStateVar -- Now we unmask exceptions to run the action. If we get the timeout -- exception then we drop straight down to the outer 'catch' handler. a result <- forall a. m a -> m a restore m a action -- The action completed without us getting an exception, but there's -- a race condition with the monitoringThread to resolve. It could be -- just about to send us an async exception when we drop out of the -- masked region, or worse, outside of the scope of the 'catch' handler. -- -- So we must synchronise with the monitoringThread to ensure that we -- know positively one way or the other whether the timeout exception is -- or is not going to be sent. -- -- We do that by having both this thread and the monitoringThread do -- an STM tx on the timeoutStateVar, to atomically move it into the -- cancelled or fired state, depending on which thread gets there first. -- So this is a race, but it's a race where we can positively establish -- the outcome. If this thread gets there first we move it to the -- cancelled state. If the monitoringThread gets there first it moves it -- to the fired state. -- -- This STM tx is not blocking, so we're guaranteed not to be interrupted -- while we have async exceptions masked. -- Bool timeoutFired <- forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically forall a b. (a -> b) -> a -> b $ do TimeoutState st <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m TimeoutState timeoutStateVar case TimeoutState st of TimeoutState TimeoutFired -> forall (m :: * -> *) a. Monad m => a -> m a return Bool True TimeoutState TimeoutPending -> forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m TimeoutState timeoutStateVar TimeoutState TimeoutCancelled forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> forall (m :: * -> *) a. Monad m => a -> m a return Bool False TimeoutState _ -> forall (m :: * -> *) e a. (MonadSTM m, MonadThrow (STM m), Exception e) => e -> STM m a throwSTM TimeoutAssertion TimeoutImpossibleTimeoutState -- If we established that the monitoring thread is definitely not firing -- the timeout exception then we're done. -- -- If on the other hand we lost the race and the monitoring thread is -- about to come for us then it's crucial that we block and wait for -- our own demise, otherwise we could escape the scope of the outer -- 'catch' handler. -- -- We do that blocking wait with another STM tx on the timeoutStateVar, -- this time waiting for the monitoring thread to set it to the -- TimeoutTerminated state. But the monitoring thread only sets it to -- that state /after/ raising the async exception in this thread. So -- we will never actually reach that terminated state. -- -- Note also that blocking STM txs are points where async exceptions that -- are pending (due to our masked state) can be raised. Hence there is no -- need for us to unmask for this bit. -- if Bool -> Bool not Bool timeoutFired then forall (m :: * -> *) a. Monad m => a -> m a return (forall a. a -> Maybe a Just a result) else forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically forall a b. (a -> b) -> a -> b $ do TimeoutState st <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m TimeoutState timeoutStateVar case TimeoutState st of TimeoutState TimeoutFired -> forall (m :: * -> *) a. MonadSTM m => STM m a retry TimeoutState TimeoutTerminated -> forall (m :: * -> *) e a. (MonadSTM m, MonadThrow (STM m), Exception e) => e -> STM m a throwSTM TimeoutAssertion TimeoutImpossibleReachedTerminated TimeoutState _ -> forall (m :: * -> *) e a. (MonadSTM m, MonadThrow (STM m), Exception e) => e -> STM m a throwSTM TimeoutAssertion TimeoutImpossibleTimeoutState forall (m :: * -> *) e a. (MonadCatch m, Exception e) => m a -> (e -> m a) -> m a `catch` \TimeoutException TimeoutException -> forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing monitoringThread :: (MonadFork m, MonadSTM m, MonadMonotonicTime m, MonadTimer m, MonadThrow (STM m)) => MonitorState m -> m () monitoringThread :: forall (m :: * -> *). (MonadFork m, MonadSTM m, MonadMonotonicTime m, MonadTimer m, MonadThrow (STM m)) => MonitorState m -> m () monitoringThread monitorState :: MonitorState m monitorState@MonitorState{TVar m Bool deadlineResetVar :: TVar m Bool deadlineResetVar :: forall (m :: * -> *). MonitorState m -> TVar m Bool deadlineResetVar} = do ThreadId m threadId <- forall (m :: * -> *). MonadThread m => m (ThreadId m) myThreadId forall (m :: * -> *). MonadThread m => ThreadId m -> String -> m () labelThread ThreadId m threadId String "timeout-monitoring-thread" forall (f :: * -> *) a b. Applicative f => f a -> f b forever forall a b. (a -> b) -> a -> b $ do -- Grab the next timeout to consider (ThreadId m tid, Time deadline, TVar m TimeoutState timeoutStateVar) <- forall (m :: * -> *). MonadSTM m => MonitorState m -> m (ThreadId m, Time, TVar m TimeoutState) readNextTimeout MonitorState m monitorState -- Work out how long to wait for and do so. For already-expired timeouts -- this is in the past, leading to a negative delay. Time now <- forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime let delay :: DiffTime delay = Time -> Time -> DiffTime diffTime Time deadline Time now forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (DiffTime delay forall a. Ord a => a -> a -> Bool > DiffTime 0) forall a b. (a -> b) -> a -> b $ do TVar m Bool timerExpired <- forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool) registerDelay DiffTime delay forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically forall a b. (a -> b) -> a -> b $ -- Wait for either the timer to expire (forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m Bool timerExpired forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *). MonadSTM m => Bool -> STM m () check) forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a `orElse` -- or to be notified that the timer deadline moved backwards (forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m Bool deadlineResetVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *). MonadSTM m => Bool -> STM m () check) -- Having woken up, we check to see if we need to send the timeout -- exception. If the timeoutStateVar we grabbed is still in the pending -- state after we have waited for the deadline then clearly it went over -- and we will send the timeout exception. -- -- As described above, there is a race between the timeout and the action -- completing and we have to establish which happens first. So this is -- the other side of that race. Here if we win the race we move to the -- TimeoutFired state. Bool cancelled <- forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically forall a b. (a -> b) -> a -> b $ do TimeoutState st <- forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m TimeoutState timeoutStateVar case TimeoutState st of TimeoutState TimeoutPending -> forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m TimeoutState timeoutStateVar TimeoutState TimeoutFired forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> forall (m :: * -> *) a. Monad m => a -> m a return Bool False TimeoutState TimeoutCancelled -> forall (m :: * -> *) a. Monad m => a -> m a return Bool True TimeoutState _ -> forall (m :: * -> *) e a. (MonadSTM m, MonadThrow (STM m), Exception e) => e -> STM m a throwSTM TimeoutAssertion TimeoutImpossibleMonitorState -- If it turns out that the timeout was cancelled before the timeout -- expired then we do nothing and go back to the start. -- -- But if it was not cancelled then we will send it the asynchronous -- exception. As described above there is a corner case where we won -- the race very narrowly and so the other thread has to block and wait -- for us to send the asynchronous exception. The way we make it block to -- wait for us -- without any concern that it might be classed as being -- blocked indefinitely -- is to make it wait for a state change that we -- will only perform /after/ we have raised the exception in the target -- thread. -- forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool cancelled forall a b. (a -> b) -> a -> b $ do forall (m :: * -> *) e. (MonadFork m, Exception e) => ThreadId m -> e -> m () throwTo ThreadId m tid TimeoutException TimeoutException -- Set the state the other thread may be waiting for /after/ raising the -- exception in the other thread. forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m TimeoutState timeoutStateVar TimeoutState TimeoutTerminated -- | These are all \"impossible\" errors. -- data TimeoutAssertion = TimeoutImpossibleReachedTerminated | TimeoutImpossibleTimeoutState | TimeoutImpossibleMonitorState deriving Int -> TimeoutAssertion -> ShowS [TimeoutAssertion] -> ShowS TimeoutAssertion -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TimeoutAssertion] -> ShowS $cshowList :: [TimeoutAssertion] -> ShowS show :: TimeoutAssertion -> String $cshow :: TimeoutAssertion -> String showsPrec :: Int -> TimeoutAssertion -> ShowS $cshowsPrec :: Int -> TimeoutAssertion -> ShowS Show instance Exception TimeoutAssertion