{-# LANGUAGE OverloadedStrings #-}

-- | RTS thread labels for an eventlog, ThreadScope session or @ghc-debug@ dump.
module Arbiter.Core.Threads
  ( labelArbiterThread
  ) where

import Control.Concurrent (myThreadId)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Foldable (toList)
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Conc.Sync (labelThread)

-- | Label the calling thread @arbiter:role[:queue]@. For long-lived threads only.
labelArbiterThread :: (MonadIO m) => Text -> Maybe Text -> m ()
labelArbiterThread :: forall (m :: * -> *). MonadIO m => Text -> Maybe Text -> m ()
labelArbiterThread Text
role Maybe Text
mQueue = 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 (T.unpack (T.intercalate ":" ("arbiter" : slug role : toList mQueue)))
  where
    slug :: Text -> Text
slug = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
" " Text
"-" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower