Added threadLabel to MonadThread

.github/workflows/github-page.yml

@@ -1,4 +1,4 @@
-name: "Haddock documentation"
+name: Haddocks
 
 on:
   schedule:
@@ -7,7 +7,7 @@ on:
 
 jobs:
   haddocks:
-    name: "Haddocks"
+    name: Haddocks
 
     runs-on: ${{ matrix.os }}
 
@@ -18,7 +18,7 @@ jobs:
     strategy:
       fail-fast: false
       matrix:
-        ghc: ["9.10.1"]
+        ghc: ["9.10"]
         os: [ubuntu-latest]
 
     permissions:
@@ -54,13 +54,10 @@ jobs:
     - name: Update Hackage index
       run: cabal update
 
-    - name: Build plan
-      run: cabal build --dry-run --enable-tests all
-
     - name: Run pandoc
-      run: pandoc --from=markdown_github --to=haddock --output=README.haddock io-classes/README.md io-sim/README.md
+      run: pandoc --from=gfm --to=haddock --output=README.haddock io-classes/README.md io-sim/README.md
 
-    - name: Build Haddock documentation 🔧
+    - name: Build haddocks 🔧
       run: |
         cabal haddock-project --prologue=README.haddock --hackage all
 

.github/workflows/haskell.yml

@@ -27,7 +27,7 @@ jobs:
       id: setup-haskell
       with:
         ghc-version: ${{ matrix.ghc }}
-        cabal-version: "3.10.3.0"
+        cabal-version: "3.12.1.0"
 
     - name: Install LLVM (macOS)
       if: runner.os == 'macOS' && matrix.ghc == '8.10'
@@ -85,8 +85,7 @@ jobs:
 
     - name: Build dependencies
       run: |
-        cabal build --only-dependencies io-classes
-        cabal build --only-dependencies io-sim
+        cabal build --only-dependencies all
 
     - uses: actions/cache/save@v4
       name: "Save cabal store"

io-classes/CHANGELOG.md

@@ -1,5 +1,11 @@
 # Revsion history of io-classes
 
+### next version
+
+### Breaking changes
+
+* Added `threadLabel` to `MonadThread`
+
 ### 1.7.0.0
 
 ### Breaking changes

io-classes/src/Control/Monad/Class/MonadFork.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -18,7 +19,7 @@ import Control.Exception (AsyncException (ThreadKilled), Exception,
            SomeException)
 import Control.Monad.Reader (ReaderT (..), lift)
 import Data.Kind (Type)
-import GHC.Conc.Sync qualified as IO (labelThread)
+import GHC.Conc.Sync qualified as IO
 
 
 class (Monad m, Eq   (ThreadId m),
@@ -30,6 +31,11 @@ class (Monad m, Eq   (ThreadId m),
   myThreadId     :: m (ThreadId m)
   labelThread    :: ThreadId m -> String -> m ()
 
+  -- | Requires ghc-9.6.1 or newer.
+  --
+  -- @since 1.8.0.0
+  threadLabel    :: ThreadId m -> m (Maybe String)
+
 -- | Apply the label to the current thread
 labelThisThread :: MonadThread m => String -> m ()
 labelThisThread label = myThreadId >>= \tid -> labelThread tid label
@@ -53,6 +59,11 @@ instance MonadThread IO where
   type ThreadId IO = IO.ThreadId
   myThreadId   = IO.myThreadId
   labelThread  = IO.labelThread
+#if MIN_VERSION_base(4,18,0)
+  threadLabel = IO.threadLabel
+#else
+  threadLabel = \_ -> pure Nothing
+#endif
 
 instance MonadFork IO where
   forkIO           = IO.forkIO
@@ -67,6 +78,7 @@ instance MonadThread m => MonadThread (ReaderT r m) where
   type ThreadId (ReaderT r m) = ThreadId m
   myThreadId      = lift myThreadId
   labelThread t l = lift (labelThread t l)
+  threadLabel     = lift . threadLabel
 
 instance MonadFork m => MonadFork (ReaderT e m) where
   forkIO (ReaderT f)   = ReaderT $ \e -> forkIO (f e)

io-sim/CHANGELOG.md

@@ -1,5 +1,9 @@
 # Revision history of io-sim
 
+## next version
+
+- Support `threadLabel` (`io-classes-1.8`)
+
 ## 1.6.0.0
 
 - Upgraded to `io-classes-1.6.0.0`

io-sim/src/Control/Monad/IOSim/Internal.hs

@@ -547,6 +547,13 @@ schedule !thread@Thread{
                            , threadLabel   = Just l }
       schedule thread' simstate
 
+    GetThreadLabel tid' k -> do
+      let tlbl' | tid' == tid = tlbl
+                | otherwise   = tid' `Map.lookup` threads
+                            >>= threadLabel
+          thread' = thread { threadControl = ThreadControl (k tlbl') ctl }
+      schedule thread' simstate
+
     LabelThread tid' l k -> do
       let thread'  = thread { threadControl = ThreadControl k ctl }
           threads' = Map.adjust (\t -> t { threadLabel = Just l }) tid' threads

