{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | A thread manager including a time manager.
--   The manager has responsibility to kill managed threads.
--
-- Because this is based on the accompanying "System.TimeManager" module,
-- the same caveats apply:
--
--   * Only works for GHC.
--   * Only works with a threaded runtime.
--   * Users of older versions should check the current semantics.
--   * Using 32-bit systems means the max timeout is @'maxBound' :: Int@
--     (2147483647) microseconds, which is less than 36 minutes.
--   * Using the same 'Handle' in different threads might cause issues in some
--     edge cases. (i.e. using cancel/pause in one thread, and resume in another)
module System.ThreadManager (
    ThreadManager,
    newThreadManager,
    stopAfter,
    stopAfterWithResult,
    KilledByThreadManager (..),

    -- * Fork
    forkManaged,
    forkManagedFinally,
    forkManagedUnmask,
    forkManagedTimeout,
    forkManagedTimeoutFinally,

    -- * Synchronization
    waitUntilAllGone,
    isAllGone,

    -- * Re-exports
    T.Manager,
    withHandle,
    T.Handle,
    T.tickle,
    T.pause,
    T.resume,
) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (Exception (..), SomeException (..))
import qualified Control.Exception as E
import Control.Monad (unless, void)
import Data.Foldable (forM_)
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import GHC.Conc.Sync (labelThread)
#if __GLASGOW_HASKELL__ >= 908
import GHC.Conc.Sync (fromThreadId)
#endif
import System.Mem.Weak (Weak, deRefWeak)
import qualified System.TimeManager as T

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

-- | Manager to manage the thread and the timer.
data ThreadManager = ThreadManager T.Manager (TVar ManagedThreads)

type Key = Word64
type ManagedThreads = Map Key ManagedThread

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

-- 'IORef' prevents race between WAI TimeManager (TimeoutThread)
-- and stopAfter (KilledByThreadManager).
-- It is initialized with 'False' and turned into 'True' when locked.
-- The winner can throw an asynchronous exception.
data ManagedThread = ManagedThread (Weak ThreadId) (IORef Bool)

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

-- | Create a thread manager.
--
-- To create a 'ThreadManager', you will first have to create a
-- 'T.Manager' from the "System.TimeManager" module.
--
-- You can use either 'System.TimeManager.initialize' or 'System.TimeManager.withManager'.
newThreadManager :: T.Manager -> IO ThreadManager
newThreadManager :: Manager -> IO ThreadManager
newThreadManager Manager
timmgr = Manager -> TVar ManagedThreads -> ThreadManager
ThreadManager Manager
timmgr (TVar ManagedThreads -> ThreadManager)
-> IO (TVar ManagedThreads) -> IO ThreadManager
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ManagedThreads -> IO (TVar ManagedThreads)
forall a. a -> IO (TVar a)
newTVarIO ManagedThreads
forall k a. Map k a
Map.empty

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

-- | An exception used internally to kill a managed thread.
data KilledByThreadManager = KilledByThreadManager (Maybe SomeException)
    deriving (Int -> KilledByThreadManager -> ShowS
[KilledByThreadManager] -> ShowS
KilledByThreadManager -> String
(Int -> KilledByThreadManager -> ShowS)
-> (KilledByThreadManager -> String)
-> ([KilledByThreadManager] -> ShowS)
-> Show KilledByThreadManager
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KilledByThreadManager -> ShowS
showsPrec :: Int -> KilledByThreadManager -> ShowS
$cshow :: KilledByThreadManager -> String
show :: KilledByThreadManager -> String
$cshowList :: [KilledByThreadManager] -> ShowS
showList :: [KilledByThreadManager] -> ShowS
Show)

instance Exception KilledByThreadManager where
    toException :: KilledByThreadManager -> SomeException
toException = KilledByThreadManager -> SomeException
forall e. Exception e => e -> SomeException
E.asyncExceptionToException
    fromException :: SomeException -> Maybe KilledByThreadManager
fromException = SomeException -> Maybe KilledByThreadManager
forall e. Exception e => SomeException -> Maybe e
E.asyncExceptionFromException

-- | Stopping the manager.
--
-- @
-- stopAfter threadManager action cleanup
-- @
--
-- The action is run in the scope of an exception handler that catches all
-- exceptions (including asynchronous ones); this allows the cleanup handler
-- to cleanup in all circumstances. If an exception is caught, it is rethrown
-- after the cleanup is complete.
stopAfter :: ThreadManager -> IO a -> (Maybe SomeException -> IO ()) -> IO a
stopAfter :: forall a.
ThreadManager -> IO a -> (Maybe SomeException -> IO ()) -> IO a
stopAfter ThreadManager
mgr IO a
action Maybe SomeException -> IO ()
cleanup =
    ThreadManager -> IO a -> (Either SomeException a -> IO a) -> IO a
forall a b.
ThreadManager -> IO a -> (Either SomeException a -> IO b) -> IO b
stopAfterWithResult ThreadManager
mgr IO a
action ((Either SomeException a -> IO a) -> IO a)
-> (Either SomeException a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Either SomeException a
mResult ->
        case Either SomeException a
mResult of
            Left SomeException
err -> do
                Maybe SomeException -> IO ()
cleanup (SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
err)
                SomeException -> IO a
forall e a. Exception e => e -> IO a
E.throwIO SomeException
err
            Right a
result -> do
                Maybe SomeException -> IO ()
cleanup Maybe SomeException
forall a. Maybe a
Nothing
                a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

-- | Generalization of 'stopAfter' where the cleanup handler is allowed to construct the final result
--
-- Unlike in 'stopAfter', if an exception is thrown, it is not re-thrown after the cleanup
-- handler completes; the cleanup handler itself can decide to rethrow it or compute a result.
--
-- @since 0.3.2
stopAfterWithResult
    :: ThreadManager -> IO a -> (Either SomeException a -> IO b) -> IO b
stopAfterWithResult :: forall a b.
ThreadManager -> IO a -> (Either SomeException a -> IO b) -> IO b
stopAfterWithResult (ThreadManager Manager
_timmgr TVar ManagedThreads
var) IO a
action Either SomeException a -> IO b
cleanup = do
    ((forall a. IO a -> IO a) -> IO b) -> IO b
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (((forall a. IO a -> IO a) -> IO b) -> IO b)
-> ((forall a. IO a -> IO a) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
        Either SomeException a
ma <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ IO a -> IO a
forall a. IO a -> IO a
unmask IO a
action
        ManagedThreads
m <- STM ManagedThreads -> IO ManagedThreads
forall a. STM a -> IO a
atomically (STM ManagedThreads -> IO ManagedThreads)
-> STM ManagedThreads -> IO ManagedThreads
forall a b. (a -> b) -> a -> b
$ do
            ManagedThreads
m0 <- TVar ManagedThreads -> STM ManagedThreads
forall a. TVar a -> STM a
readTVar TVar ManagedThreads
var
            TVar ManagedThreads -> ManagedThreads -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar ManagedThreads
var ManagedThreads
forall k a. Map k a
Map.empty
            ManagedThreads -> STM ManagedThreads
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ManagedThreads
m0
        let ths :: [ManagedThread]
ths = ManagedThreads -> [ManagedThread]
forall k a. Map k a -> [a]
Map.elems ManagedThreads
m
            er :: Maybe SomeException
er = (SomeException -> Maybe SomeException)
-> (a -> Maybe SomeException)
-> Either SomeException a
-> Maybe SomeException
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (Maybe SomeException -> a -> Maybe SomeException
forall a b. a -> b -> a
const Maybe SomeException
forall a. Maybe a
Nothing) Either SomeException a
ma
            ex :: KilledByThreadManager
ex = Maybe SomeException -> KilledByThreadManager
KilledByThreadManager Maybe SomeException
er
        [ManagedThread] -> (ManagedThread -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ManagedThread]
ths ((ManagedThread -> IO ()) -> IO ())
-> (ManagedThread -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ManagedThread Weak ThreadId
wtid IORef Bool
ref) -> Weak ThreadId -> IORef Bool -> KilledByThreadManager -> IO ()
forall e. Exception e => Weak ThreadId -> IORef Bool -> e -> IO ()
lockAndKill Weak ThreadId
wtid IORef Bool
ref KilledByThreadManager
ex
        Either SomeException a -> IO b
cleanup Either SomeException a
ma

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

-- | Fork a managed thread.
--
-- This guarantees that the thread ID is added to the manager's queue before
-- the thread starts, and is removed again when the thread terminates
-- (normally or abnormally).
forkManaged
    :: ThreadManager
    -> String
    -- ^ Thread name
    -> IO ()
    -- ^ Action
    -> IO ()
forkManaged :: ThreadManager -> String -> IO () -> IO ()
forkManaged ThreadManager
mgr String
label IO ()
io =
    ThreadManager
-> String -> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forkManagedUnmask ThreadManager
mgr String
label (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
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

-- | Like 'forkManaged', but run action with exceptions masked
forkManagedUnmask
    :: ThreadManager
    -> String
    -- ^ Thread name
    -> ((forall x. IO x -> IO x) -> IO ())
    -- ^ Action with unmask argument
    -> IO ()
forkManagedUnmask :: ThreadManager
-> String -> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forkManagedUnmask (ThreadManager Manager
_timmgr TVar ManagedThreads
var) String
label (forall a. IO a -> IO a) -> IO ()
io =
    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
$ IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
E.mask_ (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
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 -> (KilledByThreadManager -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle KilledByThreadManager -> IO ()
ignore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
labelMe String
label
        IO (Key, Weak ThreadId, IORef Bool)
-> ((Key, Weak ThreadId, IORef Bool) -> IO ())
-> ((Key, Weak ThreadId, IORef Bool) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (TVar ManagedThreads -> IO (Key, Weak ThreadId, IORef Bool)
setup TVar ManagedThreads
var) (TVar ManagedThreads -> (Key, Weak ThreadId, IORef Bool) -> IO ()
clear TVar ManagedThreads
var) (((Key, Weak ThreadId, IORef Bool) -> IO ()) -> IO ())
-> ((Key, Weak ThreadId, IORef Bool) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Key, Weak ThreadId, IORef Bool)
_ -> (forall a. IO a -> IO a) -> IO ()
io IO x -> IO x
forall a. IO a -> IO a
unmask

-- | Fork a managed thread with a handle created by a timeout manager.
forkManagedTimeout
    :: ThreadManager
    -> String
    -- ^ Thread name
    -> (T.Handle -> IO ())
    -- ^ Action with timeout handle
    -> IO ()
forkManagedTimeout :: ThreadManager -> String -> (Handle -> IO ()) -> IO ()
forkManagedTimeout (ThreadManager Manager
timmgr TVar ManagedThreads
var) String
label Handle -> IO ()
io =
    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
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
labelMe String
label
        IO (Key, Weak ThreadId, IORef Bool)
-> ((Key, Weak ThreadId, IORef Bool) -> IO ())
-> ((Key, Weak ThreadId, IORef Bool) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (TVar ManagedThreads -> IO (Key, Weak ThreadId, IORef Bool)
setup TVar ManagedThreads
var) (TVar ManagedThreads -> (Key, Weak ThreadId, IORef Bool) -> IO ()
clear TVar ManagedThreads
var) (((Key, Weak ThreadId, IORef Bool) -> IO ()) -> IO ())
-> ((Key, Weak ThreadId, IORef Bool) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Key
_n, Weak ThreadId
wtid, IORef Bool
ref) ->
            (KilledByThreadManager -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle KilledByThreadManager -> IO ()
ignore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Manager -> IO () -> (Handle -> IO ()) -> IO ()
forall a. Manager -> IO () -> (Handle -> IO a) -> IO a
T.withHandle Manager
timmgr (Weak ThreadId -> IORef Bool -> KilledByThreadManager -> IO ()
forall e. Exception e => Weak ThreadId -> IORef Bool -> e -> IO ()
lockAndKill Weak ThreadId
wtid IORef Bool
ref KilledByThreadManager
ex) Handle -> IO ()
io
  where
    ex :: KilledByThreadManager
ex = Maybe SomeException -> KilledByThreadManager
KilledByThreadManager Maybe SomeException
forall a. Maybe a
Nothing

-- | Fork a managed thread with a cleanup function.
forkManagedFinally
    :: ThreadManager
    -> String
    -- ^ Thread name
    -> IO ()
    -- ^ Action
    -> IO ()
    -- ^ Cleanup function
    -> IO ()
forkManagedFinally :: ThreadManager -> String -> IO () -> IO () -> IO ()
forkManagedFinally ThreadManager
mgr String
label IO ()
io IO ()
final =
    ThreadManager
-> String -> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forkManagedUnmask ThreadManager
mgr String
label (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore ->
        IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO () -> IO ()
forall a. IO a -> IO a
restore IO ()
io) IO (Either SomeException ())
-> (Either SomeException () -> 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
>>= \(Either SomeException ()
_ :: Either E.SomeException ()) -> IO ()
final

-- | Fork a managed thread with a handle created by a timeout manager
-- and with a cleanup function.
forkManagedTimeoutFinally
    :: ThreadManager
    -> String
    -- ^ Thread name
    -> (T.Handle -> IO ())
    -- ^ Action with timeout handle
    -> IO ()
    -- ^ Cleanup function
    -> IO ()
forkManagedTimeoutFinally :: ThreadManager -> String -> (Handle -> IO ()) -> IO () -> IO ()
forkManagedTimeoutFinally ThreadManager
mgr String
label Handle -> IO ()
io IO ()
final = ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
E.mask (((forall a. IO a -> IO a) -> IO ()) -> IO ())
-> ((forall a. IO a -> IO a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore ->
    ThreadManager -> String -> (Handle -> IO ()) -> IO ()
forkManagedTimeout ThreadManager
mgr String
label ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
th ->
        IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
io Handle
th) IO (Either SomeException ())
-> (Either SomeException () -> 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
>>= \(Either SomeException ()
_ :: Either E.SomeException ()) -> IO ()
final

setup :: TVar (Map Key ManagedThread) -> IO (Key, Weak ThreadId, IORef Bool)
setup :: TVar ManagedThreads -> IO (Key, Weak ThreadId, IORef Bool)
setup TVar ManagedThreads
var = do
    (Weak ThreadId
wtid, Key
n) <- IO (Weak ThreadId, Key)
myWeakThreadId
    IORef Bool
ref <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    let ent :: ManagedThread
ent = Weak ThreadId -> IORef Bool -> ManagedThread
ManagedThread Weak ThreadId
wtid IORef Bool
ref
    -- asking to throw KilledByThreadManager to me
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar ManagedThreads -> (ManagedThreads -> ManagedThreads) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar ManagedThreads
var ((ManagedThreads -> ManagedThreads) -> STM ())
-> (ManagedThreads -> ManagedThreads) -> STM ()
forall a b. (a -> b) -> a -> b
$ Key -> ManagedThread -> ManagedThreads -> ManagedThreads
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Key
n ManagedThread
ent
    (Key, Weak ThreadId, IORef Bool)
-> IO (Key, Weak ThreadId, IORef Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Key
n, Weak ThreadId
wtid, IORef Bool
ref)

lockAndKill :: Exception e => Weak ThreadId -> IORef Bool -> e -> IO ()
lockAndKill :: forall e. Exception e => Weak ThreadId -> IORef Bool -> e -> IO ()
lockAndKill Weak ThreadId
wtid IORef Bool
ref e
e = do
    Bool
alreadyLocked <- IORef Bool -> (Bool -> (Bool, Bool)) -> IO Bool
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Bool
ref (\Bool
b -> (Bool
True, Bool
b)) -- try to lock
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
alreadyLocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe ThreadId
mtid <- Weak ThreadId -> IO (Maybe ThreadId)
forall v. Weak v -> IO (Maybe v)
deRefWeak Weak ThreadId
wtid
        case Maybe ThreadId
mtid of
            Maybe ThreadId
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just ThreadId
tid -> ThreadId -> e -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
E.throwTo ThreadId
tid e
e

clear
    :: TVar (Map Key ManagedThread)
    -> (Key, Weak ThreadId, IORef Bool)
    -> IO ()
clear :: TVar ManagedThreads -> (Key, Weak ThreadId, IORef Bool) -> IO ()
clear TVar ManagedThreads
var (Key
n, Weak ThreadId
_, IORef Bool
_) = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar ManagedThreads -> (ManagedThreads -> ManagedThreads) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar ManagedThreads
var ((ManagedThreads -> ManagedThreads) -> STM ())
-> (ManagedThreads -> ManagedThreads) -> STM ()
forall a b. (a -> b) -> a -> b
$ Key -> ManagedThreads -> ManagedThreads
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Key
n

ignore :: KilledByThreadManager -> IO ()
ignore :: KilledByThreadManager -> IO ()
ignore (KilledByThreadManager Maybe SomeException
_) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Wait until all managed threads are finished.
waitUntilAllGone :: ThreadManager -> IO ()
waitUntilAllGone :: ThreadManager -> IO ()
waitUntilAllGone ThreadManager
tm =
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
        ThreadManager -> STM Bool
isAllGone ThreadManager
tm STM Bool -> (Bool -> STM ()) -> STM ()
forall a b. STM a -> (a -> STM b) -> STM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> STM ()
check

-- | STM action that checks if all managed threads are finished.
isAllGone :: ThreadManager -> STM Bool
isAllGone :: ThreadManager -> STM Bool
isAllGone (ThreadManager Manager
_timmgr TVar ManagedThreads
var) =
    ManagedThreads -> Bool
forall k a. Map k a -> Bool
Map.null (ManagedThreads -> Bool) -> STM ManagedThreads -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar ManagedThreads -> STM ManagedThreads
forall a. TVar a -> STM a
readTVar TVar ManagedThreads
var

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

myWeakThreadId :: IO (Weak ThreadId, Key)
myWeakThreadId :: IO (Weak ThreadId, Key)
myWeakThreadId = do
    ThreadId
tid <- IO ThreadId
myThreadId
    Weak ThreadId
wtid <- ThreadId -> IO (Weak ThreadId)
mkWeakThreadId ThreadId
tid
    let n :: Key
n = ThreadId -> Key
fromThreadId ThreadId
tid
    (Weak ThreadId, Key) -> IO (Weak ThreadId, Key)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Weak ThreadId
wtid, Key
n)

labelMe :: String -> IO ()
labelMe :: String -> IO ()
labelMe String
l = do
    ThreadId
tid <- IO ThreadId
myThreadId
    ThreadId -> String -> IO ()
labelThread ThreadId
tid String
l

-- | Registering a 'T.TimeoutAction' and unregister its 'T.Handle'
--   when the body action is finished.
withHandle
    :: ThreadManager -> T.TimeoutAction -> (T.Handle -> IO a) -> IO a
withHandle :: forall a. ThreadManager -> IO () -> (Handle -> IO a) -> IO a
withHandle (ThreadManager Manager
timmgr TVar ManagedThreads
_) = Manager -> IO () -> (Handle -> IO a) -> IO a
forall a. Manager -> IO () -> (Handle -> IO a) -> IO a
T.withHandle Manager
timmgr

#if __GLASGOW_HASKELL__ < 908
fromThreadId :: ThreadId -> Word64
fromThreadId tid = read (drop 9 $ show tid)
#endif