diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index f5f69cdb..69bc94a2 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -1,25 +1,19 @@ # Building -The project is build with `cabal-install`. You might need to run `cabal -update` after cloning the repository (to update [`Cardano Haskell -Packages`][CHaP] (`ChaP`) index). +The project is built with `cabal-install`. You might need to run `cabal +update` after cloning the repository. # Design Principles We designed `io-classes` to be as close as possible to what `base` package -provides. Almost all `IO` instances instantiate with api provided by one of +provides. Almost all `IO` instances instantiate with API provided by one of the core packages, see [example](https://github.com/input-output-hk/io-sim/blob/main/io-classes/src/Control/Monad/Class/MonadSTM.hs?plain=1#L410-L446). Please keep this in mind when adding new functionality. -# Using in your project +# Roles and Responsibilities -Currently the package is published to [`CHaP`][CHaP]. In future it will be -published to `Hackage`. If you want to pull it from [`CHaP`][CHaP], this is -relatively easy to setup; for example, checkout the -[`cabal.project`](https://github.com/input-output-hk/typed-protocols/blob/master/cabal.project) -file. Alternatively, you can relay on `source-repository-package` stanza in -a `cabal.project` file. +Maintainers of each package are listed in the corresponding `*.cabal` file. # Testing @@ -60,14 +54,15 @@ package ouroboros-network-testing # Code Style -Please follow local style. For a more detailed style guide see +Please follow the local style. For a more detailed style guide see [link](https://github.com/input-output-hk/ouroboros-network/blob/master/docs/StyleGuide.md). # Pull Requests -Each commit shall be small and preferably address one thing at a time. Well -organised & documented commits make it much easier for the maintainers to -review them. +Each commit shall be small and preferably address one thing at a time. +Well-organised & documented commits make it much easier for the maintainers to +review them. Hacking sessions are great, but please take your time to organise +your work, this usually improves the quality too! New features should be well documented & tested, which means including new tests as necessary. You might be asked by the maintainers to write & include @@ -76,30 +71,42 @@ additional tests. Each commit should build & test, at least the package you are changing. You can update other packages from this repository in a subsequent commit. -Please use a draft PRs if the work is still in progress. +Please use a draft PR if the work is still in progress. -We require all commits to be signed, see [this guide][gh-signing-commits]. - -If your pull requests resolves an existing issue, please link your PR to that +If your pull requests resolve an existing issue, please link your PR to the issue, see [GitHub documentation][gh-link-issue]. -Please include your changes in `CHANGELOG.md` files (per package). +Please include your changes in the `CHANGELOG.md` files (per package). + +We prefer to avoid merging commits, rebasing a well-organised PR is usually +quite simple. + +## Code Style + +Please follow the local style. For a more detailed style guide see +[link](https://github.com/input-output-hk/ouroboros-network/blob/master/docs/StyleGuide.md). ## MonadSTM features -If you are adding a new functionality to `MonadSTM`, don't forget to support it +If you are adding new functionality to `MonadSTM`, don't forget to support it in `strict-stm` package. +## CI + +We run CI using [GitHub actions][ci]. + # Releases -The major version of `io-sim`, `io-classes` and `strict-stm` packages are kept -in sync. This means that if any of the packages introduces a breaking change -all major version SHOULD be bumped. The minor versions are kept independent. +The major version of `io-sim`, `io-classes`, `strict-stm` and `si-timers` +packages are kept in sync. This means that if any of the packages introduce +a breaking change all major versions SHOULD be bumped. The minor versions are +kept independent. The `io-classes-mtl` is still experimental and thus it's not +following that principle. The drawback is that if you declare `io-classes ^>= 0.x` then you will need to -bump it when new version of `io-sim` is published (even if there are no changes -in `io-classes`). The con is that you just need to declare version of -`io-classes` to have a consistent ecosystem of the three packages. +bump it when a new version of `io-sim` is published (even if there are no changes +in `io-classes`). The con is that you just need to declare the version of +`io-classes` to have a consistent ecosystem of the four packages. # Tips @@ -107,7 +114,7 @@ in `io-classes`). The con is that you just need to declare version of Both `ppTrace` and `ppTrace_` are strict. They evaluate the trace before they produce any result, thus they are not useful when your trace diverges. This -can happen if evaluation encounters unhandled exception e.g. one of assertion +can happen if the evaluation encounters an unhandled exception e.g. an assertion fires (either internal or otherwise). In that case, instead of `ppTrace` you can use `Data.Trace.toList` and simply `traverse print` the list. This will give you the trace up to the point of failure. @@ -115,7 +122,7 @@ give you the trace up to the point of failure. ## `IOSim` and `STMSim` monads are based on lazy `ST` monad This means that any action is forced only when the result is needed. This is -more lazy than `IO` monad. Thus if you want to use `Debug.Trace.traceM` inside +lazier than `IO` monad. Thus if you want to use `Debug.Trace.traceM` inside `schedule` function you need to: ```hs ... @@ -128,5 +135,5 @@ more lazy than `IO` monad. Thus if you want to use `Debug.Trace.traceM` inside [CHaP]: https://github.com/input-output-hk/cardano-haskell-packages/ [gh-link-issue]: https://docs.github.com/en/github/managing-your-work-on-github/linking-a-pull-request-to-an-issue [gh-signing-commits]: https://docs.github.com/en/authentication/managing-commit-signature-verification/signing-commits - +[ci]: https://github.com/input-output-hk/io-sim/actions diff --git a/NOTICE b/NOTICE index f3a42c2d..acd2b2cd 100644 --- a/NOTICE +++ b/NOTICE @@ -1,4 +1,4 @@ -Copyright 2022 Input Output (Hong Kong) Ltd. +Copyright 2019-2023 Input Output Global Inc (IOG) Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/README.md b/README.md index a42874f1..c7774fd3 100644 --- a/README.md +++ b/README.md @@ -3,33 +3,32 @@ # io-sim - -`IOSim` is an simulator monad which supports: +`IOSim` is a simulator monad that supports: * asynchronous exceptions * simulated time * timeout API * software transaction memory (STM) -* concurrency: both low level `forkIO` as well as `async` style +* concurrency: both low-level `forkIO` as well as `async` style * strict STM * access to lazy ST * schedule discovery (see [IOSimPOR][io-sim-por-how-to]) -* eventlog +* event log * dynamic tracing * tracing committed changes to `TVar`, `TMVar`s, etc. -* labelling of threads, `TVar`'s, etc. +* labeling of threads, `TVar`'s, etc. -`io-classes` provides an interface, which allows to write code which can be run +`io-classes` provides an interface, which allows writing code that can be run in both real `IO` and `IOSim`. It is a drop-in replacement for `IO`, and -supports interfaces commonly known from `base`, `exceptions`, `stm`, `async` or -`time` packages. +supports interfaces commonly known from `base`, `exceptions`, `stm`, `async`, +or `time` packages. One of the principles of `io-classes` was to stay as close to `IO` as possible, -thus most of the `IO` instances are directly referring to `base` or `async` api. -However we made some distinctions, which are reported below. +thus most of the `IO` instances are directly referring to `base` or `async` +API. However, we made some distinctions, which are reported below. -`io-classes` supports a novel hierarchy for error handling monads as well more -familiar `exception` style. The new hierarchy provides `bracket` and +`io-classes` supports a novel hierarchy for error-handling monads as well as +more familiar `exception` style. The new hierarchy provides `bracket` and `finally` functions in the `MonadThrow` class, while `catch` style operators are provided by a super-class `MonadCatch`. Both `bracket` and `finally` are the most common functions used to write code with robust exception handling, @@ -37,12 +36,12 @@ exposing them through the more basic `MonadThrow` class informs the reader / reviewer that no tricky error handling is done in that section of the code base. -`IOSim` exposes a detailed trace, which can be enhanced by labelling threads, -or mutable variables, tracing `Dynamic` values (which can be recovered from the -trace) or simple `String` based tracing. Although its agnostic with respect to +`IOSim` exposes a detailed trace, which can be enhanced by labeling threads, or +mutable variables, tracing `Dynamic` values (which can be recovered from the +trace), or simple `String` based tracing. Although it's agnostic concerning the logging framework, it worked for us particularly well using -[contra-tracer][contra-tracer]. It has been used to develop, test and debug -a complex, highly-concurrent, distributed system +[contra-tracer][contra-tracer]. It has been used to develop, test, and debug +a complex, highly concurrent, distributed system ([ouroboros-network][ouroboros-network]), in particular * write network simulations, to verify a complex networking stack; @@ -61,9 +60,10 @@ a complex, highly-concurrent, distributed system * `io-classes`: class bases interface, which allows to to abstract over the monad * `strict-stm`: strict STM operations +* `si-timers`: non-standard timers API -## Differences from `base`, `async` or `exceptions` packages +## Differences from `base`, `async`, or `exceptions` packages ### Major differences @@ -82,11 +82,11 @@ type Async :: (Type -> Type) -> Type -> Type ``` The first type of kind `Type -> Type` describes the monad which could be -instantiated to `IO`, `IOSim` or some other monad stack build with monad +instantiated to `IO`, `IOSim` or some other monad stacks built with monad transformers. The same applies to many other types, e.g. `TVar`, `TMVar`. The following types although similar to the originals are not the same as the -ones that come from `base`, `async`, or `excpetions` packages: +ones that come from `base`, `async`, or `exceptions` packages: * `Handler` (origin: `base`) * `MaskingState` (origin: `base`) diff --git a/SECURITY.md b/SECURITY.md new file mode 100644 index 00000000..6d68e556 --- /dev/null +++ b/SECURITY.md @@ -0,0 +1,2 @@ +See the security file in the [Cardano engineering handbook](https://github.com/input-output-hk/cardano-engineering-handbook/blob/main/SECURITY.md). + diff --git a/io-classes-mtl/README.md b/io-classes-mtl/README.md index 60b90e89..0910c69b 100644 --- a/io-classes-mtl/README.md +++ b/io-classes-mtl/README.md @@ -2,16 +2,16 @@ `ReaderT` instances are included in `io-classes`, but all other instances are included in this package. Some of them are rather novel and experimental -others might be less so. This code is not really tested, neither it has run -in production environment as we know (let us know if you do!). +others might be less so. This code is not well tested, and some of it hasn't run +in a production environment as we know (let us know if you do!). The `MonadSTM` instances for monad transformers are somewhat novel. The `STM` monad is transformed together with the base monad. This means that the -transfomer primitive operations are available in `STM`. For example you an +transformer primitive operations are available in `STM`. For example you an `STM` transaction can lock updating the state of the current thread. We haven't included `MonadAsync` instances (although we have an experimental -branch how this could be done). It could work like the `lifted-async` +branch how this could be done). It could work like the `lifted-async` package. But we feel this can be controversial, so it's not included. The design goal is to follow `exception` package instances, but since we don't diff --git a/io-classes-mtl/io-classes-mtl.cabal b/io-classes-mtl/io-classes-mtl.cabal index f999eb44..320c61a2 100644 --- a/io-classes-mtl/io-classes-mtl.cabal +++ b/io-classes-mtl/io-classes-mtl.cabal @@ -2,6 +2,10 @@ cabal-version: 3.0 name: io-classes-mtl version: 0.1.0.0 synopsis: Experimental MTL instances for io-classes +description: + MTL instances for + [io-classes](https://hackage.hasekll.org/package/io-classes) package. + Some of the instances are novel and some are still experimental. license: Apache-2.0 license-files: LICENSE @@ -41,7 +45,7 @@ library array, mtl, - io-classes ^>= 0.6.0.0, + io-classes ^>= 1.0.0.0, si-timers, diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index 9ca76861..5064b990 100644 --- a/io-classes/CHANGELOG.md +++ b/io-classes/CHANGELOG.md @@ -2,6 +2,8 @@ ## next version +## 1.0.0.0 + ### Breaking changes * `MonadMonotonicTime` morphed into `MonadMonotonicTimeNSec` which supports diff --git a/io-classes/NOTICE b/io-classes/NOTICE index 2787a02a..acd2b2cd 100644 --- a/io-classes/NOTICE +++ b/io-classes/NOTICE @@ -1,4 +1,4 @@ -Copyright 2019-2023 Input Output (Hong Kong) Ltd. +Copyright 2019-2023 Input Output Global Inc (IOG) Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/io-classes/README.md b/io-classes/README.md index 43dab3e5..a6377274 100644 --- a/io-classes/README.md +++ b/io-classes/README.md @@ -1,86 +1,124 @@ -# Simulator Monad Class Hierarchy +# IO Monad Class Hierarchy -This package provides a monad class hierarchy which is an interface for both the -[io-sim](https://hackage.haskell.org/package/io-sim) and -[IO](https://hackage.haskell.org/package/base-4.14.0.0/docs/GHC-IO.html#t:IO) -monads. It was developed with the following constraints in mind: +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 +constraints in mind: -* be a drop in replacement for `IO` monad; -* `IO` instances does not alter its original semantics, providing a shallow - bindings to `async`, `base`, `stm` and `exception` packages; -* provide zero cost abstractions. +* be a drop-in replacement for `IO` monad; +* `IO` instances do not alter its original semantics, providing a shallow + bindings to [`async`], [`base`], [`stm`], and [`exceptions`] packages as well + as timer API; +* provide zero-cost abstractions. -There are a few departures from this principles, usually visible in type -signature, which we discuss in this document. When using `IO`, for most of the -interfaces, `GHC` can optimise away the provided abstractions with `-o1` -optimisation level. +We provide also non-standard extensions of this API: + +* [`strict-stm`]: strict `TVar`'s, and other mutable `STM` variables, with + support of the [`nothunks`] library; +* [`si-timers`]: timers api: + - 32-bit safe API using `DiffTime` measured in seconds (rather than time in + microseconds represented as `Int` as in `base`) + - cancellable timeouts. + +[`strict-stm`] and [`nothunks`] were successfully used in a large code base to +eliminate space leaks and keep that property over long development cycles. ## Exception Class Hierarchy This package provides an alternative class hierarchy giving access to -exceptions api. The `exception` package class hierarchy is also supported by -`io-sim`, so you can also use either one. - - The `MonadThrow` defined in this package allows to work with exceptions -without having explicit access to `catch` or `mask`. It only provides access -to `throwIO`, `bracket`, `bracket_` and `finally`. `MonadCatch` class provides -api which allows to work with exceptions, e.g. `catch` or `bracketOnError`, and -`MonadMask` gives access to low level `mask` and friends. This division makes -code review process somewhat easier. Using only `MonadThrow` constraint the -reviewer can be sure that no low level exception api is used, which usually -requires more care, and still allows to do resource handling right. +exceptions API. The [`exception`] package class hierarchy is also supported by +[`io-sim`], so you can also use either one. + +The `MonadThrow` defined in this package allows working with exceptions without +having explicit access to `catch` or `mask`. It only provides access to +`throwIO`, `bracket`, `bracket_`, and `finally`. `MonadCatch` class provides +API which allows working with exceptions, e.g. `catch` or `bracketOnError`, and +`MonadMask` gives access to low-level `mask` and friends. This division makes +code review process somewhat easier. Using only `MonadThrow` constraint, the +reviewer can be sure that no low-level exception API is used, which usually +requires more care. Still `MonadThrow` is general enough to do resource +handling right. ## Time and Timer APIs -We follow the tradition of splitting time into two units of measures: as unit -of time differences, which has monoidal nature and as a unit of time which is -a G-set for the former. We use -[DiffTime](https://hackage.haskell.org/package/time-1.10/docs/Data-Time-Clock.html#t:DiffTime) -for the former and a newtype wrapper `Time` for the later (provided for this -package). `DiffTime` is used consistently across all the type classes which is -one of the few departures from the `base` interface. One example is -[threadDelay](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadTimer.html#v:threadDela) -(provided by `MonadDelay`) which is using `DiffTime` (being in seconds) rather -than passing microseconds as an `Int` - as it is done by `base` package. -Provided `threadDelay` function is safely against overflows, this is especially -important on `32`-bit architectures (with the original `base` -approach on 32-architectures, the maximal delay is slightly more than `30` -minutes). - -`MonadTimer` class provides a unified interface to `GHC` event manager api as -defined in -[GHC.Event](https://hackage.haskell.org/package/base/docs/GHC-Event.html). We -expose instances also for architectures which do not provide this `GHC` -interface, like `Windows` or `GHCJS`. - -A good example of usage of this interface is an implementation of platform -independent (Windows!) and reliable implementation of -[timeout](https://github.com/input-output-hk/ouroboros-network/blob/master/network-mux/src/Network/Mux/Timeout.hs#L225) -function (which lives outside of this package). Note that since it is using -only type classes constraints from this package it also works in -[IOSim](https://hackage.haskell.org/package/io-sim/docs/Control-Monad-IOSim.html#t:IOSim) -monad. +The time and timer APIs of this package follows closely the API exposed by +[`base`] and [`time`] packages. We separately packaged a more convenient API +in [`si-timers`] (ref [SI]), which provides a monoidal action of `DiffTime` on +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). + +`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. +On other platforms (e.g. `Windows`), it's good enough for subsecond timeouts +but it's not good enough for fine-grained timeouts (e.g. sub milliseconds) as +it relays on the GHC thread scheduler. We support `MonadTimeout` on `Linux`, +`MacOS`, `Windows`, and `IOSim` (and unofficially on `GHCJS`). + +`MonadDelay` and `MonadTimer` classes provide a well-established interface to +delays & timers. + ## Software Transactional Memory API -We provide two interfaces to `stm` api: lazy and strict one which is provided -in a seprate library `strict-stm`. +We provide two interfaces to `stm` API: lazy, included in `io-classes`; and +strict one provided by [`strict-stm`]. + ## Threads API -We draw a line between `base` api and `async` api. The former one is provided -by +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-MonadFork.html#t:MonadAsync). Both are shallow abstractions around APIs exposed by the `base` and `async` packages. + ## Some other APIs -* [MonadEventlog](https://hackage.haskell.org/package/io-sim-classes/docs/Control-Monad-Class-MonadEventlog.html#t:MonadEventlog): - provides an API to the - [Debug.Trace](https://hackage.haskell.org/package/base/docs/Debug-Trace.html) - eventlog interface. -* [MonadST](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadST.html#t:MonadST): provides a way to lift `ST`-computations. -* [MonadSay](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadSay.html#t:MonadSay): dummy debugging interface +* [MonadEventlog]: provides an API to the [Debug.Trace] event log interface. +* [MonadST]: provides a way to lift `ST`-computations. +* [MonadSay]: dummy debugging interface + + +## Debuging & Insepction + +We provide quite extended debugging & inspection API. This proved to be +extremely helpful when analysing complex deadlocks or livelocks or writing +complex quickcheck properties of a highly concurrent system. Some of this is +only possible because we can control the execution environment of [`io-sim`]. + +* `labelThread` as part of `MonadThread` ([`IO`], [`io-sim`], which is also + part of `GHC` API, ref [`labelThread`][labelThread-base]); +* `MonadLabelledSTM` which allows to label of various `STM` mutable variables, + e.g. `TVar`, `MVar`, etc. ([`io-sim`], not provided by `GHC`); +* `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 +[`async`]: https://hackage.haskell.org/package/async +[`base`]: https://hackage.haskell.org/package/base +[`exceptions`]: https://hackage.haskell.org/package/exceptions +[`io-sim`]: https://hackage.haskell.org/package/io-sim +[`si-timers`]: https://hackage.haskell.org/package/si-timers +[`stm`]: https://hackage.haskell.org/package/stm +[`strict-stm`]: https://hackage.haskell.org/package/strict-stm +[`threadDelay`]: https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadTimer.html#v:threadDela +[`time`]: https://hackage.haskell.org/package/time +[contributing]: https://www.github.com/input-output-hk/io-sim/tree/master/CONTRIBUTING.md +[`nothunks`]: https://hackage.haskell.org/package/nothunks +[labelThread-base]: https://hackage.haskell.org/package/base-4.17.0.0/docs/GHC-Conc-Sync.html#v:labelThread + +[MonadEventlog]: https://hackage.haskell.org/package/io-sim-classes/docs/Control-Monad-Class-MonadEventlog.html#t:MonadEventlog +[Debug.Trace]: https://hackage.haskell.org/package/base/docs/Debug-Trace.html +[MonadST]: https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadST.html#t:MonadST +[MonadSay]: https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadSay.html#t:MonadSay diff --git a/io-classes/io-classes.cabal b/io-classes/io-classes.cabal index 8adc5298..443bd33e 100644 --- a/io-classes/io-classes.cabal +++ b/io-classes/io-classes.cabal @@ -1,18 +1,23 @@ -cabal-version: 3.4 +cabal-version: 3.0 name: io-classes -version: 0.6.0.0 +version: 1.0.0.0 synopsis: Type classes for concurrency with STM, ST and timing --- description: +description: + IO Monad class hierarchy compatible with + [io-sim](https://hackage.haskell.org/package/io-sim), 'base', 'async', + 'stm', 'exceptions' & 'time' packages. license: Apache-2.0 license-files: LICENSE NOTICE copyright: 2019-2023 Input Output Global Inc (IOG) -author: Alexander Vieth, Marcin Szamotulski, Duncan Coutts -maintainer: +author: Alexander Vieth, Duncan Coutts, Marcin Szamotulski, Thomas Winant +maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category: Control build-type: Simple -tested-with: GHC == 8.10.7, GHC == 9.2.5, GHC == 9.4.4 +extra-source-files: CHANGELOG.md + README.md +tested-with: GHC == { 8.10, 9.2, 9.4 } source-repository head type: git @@ -63,14 +68,28 @@ library Control.Monad.Class.MonadTest default-language: Haskell2010 other-extensions: CPP - TypeFamilies - TypeFamilyDependencies - MultiParamTypeClasses - FunctionalDependencies - FlexibleInstances + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DerivingStrategies + ExistentialQuantification + ExplicitNamespaces FlexibleContexts - ScopedTypeVariables + FlexibleInstances + FunctionalDependencies + GADTs + GeneralisedNewtypeDeriving + MultiParamTypeClasses + NamedFieldPuns + QuantifiedConstraints RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances build-depends: base >=4.9 && <4.18, array, async >=2.1, diff --git a/io-classes/src/Control/Concurrent/Class/MonadSTM.hs b/io-classes/src/Control/Concurrent/Class/MonadSTM.hs index d53113cd..8349fae9 100644 --- a/io-classes/src/Control/Concurrent/Class/MonadSTM.hs +++ b/io-classes/src/Control/Concurrent/Class/MonadSTM.hs @@ -1,4 +1,4 @@ --- | This module corresponds to `Control.Concurrent.STM` in "stm" package +-- | This module corresponds to "Control.Concurrent.STM" in "stm" package -- module Control.Concurrent.Class.MonadSTM (module STM) diff --git a/io-classes/src/Control/Monad/Class/MonadAsync.hs b/io-classes/src/Control/Monad/Class/MonadAsync.hs index e150d941..8afd3ba6 100644 --- a/io-classes/src/Control/Monad/Class/MonadAsync.hs +++ b/io-classes/src/Control/Monad/Class/MonadAsync.hs @@ -56,43 +56,72 @@ class ( MonadSTM m asyncWithUnmask, asyncOnWithUnmask, waitCatchSTM, pollSTM #-} -- | An asynchronous action + -- + -- See 'Async.Async'. type Async m = (async :: Type -> Type) | async -> m + -- | See 'Async.async'. async :: m a -> m (Async m a) + -- | See 'Async.asyncBound'. asyncBound :: m a -> m (Async m a) + -- | See 'Async.asyncOn'. asyncOn :: Int -> m a -> m (Async m a) + -- | See 'Async.asyncThreadId'. asyncThreadId :: Async m a -> ThreadId m + -- | See 'Async.withAsync'. withAsync :: m a -> (Async m a -> m b) -> m b + -- | See 'Async.withAsyncBound'. withAsyncBound :: m a -> (Async m a -> m b) -> m b + -- | See 'Async.withAsyncOn'. withAsyncOn :: Int -> m a -> (Async m a -> m b) -> m b + -- | See 'Async.waitSTM'. waitSTM :: Async m a -> STM m a + -- | See 'Async.pollSTM'. pollSTM :: Async m a -> STM m (Maybe (Either SomeException a)) + -- | See 'Async.waitCatchSTM'. waitCatchSTM :: Async m a -> STM m (Either SomeException a) default waitSTM :: MonadThrow (STM m) => Async m a -> STM m a waitSTM action = waitCatchSTM action >>= either throwSTM return + -- | See 'Async.waitAnySTM'. waitAnySTM :: [Async m a] -> STM m (Async m a, a) + -- | See 'Async.waitAnyCatchSTM'. waitAnyCatchSTM :: [Async m a] -> STM m (Async m a, Either SomeException a) + -- | See 'Async.waitEitherSTM'. waitEitherSTM :: Async m a -> Async m b -> STM m (Either a b) + -- | See 'Async.waitEitherSTM_'. waitEitherSTM_ :: Async m a -> Async m b -> STM m () + -- | See 'Async.waitEitherCatchSTM'. waitEitherCatchSTM :: Async m a -> Async m b -> STM m (Either (Either SomeException a) (Either SomeException b)) + -- | See 'Async.waitBothSTM'. waitBothSTM :: Async m a -> Async m b -> STM m (a, b) + -- | See 'Async.wait'. wait :: Async m a -> m a + -- | See 'Async.poll'. poll :: Async m a -> m (Maybe (Either SomeException a)) + -- | See 'Async.waitCatch'. waitCatch :: Async m a -> m (Either SomeException a) + -- | See 'Async.cancel'. cancel :: Async m a -> m () + -- | See 'Async.cancelWith'. cancelWith :: Exception e => Async m a -> e -> m () + -- | See 'Async.uninterruptibleCancel'. uninterruptibleCancel :: Async m a -> m () + -- | See 'Async.waitAny'. waitAny :: [Async m a] -> m (Async m a, a) + -- | See 'Async.waitAnyCatch'. waitAnyCatch :: [Async m a] -> m (Async m a, Either SomeException a) + -- | See 'Async.waitAnyCancel'. waitAnyCancel :: [Async m a] -> m (Async m a, a) + -- | See 'Async.waitAnyCatchCancel'. waitAnyCatchCancel :: [Async m a] -> m (Async m a, Either SomeException a) + -- | See 'Async.waitEither'. waitEither :: Async m a -> Async m b -> m (Either a b) default waitAnySTM :: MonadThrow (STM m) => [Async m a] -> STM m (Async m a, a) @@ -133,24 +162,39 @@ class ( MonadSTM m -- | Note, IO-based implementations should override the default -- implementation. See the @async@ package implementation and comments. -- + -- + -- See 'Async.waitEitherCatch'. waitEitherCatch :: Async m a -> Async m b -> m (Either (Either SomeException a) (Either SomeException b)) + -- | See 'Async.waitEitherCancel'. waitEitherCancel :: Async m a -> Async m b -> m (Either a b) + -- | See 'Async.waitEitherCatchCancel'. waitEitherCatchCancel :: Async m a -> Async m b -> m (Either (Either SomeException a) (Either SomeException b)) + -- | See 'Async.waitEither_'. waitEither_ :: Async m a -> Async m b -> m () + -- | See 'Async.waitBoth'. waitBoth :: Async m a -> Async m b -> m (a, b) + -- | See 'Async.race'. race :: m a -> m b -> m (Either a b) + -- | See 'Async.race_'. race_ :: m a -> m b -> m () + -- | See 'Async.concurrently'. concurrently :: m a -> m b -> m (a,b) + -- | See 'Async.concurrently_'. concurrently_ :: m a -> m b -> m () + -- | See 'Async.concurrently_'. asyncWithUnmask :: ((forall b . m b -> m b) -> m a) -> m (Async m a) + -- | See 'Async.asyncOnWithUnmask'. asyncOnWithUnmask :: Int -> ((forall b . m b -> m b) -> m a) -> m (Async m a) + -- | See 'Async.withAsyncWithUnmask'. withAsyncWithUnmask :: ((forall c. m c -> m c) -> m a) -> (Async m a -> m b) -> m b + -- | See 'Async.withAsyncOnWithUnmask'. withAsyncOnWithUnmask :: Int -> ((forall c. m c -> m c) -> m a) -> (Async m a -> m b) -> m b + -- | See 'Async.compareAsyncs'. compareAsyncs :: Async m a -> Async m b -> Ordering -- default implementations @@ -279,21 +323,27 @@ instance ( Monoid a mempty = pure mempty +-- | See 'Async.mapConcurrently'. mapConcurrently :: (Traversable t, MonadAsync m) => (a -> m b) -> t a -> m (t b) mapConcurrently f = runConcurrently . traverse (Concurrently . f) +-- | See 'Async.forConcurrently'. forConcurrently :: (Traversable t, MonadAsync m) => t a -> (a -> m b) -> m (t b) forConcurrently = flip mapConcurrently +-- | See 'Async.mapConcurrently_'. mapConcurrently_ :: (Foldable f, MonadAsync m) => (a -> m b) -> f a -> m () mapConcurrently_ f = runConcurrently . foldMap (Concurrently . void . f) +-- | See 'Async.forConcurrently_'. forConcurrently_ :: (Foldable f, MonadAsync m) => f a -> (a -> m b) -> m () forConcurrently_ = flip mapConcurrently_ +-- | See 'Async.replicateConcurrently'. replicateConcurrently :: MonadAsync m => Int -> m a -> m [a] replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently +-- | See 'Async.replicateConcurrently_'. replicateConcurrently_ :: MonadAsync m => Int -> m a -> m () replicateConcurrently_ cnt = runConcurrently . fold . replicate cnt . Concurrently . void @@ -395,10 +445,12 @@ instance Exception ExceptionInLinkedThread where fromException = E.asyncExceptionFromException toException = E.asyncExceptionToException +-- | Like 'Async.link'. link :: (MonadAsync m, MonadFork m, MonadMask m) => Async m a -> m () link = linkOnly (not . isCancel) +-- | Like 'Async.linkOnly'. linkOnly :: forall m a. (MonadAsync m, MonadFork m, MonadMask m) => (SomeException -> Bool) -> Async m a -> m () linkOnly shouldThrow a = do @@ -416,10 +468,12 @@ linkOnly shouldThrow a = do exceptionInLinkedThread = ExceptionInLinkedThread (show linkedThreadId) +-- | Like 'Async.link2'. link2 :: (MonadAsync m, MonadFork m, MonadMask m) => Async m a -> Async m b -> m () link2 = link2Only (not . isCancel) +-- | Like 'Async.link2Only'. link2Only :: (MonadAsync m, MonadFork m, MonadMask m) => (SomeException -> Bool) -> Async m a -> Async m b -> m () link2Only shouldThrow left right = diff --git a/io-classes/src/Control/Monad/Class/MonadEventlog.hs b/io-classes/src/Control/Monad/Class/MonadEventlog.hs index d50a7b4a..51cd9e3d 100644 --- a/io-classes/src/Control/Monad/Class/MonadEventlog.hs +++ b/io-classes/src/Control/Monad/Class/MonadEventlog.hs @@ -1,8 +1,5 @@ module Control.Monad.Class.MonadEventlog ( MonadEventlog (..) - -- * Deprecated API - , traceEventM - , traceMarkerM ) where import Control.Monad.Reader @@ -22,17 +19,6 @@ class Monad m => MonadEventlog m where -- profiling tools to help you keep clear which marker is which. traceMarkerIO :: String -> m () - -traceEventM :: MonadEventlog m => String -> m () -traceEventM = traceEventIO -{-# DEPRECATED traceEventM "Use traceEventIO" #-} - - -traceMarkerM :: MonadEventlog m => String -> m () -traceMarkerM = traceMarkerIO -{-# DEPRECATED traceMarkerM "Use traceEventIO" #-} - - -- -- Instances for IO -- diff --git a/io-classes/src/Control/Monad/Class/MonadFork.hs b/io-classes/src/Control/Monad/Class/MonadFork.hs index fb30c905..77a7a9e6 100644 --- a/io-classes/src/Control/Monad/Class/MonadFork.hs +++ b/io-classes/src/Control/Monad/Class/MonadFork.hs @@ -5,11 +5,8 @@ module Control.Monad.Class.MonadFork ( MonadThread (..) - , MonadFork (..) , labelThisThread - -- * Deprecated API - , fork - , forkWithUnmask + , MonadFork (..) ) where import qualified Control.Concurrent as IO @@ -28,6 +25,10 @@ class (Monad m, Eq (ThreadId m), myThreadId :: m (ThreadId m) labelThread :: ThreadId m -> String -> m () +-- | Apply the label to the current thread +labelThisThread :: MonadThread m => String -> m () +labelThisThread label = myThreadId >>= \tid -> labelThread tid label + class MonadThread m => MonadFork m where @@ -41,14 +42,6 @@ class MonadThread m => MonadFork m where yield :: m () -fork :: MonadFork m => m () -> m (ThreadId m) -fork = forkIO -{-# DEPRECATED fork "use forkIO" #-} - -forkWithUnmask :: MonadFork m => ((forall a. m a -> m a) -> m ()) -> m (ThreadId m) -forkWithUnmask = forkIOWithUnmask -{-# DEPRECATED forkWithUnmask "use forkIO" #-} - instance MonadThread IO where type ThreadId IO = IO.ThreadId @@ -77,7 +70,3 @@ instance MonadFork m => MonadFork (ReaderT e m) where in runReaderT (k restore') e throwTo e t = lift (throwTo e t) yield = lift yield - --- | Apply the label to the current thread -labelThisThread :: MonadThread m => String -> m () -labelThisThread label = myThreadId >>= \tid -> labelThread tid label diff --git a/io-classes/src/Control/Monad/Class/MonadMVar.hs b/io-classes/src/Control/Monad/Class/MonadMVar.hs index 5a35d18b..345df0e5 100644 --- a/io-classes/src/Control/Monad/Class/MonadMVar.hs +++ b/io-classes/src/Control/Monad/Class/MonadMVar.hs @@ -3,9 +3,7 @@ {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} -module Control.Monad.Class.MonadMVar - ( MonadMVar (..) - ) where +module Control.Monad.Class.MonadMVar (MonadMVar (..)) where import qualified Control.Concurrent.MVar as IO import Control.Monad.Class.MonadThrow @@ -25,23 +23,39 @@ class Monad m => MonadMVar m where type MVar m :: Type -> Type + -- | See 'IO.newEmptyMVar'. newEmptyMVar :: m (MVar m a) + -- | See 'IO.takeMVar'. takeMVar :: MVar m a -> m a + -- | See 'IO.putMVar'. putMVar :: MVar m a -> a -> m () + -- | See 'IO.tryTakeMVar'. tryTakeMVar :: MVar m a -> m (Maybe a) + -- | See 'IO.tryPutMVar'. tryPutMVar :: MVar m a -> a -> m Bool - readMVar :: MVar m a -> m a - tryReadMVar :: MVar m a -> m (Maybe a) + -- | See 'IO.isEmptyMVar'. isEmptyMVar :: MVar m a -> m Bool -- methods with a default implementation + -- | See 'IO.newMVar'. newMVar :: a -> m (MVar m a) + -- | See 'IO.readMVar'. + readMVar :: MVar m a -> m a + -- | See 'IO.tryReadMVar'. + tryReadMVar :: MVar m a -> m (Maybe a) + -- | See 'IO.swapMVar'. swapMVar :: MVar m a -> a -> m a + -- | See 'IO.withMVar'. withMVar :: MVar m a -> (a -> m b) -> m b + -- | See 'IO.withMVarMasked'. withMVarMasked :: MVar m a -> (a -> m b) -> m b + -- | See 'IO.modifyMVar_'. modifyMVar_ :: MVar m a -> (a -> m a) -> m () + -- | See 'IO.modifyMVar'. modifyMVar :: MVar m a -> (a -> m (a, b)) -> m b + -- | See 'IO.modifyMVarMasked_'. modifyMVarMasked_ :: MVar m a -> (a -> m a) -> m () + -- | See 'IO.modifyMVarMasked'. modifyMVarMasked :: MVar m a -> (a -> m (a,b)) -> m b default newMVar :: a -> m (MVar m a) diff --git a/io-classes/src/Control/Monad/Class/MonadSTM.hs b/io-classes/src/Control/Monad/Class/MonadSTM.hs index 8a1e1139..92512b8c 100644 --- a/io-classes/src/Control/Monad/Class/MonadSTM.hs +++ b/io-classes/src/Control/Monad/Class/MonadSTM.hs @@ -1,4 +1,4 @@ --- | This module corresponds to `Control.Monad.STM` in "stm" package +-- | This module corresponds to "Control.Monad.STM" in "stm" package -- {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} @@ -14,10 +14,20 @@ module Control.Monad.Class.MonadSTM ( MonadSTM (STM, atomically, retry, orElse, check) , throwSTM -- * non standard extensions + -- + -- $non-standard-extensions , MonadLabelledSTM - , MonadTraceSTM - , MonadInspectSTM (..) + , MonadTraceSTM (..) , TraceValue (..) + , MonadInspectSTM (..) ) where import Control.Monad.Class.MonadSTM.Internal + +-- $non-standard-extensions +-- +-- The non standard extensions include `MonadLabelledSTM` and `MonadTraceSTM` / +-- `MonadInspectSTM`. For `IO` these are all no-op, however they greatly +-- enhance [`IOSim`](https://hackage.haskell.org/package/io-sim) capabilities. +-- They are not only useful for debugging concurrency issues, but also to write +-- testable properties. diff --git a/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs b/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs index e9934cb5..8938677b 100644 --- a/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs +++ b/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs @@ -28,31 +28,83 @@ module Control.Monad.Class.MonadSTM.Internal , MonadInspectSTM (..) , TraceValue (TraceValue, TraceDynamic, TraceString, DontTrace, traceDynamic, traceString) , MonadTraceSTM (..) - , LazyTVar - , LazyTMVar - -- * Default 'TMVar' implementation + -- * MonadThrow aliases + , throwSTM + , catchSTM + -- * Default implementations + -- $default-implementations + -- + -- ** Default 'TMVar' implementation , TMVarDefault (..) - -- * Default 'TBQueue' implementation + , newTMVarDefault + , newEmptyTMVarDefault + , takeTMVarDefault + , tryTakeTMVarDefault + , putTMVarDefault + , tryPutTMVarDefault + , readTMVarDefault + , tryReadTMVarDefault + , swapTMVarDefault + , isEmptyTMVarDefault + , labelTMVarDefault + , traceTMVarDefault + -- ** Default 'TBQueue' implementation , TQueueDefault (..) - -- * Default 'TBQueue' implementation + , newTQueueDefault + , writeTQueueDefault + , readTQueueDefault + , tryReadTQueueDefault + , isEmptyTQueueDefault + , peekTQueueDefault + , tryPeekTQueueDefault + , flushTQueueDefault + , unGetTQueueDefault + , labelTQueueDefault + -- ** Default 'TBQueue' implementation , TBQueueDefault (..) - -- * Default 'TArray' implementation + , newTBQueueDefault + , writeTBQueueDefault + , readTBQueueDefault + , tryReadTBQueueDefault + , peekTBQueueDefault + , tryPeekTBQueueDefault + , isEmptyTBQueueDefault + , isFullTBQueueDefault + , lengthTBQueueDefault + , flushTBQueueDefault + , unGetTBQueueDefault + , labelTBQueueDefault + -- ** Default 'TArray' implementation , TArrayDefault (..) - -- * Default 'TSem' implementation + -- ** Default 'TSem' implementation , TSemDefault (..) - -- * Default 'TChan' implementation + , newTSemDefault + , waitTSemDefault + , signalTSemDefault + , signalTSemNDefault + , labelTSemDefault + -- ** Default 'TChan' implementation , TChanDefault (..) - -- * MonadThrow aliases - , throwSTM - , catchSTM - -- * Deprecated API - , newTVarM - , newTMVarM - , newTMVarMDefault - , newEmptyTMVarM - , newEmptyTMVarMDefault + , newTChanDefault + , newBroadcastTChanDefault + , writeTChanDefault + , readTChanDefault + , tryReadTChanDefault + , peekTChanDefault + , tryPeekTChanDefault + , dupTChanDefault + , unGetTChanDefault + , isEmptyTChanDefault + , cloneTChanDefault + , labelTChanDefault ) where +-- $default-implementations +-- +-- The default implementations are based on a `TVar` defined in the class. They +-- are tailored towards `IOSim` rather than instances which would like to derive +-- from `IO` or monad transformers. + import Prelude hiding (read) import qualified Control.Concurrent.STM.TArray as STM @@ -84,23 +136,27 @@ import GHC.Stack import Numeric.Natural (Natural) -{-# DEPRECATED LazyTVar "Renamed back to 'TVar'" #-} -{-# DEPRECATED LazyTMVar "Renamed back to 'TMVar'" #-} -type LazyTVar m = TVar m -type LazyTMVar m = TMVar m - --- The STM primitives +-- | The STM primitives parametrised by a monad `m`. +-- class (Monad m, Monad (STM m)) => MonadSTM m where - -- STM transactions + -- | The STM monad. type STM m = (stm :: Type -> Type) | stm -> m + -- | Atomically run an STM computation. + -- + -- See `STM.atomically`. atomically :: HasCallStack => STM m a -> m a + -- | A type of a 'TVar'. + -- + -- See `STM.TVar'. type TVar m :: Type -> Type newTVar :: a -> STM m (TVar m a) readTVar :: TVar m a -> STM m a writeTVar :: TVar m a -> a -> STM m () + -- | See `STM.retry`. retry :: STM m a + -- | See `STM.orElse`. orElse :: STM m a -> STM m a -> STM m a modifyTVar :: TVar m a -> (a -> a) -> STM m () @@ -116,6 +172,7 @@ class (Monad m, Monad (STM m)) => MonadSTM m where swapTVar :: TVar m a -> a -> STM m a swapTVar = swapTVarDefault + -- | See `STM.check`. check :: Bool -> STM m () check True = return () check _ = retry @@ -195,14 +252,6 @@ class (Monad m, Monad (STM m)) => MonadSTM m where -- default implementations -- - default newTMVar :: TMVar m ~ TMVarDefault m - => a -> STM m (TMVar m a) - newTMVar = newTMVarDefault - - default newEmptyTMVar :: TMVar m ~ TMVarDefault m - => STM m (TMVar m a) - newEmptyTMVar = newEmptyTMVarDefault - newTVarIO = atomically . newTVar readTVarIO = atomically . readTVar newTMVarIO = atomically . newTMVar @@ -212,175 +261,6 @@ class (Monad m, Monad (STM m)) => MonadSTM m where newTChanIO = atomically newTChan newBroadcastTChanIO = atomically newBroadcastTChan - default takeTMVar :: TMVar m ~ TMVarDefault m - => TMVar m a -> STM m a - takeTMVar = takeTMVarDefault - - default tryTakeTMVar :: TMVar m ~ TMVarDefault m - => TMVar m a -> STM m (Maybe a) - tryTakeTMVar = tryTakeTMVarDefault - - default putTMVar :: TMVar m ~ TMVarDefault m => TMVar m a -> a -> STM m () - putTMVar = putTMVarDefault - - default tryPutTMVar :: TMVar m ~ TMVarDefault m => TMVar m a -> a -> STM m Bool - tryPutTMVar = tryPutTMVarDefault - - default readTMVar :: TMVar m ~ TMVarDefault m - => TMVar m a -> STM m a - readTMVar = readTMVarDefault - - default tryReadTMVar :: TMVar m ~ TMVarDefault m - => TMVar m a -> STM m (Maybe a) - tryReadTMVar = tryReadTMVarDefault - - default swapTMVar :: TMVar m ~ TMVarDefault m - => TMVar m a -> a -> STM m a - swapTMVar = swapTMVarDefault - - default isEmptyTMVar :: TMVar m ~ TMVarDefault m - => TMVar m a -> STM m Bool - isEmptyTMVar = isEmptyTMVarDefault - - default newTQueue :: TQueue m ~ TQueueDefault m - => STM m (TQueue m a) - newTQueue = newTQueueDefault - - default writeTQueue :: TQueue m ~ TQueueDefault m - => TQueue m a -> a -> STM m () - writeTQueue = writeTQueueDefault - - default readTQueue :: TQueue m ~ TQueueDefault m - => TQueue m a -> STM m a - readTQueue = readTQueueDefault - - default tryReadTQueue :: TQueue m ~ TQueueDefault m - => TQueue m a -> STM m (Maybe a) - tryReadTQueue = tryReadTQueueDefault - - default isEmptyTQueue :: TQueue m ~ TQueueDefault m - => TQueue m a -> STM m Bool - isEmptyTQueue = isEmptyTQueueDefault - - default unGetTQueue :: TQueue m ~ TQueueDefault m - => TQueue m a -> a -> STM m () - unGetTQueue = unGetTQueueDefault - - default peekTQueue :: TQueue m ~ TQueueDefault m - => TQueue m a -> STM m a - peekTQueue = peekTQueueDefault - - default tryPeekTQueue :: TQueue m ~ TQueueDefault m - => TQueue m a -> STM m (Maybe a) - tryPeekTQueue = tryPeekTQueueDefault - - default flushTQueue :: TQueue m ~ TQueueDefault m - => TQueue m a -> STM m [a] - flushTQueue = flushTQueueDefault - - default newTBQueue :: TBQueue m ~ TBQueueDefault m - => Natural -> STM m (TBQueue m a) - newTBQueue = newTBQueueDefault - - default writeTBQueue :: TBQueue m ~ TBQueueDefault m - => TBQueue m a -> a -> STM m () - writeTBQueue = writeTBQueueDefault - - default readTBQueue :: TBQueue m ~ TBQueueDefault m - => TBQueue m a -> STM m a - readTBQueue = readTBQueueDefault - - default tryReadTBQueue :: TBQueue m ~ TBQueueDefault m - => TBQueue m a -> STM m (Maybe a) - tryReadTBQueue = tryReadTBQueueDefault - - default isEmptyTBQueue :: TBQueue m ~ TBQueueDefault m - => TBQueue m a -> STM m Bool - isEmptyTBQueue = isEmptyTBQueueDefault - - default peekTBQueue :: TBQueue m ~ TBQueueDefault m - => TBQueue m a -> STM m a - peekTBQueue = peekTBQueueDefault - - default tryPeekTBQueue :: TBQueue m ~ TBQueueDefault m - => TBQueue m a -> STM m (Maybe a) - tryPeekTBQueue = tryPeekTBQueueDefault - - default isFullTBQueue :: TBQueue m ~ TBQueueDefault m - => TBQueue m a -> STM m Bool - isFullTBQueue = isFullTBQueueDefault - - default lengthTBQueue :: TBQueue m ~ TBQueueDefault m - => TBQueue m a -> STM m Natural - lengthTBQueue = lengthTBQueueDefault - - default flushTBQueue :: TBQueue m ~ TBQueueDefault m - => TBQueue m a -> STM m [a] - flushTBQueue = flushTBQueueDefault - - default unGetTBQueue :: TBQueue m ~ TBQueueDefault m - => TBQueue m a -> a -> STM m () - unGetTBQueue = unGetTBQueueDefault - - default newTSem :: TSem m ~ TSemDefault m - => Integer -> STM m (TSem m) - newTSem = newTSemDefault - - default waitTSem :: TSem m ~ TSemDefault m - => TSem m -> STM m () - waitTSem = waitTSemDefault - - default signalTSem :: TSem m ~ TSemDefault m - => TSem m -> STM m () - signalTSem = signalTSemDefault - - default signalTSemN :: TSem m ~ TSemDefault m - => Natural -> TSem m -> STM m () - signalTSemN = signalTSemNDefault - - default newTChan :: TChan m ~ TChanDefault m - => STM m (TChan m a) - newTChan = newTChanDefault - - default newBroadcastTChan :: TChan m ~ TChanDefault m - => STM m (TChan m a) - newBroadcastTChan = newBroadcastTChanDefault - - default writeTChan :: TChan m ~ TChanDefault m - => TChan m a -> a -> STM m () - writeTChan = writeTChanDefault - - default readTChan :: TChan m ~ TChanDefault m - => TChan m a -> STM m a - readTChan = readTChanDefault - - default tryReadTChan :: TChan m ~ TChanDefault m - => TChan m a -> STM m (Maybe a) - tryReadTChan = tryReadTChanDefault - - default peekTChan :: TChan m ~ TChanDefault m - => TChan m a -> STM m a - peekTChan = peekTChanDefault - - default tryPeekTChan :: TChan m ~ TChanDefault m - => TChan m a -> STM m (Maybe a) - tryPeekTChan = tryPeekTChanDefault - - default dupTChan :: TChan m ~ TChanDefault m - => TChan m a -> STM m (TChan m a) - dupTChan = dupTChanDefault - - default unGetTChan :: TChan m ~ TChanDefault m - => TChan m a -> a -> STM m () - unGetTChan = unGetTChanDefault - - default isEmptyTChan :: TChan m ~ TChanDefault m - => TChan m a -> STM m Bool - isEmptyTChan = isEmptyTChanDefault - - default cloneTChan :: TChan m ~ TChanDefault m - => TChan m a -> STM m (TChan m a) - cloneTChan = cloneTChanDefault stateTVarDefault :: MonadSTM m => TVar m s -> (s -> (a, s)) -> STM m a @@ -397,23 +277,15 @@ swapTVarDefault var new = do return old -newTVarM :: MonadSTM m => a -> m (TVar m a) -newTVarM = newTVarIO -{-# DEPRECATED newTVarM "Use newTVarIO" #-} - -newTMVarM :: MonadSTM m => a -> m (TMVar m a) -newTMVarM = newTMVarIO -{-# DEPRECATED newTMVarM "Use newTMVarIO" #-} - -newEmptyTMVarM :: MonadSTM m => m (TMVar m a) -newEmptyTMVarM = newEmptyTMVarIO -{-# DEPRECATED newEmptyTMVarM "Use newEmptyTMVarIO" #-} - - --- | Labelled 'TVar's, 'TMVar's, 'TQueue's and 'TBQueue's. +-- | Labelled `TVar`s & friends. +-- +-- 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 MonadSTM m => MonadLabelledSTM m where + -- | Name a `TVar`. labelTVar :: TVar m a -> String -> STM m () labelTMVar :: TMVar m a -> String -> STM m () labelTQueue :: TQueue m a -> String -> STM m () @@ -486,15 +358,21 @@ class MonadSTM m labelTChanIO = \v l -> atomically (labelTChan v l) --- | This type class is indented for 'io-sim', where one might want to access --- 'TVar' in the underlying 'ST' monad. +-- | This type class is indented for +-- ['io-sim'](https://hackage.haskell.org/package/io-sim), where one might want +-- to access a 'TVar' in the underlying 'ST' monad. -- class ( MonadSTM m , Monad (InspectMonad m) ) => MonadInspectSTM m where type InspectMonad 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 + -- | Return the value of a `TMVar` as an `InspectMonad` computation. inspectTMVar :: proxy m -> TMVar m a -> InspectMonad m (Maybe a) -- TODO: inspectTQueue, inspectTBQueue @@ -506,8 +384,10 @@ instance MonadInspectSTM IO where -- | A GADT which instructs how to trace the value. The 'traceDynamic' will --- use dynamic tracing, e.g. 'Control.Monad.IOSim.traceM'; while 'traceString' --- will be traced with 'EventSay'. +-- use dynamic tracing, e.g. "Control.Monad.IOSim.traceM"; while 'traceString' +-- will be traced with 'EventSay'. The `IOSim`s dynamic tracing allows to +-- recover the value from the simulation trace (see +-- "Control.Monad.IOSim.selectTraceEventsDynamic"). -- data TraceValue where TraceValue :: forall tr. Typeable tr @@ -517,7 +397,7 @@ data TraceValue where -> TraceValue --- | Use only dynamic tracer. +-- | Use only a dynamic tracer. -- pattern TraceDynamic :: () => forall tr. Typeable tr => tr -> TraceValue pattern TraceDynamic tr <- TraceValue { traceDynamic = Just tr } @@ -546,14 +426,23 @@ pattern DontTrace <- TraceValue Nothing Nothing -- class MonadInspectSTM m => MonadTraceSTM m where - -- | Construct a trace out of previous & new value of a 'TVar'. The callback - -- is called whenever an stm transaction which modifies the 'TVar' is + {-# MINIMAL traceTVar, traceTQueue, traceTBQueue #-} + + -- | Construct a trace output out of previous & new value of a 'TVar'. The + -- callback is called whenever an stm transaction which modifies the 'TVar' is -- committed. -- - -- This is supported by 'IOSim' and 'IOSimPOR'; 'IO' has a trivial instance. + -- This is supported by 'IOSim' (and 'IOSimPOR'); 'IO' has a trivial instance. + -- + -- The simplest example is: + -- + -- > + -- > traceTVar (Proxy @m) tvar (\_ -> TraceString . show) + -- > + -- + -- Note that the interpretation of `TraceValue` depends on the monad `m` + -- itself (see 'TraceValue'). -- - {-# MINIMAL traceTVar, traceTQueue, traceTBQueue #-} - traceTVar :: proxy m -> TVar m a -> (Maybe a -> a -> InspectMonad m TraceValue) @@ -800,31 +689,11 @@ newTMVarDefault a = do t <- newTVar (Just a) return (TMVar t) -newTMVarIODefault :: MonadSTM m => a -> m (TMVarDefault m a) -newTMVarIODefault a = do - t <- newTVarM (Just a) - return (TMVar t) -{-# DEPRECATED newTMVarIODefault "MonadSTM provides a default implementation" #-} - -newTMVarMDefault :: MonadSTM m => a -> m (TMVarDefault m a) -newTMVarMDefault = newTMVarIODefault -{-# DEPRECATED newTMVarMDefault "Use newTMVarIODefault" #-} - newEmptyTMVarDefault :: MonadSTM m => STM m (TMVarDefault m a) newEmptyTMVarDefault = do t <- newTVar Nothing return (TMVar t) -newEmptyTMVarIODefault :: MonadSTM m => m (TMVarDefault m a) -newEmptyTMVarIODefault = do - t <- newTVarIO Nothing - return (TMVar t) -{-# DEPRECATED newEmptyTMVarIODefault "MonadSTM provides a default implementation" #-} - -newEmptyTMVarMDefault :: MonadSTM m => m (TMVarDefault m a) -newEmptyTMVarMDefault = newEmptyTMVarIODefault -{-# DEPRECATED newEmptyTMVarMDefault "Use newEmptyTMVarIODefault" #-} - takeTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m a takeTMVarDefault (TMVar t) = do m <- readTVar t diff --git a/io-classes/src/Control/Monad/Class/MonadTest.hs b/io-classes/src/Control/Monad/Class/MonadTest.hs index cb069b85..a53c645f 100644 --- a/io-classes/src/Control/Monad/Class/MonadTest.hs +++ b/io-classes/src/Control/Monad/Class/MonadTest.hs @@ -2,7 +2,11 @@ module Control.Monad.Class.MonadTest (MonadTest (..)) where import Control.Monad.Reader +-- | A helper monad for /IOSimPOR/. class Monad m => MonadTest m where + -- | mark a thread for schedule exploration. All threads that are forked by + -- it are also included in the exploration. + -- exploreRaces :: m () exploreRaces = return () diff --git a/io-classes/src/Control/Monad/Class/MonadThrow.hs b/io-classes/src/Control/Monad/Class/MonadThrow.hs index 5e4042d0..fba54fbf 100644 --- a/io-classes/src/Control/Monad/Class/MonadThrow.hs +++ b/io-classes/src/Control/Monad/Class/MonadThrow.hs @@ -19,8 +19,6 @@ module Control.Monad.Class.MonadThrow , ExitCase (..) , Handler (..) , catches - -- * Deprecated interfaces - , throwM ) where import Control.Exception (Exception (..), MaskingState, SomeException) @@ -58,10 +56,6 @@ class Monad m => MonadThrow m where a `finally` sequel = bracket_ (return ()) sequel a -throwM :: (MonadThrow m, Exception e) => e -> m a -throwM = throwIO -{-# DEPRECATED throwM "Use throwIO" #-} - -- | Catching exceptions. -- -- Covers standard utilities to respond to exceptions. diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index 06aa4477..35814338 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -2,6 +2,8 @@ ## next version +## 1.0.0.0 + ### Breaking changes * Support refactored `MonadTimer`, and new `MonadTimerFancy`, `MonadTimeNSec` diff --git a/io-sim/README.md b/io-sim/README.md index eeacaeab..d2bb3b4d 100644 --- a/io-sim/README.md +++ b/io-sim/README.md @@ -1,7 +1,8 @@ -# Simulator Monad +# IOSim - IO Simulator Monad -A pure simulator monad built on top of the `ST` monad which supports: +A pure simulator monad built on top of the lazy `ST` monad which supports: + * optional dynamic race discovery and schedule exploration * synchronous and asynchronous exceptions; including: throwing, catching and masking synchronous and asynchronous exceptions; * concurrency (using simulated threads), with interfaces shaped by the @@ -11,25 +12,33 @@ A pure simulator monad built on top of the `ST` monad which supports: * timeouts; * dynamically typed traces and event log tracing; * lifting any `ST` computations; - * deadlock detection. + * inspection of `STM` mutable data structures; + * deadlock detection; + * `MonadFix` instances for both `IOSim` and its corresponding `STM` monad. -`io-sim` is a drop-in replacement for the `IO` monad. It was designed to write easily -testable Haskell networking code. Using -[io-classes](https://hackage.haskell.org/package/io-classes) library -one can write code that can run in both: real `IO` and the `SimM` monad. One -of the design goals was to keep the api as close as possible to `base`, -`exceptions`, `async` and `stm` packages. +`io-sim` together with [`io-classes`] is a drop-in replacement for the `IO` +monad (with some ramifications). It was designed to write easily testable +Haskell code (including simulating socket programming or disk IO). Using +[`io-classes`] and [`si-timers`] libraries one can write code that can run in +both: the real `IO` and the `IOSim` monad provided by this package. One of the +design goals was to keep the API as close as possible to `base`, `exceptions`, +`async`, and `stm` packages. -As a design choice `IOSim` does not support `MVar`s by default, but they can be -simulated using `stm` interface. +`io-sim` package also provides two interpreters, a standard one and `IOSimPOR` +which supports dynamic discovery or race conditions and schedule exploration +with partial order reduction. -`io-sim` supports both `io-classes` class hierarchy and `base` -/ `exceptions` class hierarchies (they diverge in some detail). +`io-sim` provides API to explore traces produced by a simulation. It can +contain arbitrary Haskell terms, a feature that is very useful to build +property-based tests using `QuickCheck`. - -The package contains thorough tests, including tests of `STM` against the original -specification (as described in [Composable Memory +The package contains thorough tests, including tests of `STM` against the +original specification (as described in [Composable Memory Transactions](https://research.microsoft.com/en-us/um/people/simonpj/papers/stm/stm.pdf) and its `GHC` implementation. This can be seen in both ways: as a check that -our implementation matches the specification and the `GHC` implementation, but also -the other way around: that `GHC`s `STM` implementation meets the specification. +our implementation matches the specification and the `GHC` implementation, but +also the other way around: that `GHC`s `STM` implementation meets the +specification. + +[`io-classes`]: https://hackage.haskell.org/package/io-classes +[`si-timers`]: https://hackage.haskell.org/package/si-timers diff --git a/io-sim/io-sim.cabal b/io-sim/io-sim.cabal index ddb9e45e..92cbbaa5 100644 --- a/io-sim/io-sim.cabal +++ b/io-sim/io-sim.cabal @@ -1,18 +1,23 @@ -cabal-version: 3.4 +cabal-version: 3.0 name: io-sim -version: 0.6.0.0 -synopsis: A pure simulator for monadic concurrency with STM --- description: +version: 1.0.0.0 +synopsis: A pure simulator for monadic concurrency with STM. +description: + A pure simulator monad with support of concurency (base, async), stm, + synchronous and asynchronous exceptions, timeouts & delays, dynamic traces, + and more. license: Apache-2.0 license-files: LICENSE NOTICE -copyright: 2019-2023 Input Output Global Inc (IOG) -author: Duncan Coutts, Marcin Szamotulski, Alexander Vieth -maintainer: +copyright: 2022-2023 Input Output Global Inc (IOG) +author: Alexander Vieth, Duncan Coutts, John Hughes, Marcin Szamotulski +maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category: Testing build-type: Simple -tested-with: GHC == 8.10.7, GHC == 9.2.5, GHC == 9.4.4 +extra-source-files: CHANGELOG.md + README.md +tested-with: GHC == { 8.10, 9.2, 9.4 } flag asserts description: Enable assertions @@ -42,9 +47,9 @@ library import: warnings hs-source-dirs: src exposed-modules: Data.List.Trace, - Control.Monad.IOSim, - Control.Monad.IOSim.Types + Control.Monad.IOSim other-modules: Control.Monad.IOSim.CommonTypes, + Control.Monad.IOSim.Types, Control.Monad.IOSim.Internal, Control.Monad.IOSim.InternalTypes, Control.Monad.IOSim.STM, @@ -55,23 +60,31 @@ library default-language: Haskell2010 other-extensions: BangPatterns, CPP, + DeriveFunctor, + DeriveGeneric, + DerivingVia, ExistentialQuantification, + ExplicitNamespaces, + FlexibleContexts, FlexibleInstances, GADTSyntax, GeneralizedNewtypeDeriving, MultiParamTypeClasses, NamedFieldPuns, + NumericUnderscores, RankNTypes, ScopedTypeVariables, TypeFamilies build-depends: base >=4.9 && <4.18, - io-classes ^>=0.6, + io-classes ^>=1.0, exceptions >=0.10, containers, deque, + nothunks, parallel, psqueues >=0.2 && <0.3, - si-timers ^>=0.6, + strict-stm ^>=1.0, + si-timers ^>=1.0, time >=1.9.1 && <1.13, quiet, QuickCheck, diff --git a/io-sim/src/Control/Monad/IOSim.hs b/io-sim/src/Control/Monad/IOSim.hs index c592ce8f..f266b479 100644 --- a/io-sim/src/Control/Monad/IOSim.hs +++ b/io-sim/src/Control/Monad/IOSim.hs @@ -14,25 +14,37 @@ module Control.Monad.IOSim , runSimStrictShutdown , Failure (..) , runSimTrace - , controlSimTrace + , runSimTraceST + -- ** Explore races using /IOSimPOR/ + -- $iosimpor , exploreSimTrace + , controlSimTrace , ScheduleMod (..) , ScheduleControl (..) - , runSimTraceST + -- *** Exploration options + , ExplorationSpec + , ExplorationOptions (..) + , stdExplorationOptions + , withScheduleBound + , withBranching + , withStepTimelimit + , withReplay + -- * Lift ST computations , liftST - , traceM - , traceSTM -- * Simulation time , setCurrentTime , unshareClock -- * Simulation trace , type SimTrace - , Trace (Cons, Nil, Trace, SimTrace, SimPORTrace, TraceDeadlock, TraceLoop, TraceMainReturn, TraceMainException, TraceRacesFound) + , Trace (Cons, Nil, SimTrace, SimPORTrace, TraceDeadlock, TraceLoop, TraceMainReturn, TraceMainException, TraceRacesFound) , SimResult (..) , SimEvent (..) , SimEventType (..) , ThreadLabel , Labelled (..) + -- ** Dynamic Tracing + , traceM + , traceSTM -- ** Pretty printers , ppTrace , ppTrace_ @@ -56,27 +68,14 @@ module Control.Monad.IOSim , traceSelectTraceEventsSay -- ** IO printer , printTraceEventsSay - -- * Exploration options - , ExplorationSpec - , ExplorationOptions (..) - , stdExplorationOptions - , withScheduleBound - , withBranching - , withStepTimelimit - , withReplay -- * Eventlog , EventlogEvent (..) , EventlogMarker (..) -- * Low-level API - , execReadTVar , newTimeout , readTimeout , cancelTimeout , awaitTimeout - -- * Deprecated interfaces - , SimM - , SimSTM - , TraceEvent ) where import Prelude @@ -84,6 +83,7 @@ import Prelude import Data.Bifoldable import Data.Dynamic (fromDynamic) import Data.List (intercalate) +import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable (Typeable) @@ -95,7 +95,7 @@ import Control.Monad.ST.Lazy import Control.Monad.Class.MonadThrow as MonadThrow -import Control.Monad.IOSim.Internal +import Control.Monad.IOSim.Internal (runSimTraceST) import Control.Monad.IOSim.Types import Control.Monad.IOSimPOR.Internal (controlSimTraceST) import Control.Monad.IOSimPOR.QuickCheckUtils @@ -167,7 +167,7 @@ detachTraceRaces trace = unsafePerformIO $ do go (SimPORTrace a b c d e trace) = SimPORTrace a b c d e $ go trace go (TraceRacesFound r trace) = saveRaces r $ go trace go t = t - return (readRaces,go trace) + return (readRaces, go trace) -- | Select all the traced values matching the expected type. This relies on -- the sim's dynamic trace facility. @@ -261,18 +261,18 @@ traceSelectTraceEventsSay = traceSelectTraceEvents fn fn (EventSay s) = Just s fn _ = Nothing --- | Simulation termination with failure +-- | Simulation terminated a failure. -- data Failure = - -- | The main thread terminated with an exception + -- | The main thread terminated with an exception. FailureException SomeException - -- | The threads all deadlocked + -- | The threads all deadlocked. | FailureDeadlock ![Labelled ThreadId] -- | The main thread terminated normally but other threads were still -- alive, and strict shutdown checking was requested. - -- See 'runSimStrictShutdown' + -- See 'runSimStrictShutdown'. | FailureSloppyShutdown [Labelled ThreadId] -- | An exception was thrown while evaluation the trace. @@ -310,14 +310,22 @@ runSimOrThrow mainAction = Left e -> throw e Right x -> x --- | Like 'runSim' but also fail if when the main thread terminates, there --- are other threads still running or blocked. If one is trying to follow --- a strict thread cleanup policy then this helps testing for that. +-- | Like 'runSim' but fail when the main thread terminates if there are other +-- threads still running or blocked. If one is trying to follow a strict thread +-- cleanup policy then this helps testing for that. -- runSimStrictShutdown :: forall a. (forall s. IOSim s a) -> Either Failure a runSimStrictShutdown mainAction = traceResult True (runSimTrace mainAction) -traceResult :: Bool -> SimTrace a -> Either Failure a +-- | Fold through the trace and return either a 'Failure' or the simulation +-- result, i.e. the return value of the main thread. +-- +traceResult :: Bool + -- ^ if True the simulation will fail if there are any threads which + -- didn't terminated when the main thread terminated. + -> SimTrace a + -- ^ simulation trace + -> Either Failure a traceResult strict = unsafePerformIO . eval where eval :: SimTrace a -> IO (Either Failure a) @@ -338,6 +346,8 @@ traceResult strict = unsafePerformIO . eval go (TraceDeadlock _ threads) = pure $ Left (FailureDeadlock threads) go TraceLoop{} = error "Impossible: traceResult TraceLoop{}" +-- | Turn 'SimTrace' into a list of timestamped events. +-- traceEvents :: SimTrace a -> [(Time, ThreadId, Maybe ThreadLabel, SimEventType)] traceEvents (SimTrace time tid tlbl event t) = (time, tid, tlbl, event) : traceEvents t @@ -346,6 +356,8 @@ traceEvents (SimPORTrace time tid _ tlbl event t) = (time, tid, tlbl, event) traceEvents _ = [] +-- | Pretty print a timestamped event. +-- ppEvents :: [(Time, ThreadId, Maybe ThreadLabel, SimEventType)] -> String ppEvents events = @@ -374,20 +386,42 @@ ppEvents events = runSimTrace :: forall a. (forall s. IOSim s a) -> SimTrace a runSimTrace mainAction = runST (runSimTraceST mainAction) -controlSimTrace :: forall a. - Maybe Int - -> ScheduleControl - -- ^ note: must be either `ControlDefault` or `ControlAwait`. - -> (forall s. IOSim s a) - -> SimTrace a -controlSimTrace limit control mainAction = - runST (controlSimTraceST limit control mainAction) - +-- +-- IOSimPOR +-- +-- +-- $iosimpor +-- +-- /IOSimPOR/ is a different interpreter of 'IOSim' which has the ability to +-- discover race conditions and replay the simulation using a schedule which +-- reverts them. For extended documentation how to use it see +-- [here](https://github.com/input-output-hk/io-sim/blob/main/io-sim/how-to-use-IOSimPOR.md). +-- +-- /IOSimPOR/ only discovers races between events which happen in the same time +-- slot. In /IOSim/ and /IOSimPOR/ time only moves explicitly through timer +-- events, e.g. things like `Control.Monad.Class.MonadTimer.SI.threadDelay`, +-- `Control.Monad.Class.MonadTimer.SI.registerDelay` or the +-- `Control.Monad.Class.MonadTimer.NonStandard.MonadTimeout` api. The usual +-- quickcheck techniques can help explore different schedules of +-- threads too. + +-- | Execute a simulation, discover & revert races. Note that this will execute +-- the simulation multiple times with different schedules, and thus it's much +-- more costly than a simple `runSimTrace` (also the simulation environments has +-- much more state to track and hence is slower). +-- +-- On property failure it will show the failing schedule (`ScheduleControl`) +-- which can be plugged to `controlSimTrace`. +-- exploreSimTrace :: forall a test. Testable test => (ExplorationOptions -> ExplorationOptions) + -- ^ modify default exploration options -> (forall s. IOSim s a) + -- ^ a simulation to run -> (Maybe (SimTrace a) -> SimTrace a -> test) + -- ^ a callback which receives the previous trace (e.g. before reverting + -- a race condition) and current trace -> Property exploreSimTrace optsf mainAction k = case explorationReplay opts of @@ -396,42 +430,49 @@ exploreSimTrace optsf mainAction k = let size = cacheSize() in size `seq` tabulate "Modified schedules explored" [bucket size] True Just control -> - replaySimTrace opts mainAction control k + replaySimTrace opts mainAction control (k Nothing) where opts = optsf stdExplorationOptions + explore :: Int -> Int -> ScheduleControl -> Maybe (SimTrace a) -> Property explore n m control passingTrace = -- ALERT!!! Impure code: readRaces must be called *after* we have -- finished with trace. - let (readRaces,trace0) = detachTraceRaces $ - controlSimTrace (explorationStepTimelimit opts) control mainAction + let (readRaces, trace0) = detachTraceRaces $ + controlSimTrace + (explorationStepTimelimit opts) control mainAction (sleeper,trace) = compareTraces passingTrace trace0 - in (counterexample ("Schedule control: " ++ show control) $ - counterexample (case sleeper of Nothing -> "No thread delayed" - Just ((t,tid,lab),racing) -> - showThread (tid,lab) ++ - " delayed at time "++ - show t ++ - "\n until after:\n" ++ - unlines (map ((" "++).showThread) $ Set.toList racing) - ) $ - k passingTrace trace) .&&| - let limit = (n+m-1) `div` m - -- To ensure the set of schedules explored is deterministic, we filter out - -- cached ones *after* selecting the children of this node. - races = filter (not . cached) . take limit $ readRaces() - branching = length races - in -- tabulate "Races explored" (map show races) $ - tabulate "Branching factor" [bucket branching] $ - tabulate "Race reversals per schedule" [bucket (raceReversals control)] $ - conjoinPar - [ --Debug.trace "New schedule:" $ - --Debug.trace (" "++show r) $ - --counterexample ("Schedule control: " ++ show r) $ - explore n' ((m-1) `max` 1) r (Just trace0) - | (r,n') <- zip races (divide (n-branching) branching) ] - + in ( counterexample ("Schedule control: " ++ show control) + $ counterexample + (case sleeper of + Nothing -> "No thread delayed" + Just ((t,tid,lab),racing) -> + showThread (tid,lab) ++ + " delayed at time "++ + show t ++ + "\n until after:\n" ++ + unlines (map ((" "++).showThread) $ Set.toList racing) + ) + $ k passingTrace trace + ) + .&&| let limit = (n+m-1) `div` m + -- To ensure the set of schedules explored is deterministic, we + -- filter out cached ones *after* selecting the children of this + -- node. + races = filter (not . cached) . take limit $ readRaces () + branching = length races + in -- tabulate "Races explored" (map show races) $ + tabulate "Branching factor" [bucket branching] $ + tabulate "Race reversals per schedule" [bucket (raceReversals control)] $ + conjoinPar + [ --Debug.trace "New schedule:" $ + --Debug.trace (" "++show r) $ + --counterexample ("Schedule control: " ++ show r) $ + explore n' ((m-1) `max` 1) r (Just trace0) + | (r,n') <- zip races (divide (n-branching) branching) ] + + bucket :: Int -> String bucket n | n<10 = show n | n>=10 = buck n 1 | otherwise = error "Ord Int is not a total order!" -- GHC made me do it! @@ -439,6 +480,7 @@ exploreSimTrace optsf mainAction k = | n>=10 = buck (n `div` 10) (t*10) | otherwise = error "Ord Int is not a total order!" -- GHC made me do it! + divide :: Int -> Int -> [Int] divide n k = [ n `div` k + if i "" Just l -> " ("++l++")") + -- cache of explored schedules + cache :: IORef (Set ScheduleControl) + cache = unsafePerformIO cacheIO + + -- insert a schedule into the cache + cached :: ScheduleControl -> Bool + cached = unsafePerformIO . cachedIO + + -- compute cache size; it's a function to make sure that `GHC` does not + -- inline it (and share the same thunk). + cacheSize :: () -> Int + cacheSize = unsafePerformIO . cacheSizeIO + + -- + -- Caching in IO monad + -- + -- It is possible for the same control to be generated several times. -- To avoid exploring them twice, we keep a cache of explored schedules. - cache = unsafePerformIO $ newIORef $ + cacheIO :: IO (IORef (Set ScheduleControl)) + cacheIO = newIORef $ -- we use opts here just to be sure the reference cannot be -- lifted out of exploreSimTrace - if explorationScheduleBound opts>=0 + if explorationScheduleBound opts >=0 then Set.empty else error "exploreSimTrace: negative schedule bound" - cached m = unsafePerformIO $ atomicModifyIORef' cache $ \set -> + + cachedIO :: ScheduleControl -> IO Bool + cachedIO m = atomicModifyIORef' cache $ \set -> (Set.insert m set, Set.member m set) - cacheSize () = unsafePerformIO $ Set.size <$> readIORef cache + + cacheSizeIO :: () -> IO Int + cacheSizeIO () = Set.size <$> readIORef cache + + +-- | A specialised version of `controlSimTrace'. +-- +-- An internal function. +-- replaySimTrace :: forall a test. (Testable test) => ExplorationOptions + -- ^ race exploration options -> (forall s. IOSim s a) -> ScheduleControl - -> (Maybe (SimTrace a) -> SimTrace a -> test) + -- ^ a schedule control to reproduce + -> (SimTrace a -> test) + -- ^ a callback which receives the simulation trace. The trace + -- will not contain any race events -> Property replaySimTrace opts mainAction control k = let (_,trace) = detachTraceRaces $ - controlSimTrace (explorationStepTimelimit opts) control mainAction - in property (k Nothing trace) + controlSimTrace (explorationStepTimelimit opts) control mainAction + in property (k trace) + +-- | Run a simulation using a given schedule. This is useful to reproduce +-- failing cases without exploring the races. +-- +controlSimTrace :: forall a. + Maybe Int + -- ^ limit on the computation time allowed per scheduling step, for + -- catching infinite loops etc. + -> ScheduleControl + -- ^ a schedule to replay + -- + -- /note/: must be either `ControlDefault` or `ControlAwait`. + -> (forall s. IOSim s a) + -- ^ a simulation to run + -> SimTrace a +controlSimTrace limit control mainAction = + runST (controlSimTraceST limit control mainAction) raceReversals :: ScheduleControl -> Int raceReversals ControlDefault = 0 diff --git a/io-sim/src/Control/Monad/IOSim/CommonTypes.hs b/io-sim/src/Control/Monad/IOSim/CommonTypes.hs index 183771f3..5254577a 100644 --- a/io-sim/src/Control/Monad/IOSim/CommonTypes.hs +++ b/io-sim/src/Control/Monad/IOSim/CommonTypes.hs @@ -13,6 +13,14 @@ import Data.Map (Map) import Data.STRef.Lazy import Data.Set (Set) + +-- | A thread id. +-- +-- /IOSimPOR/: 'RacyThreadId' indicates that this thread is taken into account +-- when discovering races. A thread is marked as racy iff +-- `Control.Monad.Class.MonadTest.exploreRaces` was +-- executed in it or it's a thread forked by a racy thread. +-- data ThreadId = RacyThreadId [Int] | ThreadId [Int] -- non racy threads have higher priority deriving (Eq, Ord, Show) diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index b810c63e..a7ca351c 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/io-sim/src/Control/Monad/IOSim/Internal.hs @@ -10,21 +10,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} -- incomplete uni patterns in 'schedule' (when interpreting 'StmTxCommitted') -- and 'reschedule'. {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Control.Monad.IOSim.Internal ( IOSim (..) - , SimM , runIOSim , runSimTraceST , traceM , traceSTM , STM , STMSim - , SimSTM , setCurrentTime , unshareClock , TimeoutException (..) @@ -34,11 +31,10 @@ module Control.Monad.IOSim.Internal , ThreadLabel , Labelled (..) , SimTrace - , Trace.Trace (SimTrace, Trace, TraceMainReturn, TraceMainException, TraceDeadlock) + , Trace.Trace (SimTrace, TraceMainReturn, TraceMainException, TraceDeadlock) , SimEvent (..) , SimResult (..) , SimEventType (..) - , TraceEvent , ppTrace , ppTrace_ , ppSimEvent @@ -120,7 +116,8 @@ labelledThreads threadMap = -- | Timers mutable variables. Supports 'newTimeout' api, the second --- one 'registerDelay', the third one 'threadDelay'. +-- one 'Control.Monad.Class.MonadTimer.SI.registerDelay', the third one +-- 'Control.Monad.Class.MonadTimer.SI.threadDelay'. -- data TimerCompletionInfo s = Timer !(TVar s TimeoutState) @@ -1020,9 +1017,10 @@ lookupThreadLabel tid threads = join (threadLabel <$> Map.lookup tid threads) -- | The most general method of running 'IOSim' is in 'ST' monad. One can --- recover failures or the result from 'SimTrace' with 'traceResult', or access --- 'SimEventType's generated by the computation with 'traceEvents'. A slightly --- more convenient way is exposed by 'runSimTrace'. +-- recover failures or the result from 'SimTrace' with +-- 'Control.Monad.IOSim.traceResult', or access 'SimEventType's generated by the +-- computation with 'Control.Monad.IOSim.traceEvents'. A slightly more +-- convenient way is exposed by 'Control.Monad.IOSim.runSimTrace'. -- runSimTraceST :: forall s a. IOSim s a -> ST s (SimTrace a) runSimTraceST mainAction = schedule mainThread initialState @@ -1278,9 +1276,8 @@ execNewTVar nextVid !mbLabel x = do tvarCurrent, tvarUndo, tvarBlocked, tvarVClock, tvarTrace} -execReadTVar :: TVar s a -> ST s a -execReadTVar TVar{tvarCurrent} = readSTRef tvarCurrent -{-# INLINE execReadTVar #-} + +-- 'execReadTVar' is defined in `Control.Monad.IOSim.Type` and shared with /IOSimPOR/ execWriteTVar :: TVar s a -> a -> ST s () execWriteTVar TVar{tvarCurrent} = writeSTRef tvarCurrent diff --git a/io-sim/src/Control/Monad/IOSim/STM.hs b/io-sim/src/Control/Monad/IOSim/STM.hs index 25f910e8..159cfc59 100644 --- a/io-sim/src/Control/Monad/IOSim/STM.hs +++ b/io-sim/src/Control/Monad/IOSim/STM.hs @@ -227,8 +227,8 @@ unGetTBQueueDefault (TBQueue queue _size) a = do -- Default MVar implementation in terms of STM (used by sim) -- --- | A default 'MVar' implementation based on `TVar`'s. An 'MVar' provides --- fairness guarantees. +-- | A default 'MonadMVar' implementation is based on `TVar`'s. An @MVar@ +-- guarantees fairness. -- -- /Implementation details:/ -- diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs index cc06cffd..9f3b6244 100644 --- a/io-sim/src/Control/Monad/IOSim/Types.hs +++ b/io-sim/src/Control/Monad/IOSim/Types.hs @@ -12,8 +12,8 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# OPTIONS_GHC -Wno-partial-fields #-} +-- Needed for `SimEvent` type. +{-# OPTIONS_GHC -Wno-partial-fields #-} module Control.Monad.IOSim.Types ( IOSim (..) @@ -48,16 +48,13 @@ module Control.Monad.IOSim.Types , SimEvent (..) , SimResult (..) , SimTrace - , Trace.Trace (Trace, SimTrace, SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceRacesFound, TraceLoop) + , Trace.Trace (SimTrace, SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceRacesFound, TraceLoop) , ppTrace , ppTrace_ , ppSimEvent , ppDebug - , TraceEvent , Labelled (..) , module Control.Monad.IOSim.CommonTypes - , SimM - , SimSTM , Thrower (..) , Time (..) , addTime @@ -68,6 +65,8 @@ module Control.Monad.IOSim.Types , readTimeout , cancelTimeout , awaitTimeout + -- * Low-level API + , execReadTVar ) where import Control.Applicative @@ -76,6 +75,8 @@ import Control.Exception (ErrorCall (..), asyncExceptionFromException, import Control.Monad import Control.Monad.Fix (MonadFix (..)) +import Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar) +import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as StrictTVar import Control.Monad.Class.MonadAsync hiding (Async) import qualified Control.Monad.Class.MonadAsync as MonadAsync import Control.Monad.Class.MonadEventlog @@ -100,6 +101,7 @@ import Control.Monad.Class.MonadTimer.SI (TimeoutState (..)) import qualified Control.Monad.Class.MonadTimer.SI as SI import Control.Monad.ST.Lazy import qualified Control.Monad.ST.Strict as StrictST +import Control.Monad.ST.Unsafe (unsafeSTToIO) import qualified Control.Monad.Catch as Exceptions import qualified Control.Monad.Fail as Fail @@ -117,6 +119,7 @@ import Data.Time.Clock (diffTimeToPicoseconds) import Data.Typeable import Data.Word (Word64) import qualified Debug.Trace as Debug +import NoThunks.Class (NoThunks (..)) import Text.Printf import GHC.Exts (oneShot) @@ -133,15 +136,19 @@ import qualified System.IO.Error as IO.Error (userError) {-# ANN module "HLint: ignore Use readTVarIO" #-} newtype IOSim s a = IOSim { unIOSim :: forall r. (a -> SimA s r) -> SimA s r } -type SimM s = IOSim s -{-# DEPRECATED SimM "Use IOSim" #-} - runIOSim :: IOSim s a -> SimA s a runIOSim (IOSim k) = k Return +-- | 'IOSim' has the ability to story any 'Typeable' value in its trace which +-- can then be recovered with `selectTraceEventsDynamic` or +-- `selectTraceEventsDynamic'`. +-- traceM :: Typeable a => a -> IOSim s () traceM x = IOSim $ oneShot $ \k -> Output (toDyn x) (k ()) +-- | Trace a value, in the same was as `traceM` does, but from the `STM` monad. +-- This is primarily useful for debugging. +-- traceSTM :: Typeable a => a -> STMSim s () traceSTM x = STM $ oneShot $ \k -> OutputStm (toDyn x) (k ()) @@ -226,9 +233,6 @@ data StmA s a where -- Exported type type STMSim = STM -type SimSTM = STM -{-# DEPRECATED SimSTM "Use STMSim" #-} - -- -- Monad class instances -- @@ -327,6 +331,11 @@ instance MonadThrow (IOSim s) where instance MonadEvaluate (IOSim s) where evaluate a = IOSim $ oneShot $ \k -> Evaluate a k +-- | Just like the IO instance, we don't actually check anything here +instance NoThunks (IOSim s a) where + showTypeOf _ = "IOSim" + wNoThunks _ctxt _act = return Nothing + instance Exceptions.MonadThrow (IOSim s) where throwM = MonadThrow.throwIO @@ -418,6 +427,16 @@ instance Exceptions.MonadMask (IOSim s) where c <- release resource (Exceptions.ExitCaseSuccess b) return (b, c) +instance NoThunks a => NoThunks (StrictTVar (IOSim s) a) where + showTypeOf _ = "StrictTVar IOSim" + wNoThunks ctxt tvar = do + a <- unsafeSTToIO . lazyToStrictST . execReadTVar . StrictTVar.toLazyTVar + $ tvar + noThunks ctxt a + +execReadTVar :: TVar s a -> ST s a +execReadTVar TVar{tvarCurrent} = readSTRef tvarCurrent +{-# INLINE execReadTVar #-} getMaskingStateImpl :: IOSim s MaskingState unblock, block, blockUninterruptible :: IOSim s a -> IOSim s a @@ -469,6 +488,17 @@ instance MonadSTM (IOSim s) where retry = STM $ oneShot $ \_ -> Retry orElse a b = STM $ oneShot $ \k -> OrElse (runSTM a) (runSTM b) k + newTMVar = MonadSTM.newTMVarDefault + newEmptyTMVar = MonadSTM.newEmptyTMVarDefault + takeTMVar = MonadSTM.takeTMVarDefault + tryTakeTMVar = MonadSTM.tryTakeTMVarDefault + putTMVar = MonadSTM.putTMVarDefault + tryPutTMVar = MonadSTM.tryPutTMVarDefault + readTMVar = MonadSTM.readTMVarDefault + tryReadTMVar = MonadSTM.tryReadTMVarDefault + swapTMVar = MonadSTM.swapTMVarDefault + isEmptyTMVar = MonadSTM.isEmptyTMVarDefault + newTQueue = newTQueueDefault readTQueue = readTQueueDefault tryReadTQueue = tryReadTQueueDefault @@ -491,6 +521,23 @@ instance MonadSTM (IOSim s) where isFullTBQueue = isFullTBQueueDefault unGetTBQueue = unGetTBQueueDefault + newTSem = MonadSTM.newTSemDefault + waitTSem = MonadSTM.waitTSemDefault + signalTSem = MonadSTM.signalTSemDefault + signalTSemN = MonadSTM.signalTSemNDefault + + newTChan = MonadSTM.newTChanDefault + newBroadcastTChan = MonadSTM.newBroadcastTChanDefault + writeTChan = MonadSTM.writeTChanDefault + readTChan = MonadSTM.readTChanDefault + tryReadTChan = MonadSTM.tryReadTChanDefault + peekTChan = MonadSTM.peekTChanDefault + tryPeekTChan = MonadSTM.tryPeekTChanDefault + dupTChan = MonadSTM.dupTChanDefault + unGetTChan = MonadSTM.unGetTChanDefault + isEmptyTChan = MonadSTM.isEmptyTChanDefault + cloneTChan = MonadSTM.cloneTChanDefault + instance MonadInspectSTM (IOSim s) where type InspectMonad (IOSim s) = ST s inspectTVar _ TVar { tvarCurrent } = readSTRef tvarCurrent @@ -559,6 +606,10 @@ instance MonadAsync (IOSim s) where instance MonadST (IOSim s) where withLiftST f = f liftST +-- | Lift an 'StrictST.ST' computation to 'IOSim'. +-- +-- Note: you can use 'MonadST' to lift 'StrictST.ST' computations, this is just +-- a more convenient function just for 'IOSim'. liftST :: StrictST.ST s a -> IOSim s a liftST action = IOSim $ oneShot $ \k -> LiftST action k @@ -664,26 +715,30 @@ instance MonadEventlog (IOSim s) where traceEventIO = traceM . EventlogEvent traceMarkerIO = traceM . EventlogMarker --- | 'Trace' is a recursive data type, it is the trace of a 'IOSim' computation. --- The trace will contain information about thread sheduling, blocking on --- 'TVar's, and other internal state changes of 'IOSim'. More importantly it --- also supports traces generated by the computation with 'say' (which --- corresponds to using 'putStrLn' in 'IO'), 'traceEventM', or dynamically typed --- traces with 'traceM' (which generalise the @base@ library +-- | 'Trace' is a recursive data type, it is the trace of a 'IOSim' +-- computation. The trace will contain information about thread scheduling, +-- blocking on 'TVar's, and other internal state changes of 'IOSim'. More +-- importantly it also supports traces generated by the computation with 'say' +-- (which corresponds to using 'putStrLn' in 'IO'), 'traceEventM', or +-- dynamically typed traces with 'traceM' (which generalise the @base@ library -- 'Debug.Trace.traceM') -- --- It also contains information on races discovered. +-- It also contains information on discovered races. -- --- See also: 'traceEvents', 'traceResult', 'selectTraceEvents', --- 'selectTraceEventsDynamic' and 'printTraceEventsSay'. +-- See also: 'Control.Monad.IOSim.traceEvents', +-- 'Control.Monad.IOSim.traceResult', 'Control.Monad.IOSim.selectTraceEvents', +-- 'Control.Monad.IOSim.selectTraceEventsDynamic' and +-- 'Control.Monad.IOSim.printTraceEventsSay'. -- data SimEvent + -- | Used when using `IOSim`. = SimEvent { seTime :: !Time, seThreadId :: !ThreadId, seThreadLabel :: !(Maybe ThreadLabel), seType :: !SimEventType } + -- | Only used for /IOSimPOR/ | SimPOREvent { seTime :: !Time, seThreadId :: !ThreadId, @@ -691,11 +746,14 @@ data SimEvent seThreadLabel :: !(Maybe ThreadLabel), seType :: !SimEventType } + -- | Only used for /IOSimPOR/ | SimRacesFound [ScheduleControl] deriving Generic deriving Show via Quiet SimEvent +-- | Pretty print a 'SimEvent'. +-- ppSimEvent :: Int -- ^ width of the time -> Int -- ^ width of thread id -> Int -- ^ width of thread label @@ -726,14 +784,24 @@ ppSimEvent timeWidth tidWidth tLableWidth SimPOREvent {seTime, seThreadId, seSte ppSimEvent _ _ _ (SimRacesFound controls) = "RacesFound "++show controls +-- | A result type of a simulation. data SimResult a = MainReturn !Time a ![Labelled ThreadId] + -- ^ Return value of the main thread. | MainException !Time SomeException ![Labelled ThreadId] + -- ^ Exception thrown by the main thread. | Deadlock !Time ![Labelled ThreadId] + -- ^ Deadlock discovered in the simulation. Deadlocks are discovered if + -- simply the simulation cannot do any progress in a given time slot and + -- there's no event which would advance the time. | Loop + -- ^ Only returned by /IOSimPOR/ when a step execution took longer than + -- 'explorationStepTimelimit` was exceeded. deriving (Show, Functor) - +-- | A type alias for 'IOSim' simulation trace. It comes with useful pattern +-- synonyms. +-- type SimTrace a = Trace.Trace (SimResult a) SimEvent -- | Pretty print simulation trace. @@ -799,13 +867,6 @@ ppDebug = appEndo . foldMap (Endo . Debug.trace . show) . Trace.toList -pattern Trace :: Time -> ThreadId -> Maybe ThreadLabel -> SimEventType -> SimTrace a - -> SimTrace a -pattern Trace time threadId threadLabel traceEvent trace = - Trace.Cons (SimEvent time threadId threadLabel traceEvent) - trace - -{-# DEPRECATED Trace "Use 'SimTrace' instead." #-} pattern SimTrace :: Time -> ThreadId -> Maybe ThreadLabel -> SimEventType -> SimTrace a -> SimTrace a @@ -841,63 +902,123 @@ pattern TraceLoop :: SimTrace a pattern TraceLoop = Trace.Nil Loop {-# COMPLETE SimTrace, SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceLoop #-} -{-# COMPLETE Trace, TraceMainReturn, TraceMainException, TraceDeadlock, TraceLoop #-} +-- | Events recorded by the simulation. +-- data SimEventType - = EventSimStart ScheduleControl - | EventSay String + = EventSay String + -- ^ hold value of `say` | EventLog Dynamic + -- ^ hold a dynamic value of `Control.Monad.IOSim.traceM` | EventMask MaskingState + -- ^ masking state changed | EventThrow SomeException - | EventThrowTo SomeException ThreadId -- This thread used ThrowTo - | EventThrowToBlocked -- The ThrowTo blocked - | EventThrowToWakeup -- The ThrowTo resumed - | EventThrowToUnmasked (Labelled ThreadId) -- A pending ThrowTo was activated + -- ^ throw exception + | EventThrowTo SomeException ThreadId + -- ^ throw asynchronous exception (`throwTo`) + | EventThrowToBlocked + -- ^ the thread which executed `throwTo` is blocked + | EventThrowToWakeup + -- ^ the thread which executed `throwTo` is woken up + | EventThrowToUnmasked (Labelled ThreadId) + -- ^ a target thread of `throwTo` unmasked its exceptions, this is paired + -- with `EventThrowToWakeup` for threads which were blocked on `throwTo` | EventThreadForked ThreadId - | EventThreadFinished -- terminated normally - | EventThreadUnhandled SomeException -- terminated due to unhandled exception + -- ^ forked a thread + | EventThreadFinished + -- ^ thread terminated normally + | EventThreadUnhandled SomeException + -- ^ thread terminated by an unhandled exception + + -- + -- STM events + -- + + -- | committed STM transaction + | EventTxCommitted [Labelled TVarId] -- ^ stm tx wrote to these + [Labelled TVarId] -- ^ and created these + (Maybe Effect) -- ^ effect performed (only for `IOSimPOR`) + -- | aborted an STM transaction (by an exception) + -- + -- For /IOSimPOR/ it also holds performed effect. + | EventTxAborted (Maybe Effect) + -- | STM transaction blocked (due to `retry`) + | EventTxBlocked [Labelled TVarId] -- stm tx blocked reading these + (Maybe Effect) -- ^ effect performed (only for `IOSimPOR`) + | EventTxWakeup [Labelled TVarId] -- ^ changed vars causing retry - | EventTxCommitted [Labelled TVarId] -- tx wrote to these - [Labelled TVarId] -- and created these - (Maybe Effect) -- effect performed (only for `IOSimPOR`) - | EventTxAborted (Maybe Effect) -- effect performed (only for `IOSimPOR`) - | EventTxBlocked [Labelled TVarId] -- tx blocked reading these - (Maybe Effect) -- effect performed (only for `IOSimPOR`) - | EventTxWakeup [Labelled TVarId] -- changed vars causing retry + | EventUnblocked [ThreadId] + -- ^ unblocked threads by a committed STM transaction + + -- + -- Timeouts, Timers & Delays + -- | EventThreadDelay TimeoutId Time + -- ^ thread delayed | EventThreadDelayFired TimeoutId + -- ^ thread woken up after a delay | EventTimeoutCreated TimeoutId ThreadId Time + -- ^ new timeout created (via `timeout`) | EventTimeoutFired TimeoutId + -- ^ timeout fired | EventRegisterDelayCreated TimeoutId TVarId Time + -- ^ registered delay (via `registerDelay`) | EventRegisterDelayFired TimeoutId + -- ^ registered delay fired | EventTimerCreated TimeoutId TVarId Time + -- ^ a new 'Timeout' created (via `newTimeout`) | EventTimerUpdated TimeoutId Time + -- ^ a 'Timeout' was updated (via `updateTimeout`) | EventTimerCancelled TimeoutId + -- ^ a 'Timeout' was cancelled (via `cancelTimeout`) | EventTimerFired TimeoutId - - -- the following events are inserted to mark the difference between - -- a failed trace and a similar passing trace of the same action - | EventThreadSleep -- the labelling thread was runnable, - -- but its execution was delayed - | EventThreadWake -- until this point + -- ^ a 'Timeout` fired + + -- + -- threadStatus + -- + + -- | event traced when `threadStatus` is executed + | EventThreadStatus ThreadId -- ^ current thread + ThreadId -- ^ queried thread + + -- + -- /IOSimPOR/ events + -- + + | EventSimStart ScheduleControl + -- ^ /IOSimPOR/ event: new execution started exploring the given schedule. + | EventThreadSleep + -- ^ /IOSimPOR/ event: the labelling thread was runnable, but its execution + -- was delayed, until 'EventThreadWake'. + -- + -- Event inserted to mark a difference between a failed trace and a similar + -- passing trace. + | EventThreadWake + -- ^ /IOSimPOR/ event: marks when the thread was rescheduled by /IOSimPOR/ | EventDeschedule Deschedule + -- ^ /IOSim/ and /IOSimPOR/ event: a thread was descheduled | EventFollowControl ScheduleControl + -- ^ /IOSimPOR/ event: following given schedule | EventAwaitControl StepId ScheduleControl + -- ^ /IOSimPOR/ event: thread delayed to follow the given schedule | EventPerformAction StepId + -- ^ /IOSimPOR/ event: perform action of the given step | EventReschedule ScheduleControl - | EventUnblocked [ThreadId] deriving Show -type TraceEvent = SimEventType -{-# DEPRECATED TraceEvent "Use 'SimEventType' instead." #-} +-- | A labelled value. +-- +-- For example 'labelThread' or `labelTVar' will insert a label to `ThreadId` +-- (or `TVarId`). data Labelled a = Labelled { l_labelled :: !a, l_label :: !(Maybe String) @@ -909,6 +1030,8 @@ data Labelled a = Labelled { -- Executing STM Transactions -- +-- | Result of an STM computation. +-- data StmTxResult s a = -- | A committed transaction reports the vars that were written (in order -- of first write) so that the scheduler can unblock other threads that @@ -976,6 +1099,8 @@ data StmStack s b a where --- Schedules --- +-- | Modified execution schedule. +-- data ScheduleControl = ControlDefault -- ^ default scheduling mode | ControlAwait [ScheduleMod] @@ -990,6 +1115,8 @@ data ScheduleControl = ControlDefault -- when 'controlTargets' returns true. deriving (Eq, Ord, Show) +-- | A schedule modification inserted at given execution step. +-- data ScheduleMod = ScheduleMod{ -- | Step at which the 'ScheduleMod' is activated. scheduleModTarget :: StepId, @@ -1003,6 +1130,9 @@ data ScheduleMod = ScheduleMod{ } deriving (Eq, Ord) +-- | Execution step is identified by the thread id and a monotonically +-- increasing number (thread specific). +-- type StepId = (ThreadId, Int) instance Show ScheduleMod where @@ -1019,11 +1149,42 @@ instance Show ScheduleMod where --- Exploration options --- +-- | Race exploration options. +-- data ExplorationOptions = ExplorationOptions{ explorationScheduleBound :: Int, + -- ^ This is an upper bound on the number of schedules with race reversals + -- that will be explored; a bound of zero means that the default schedule + -- will be explored, but no others. Setting the bound to zero makes + -- IOSimPOR behave rather like IOSim, in that only one schedule is + -- explored, but (a) IOSimPOR is considerably slower, because it still + -- collects information on potential races, and (b) the IOSimPOR schedule + -- is different (based on priorities, in contrast to IOSim's round-robin), + -- and plays better with shrinking. + -- + -- The default value is `100`. explorationBranching :: Int, + -- ^ The branching factor. This is the number of alternative schedules that + -- IOSimPOR tries to run, per race reversal. With the default parameters, + -- IOSimPOR will try to reverse the first 33 (100 div 3) races discovered + -- using the default schedule, then (if 33 or more races are discovered), + -- for each such reversed race, will run the reversal and try to reverse + -- two more races in the resulting schedule. A high branching factor will + -- explore more combinations of reversing fewer races, within the overall + -- schedule bound. A branching factor of one will explore only schedules + -- resulting from a single race reversal (unless there are fewer races + -- available to be reversed than the schedule bound). + -- + -- The default value is `3`. explorationStepTimelimit :: Maybe Int, + -- ^ Limit on the computation time allowed per scheduling step, for + -- catching infinite loops etc. + -- + -- The default value is `Nothing`. explorationReplay :: Maybe ScheduleControl + -- ^ A schedule to replay. + -- + -- The default value is `Nothing`. } deriving Show diff --git a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs index 8504f603..931e5f7f 100644 --- a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs +++ b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs @@ -11,21 +11,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-orphans #-} -- incomplete uni patterns in 'schedule' (when interpreting 'StmTxCommitted') -- and 'reschedule'. {-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-unused-matches #-} module Control.Monad.IOSimPOR.Internal ( IOSim (..) - , SimM , runIOSim , runSimTraceST , traceM , traceSTM , STM , STMSim - , SimSTM , setCurrentTime , unshareClock , TimeoutException (..) @@ -35,11 +32,10 @@ module Control.Monad.IOSimPOR.Internal , ThreadLabel , Labelled (..) , SimTrace - , Trace.Trace (SimPORTrace, Trace, TraceMainReturn, TraceMainException, TraceDeadlock) + , Trace.Trace (SimPORTrace, TraceMainReturn, TraceMainException, TraceDeadlock) , SimEvent (..) , SimResult (..) , SimEventType (..) - , TraceEvent , liftST , execReadTVar , controlSimTraceST @@ -163,7 +159,8 @@ labelledThreads threadMap = -- | Timers mutable variables. First one supports 'newTimeout' api, the second --- one 'registerDelay', the third one 'threadDelay'. +-- one 'Control.Monad.Class.MonadTimer.SI.registerDelay', the third one +-- 'Control.Monad.Class.MonadTimer.SI.threadDelay'. -- data TimerCompletionInfo s = Timer !(TVar s TimeoutState) @@ -1519,9 +1516,7 @@ execNewTVar nextVid !mbLabel x = do tvarCurrent, tvarUndo, tvarBlocked, tvarVClock, tvarTrace} -execReadTVar :: TVar s a -> ST s a -execReadTVar TVar{tvarCurrent} = readSTRef tvarCurrent -{-# INLINE execReadTVar #-} +-- 'execReadTVar' is defined in `Control.Monad.IOSim.Type` and shared with /IOSim/ execWriteTVar :: TVar s a -> a -> ST s () execWriteTVar TVar{tvarCurrent} = writeSTRef tvarCurrent diff --git a/io-sim/src/Data/List/Trace.hs b/io-sim/src/Data/List/Trace.hs index 2cc15191..ffdde8c2 100644 --- a/io-sim/src/Data/List/Trace.hs +++ b/io-sim/src/Data/List/Trace.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} module Data.List.Trace @@ -21,7 +22,7 @@ import Data.Bifunctor import Data.Bitraversable import Data.Functor.Classes --- | A 'cons' list with polymorphic 'nil', thus an octopus. +-- | A 'cons' list with polymorphic 'nil'. -- -- * @'Trace' Void a@ is an infinite stream -- * @'Trace' () a@ is isomorphic to @[a]@ @@ -58,7 +59,7 @@ toList = bifoldr (\_ bs -> bs) (:) [] fromList :: a -> [b] -> Trace a b fromList a = foldr Cons (Nil a) --- | Pretty print an 'Trace'. +-- | Pretty print a 'Trace'. -- ppTrace :: (a -> String) -> (b -> String) -> Trace a b -> String ppTrace sa sb (Cons b bs) = sb b ++ "\n" ++ ppTrace sa sb bs @@ -106,8 +107,10 @@ instance Monoid a => Monad (Trace a) where -- @bifoldMap Nil id@ is the @join@ of @Trace a@ o >>= f = bifoldMap Nil id $ fmap f o +#if MIN_VERSION_base(4,13,0) instance Monoid a => MonadFail (Trace a) where fail _ = mzero +#endif instance Monoid a => Alternative (Trace a) where empty = mempty diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index a9ce9772..285b0d30 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/io-sim/test/Test/Control/Monad/IOSim.hs @@ -339,6 +339,8 @@ prop_mfix_lazy (NonEmpty env) = ( #if MIN_VERSION_base(4,13,0) MonadFail m +#else + Monad m #endif ) => m Char diff --git a/si-timers/CHANGELOG.md b/si-timers/CHANGELOG.md index cefddb91..ade6a936 100644 --- a/si-timers/CHANGELOG.md +++ b/si-timers/CHANGELOG.md @@ -1,6 +1,6 @@ # Changelog -## 0.6.0.0 +## 1.0.0.0 * initial version diff --git a/si-timers/NOTICE b/si-timers/NOTICE index 3a29844a..acd2b2cd 100644 --- a/si-timers/NOTICE +++ b/si-timers/NOTICE @@ -1,4 +1,4 @@ -Copyright 2019-2020 Input Output (Hong Kong) Ltd. +Copyright 2019-2023 Input Output Global Inc (IOG) Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/si-timers/README.md b/si-timers/README.md new file mode 100644 index 00000000..97c7b639 --- /dev/null +++ b/si-timers/README.md @@ -0,0 +1,21 @@ +# [SI] Timers + +The `si-timers` package provides delays & timeouts which are safe on 32-bit +systems; cancellable timeouts (see `registerDelayCancellable`); a refined +interface for monotonic `Time`. `Time` is given with left monoid action of +`DiffTime` (which encodes the notion of time differences). The +`MonadMonotonicTime`, `MonadDelay` type classes & `MonadTimers` (type synonym) +API provide a consistent interface for working with delays and timeouts. + +`si-timers` package also defined a low level `MonadTimout` type class. On +system with a native timer manager (e.g. `Linux`, `MacOS`, `FreeBSD`), it's +very efficient but for other platforms (e.g. `Windows`), it might not be the +right API for low latency timeouts needed for example for low level networking +code, because it relies on `GHC`'s `RTS` thread scheduling. + +`si-timers` are compatible with `io-sim`. + +The `SI` comes from the [International System of Units][SI]. + +[SI]: https://www.wikiwand.com/en/International_System_of_Units +[`io-sim`]: https://hackage.haskell.org/package/io-sim diff --git a/si-timers/si-timers.cabal b/si-timers/si-timers.cabal index fe8091d8..0257f0f2 100644 --- a/si-timers/si-timers.cabal +++ b/si-timers/si-timers.cabal @@ -1,19 +1,22 @@ -cabal-version: 3.4 +cabal-version: 3.0 name: si-timers -version: 0.6.0.0 -synopsis: Timers using SI units (seconds) which are safe on 32-bit - platforms. --- description: +version: 1.0.0.0 +synopsis: timers using SI units (seconds) +description: + Timers using SI units (seconds) which are safe on 32-bit platforms and + compatible with [io-sim](https://hackage.haskell.org/package/io-sim). license: Apache-2.0 license-files: LICENSE NOTICE copyright: 2022-2023 Input Output Global Inc (IOG) -author: Duncan Coutts, Marcin Szamotulski, Neil Davis -maintainer: Marcin Szamotulski +author: Duncan Coutts, Neil Davis, Marcin Szamotulski +maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category: Control build-type: Simple -tested-with: GHC == 8.10.7, GHC == 9.2.5, GHC == 9.4.3 +extra-source-files: CHANGELOG.md + README.md +tested-with: GHC == { 8.10, 9.2, 9.4 } flag asserts description: Enable assertions @@ -22,7 +25,7 @@ flag asserts source-repository head type: git - location: https://github.com/input-output-hk/ouroboros-network + location: https://github.com/input-output-hk/io-sim subdir: io-sim common warnings @@ -46,13 +49,9 @@ library other-extensions: BangPatterns, CPP, ConstraintKinds, - ExistentialQuantification, - FlexibleInstances, - GADTSyntax, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses, - NamedFieldPuns, - RankNTypes, + DefaultSignatures, + DeriveGeneric, + NumericUnderscores, ScopedTypeVariables, TypeFamilies build-depends: base >=4.9 && <4.18, @@ -60,7 +59,7 @@ library stm, time >=1.9.1 && <1.13, - io-classes ^>=0.6 + io-classes ^>=1.0 if flag(asserts) ghc-options: -fno-ignore-asserts diff --git a/si-timers/src/Control/Monad/Class/MonadTimer/NonStandard.hs b/si-timers/src/Control/Monad/Class/MonadTimer/NonStandard.hs index c3562d63..6b4e34ba 100644 --- a/si-timers/src/Control/Monad/Class/MonadTimer/NonStandard.hs +++ b/si-timers/src/Control/Monad/Class/MonadTimer/NonStandard.hs @@ -13,13 +13,16 @@ -- | A non-standard interface for timer api. -- -- This module also provides a polyfill which allows to use timer api also on --- non-threaded RTS regardless of the architecture \/ OS. +-- non-threaded RTS regardless of the architecture \/ OS. Currently we support +-- `*nix`, `macOS`, `Windows` (and, unofficially `GHCJS`). -- --- We use it to provide 'MonadTimer IO' instance and to implement a cancellable --- timer, see 'registerDelayCancellable' below. +-- We use it to provide @'Control.Monad.Class.MonadTimer.MonadTimer' 'IO'@ +-- instance and to implement a cancellable timers, see +-- 'Control.Monad.Class.MonadTimer.SI.registerDelayCancellable'. -- -- You can expect we will deprecate it at some point (e.g. once GHC gets --- a better support for timers especially across different OSes). +-- a better support for timers especially across different execution +-- environments). -- module Control.Monad.Class.MonadTimer.NonStandard ( TimeoutState (..) @@ -74,6 +77,9 @@ data Timeout = TimeoutIO !(STM.TVar (STM.TVar Bool)) !(STM.TVar Bool) -- (as this would be very racy). You should create a new timeout if you need -- this functionality. -- +-- When native timer manager is supported (on `*nix` systems), it only holds +-- a `TVar` with `TimeoutState` and `GHC.TimeoutKey`. +-- newTimeout :: NewTimeout IO Timeout type NewTimeout m timeout = Int -> m timeout diff --git a/strict-mvar/CHANGELOG.md b/strict-mvar/CHANGELOG.md index fe89d200..d4f2c83a 100644 --- a/strict-mvar/CHANGELOG.md +++ b/strict-mvar/CHANGELOG.md @@ -1,6 +1,6 @@ # Revsion history of strict-mvar -## 0.6.0.0 +## 1.0.0.0 ## 0.1.0.0 diff --git a/strict-mvar/README.md b/strict-mvar/README.md index ca755894..97e3687f 100644 --- a/strict-mvar/README.md +++ b/strict-mvar/README.md @@ -1,4 +1,4 @@ -# Strict mutable variables +# Strict Mutable Variables The `strict-mvar` package provides a strict interface to mutable variables (`MVar`). It builds on top of `io-classes`, and thus it provides the interface diff --git a/strict-mvar/strict-mvar.cabal b/strict-mvar/strict-mvar.cabal index 465a87fa..500cc4c8 100644 --- a/strict-mvar/strict-mvar.cabal +++ b/strict-mvar/strict-mvar.cabal @@ -1,8 +1,11 @@ cabal-version: 3.0 name: strict-mvar -version: 0.1.0.0 -synopsis: Strict MVars for implementations of the `io-classes` MVar interface -description: Strict MVars for implementations of the `io-classes` MVar interface. +version: 1.0.0.0 +synopsis: Strict MVars for IO and IOSim +description: + Strict @MVar@ interface compatible with + [IO](https://hackage.haskell.org/package/base-4.18.0.0/docs/Prelude.html#t:IO) + & [io-sim](https://hackage.haskell.org/package/io-sim). license: Apache-2.0 license-files: LICENSE @@ -12,6 +15,8 @@ author: IOHK Engineering Team maintainer: operations@iohk.io category: Control build-type: Simple +extra-source-files: CHANGELOG.md + README.md tested-with: GHC == { 8.10.7, 9.2.5, 9.4.4 } source-repository head @@ -30,7 +35,7 @@ library exposed-modules: Control.Concurrent.Class.MonadMVar.Strict default-language: Haskell2010 build-depends: base >= 4.9 && <4.18, - io-classes ^>= 0.6 + io-classes ^>= 1.0 ghc-options: -Wall -Wno-unticked-promoted-constructors -Wcompat diff --git a/strict-stm/CHANGELOG.md b/strict-stm/CHANGELOG.md index ab979708..20fb7308 100644 --- a/strict-stm/CHANGELOG.md +++ b/strict-stm/CHANGELOG.md @@ -1,5 +1,7 @@ # Changelog +## 1.0.0.0 + ## 0.6.0.0 ## 0.5.0.0 diff --git a/strict-stm/README.md b/strict-stm/README.md index 8c9972c0..1b396233 100644 --- a/strict-stm/README.md +++ b/strict-stm/README.md @@ -1,20 +1,18 @@ # Strict Software Transaction Memory The `strict-stm` package provides a strict interface to software transaction -memory. It builds on top of `io-classes` and thus it provides the interface -for both [STM](https://hackage.haskell.org/package/stm) as well as -[io-sim](https://github.com/input-output-hk/io-sim). +memory. It builds on top of [`io-classes`] and thus it provides the interface +for both [`stm`] as well as [`io-sim`]. # Novel testing / space-leak elimination approach -The strict interface provides a novel way of testing / eliminating space-leaks -which might lurk in `stm` shared mutable variables. This together with an -interface build on top of -[ghc-heap](https://gitlab.haskell.org/ghc/ghc/-/tree/master/libraries/ghc-heap) -was successfully used to eliminate such bugs in a large system. We strongly -recommend to use `Control.Monad.Class.MonadSTM.Strict`. It exposes the -[MonadSTM](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadSTM.html#t:MonadSTM) -interface and gives access to -[StrictTVar](https://hackage.haskell.org/package/io-sim-classes/docs/Control-Monad-Class-MonadSTM-Strict.html#t:StrictTVar)'s -in place of non-strict -[TVar](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadSTM.html#t:TVar)'s. +The strict interface provides a novel way of testing/eliminating space-leaks +which might lurk in `stm` shared mutable variables. Together with the +[`nothunks`] library it was successfully used to eliminate and keep a large +system ([`cardano-node`]) space leak free. + +[`cardano-node`]: https://www.github.com/input-output-hk/cardano-node +[`io-classes`]: https://hackage.haskell.org/package/io-classes +[`io-sim`]: https://hackage.haskell.org/package/io-sim +[`nothunks`]: https://hackage.haskell.org/package/nothunks +[`stm`]: https://hackage.haskell.org/package/stm diff --git a/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict.hs b/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict.hs index f4476375..133a2250 100644 --- a/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict.hs +++ b/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict.hs @@ -4,7 +4,11 @@ module Control.Concurrent.Class.MonadSTM.Strict (module STM) where -import Control.Monad.Class.MonadSTM as STM +import Control.Monad.Class.MonadSTM as STM hiding ( traceTVar, traceTVarIO, + traceTMVar, traceTMVarIO, + traceTQueue, traceTQueueIO, + traceTBQueue, traceTBQueueIO + ) import Control.Concurrent.Class.MonadSTM.Strict.TVar as STM import Control.Concurrent.Class.MonadSTM.Strict.TMVar as STM import Control.Concurrent.Class.MonadSTM.Strict.TChan as STM diff --git a/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs b/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs index d5b0ed28..7b02c94b 100644 --- a/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs +++ b/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs @@ -35,7 +35,7 @@ module Control.Concurrent.Class.MonadSTM.Strict.TBQueue import qualified Control.Concurrent.Class.MonadSTM.TBQueue as Lazy -import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadSTM hiding (traceTBQueue, traceTBQueueIO) import Numeric.Natural (Natural) diff --git a/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs b/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs index 9567b416..2623b53d 100644 --- a/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs +++ b/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs @@ -38,7 +38,7 @@ module Control.Concurrent.Class.MonadSTM.Strict.TMVar import qualified Control.Concurrent.Class.MonadSTM.TMVar as Lazy -import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadSTM hiding (traceTMVar, traceTMVarIO) type LazyTMVar m = Lazy.TMVar m diff --git a/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs b/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs index 343fed9a..d12e25c2 100644 --- a/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs +++ b/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs @@ -34,7 +34,7 @@ module Control.Concurrent.Class.MonadSTM.Strict.TQueue import qualified Control.Concurrent.Class.MonadSTM.TQueue as Lazy -import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadSTM hiding (traceTQueue, traceTQueueIO) type LazyTQueue m = Lazy.TQueue m diff --git a/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs b/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs index eeed40b4..7fd0124b 100644 --- a/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs +++ b/strict-stm/src/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs @@ -40,7 +40,7 @@ module Control.Concurrent.Class.MonadSTM.Strict.TVar ) where import qualified Control.Concurrent.Class.MonadSTM.TVar as Lazy -import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadSTM hiding (traceTVar, traceTVarIO) import GHC.Stack diff --git a/strict-stm/strict-stm.cabal b/strict-stm/strict-stm.cabal index 028182e7..c1e5b442 100644 --- a/strict-stm/strict-stm.cabal +++ b/strict-stm/strict-stm.cabal @@ -1,20 +1,24 @@ -cabal-version: 2.0 +cabal-version: 3.0 name: strict-stm -version: 0.6.0.0 +version: 1.0.0.0 synopsis: Strict STM interface polymorphic over stm implementation. -description: The `strict-stm` package gives a strict interface to stm, - currently either one provided by `stm` package for the - `IO` monad or `io-sim` package for the `IOSim` monad. +description: + Strict STM interface provided on top of + [io-classes](https://hackage.haskell.org/package/io-classes) and thus + compatible with [stm](https://hackage.haskell.org/package/stm) + & [io-sim](https://hackage.haskell.org/package/io-sim). license: Apache-2.0 license-files: LICENSE NOTICE copyright: 2019-2023 Input Output Global Inc (IOG) -author: Alexander Vieth, Marcin Szamotulski, Duncan Coutts -maintainer: +author: Alexander Vieth, Duncan Coutts, Marcin Szamotulski, Thomas Winant +maintainer: Duncan Coutts dunca@well-typed.com, Marcin Szamotulski coot@coot.me category: Control build-type: Simple -tested-with: GHC == 8.10.7, GHC == 9.2.5, GHC == 9.4.4 +extra-source-files: CHANGELOG.md + README.md +tested-with: GHC == { 8.10, 9.2, 9.4 } source-repository head type: git @@ -41,12 +45,21 @@ library Control.Concurrent.Class.MonadSTM.Strict.TMVar 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 + reexported-modules: Control.Concurrent.Class.MonadSTM.TSem as Control.Concurrent.Class.MonadSTM.Strict.TSem default-language: Haskell2010 + default-extensions: BangPatterns, + CPP, + ExplicitNamespaces, + FlexibleContexts, + FlexibleInstances, + GADTs, + NamedFieldPuns, + TypeOperators build-depends: base >= 4.9 && <4.18, array, stm >= 2.5 && <2.6, - io-classes ^>= 0.6 + + io-classes ^>= 1.0 ghc-options: -Wall -Wno-unticked-promoted-constructors -Wcompat @@ -59,4 +72,4 @@ library ghc-options: -fno-ignore-asserts if flag(checktvarinvariant) - cpp-options: -DCHECK_TVAR_INVARIANT + cpp-options: -DCHECK_TVAR_INVARIAN