diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,26 @@ # Revsion history of io-classes +### 1.8.0.0 + +### Breaking changes + +* Provided `MonadTraceMVar` +* Renamed `InspectMonad` to `InspectMonadSTM` +* Added `threadLabel` to `MonadThread` +* Added `MonadLabelledMVar` class. +* Added `labelMVar` to `Control.Concurrent.Class.MonadMVar.Strict` +* Added `debugTraceTVar`, `debugTraceTMVar`, `debugTraceTVarIO`, `debugTraceTMVarIO` for `Show`-based tracing. +* `MonadEvaluate` is not a supper-class of `MonadThrow` anymore. +* Moved all `MonadMaskingState` methods to `MonadMask`. `MonadMaskingState` is + available but deprecated, it will be removed in one of the future releases. +* `io-classes:mtl` instances support the extended `MonadMask` instance. + +### Non-breaking changes + +* Added monad transformer instances for `MonadInspectSTM` & `MonadTraceSTM` + type classes. +* Support ghc-9.12 + ### 1.7.0.0 ### Breaking changes diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# IO Monad Class Hierarchy: `io-classes` +# IO Monad Class Hierarchy: `io-classes` package This package provides a monad class hierarchy which is an interface for both the [`io-sim`] and [`IO`] monads. It was developed with the following @@ -21,7 +21,7 @@ microseconds represented as `Int` as in `base`) - cancellable timeouts. -* [`io-classes:io-classes-mtl`](https://input-output-hk.github.io/io-sim/io-classes/io-classes-mtl/index.html): +* [`io-classes:mtl`](https://input-output-hk.github.io/io-sim/io-classes/mtl/index.html): MTL instances. [`io-classes:strict-stm`](https://input-output-hk.github.io/io-sim/io-classes/strict-stm/index.html) @@ -63,6 +63,8 @@ monotonic time as well as exposes 32-bit safe timer API (on 32-bit systems time in microseconds represented as an `Int` can only hold timeouts of ~35 minutes). +[`si-timers`] sublibrary provides cancellable timers API, see [`registerDelayCancellable`]. + `Control.Monad.Class.MonadTimer.NonStandard.MonadTimeout` provides a low-level timeout abstraction. On systems that support a native timer manager, it's used to implement its API, which is very efficient even for low-latency timeouts. @@ -77,25 +79,38 @@ ## Software Transactional Memory API -We provide two interfaces to `stm` API: lazy, included in `io-classes`; and +We provide two interfaces to `stm` API: lazy, included in [`io-classes`][lazy-stm]; and strict one provided by [`io-classes:strict-stm`](https://input-output-hk.github.io/io-sim/io-classes/strict-stm/index.html). ## Threads API We draw a line between `base` API and `async` API. The former is provided by -[MonadFork](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadFork.html#t:MonadFork) -the latter by -[MonadAsync](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadAsync.html#t:MonadAsync). -Both are shallow abstractions around APIs exposed by the `base` and `async` -packages. +[MonadFork] the latter by +[MonadAsync] Both are shallow abstractions around APIs exposed by the `base` +and `async` packages. +## `MVar` API +We also provide lazy and strict `MVar`s: + +* [lazy `MVar`][MonadMVar] API +* [strict `MVar`][strict-mvar] API is provided in the [io-classes:strict-mvar] sublibrary. + + ## Some other APIs * [MonadEventlog][MonadEventlog]: provides an API to the [Debug.Trace] event log interface. * [MonadST][MonadST]: provides a way to lift `ST`-computations. * [MonadSay][MonadSay]: dummy debugging interface + +## Monad Transformers + +We provide support for monad transformers, see [io-classes:mtl] sublibrary. +Although at this stage it might have its limitations and so there might be some +rough edges. PRs are welcomed, [contributing]. + + ## Differences from `base`, `async`, or `exceptions` packages ### Major differences @@ -142,13 +157,6 @@ * `MonadInspectSTM` which allows inspecting values of `STM` mutable variables when they are committed. ([`io-sim`], not provided by `GHC`). - -## Monad Transformers - -We provide support for monad transformers (although at this stage it might have -its limitations and so there might be some rough edges. PRs are welcomed, -[contributing]). - [SI]: https://www.wikiwand.com/en/International_System_of_Units [`DiffTime`]: https://hackage.haskell.org/package/time-1.10/docs/Data-Time-Clock.html#t:DiffTime [`IO`]: https://hackage.haskell.org/package/base-4.14.0.0/docs/GHC-IO.html#t:IO @@ -156,8 +164,10 @@ [`base`]: https://hackage.haskell.org/package/base [`exceptions`]: https://hackage.haskell.org/package/exceptions [`io-sim`]: https://hackage.haskell.org/package/io-sim +[io-classes:strict-mvar]: https://input-output-hk.github.io/io-sim/io-classes/strict-mvar/index.html [io-classes:mtl]: https://input-output-hk.github.io/io-sim/io-classes/mtl/index.html [`stm`]: https://hackage.haskell.org/package/stm +[lazy-stm]: https://input-output-hk.github.io/io-sim/io-classes/Control-Concurrent-Class-MonadSTM.html [`threadDelay`]: https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadTimer.html#v:threadDelay [`time`]: https://hackage.haskell.org/package/time [contributing]: https://www.github.com/input-output-hk/io-sim/tree/master/CONTRIBUTING.md @@ -167,6 +177,11 @@ [MonadEventlog]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadEventlog.html#t:MonadEventlog [Debug.Trace]: https://hackage.haskell.org/package/base/docs/Debug-Trace.html +[MonadAsync]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadAsync.html#t:MonadAsync +[MonadFork]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadFork.html#t:MonadFork +[MonadMVar]: https://input-output-hk.github.io/io-sim/io-classes/Control-Concurrent-Class-MonadMVar.html#t:MonadMVar +[`registerDelayCancellable`]: http://input-output-hk.github.io/io-sim/io-classes/si-timers/Control-Monad-Class-MonadTimer-SI.html#v:registerDelayCancellable +[strict-mvar]: https://input-output-hk.github.io/io-sim/io-classes/strict-mvar/Control-Concurrent-Class-MonadMVar-Strict.html [MonadST]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadST.html#t:MonadST [MonadSay]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadSay.html#t:MonadSay [io-classes-haddocks]: https://input-output-hk.github.io/io-sim diff --git a/io-classes.cabal b/io-classes.cabal --- a/io-classes.cabal +++ b/io-classes.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: io-classes -version: 1.7.0.0 +version: 1.8.0.0 synopsis: Type classes for concurrency with STM, ST and timing description: IO Monad class hierarchy compatible with: @@ -14,16 +14,31 @@ packages. + = Sublibraries + @io-classes@ provides non-standard extensions distributed in public + sublibraries + + * @io-classes:io-classes@ - the main library compatible with the above + packages + * @io-classes:strict-stm@ - strict @STM@ API + * @io-classes:strict-mvar@ - strict @MVar@ API + * @io-classes:si-timers@ - SI-unit based time / timers API, cancellable timers + * @io-classes:mtl@ - MTL instances, some of which are experiemental + + = Documentation + Haddocks of all public sublibraries are published + [here](https://input-output-hk.github.io/io-sim). + license: Apache-2.0 license-files: LICENSE NOTICE -copyright: 2019-2024 Input Output Global Inc (IOG) -author: Alexander Vieth, Duncan Coutts, Marcin Szamotulski, Thomas Winant +copyright: 2019-2025 Input Output Global Inc (IOG) +author: Alexander Vieth, Duncan Coutts, Marcin Szamotulski, Neil Davies, Thomas Winant maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category: Control build-type: Simple extra-doc-files: CHANGELOG.md README.md strict-stm/README.md strict-mvar/README.md bug-reports: https://github.com/input-output-hk/io-sim/issues -tested-with: GHC == { 8.10, 9.2, 9.4, 9.6, 9.8, 9.10 } +tested-with: GHC == { 9.6, 9.8, 9.10, 9.12 } source-repository head type: git @@ -72,38 +87,15 @@ Control.Monad.Class.MonadTime Control.Monad.Class.MonadTimer Control.Monad.Class.MonadTest - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - other-extensions: CPP - DataKinds - DefaultSignatures - DeriveFunctor - DeriveGeneric - DerivingStrategies - ExistentialQuantification - ExplicitNamespaces - FlexibleContexts - FlexibleInstances - FunctionalDependencies - GADTs - GeneralisedNewtypeDeriving - MultiParamTypeClasses - NamedFieldPuns - QuantifiedConstraints - RankNTypes - ScopedTypeVariables - StandaloneDeriving - TypeFamilies - TypeFamilyDependencies - TypeOperators - UndecidableInstances - build-depends: base >=4.9 && <4.21, + default-language: GHC2021 + default-extensions: LambdaCase + build-depends: base >=4.9 && <4.22, array, - async >=2.1, + async >=2.1 && <2.3, bytestring, mtl >=2.2 && <2.4, primitive >= 0.7 && <0.11, - stm >=2.5 && <2.5.2 || >=2.5.3 && <2.6, + stm >=2.5 && <2.5.2 || ^>=2.5.3, time >=1.9.1 && <1.13 if impl(ghc >= 9.10) build-depends: ghc-internal @@ -112,6 +104,7 @@ ghc-options: -fno-ignore-asserts library strict-stm + import: warnings visibility: public hs-source-dirs: strict-stm @@ -123,40 +116,26 @@ Control.Concurrent.Class.MonadSTM.Strict.TQueue Control.Concurrent.Class.MonadSTM.Strict.TVar reexported-modules: Control.Concurrent.Class.MonadSTM.TSem as Control.Concurrent.Class.MonadSTM.Strict.TSem - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - build-depends: base >= 4.9 && <4.21, + default-language: GHC2021 + default-extensions: LambdaCase + build-depends: base, array, - stm >= 2.5 && <2.6, io-classes:io-classes, - ghc-options: -Wall - -Wno-unticked-promoted-constructors - -Wcompat - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wpartial-fields - -Widentities if flag(asserts) ghc-options: -fno-ignore-asserts library strict-mvar + import: warnings visibility: public hs-source-dirs: strict-mvar/src exposed-modules: Control.Concurrent.Class.MonadMVar.Strict - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - build-depends: base >= 4.9 && <4.21, + default-language: GHC2021 + default-extensions: LambdaCase + build-depends: base, io-classes:io-classes, - ghc-options: -Wall - -Wno-unticked-promoted-constructors - -Wcompat - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wpartial-fields - -Widentities library si-timers import: warnings @@ -165,22 +144,14 @@ exposed-modules: Control.Monad.Class.MonadTime.SI Control.Monad.Class.MonadTimer.SI other-modules: Control.Monad.Class.MonadTimer.NonStandard - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - other-extensions: BangPatterns, - CPP, - ConstraintKinds, - DefaultSignatures, - DeriveGeneric, - NumericUnderscores, - ScopedTypeVariables, - TypeFamilies - build-depends: base >=4.9 && <4.21, + default-language: GHC2021 + default-extensions: LambdaCase + build-depends: base, deepseq, mtl, nothunks, stm, - time >=1.9.1 && <1.13, + time, io-classes:io-classes if flag(asserts) @@ -199,24 +170,24 @@ , Control.Monad.Class.MonadTime.SI.Trans , Control.Monad.Class.MonadTimer.Trans , Control.Monad.Class.MonadTimer.SI.Trans - build-depends: base >=4.9 && <4.21, + build-depends: base, array, mtl, io-classes:{io-classes,si-timers} hs-source-dirs: mtl - default-language: Haskell2010 - default-extensions: ImportQualifiedPost + default-language: GHC2021 + default-extensions: LambdaCase library testlib import: warnings visibility: public hs-source-dirs: test exposed-modules: Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF - default-language: Haskell2010 - default-extensions: ImportQualifiedPost - build-depends: base >=4.9 && <4.21, + default-language: GHC2021 + default-extensions: LambdaCase + build-depends: base, nothunks, QuickCheck, io-classes:strict-mvar @@ -224,27 +195,18 @@ ghc-options: -fno-ignore-asserts test-suite test-strict-mvar + import: warnings type: exitcode-stdio-1.0 hs-source-dirs: strict-mvar/test main-is: Main.hs - - default-language: Haskell2010 - default-extensions: ImportQualifiedPost + default-language: GHC2021 + default-extensions: LambdaCase build-depends: base, QuickCheck, tasty, tasty-quickcheck, io-classes:testlib - ghc-options: -Wall - -Wno-unticked-promoted-constructors - -Wcompat - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wpartial-fields - -Widentities - -fno-ignore-asserts - -- Since `io-sim` depends on `si-times` (`io-sim` depends on `Time`) some tests of -- are in `io-sim:test`: this is a good enough reason to pull `io-sim:test` -- into a seprate package. @@ -254,8 +216,8 @@ hs-source-dirs: si-timers/test main-is: Main.hs other-modules: Test.MonadTimer - default-language: Haskell2010 - default-extensions: ImportQualifiedPost + default-language: GHC2021 + default-extensions: LambdaCase build-depends: base, QuickCheck, diff --git a/mtl/Control/Monad/Class/MonadSTM/Trans.hs b/mtl/Control/Monad/Class/MonadSTM/Trans.hs --- a/mtl/Control/Monad/Class/MonadSTM/Trans.hs +++ b/mtl/Control/Monad/Class/MonadSTM/Trans.hs @@ -1,16 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} -- undecidable instances needed for 'ContTSTM' instances of -- 'MonadThrow' and 'MonadCatch' type classes. -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Control.Monad.Class.MonadSTM.Trans (ContTSTM (..)) where @@ -31,6 +25,7 @@ import Data.Array.Base (MArray (..)) import Data.Function (on) import Data.Kind (Type) +import Data.Proxy (Proxy (..)) -- | A newtype wrapper for an 'STM' monad for 'ContT' @@ -51,9 +46,7 @@ getNumElements = ContTSTM . getNumElements unsafeRead arr = ContTSTM . unsafeRead arr unsafeWrite arr i = ContTSTM . unsafeWrite arr i -#if __GLASGOW_HASKELL__ >= 910 newArray idxs = ContTSTM . newArray idxs -#endif -- note: this (and the following) instance requires 'UndecidableInstances' @@ -161,6 +154,19 @@ isEmptyTChan = ContTSTM . isEmptyTChan +instance MonadInspectSTM m => MonadInspectSTM (ContT r m) where + type InspectMonadSTM (ContT r m) = InspectMonadSTM m + inspectTVar _ = inspectTVar (Proxy @m) + inspectTMVar _ = inspectTMVar (Proxy @m) + +instance MonadTraceSTM m => MonadTraceSTM (ContT r m) where + traceTVar _ = ContTSTM .: traceTVar (Proxy @m) + traceTMVar _ = ContTSTM .: traceTMVar (Proxy @m) + traceTQueue _ = ContTSTM .: traceTQueue (Proxy @m) + traceTBQueue _ = ContTSTM .: traceTBQueue (Proxy @m) + traceTSem _ = ContTSTM .: traceTSem (Proxy @m) + + -- | The underlying stm monad is also transformed. -- instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.WriterT w m) where @@ -239,6 +245,19 @@ isEmptyTChan = lift . isEmptyTChan +instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Lazy.WriterT w m) where + type InspectMonadSTM (Lazy.WriterT w m) = InspectMonadSTM m + inspectTVar _ = inspectTVar (Proxy @m) + inspectTMVar _ = inspectTMVar (Proxy @m) + +instance (Monoid w, MonadTraceSTM m) => MonadTraceSTM (Lazy.WriterT w m) where + traceTVar _ = lift .: traceTVar (Proxy @m) + traceTMVar _ = lift .: traceTMVar (Proxy @m) + traceTQueue _ = lift .: traceTQueue (Proxy @m) + traceTBQueue _ = lift .: traceTBQueue (Proxy @m) + traceTSem _ = lift .: traceTSem (Proxy @m) + + -- | The underlying stm monad is also transformed. -- instance (Monoid w, MonadSTM m) => MonadSTM (Strict.WriterT w m) where @@ -317,6 +336,19 @@ isEmptyTChan = lift . isEmptyTChan +instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Strict.WriterT w m) where + type InspectMonadSTM (Strict.WriterT w m) = InspectMonadSTM m + inspectTVar _ = inspectTVar (Proxy @m) + inspectTMVar _ = inspectTMVar (Proxy @m) + +instance (Monoid w, MonadTraceSTM m) => MonadTraceSTM (Strict.WriterT w m) where + traceTVar _ = lift .: traceTVar (Proxy @m) + traceTMVar _ = lift .: traceTMVar (Proxy @m) + traceTQueue _ = lift .: traceTQueue (Proxy @m) + traceTBQueue _ = lift .: traceTBQueue (Proxy @m) + traceTSem _ = lift .: traceTSem (Proxy @m) + + -- | The underlying stm monad is also transformed. -- instance MonadSTM m => MonadSTM (Lazy.StateT s m) where @@ -395,6 +427,19 @@ isEmptyTChan = lift . isEmptyTChan +instance MonadInspectSTM m => MonadInspectSTM (Lazy.StateT s m) where + type InspectMonadSTM (Lazy.StateT s m) = InspectMonadSTM m + inspectTVar _ = inspectTVar (Proxy @m) + inspectTMVar _ = inspectTMVar (Proxy @m) + +instance MonadTraceSTM m => MonadTraceSTM (Lazy.StateT s m) where + traceTVar _ = lift .: traceTVar (Proxy @m) + traceTMVar _ = lift .: traceTMVar (Proxy @m) + traceTQueue _ = lift .: traceTQueue (Proxy @m) + traceTBQueue _ = lift .: traceTBQueue (Proxy @m) + traceTSem _ = lift .: traceTSem (Proxy @m) + + -- | The underlying stm monad is also transformed. -- instance MonadSTM m => MonadSTM (Strict.StateT s m) where @@ -473,6 +518,19 @@ isEmptyTChan = lift . isEmptyTChan +instance MonadInspectSTM m => MonadInspectSTM (Strict.StateT s m) where + type InspectMonadSTM (Strict.StateT s m) = InspectMonadSTM m + inspectTVar _ = inspectTVar (Proxy @m) + inspectTMVar _ = inspectTMVar (Proxy @m) + +instance MonadTraceSTM m => MonadTraceSTM (Strict.StateT s m) where + traceTVar _ = lift .: traceTVar (Proxy @m) + traceTMVar _ = lift .: traceTMVar (Proxy @m) + traceTQueue _ = lift .: traceTQueue (Proxy @m) + traceTBQueue _ = lift .: traceTBQueue (Proxy @m) + traceTSem _ = lift .: traceTSem (Proxy @m) + + -- | The underlying stm monad is also transformed. -- instance MonadSTM m => MonadSTM (ExceptT e m) where @@ -551,6 +609,19 @@ isEmptyTChan = lift . isEmptyTChan +instance MonadInspectSTM m => MonadInspectSTM (ExceptT e m) where + type InspectMonadSTM (ExceptT e m) = InspectMonadSTM m + inspectTVar _ = inspectTVar (Proxy @m) + inspectTMVar _ = inspectTMVar (Proxy @m) + +instance MonadTraceSTM m => MonadTraceSTM (ExceptT e m) where + traceTVar _ = lift .: traceTVar (Proxy @m) + traceTMVar _ = lift .: traceTMVar (Proxy @m) + traceTQueue _ = lift .: traceTQueue (Proxy @m) + traceTBQueue _ = lift .: traceTBQueue (Proxy @m) + traceTSem _ = lift .: traceTSem (Proxy @m) + + -- | The underlying stm monad is also transformed. -- instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.RWST r w s m) where @@ -629,6 +700,19 @@ isEmptyTChan = lift . isEmptyTChan +instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Lazy.RWST r w s m) where + type InspectMonadSTM (Lazy.RWST r w s m) = InspectMonadSTM m + inspectTVar _ = inspectTVar (Proxy @m) + inspectTMVar _ = inspectTMVar (Proxy @m) + +instance (Monoid w, MonadTraceSTM m) => MonadTraceSTM (Lazy.RWST r w s m) where + traceTVar _ = lift .: traceTVar (Proxy @m) + traceTMVar _ = lift .: traceTMVar (Proxy @m) + traceTQueue _ = lift .: traceTQueue (Proxy @m) + traceTBQueue _ = lift .: traceTBQueue (Proxy @m) + traceTSem _ = lift .: traceTSem (Proxy @m) + + -- | The underlying stm monad is also transformed. -- instance (Monoid w, MonadSTM m) => MonadSTM (Strict.RWST r w s m) where @@ -705,6 +789,19 @@ writeTChan = lift .: writeTChan unGetTChan = lift .: unGetTChan isEmptyTChan = lift . isEmptyTChan + + +instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Strict.RWST r w s m) where + type InspectMonadSTM (Strict.RWST r w s m) = InspectMonadSTM m + inspectTVar _ = inspectTVar (Proxy @m) + inspectTMVar _ = inspectTMVar (Proxy @m) + +instance (Monoid w, MonadTraceSTM m) => MonadTraceSTM (Strict.RWST r w s m) where + traceTVar _ = lift .: traceTVar (Proxy @m) + traceTMVar _ = lift .: traceTMVar (Proxy @m) + traceTQueue _ = lift .: traceTQueue (Proxy @m) + traceTBQueue _ = lift .: traceTBQueue (Proxy @m) + traceTSem _ = lift .: traceTSem (Proxy @m) (.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) diff --git a/mtl/Control/Monad/Class/MonadThrow/Trans.hs b/mtl/Control/Monad/Class/MonadThrow/Trans.hs --- a/mtl/Control/Monad/Class/MonadThrow/Trans.hs +++ b/mtl/Control/Monad/Class/MonadThrow/Trans.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-orphans #-} module Control.Monad.Class.MonadThrow.Trans () where @@ -60,6 +59,11 @@ -> ExceptT e m a -> ExceptT e m a q u (ExceptT b) = ExceptT (u b) + getMaskingState = lift getMaskingState + interruptible = ExceptT . interruptible . runExceptT + allowInterrupt = lift allowInterrupt + + -- -- Lazy.WriterT instances -- @@ -104,6 +108,11 @@ -> Lazy.WriterT w m a -> Lazy.WriterT w m a q u (Lazy.WriterT b) = Lazy.WriterT (u b) + getMaskingState = lift getMaskingState + interruptible = Lazy.WriterT . interruptible . Lazy.runWriterT + allowInterrupt = lift allowInterrupt + + -- -- Strict.WriterT instances -- @@ -147,7 +156,11 @@ -> Strict.WriterT w m a -> Strict.WriterT w m a q u (Strict.WriterT b) = Strict.WriterT (u b) + getMaskingState = lift getMaskingState + interruptible = Strict.WriterT . interruptible . Strict.runWriterT + allowInterrupt = lift allowInterrupt + -- -- Lazy.RWST Instances -- @@ -193,7 +206,11 @@ -> Lazy.RWST r w s m a -> Lazy.RWST r w s m a q u (Lazy.RWST b) = Lazy.RWST $ \r s -> u (b r s) + getMaskingState = lift getMaskingState + interruptible f = Lazy.RWST $ \r s -> interruptible (Lazy.runRWST f r s) + allowInterrupt = lift allowInterrupt + -- -- Strict.RWST Instances -- @@ -239,7 +256,11 @@ -> Strict.RWST r w s m a -> Strict.RWST r w s m a q u (Strict.RWST b) = Strict.RWST $ \r s -> u (b r s) + getMaskingState = lift getMaskingState + interruptible f = Strict.RWST $ \r s -> interruptible (Strict.runRWST f r s) + allowInterrupt = lift allowInterrupt + -- -- Lazy.StateT instances -- @@ -283,7 +304,11 @@ -> Lazy.StateT s m a -> Lazy.StateT s m a q u (Lazy.StateT b) = Lazy.StateT $ \s -> u (b s) + getMaskingState = lift getMaskingState + interruptible f = Lazy.StateT $ \s -> interruptible (Lazy.runStateT f s) + allowInterrupt = lift allowInterrupt + -- -- Strict.StateT instances -- @@ -327,3 +352,7 @@ -> Strict.StateT s m a -> Strict.StateT s m a q u (Strict.StateT b) = Strict.StateT $ \s -> u (b s) + + getMaskingState = lift getMaskingState + interruptible f = Strict.StateT $ \s -> interruptible (Strict.runStateT f s) + allowInterrupt = lift allowInterrupt diff --git a/si-timers/src/Control/Monad/Class/MonadTime/SI.hs b/si-timers/src/Control/Monad/Class/MonadTime/SI.hs --- a/si-timers/src/Control/Monad/Class/MonadTime/SI.hs +++ b/si-timers/src/Control/Monad/Class/MonadTime/SI.hs @@ -1,9 +1,6 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} module Control.Monad.Class.MonadTime.SI ( MonadTime (..) diff --git a/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs b/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs --- a/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs +++ b/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Control.Monad.Class.MonadTimer.SI ( -- * Type classes MonadDelay (..) @@ -124,7 +118,7 @@ -- | A timeout function. -- - -- TODO: 'IO' instance is not safe on 32-bit systems. + -- __TODO__: /'IO' instance is not safe on 32-bit systems./ timeout :: DiffTime -> m a -> m (Maybe a) @@ -244,7 +238,7 @@ -- small enough it will use the `MonadTimer`'s `registerDelay` (e.g. for `IO` -- monad it will use the `GHC`'s `GHC.Conc.registerDelay`). -- --- TODO: 'timeout' not safe on 32-bit systems. +-- __TODO__: /'timeout' is not safe on 32-bit systems./ instance MonadTimer IO where registerDelay d | d <= maxDelay = diff --git a/src/Control/Concurrent/Class/MonadMVar.hs b/src/Control/Concurrent/Class/MonadMVar.hs --- a/src/Control/Concurrent/Class/MonadMVar.hs +++ b/src/Control/Concurrent/Class/MonadMVar.hs @@ -1,11 +1,12 @@ {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE TypeFamilyDependencies #-} module Control.Concurrent.Class.MonadMVar ( MonadMVar (..) + -- * non-standard extensions , MonadInspectMVar (..) + , MonadTraceMVar (..) + , MonadLabelledMVar (..) ) where import Control.Concurrent.MVar qualified as IO @@ -14,6 +15,7 @@ import Control.Monad.Reader (ReaderT (..)) import Control.Monad.Trans (lift) +import Control.Concurrent.Class.MonadSTM (TraceValue) import Data.Kind (Type) @@ -153,7 +155,6 @@ modifyMVarMasked_ = IO.modifyMVarMasked_ modifyMVarMasked = IO.modifyMVarMasked - -- -- ReaderT instance -- @@ -204,6 +205,27 @@ type InspectMVarMonad IO = IO inspectMVar _ = tryReadMVar +class MonadTraceMVar m where + traceMVarIO :: proxy + -> MVar m a + -> (Maybe (Maybe a) -> Maybe a -> InspectMVarMonad m TraceValue) + -> m () + +instance MonadTraceMVar IO where + traceMVarIO = \_ _ _ -> pure () + +-- | Labelled `MVar`s +-- +-- The `IO` instances is no-op, the `IOSim` instance enhances simulation trace. +-- This is very useful when analysing low lever concurrency issues (e.g. +-- deadlocks, livelocks etc). +class MonadMVar m + => MonadLabelledMVar m where + -- | Name an `MVar` + labelMVar :: MVar m a -> String -> m () + +instance MonadLabelledMVar IO where + labelMVar = \_ _ -> pure () -- -- Utilities -- diff --git a/src/Control/Concurrent/Class/MonadSTM/TMVar.hs b/src/Control/Concurrent/Class/MonadSTM/TMVar.hs --- a/src/Control/Concurrent/Class/MonadSTM/TMVar.hs +++ b/src/Control/Concurrent/Class/MonadSTM/TMVar.hs @@ -24,6 +24,8 @@ -- * MonadTraceSTM , traceTMVar , traceTMVarIO + , debugTraceTMVar + , debugTraceTMVarIO ) where import Control.Monad.Class.MonadSTM.Internal diff --git a/src/Control/Concurrent/Class/MonadSTM/TVar.hs b/src/Control/Concurrent/Class/MonadSTM/TVar.hs --- a/src/Control/Concurrent/Class/MonadSTM/TVar.hs +++ b/src/Control/Concurrent/Class/MonadSTM/TVar.hs @@ -21,6 +21,8 @@ -- * MonadTraceSTM , traceTVar , traceTVarIO + , debugTraceTVar + , debugTraceTVarIO ) where import Control.Monad.Class.MonadSTM.Internal diff --git a/src/Control/Monad/Class/MonadAsync.hs b/src/Control/Monad/Class/MonadAsync.hs --- a/src/Control/Monad/Class/MonadAsync.hs +++ b/src/Control/Monad/Class/MonadAsync.hs @@ -1,12 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilyDependencies #-} -- MonadAsync's ReaderT instance is undecidable. {-# LANGUAGE UndecidableInstances #-} diff --git a/src/Control/Monad/Class/MonadFork.hs b/src/Control/Monad/Class/MonadFork.hs --- a/src/Control/Monad/Class/MonadFork.hs +++ b/src/Control/Monad/Class/MonadFork.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} -- | A generalisation of -- @@ -18,7 +16,7 @@ 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 +28,11 @@ 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 @@ -37,36 +40,45 @@ class MonadThread m => MonadFork m where - forkIO :: m () -> m (ThreadId m) - forkOn :: Int -> m () -> m (ThreadId m) - forkIOWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m) - forkFinally :: m a -> (Either SomeException a -> m ()) -> m (ThreadId m) - throwTo :: Exception e => ThreadId m -> e -> m () + forkIO :: m () -> m (ThreadId m) + forkOn :: Int -> m () -> m (ThreadId m) + forkIOWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m) + forkFinally :: m a -> (Either SomeException a -> m ()) -> m (ThreadId m) + throwTo :: Exception e => ThreadId m -> e -> m () - killThread :: ThreadId m -> m () - killThread tid = throwTo tid ThreadKilled + killThread :: ThreadId m -> m () + killThread tid = throwTo tid ThreadKilled - yield :: m () + yield :: m () + getNumCapabilities :: m Int + 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 - forkOn = IO.forkOn - forkIOWithUnmask = IO.forkIOWithUnmask - forkFinally = IO.forkFinally - throwTo = IO.throwTo - killThread = IO.killThread - yield = IO.yield + forkIO = IO.forkIO + forkOn = IO.forkOn + forkIOWithUnmask = IO.forkIOWithUnmask + forkFinally = IO.forkFinally + throwTo = IO.throwTo + killThread = IO.killThread + yield = IO.yield + getNumCapabilities = IO.getNumCapabilities 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) @@ -75,7 +87,9 @@ let restore' :: ReaderT e m a -> ReaderT e m a restore' (ReaderT f) = ReaderT $ restore . f in runReaderT (k restore') e - forkFinally f k = ReaderT $ \e -> forkFinally (runReaderT f e) - $ \err -> runReaderT (k err) e + forkFinally f k = ReaderT $ \e -> forkFinally (runReaderT f e) + $ \err -> runReaderT (k err) e throwTo e t = lift (throwTo e t) yield = lift yield + + getNumCapabilities = lift getNumCapabilities diff --git a/src/Control/Monad/Class/MonadST.hs b/src/Control/Monad/Class/MonadST.hs --- a/src/Control/Monad/Class/MonadST.hs +++ b/src/Control/Monad/Class/MonadST.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} module Control.Monad.Class.MonadST (MonadST (..)) where import Control.Monad.Reader diff --git a/src/Control/Monad/Class/MonadSTM.hs b/src/Control/Monad/Class/MonadSTM.hs --- a/src/Control/Monad/Class/MonadSTM.hs +++ b/src/Control/Monad/Class/MonadSTM.hs @@ -1,15 +1,11 @@ --- | This module corresponds to "Control.Monad.STM" in "stm" package --- -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} -- undecidable instances needed for 'WrappedSTM' instances of 'MonadThrow' and -- 'MonadCatch' type classes. -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module corresponds to "Control.Monad.STM" in "stm" package +-- module Control.Monad.Class.MonadSTM ( MonadSTM (STM, atomically, retry, orElse, check) , throwSTM diff --git a/src/Control/Monad/Class/MonadSTM/Internal.hs b/src/Control/Monad/Class/MonadSTM/Internal.hs --- a/src/Control/Monad/Class/MonadSTM/Internal.hs +++ b/src/Control/Monad/Class/MonadSTM/Internal.hs @@ -1,23 +1,12 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} -- needed for `ReaderT` instance -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Internal module. It's only exposed as it provides various default types for -- defining new instances, otherwise prefer to use @@ -99,6 +88,11 @@ , isEmptyTChanDefault , cloneTChanDefault , labelTChanDefault + -- * Trace tvar and tmvar + , debugTraceTVar + , debugTraceTVarIO + , debugTraceTMVar + , debugTraceTMVarIO ) where import Prelude hiding (read) @@ -367,21 +361,21 @@ -- to access a 'TVar' in the underlying 'ST' monad. -- class ( MonadSTM m - , Monad (InspectMonad m) + , Monad (InspectMonadSTM m) ) => MonadInspectSTM m where - type InspectMonad m :: Type -> Type + type InspectMonadSTM m :: Type -> Type -- | Return the value of a `TVar` as an `InspectMonad` computation. -- -- `inspectTVar` is useful if the value of a `TVar` observed by `traceTVar` -- contains other `TVar`s. - inspectTVar :: proxy m -> TVar m a -> InspectMonad m a + inspectTVar :: proxy m -> TVar m a -> InspectMonadSTM m a -- | Return the value of a `TMVar` as an `InspectMonad` computation. - inspectTMVar :: proxy m -> TMVar m a -> InspectMonad m (Maybe a) + inspectTMVar :: proxy m -> TMVar m a -> InspectMonadSTM m (Maybe a) -- TODO: inspectTQueue, inspectTBQueue instance MonadInspectSTM IO where - type InspectMonad IO = IO + type InspectMonadSTM IO = IO inspectTVar _ = readTVarIO -- issue #3198: tryReadTMVarIO inspectTMVar _ = atomically . tryReadTMVar @@ -449,7 +443,7 @@ -- traceTVar :: proxy m -> TVar m a - -> (Maybe a -> a -> InspectMonad m TraceValue) + -> (Maybe a -> a -> InspectMonadSTM m TraceValue) -- ^ callback which receives initial value or 'Nothing' (if it -- is a newly created 'TVar'), and the committed value. -> STM m () @@ -457,85 +451,128 @@ traceTMVar :: proxy m -> TMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue) -> STM m () traceTQueue :: proxy m -> TQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> STM m () traceTBQueue :: proxy m -> TBQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> STM m () traceTSem :: proxy m -> TSem m - -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue) -> STM m () default traceTMVar :: TMVar m a ~ TMVarDefault m a => proxy m -> TMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue) -> STM m () traceTMVar = traceTMVarDefault default traceTSem :: TSem m ~ TSemDefault m => proxy m -> TSem m - -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue) -> STM m () traceTSem = traceTSemDefault traceTVarIO :: TVar m a - -> (Maybe a -> a -> InspectMonad m TraceValue) + -> (Maybe a -> a -> InspectMonadSTM m TraceValue) -> m () traceTMVarIO :: TMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue) -> m () traceTQueueIO :: TQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTBQueueIO :: TBQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTSemIO :: TSem m - -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue) -> m () default traceTVarIO :: TVar m a - -> (Maybe a -> a -> InspectMonad m TraceValue) + -> (Maybe a -> a -> InspectMonadSTM m TraceValue) -> m () traceTVarIO = \v f -> atomically (traceTVar Proxy v f) default traceTMVarIO :: TMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue) -> m () traceTMVarIO = \v f -> atomically (traceTMVar Proxy v f) default traceTQueueIO :: TQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTQueueIO = \v f -> atomically (traceTQueue Proxy v f) default traceTBQueueIO :: TBQueue m a - -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTBQueueIO = \v f -> atomically (traceTBQueue Proxy v f) default traceTSemIO :: TSem m - -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue) -> m () traceTSemIO = \v f -> atomically (traceTSem Proxy v f) +debugTraceTVar :: (MonadTraceSTM m, Show a) + => proxy m + -> TVar m a + -> STM m () +debugTraceTVar p tvar = + traceTVar p tvar (\pv v -> pure $ TraceString $ case (pv, v) of + (Nothing, _) -> error "Unreachable" + (Just st', st'') -> "Modified: " <> show st' <> " -> " <> show st'' + ) +debugTraceTVarIO :: (MonadTraceSTM m, Show a) + => TVar m a + -> m () +debugTraceTVarIO tvar = + traceTVarIO tvar (\pv v -> pure $ TraceString $ case (pv, v) of + (Nothing, _) -> error "Unreachable" + (Just st', st'') -> "Modified: " <> show st' <> " -> " <> show st'' + ) + +debugTraceTMVar :: (MonadTraceSTM m, Show a) + => proxy m + -> TMVar m a + -> STM m () +debugTraceTMVar p tmvar = + traceTMVar p tmvar (\pv v -> pure $ TraceString $ case (pv, v) of + (Nothing, _) -> error "Unreachable" + (Just Nothing, Just st') -> "Put: " <> show st' + (Just Nothing, Nothing) -> "Remains empty" + (Just Just{}, Nothing) -> "Take" + (Just (Just st'), Just st'') -> "Modified: " <> show st' <> " -> " <> show st'' + ) + +debugTraceTMVarIO :: (Show a, MonadTraceSTM m) + => TMVar m a + -> m () +debugTraceTMVarIO tmvar = + traceTMVarIO tmvar (\pv v -> pure $ TraceString $ case (pv, v) of + (Nothing, _) -> error "Unreachable" + (Just Nothing, Just st') -> "Put: " <> show st' + (Just Nothing, Nothing) -> "Remains empty" + (Just Just{}, Nothing) -> "Take" + (Just (Just st'), Just st'') -> "Modified: " <> show st' <> " -> " <> show st'' + ) + -- -- Instance for IO uses the existing STM library implementations -- @@ -689,7 +726,7 @@ :: MonadTraceSTM m => proxy m -> TMVarDefault m a - -> (Maybe (Maybe a) -> Maybe a -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue) -> STM m () traceTMVarDefault p (TMVar t) f = traceTVar p t f @@ -982,7 +1019,6 @@ -- | Default implementation of 'TArray'. -- data TArrayDefault m i e = TArray (Array i (TVar m e)) - deriving Typeable deriving instance (Eq (TVar m e), Ix i) => Eq (TArrayDefault m i e) @@ -1029,7 +1065,7 @@ traceTSemDefault :: MonadTraceSTM m => proxy m -> TSemDefault m - -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue) -> STM m () traceTSemDefault proxy (TSem t) k = traceTVar proxy t k @@ -1247,6 +1283,17 @@ unGetTChan = lift .: unGetTChan isEmptyTChan = lift . isEmptyTChan +instance MonadInspectSTM m => MonadInspectSTM (ReaderT r m) where + type InspectMonadSTM (ReaderT r m) = InspectMonadSTM m + inspectTVar _ = inspectTVar (Proxy :: Proxy m) + inspectTMVar _ = inspectTMVar (Proxy :: Proxy m) + +instance MonadTraceSTM m => MonadTraceSTM (ReaderT r m) where + traceTVar _ = lift .: traceTVar Proxy + traceTMVar _ = lift .: traceTMVar Proxy + traceTQueue _ = lift .: traceTQueue Proxy + traceTBQueue _ = lift .: traceTBQueue Proxy + traceTSem _ = lift .: traceTSem Proxy (.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) (f .: g) x y = f (g x y) diff --git a/src/Control/Monad/Class/MonadThrow.hs b/src/Control/Monad/Class/MonadThrow.hs --- a/src/Control/Monad/Class/MonadThrow.hs +++ b/src/Control/Monad/Class/MonadThrow.hs @@ -1,12 +1,6 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} -- | A generalisation of -- @@ -16,7 +10,7 @@ ( MonadThrow (..) , MonadCatch (..) , MonadMask (..) - , MonadMaskingState (..) + , MonadMaskingState , MonadEvaluate (..) , MaskingState (..) , Exception (..) @@ -193,27 +187,30 @@ -- class MonadCatch m => MonadMask m where - {-# MINIMAL mask, uninterruptibleMask #-} + {-# MINIMAL mask, + uninterruptibleMask, + getMaskingState, + interruptible #-} + mask, uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b mask_, uninterruptibleMask_ :: m a -> m a mask_ action = mask $ \_ -> action uninterruptibleMask_ action = uninterruptibleMask $ \_ -> action - -class MonadMask m => MonadMaskingState m where - {-# MINIMAL getMaskingState, interruptible #-} getMaskingState :: m MaskingState interruptible :: m a -> m a - allowInterrupt :: m () + allowInterrupt :: m () allowInterrupt = interruptible (return ()) +class MonadMask m => MonadMaskingState m +{-# DEPRECATED MonadMaskingState "Use MonadMask instead" #-} -- | Monads which can 'evaluate'. -- -class MonadThrow m => MonadEvaluate m where +class MonadEvaluate m where evaluate :: a -> m a -- @@ -254,11 +251,12 @@ uninterruptibleMask = IO.uninterruptibleMask uninterruptibleMask_ = IO.uninterruptibleMask_ -instance MonadMaskingState IO where getMaskingState = IO.getMaskingState interruptible = IO.interruptible allowInterrupt = IO.allowInterrupt +instance MonadMaskingState IO + instance MonadEvaluate IO where evaluate = IO.evaluate @@ -321,5 +319,10 @@ where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a q u (ReaderT b) = ReaderT (u . b) -instance MonadEvaluate m => MonadEvaluate (ReaderT r m) where + getMaskingState = lift getMaskingState + interruptible a = + ReaderT $ \e -> interruptible (runReaderT a e) + allowInterrupt = lift allowInterrupt + +instance (Monad m, MonadEvaluate m) => MonadEvaluate (ReaderT r m) where evaluate = lift . evaluate diff --git a/src/Control/Monad/Class/MonadTime.hs b/src/Control/Monad/Class/MonadTime.hs --- a/src/Control/Monad/Class/MonadTime.hs +++ b/src/Control/Monad/Class/MonadTime.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - -- | and -- time API compatible with both -- 'IO' and . diff --git a/src/Control/Monad/Class/MonadTimer.hs b/src/Control/Monad/Class/MonadTimer.hs --- a/src/Control/Monad/Class/MonadTimer.hs +++ b/src/Control/Monad/Class/MonadTimer.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} -- | Provides classes to handle delays and timeouts which generalised -- API to both 'IO' and diff --git a/strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs b/strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs --- a/strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs +++ b/strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -- | This module corresponds to "Control.Concurrent.MVar" in the @base@ package. module Control.Concurrent.Class.MonadMVar.Strict ( -- * StrictMVar @@ -26,11 +22,12 @@ , modifyMVarMasked_ , modifyMVarMasked , tryReadMVar + , labelMVar -- * Re-exports , MonadMVar ) where -import Control.Concurrent.Class.MonadMVar (MonadMVar) +import Control.Concurrent.Class.MonadMVar (MonadLabelledMVar, MonadMVar) import Control.Concurrent.Class.MonadMVar qualified as Lazy -- @@ -61,6 +58,9 @@ -- is in WHNF. This should be used with caution. fromLazyMVar :: Lazy.MVar m a -> StrictMVar m a fromLazyMVar = StrictMVar + +labelMVar :: MonadLabelledMVar m => StrictMVar m a -> String -> m () +labelMVar (StrictMVar m) = Lazy.labelMVar m newEmptyMVar :: MonadMVar m => m (StrictMVar m a) newEmptyMVar = fromLazyMVar <$> Lazy.newEmptyMVar diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs --- a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE UndecidableInstances #-} -- | This module corresponds to `Control.Concurrent.STM.TArray` in "stm" package -- diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs --- a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} - -- | This module corresponds to `Control.Concurrent.STM.TBQueue` in "stm" package -- module Control.Concurrent.Class.MonadSTM.Strict.TBQueue @@ -59,13 +54,13 @@ traceTBQueue :: MonadTraceSTM m => proxy m -> StrictTBQueue m a - -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue) -> STM m () traceTBQueue p (StrictTBQueue queue) = Lazy.traceTBQueue p queue traceTBQueueIO :: MonadTraceSTM m => StrictTBQueue m a - -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTBQueueIO (StrictTBQueue queue) = Lazy.traceTBQueueIO queue diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs --- a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeOperators #-} - -- | This module corresponds to `Control.Concurrent.STM.TChan` in "stm" package -- module Control.Concurrent.Class.MonadSTM.Strict.TChan diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs --- a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeOperators #-} - -- | This module corresponds to `Control.Concurrent.STM.TMVar` in "stm" package -- module Control.Concurrent.Class.MonadSTM.Strict.TMVar @@ -31,6 +26,8 @@ -- * MonadTraceSTM , traceTMVar , traceTMVarIO + , debugTraceTMVar + , debugTraceTMVarIO ) where @@ -55,15 +52,26 @@ traceTMVar :: MonadTraceSTM m => proxy m -> StrictTMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue) -> STM m () traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var +debugTraceTMVar :: (MonadTraceSTM m, Show a) + => proxy m + -> StrictTMVar m a + -> STM m () +debugTraceTMVar p (StrictTMVar var) = Lazy.debugTraceTMVar p var + traceTMVarIO :: MonadTraceSTM m => StrictTMVar m a - -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue) -> m () traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var + +debugTraceTMVarIO :: (MonadTraceSTM m, Show a) + => StrictTMVar m a + -> m () +debugTraceTMVarIO (StrictTMVar var) = Lazy.debugTraceTMVarIO var castStrictTMVar :: LazyTMVar m ~ LazyTMVar n => StrictTMVar m a -> StrictTMVar n a diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs --- a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs @@ -1,9 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeOperators #-} - -- | This module corresponds to `Control.Concurrent.STM.TQueue` in "stm" package -- module Control.Concurrent.Class.MonadSTM.Strict.TQueue @@ -56,13 +50,13 @@ traceTQueue :: MonadTraceSTM m => proxy m -> StrictTQueue m a - -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue) -> STM m () traceTQueue p (StrictTQueue queue) = Lazy.traceTQueue p queue traceTQueueIO :: MonadTraceSTM m => StrictTQueue m a - -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue) -> m () traceTQueueIO (StrictTQueue queue) = Lazy.traceTQueueIO queue diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs --- a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -- | This module corresponds to `Control.Concurrent.STM.TVar` in "stm" package -- module Control.Concurrent.Class.MonadSTM.Strict.TVar @@ -27,6 +22,8 @@ -- * MonadTraceSTM , traceTVar , traceTVarIO + , debugTraceTVar + , debugTraceTVarIO ) where import Control.Concurrent.Class.MonadSTM.TVar qualified as Lazy @@ -47,15 +44,26 @@ traceTVar :: MonadTraceSTM m => proxy m -> StrictTVar m a - -> (Maybe a -> a -> InspectMonad m TraceValue) + -> (Maybe a -> a -> InspectMonadSTM m TraceValue) -> STM m () traceTVar p StrictTVar {tvar} = Lazy.traceTVar p tvar +debugTraceTVar :: (MonadTraceSTM m, Show a) + => proxy m + -> StrictTVar m a + -> STM m () +debugTraceTVar p StrictTVar {tvar} = Lazy.debugTraceTVar p tvar + traceTVarIO :: MonadTraceSTM m => StrictTVar m a - -> (Maybe a -> a -> InspectMonad m TraceValue) + -> (Maybe a -> a -> InspectMonadSTM m TraceValue) -> m () traceTVarIO StrictTVar {tvar} = Lazy.traceTVarIO tvar + +debugTraceTVarIO :: (MonadTraceSTM m, Show a) + => StrictTVar m a + -> m () +debugTraceTVarIO StrictTVar {tvar} = Lazy.debugTraceTVarIO tvar -- | Cast the monad if both use the same representation of `TVar`s. --