diff --git a/.github/workflows/github-page.yml b/.github/workflows/github-page.yml index a2db413b..e36240c8 100644 --- a/.github/workflows/github-page.yml +++ b/.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 diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index f34cc62a..8fc201a1 100644 --- a/.github/workflows/haskell.yml +++ b/.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" diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index 23c4e26b..5dd17399 100644 --- a/io-classes/CHANGELOG.md +++ b/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 diff --git a/io-classes/src/Control/Monad/Class/MonadFork.hs b/io-classes/src/Control/Monad/Class/MonadFork.hs index 0bc80518..6a67f9f6 100644 --- a/io-classes/src/Control/Monad/Class/MonadFork.hs +++ b/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) diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index 99982ad2..9fd7db5c 100644 --- a/io-sim/CHANGELOG.md +++ b/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` diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index 2eb8e3f0..0e72298e 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/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 diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs index 71ccb154..50361c99 100644 --- a/io-sim/src/Control/Monad/IOSim/Types.hs +++ b/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 diff --git a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs index d361e417..ea001220 100644 --- a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs +++ b/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