module Network.GRPC.Util.GHC (
    -- * Thread labelling
    ThreadLabel
  , labelThisThread
  , forkLabelled
  , asyncLabelled
  ) where

import Control.Concurrent.Async
import Control.Exception
import Control.Monad.IO.Class
import GHC.Conc

{-------------------------------------------------------------------------------
  Thread labelling
-------------------------------------------------------------------------------}

type ThreadLabel = String

labelThisThread :: MonadIO m => ThreadLabel -> m ()
labelThisThread :: forall (m :: * -> *). MonadIO m => ThreadLabel -> m ()
labelThisThread ThreadLabel
label = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    tid <- IO ThreadId
myThreadId
    labelThread tid label

forkLabelled :: ThreadLabel -> IO () -> IO ThreadId
forkLabelled :: ThreadLabel -> IO () -> IO ThreadId
forkLabelled ThreadLabel
label IO ()
io =
    IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
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 -> do
      ThreadLabel -> IO ()
forall (m :: * -> *). MonadIO m => ThreadLabel -> m ()
labelThisThread ThreadLabel
label
      IO () -> IO ()
forall a. IO a -> IO a
unmask IO ()
io

asyncLabelled :: ThreadLabel -> IO a -> IO (Async a)
asyncLabelled :: forall a. ThreadLabel -> IO a -> IO (Async a)
asyncLabelled ThreadLabel
label IO a
io =
    IO (Async a) -> IO (Async a)
forall a. IO a -> IO a
mask_ (IO (Async a) -> IO (Async a)) -> IO (Async a) -> IO (Async a)
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO a) -> IO (Async a)
forall a. ((forall a. IO a -> IO a) -> IO a) -> IO (Async a)
asyncWithUnmask (((forall a. IO a -> IO a) -> IO a) -> IO (Async a))
-> ((forall a. IO a -> IO a) -> IO a) -> IO (Async a)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
      ThreadLabel -> IO ()
forall (m :: * -> *). MonadIO m => ThreadLabel -> m ()
labelThisThread ThreadLabel
label
      IO a -> IO a
forall a. IO a -> IO a
unmask IO a
io