io-sim/src/Control/Monad/IOSim/Types.hs

@@ -186,9 +186,10 @@ data SimA s a where
                   SimA s a -> (e -> SimA s a) -> (a -> SimA s b) -> SimA s b
   Evaluate     :: a -> (a -> SimA s b) -> SimA s b
 
-  Fork         :: IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b
-  GetThreadId  :: (IOSimThreadId -> SimA s b) -> SimA s b
-  LabelThread  :: IOSimThreadId -> String -> SimA s b -> SimA s b
+  Fork           :: IOSim s () -> (IOSimThreadId -> SimA s b) -> SimA s b
+  GetThreadId    :: (IOSimThreadId -> SimA s b) -> SimA s b
+  LabelThread    :: IOSimThreadId -> String -> SimA s b -> SimA s b
+  GetThreadLabel :: IOSimThreadId -> (Maybe String -> SimA s b) -> SimA s b
 
   Atomically   :: STM  s a -> (a -> SimA s b) -> SimA s b
 
@@ -469,6 +470,7 @@ instance MonadThread (IOSim s) where
   type ThreadId (IOSim s) = IOSimThreadId
   myThreadId       = IOSim $ oneShot $ \k -> GetThreadId k
   labelThread t l  = IOSim $ oneShot $ \k -> LabelThread t l (k ())
+  threadLabel t    = IOSim $ oneShot $ \k -> GetThreadLabel t k
 
 instance MonadFork (IOSim s) where
   forkIO task        = IOSim $ oneShot $ \k -> Fork task k
@@ -815,10 +817,8 @@ ppSimEvent timeWidth tidWidth tLabelWidth SimEvent {seTime = Time time, seThread
            tidWidth
            (ppIOSimThreadId seThreadId)
            tLabelWidth
-           threadLabel
+           (fromMaybe "" seThreadLabel)
            (ppSimEventType seType)
-  where
-    threadLabel = fromMaybe "" seThreadLabel
 
 ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime = Time time, seThreadId, seStep, seThreadLabel, seType} =
     printf "%-*s - %-*s %-*s - %s"
@@ -827,10 +827,8 @@ ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime = Time time, seThr
            tidWidth
            (ppStepId (seThreadId, seStep))
            tLableWidth
-           threadLabel
+           (fromMaybe "" seThreadLabel)
            (ppSimEventType seType)
-  where
-    threadLabel = fromMaybe "" seThreadLabel
 
 ppSimEvent _ _ _ (SimRacesFound controls) =
     "RacesFound "++show controls

io-sim/src/Control/Monad/IOSimPOR/Internal.hs

@@ -703,6 +703,13 @@ schedule thread@Thread{
                            , threadLabel   = Just l }
       schedule thread' simstate
 
+    GetThreadLabel tid' k -> do
+      let tlbl' | tid' == tid = tlbl
+                | otherwise   = tid' `Map.lookup` threads
+                            >>= threadLabel
+          thread' = thread { threadControl = ThreadControl (k tlbl') ctl }
+      schedule thread' simstate
+
     LabelThread tid' l k -> do
       let thread'  = thread { threadControl = ThreadControl k ctl }
           threads' = Map.adjust (\t -> t { threadLabel = Just l }) tid' threads