diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,59 @@ +# Revsion history of io-classes + +## next version + +## 1.0.0.0 + +### Breaking changes + +* `MonadMonotonicTime` morphed into `MonadMonotonicTimeNSec` which supports + `getMonotonicTimeNSec` from "base". `MonadMonotonicTime` can be found in new + package `si-timers`. +* A simplified `MonadTimer` which is using time in microseconds encoded as + `Int` rather than `DiffTime`. The previous interface can be found in the + package `si-timers`. +* The non standard timer API is moved from `MonadTimer` to a `MonadTimerFancy` + type class which can be imported from + `Control.Monad.Class.MonadTimer.NonStandard` module. + +### Non breaking changes + +* Added `registerDelayCancellable` to `Control.Monad.Class.MonadTimer` module. + +## 0.6.0.0 + +## 0.5.0.0 + +* fixed `tryTakeMVarDefault`, `takeMVarDefault`, `putMVarDefault` and + `isEmptyMVarDefault`. +* Implemented the proper `readMVar` semantics. +* Added `tryReadMVar` to `MonadMVar` type class. +* Moved `MVarDefault` to `io-sim` package. + +## 0.4.0.0 + +* support `ghc-9.4` (except on Windows input-output-hk/io-sim#51) + +## 0.3.0.0 + +* added missing `MArray` instance for `WrappedSTM` +* added monoid instances for `WrappedSTM` +* added `threadStatus` method of `MonadFork` class +* removed `linktTo` and `linkToOnly` +* added `labelTChan` +* added `flushTQueue` +* split `MonadSTM` into submodules in a similar way that the `stm` package is. +* added `TChan`, `TSem` and `TArray` +* added `interruptible` and `allowInterrupt` to `MonadMaskingState` type class. +* added `unGetTQueue` & `unGetTBQueue` +* support `ghc-9.2` & `ghc-9.4` +* added `MonadMVar` + +## 0.2.0.0 + +* First version published on Hackage. +* added `lengthTBQueue` to `MonadSTM`; `io-classes` now depends on `stm-2.5.0.0`. + +## 0.1.0.0 + +* Initial version, not released on Hackage. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -0,0 +1,14 @@ +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. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,124 @@ +# IO Monad Class Hierarchy + +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 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. + +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 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 + +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, 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 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]: 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.cabal b/io-classes.cabal new file mode 100644 --- /dev/null +++ b/io-classes.cabal @@ -0,0 +1,102 @@ +cabal-version: 3.0 +name: io-classes +version: 1.0.0.0 +synopsis: Type classes for concurrency with STM, ST and timing +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, Duncan Coutts, Marcin Szamotulski, Thomas Winant +maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me +category: Control +build-type: Simple +extra-source-files: CHANGELOG.md + README.md +tested-with: GHC == { 8.10, 9.2, 9.4 } + +source-repository head + type: git + location: https://github.com/input-output-hk/io-sim + subdir: io-classes + +flag asserts + description: Enable assertions + manual: False + default: False + +common warnings + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wunused-packages + -Wno-redundant-constraints + -Wno-unticked-promoted-constructors + +library + import: warnings + hs-source-dirs: src + + -- At this experiment/prototype stage everything is exposed. + -- This has to be tidied up once the design becomes clear. + exposed-modules: Control.Concurrent.Class.MonadSTM + Control.Concurrent.Class.MonadSTM.TArray + Control.Concurrent.Class.MonadSTM.TBQueue + Control.Concurrent.Class.MonadSTM.TChan + Control.Concurrent.Class.MonadSTM.TMVar + Control.Concurrent.Class.MonadSTM.TQueue + Control.Concurrent.Class.MonadSTM.TSem + Control.Concurrent.Class.MonadSTM.TVar + Control.Monad.Class.MonadAsync + Control.Monad.Class.MonadEventlog + Control.Monad.Class.MonadFork + Control.Monad.Class.MonadMVar + Control.Monad.Class.MonadSay + Control.Monad.Class.MonadST + Control.Monad.Class.MonadSTM + Control.Monad.Class.MonadSTM.Internal + Control.Monad.Class.MonadThrow + Control.Monad.Class.MonadTime + Control.Monad.Class.MonadTimer + Control.Monad.Class.MonadTest + default-language: Haskell2010 + other-extensions: CPP + DataKinds + DefaultSignatures + DeriveFunctor + DeriveGeneric + DerivingStrategies + ExistentialQuantification + ExplicitNamespaces + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralisedNewtypeDeriving + MultiParamTypeClasses + NamedFieldPuns + QuantifiedConstraints + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TypeFamilies + TypeFamilyDependencies + TypeOperators + UndecidableInstances + build-depends: base >=4.9 && <4.18, + array, + async >=2.1, + bytestring, + mtl >=2.2 && <2.4, + stm >=2.5 && <2.6, + time >=1.9.1 && <1.13 + + if flag(asserts) + ghc-options: -fno-ignore-asserts diff --git a/src/Control/Concurrent/Class/MonadSTM.hs b/src/Control/Concurrent/Class/MonadSTM.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM.hs @@ -0,0 +1,14 @@ +-- | This module corresponds to "Control.Concurrent.STM" in "stm" package +-- +module Control.Concurrent.Class.MonadSTM + (module STM) + where + +import Control.Monad.Class.MonadSTM as STM +import Control.Concurrent.Class.MonadSTM.TVar as STM +import Control.Concurrent.Class.MonadSTM.TMVar as STM +import Control.Concurrent.Class.MonadSTM.TChan as STM +import Control.Concurrent.Class.MonadSTM.TQueue as STM +import Control.Concurrent.Class.MonadSTM.TBQueue as STM +import Control.Concurrent.Class.MonadSTM.TArray as STM + diff --git a/src/Control/Concurrent/Class/MonadSTM/TArray.hs b/src/Control/Concurrent/Class/MonadSTM/TArray.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/TArray.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrent.STM.TArray` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TArray (type TArray) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/src/Control/Concurrent/Class/MonadSTM/TBQueue.hs b/src/Control/Concurrent/Class/MonadSTM/TBQueue.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/TBQueue.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrent.STM.TVar` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TBQueue + ( -- * MonadSTM + type TBQueue + , newTBQueue + , newTBQueueIO + , readTBQueue + , tryReadTBQueue + , peekTBQueue + , tryPeekTBQueue + , flushTBQueue + , writeTBQueue + , lengthTBQueue + , isEmptyTBQueue + , isFullTBQueue + , unGetTBQueue + -- * MonadLabelledSTM + , labelTBQueue + , labelTBQueueIO + -- * MonadTraceSTM + , traceTBQueue + , traceTBQueueIO + ) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/src/Control/Concurrent/Class/MonadSTM/TChan.hs b/src/Control/Concurrent/Class/MonadSTM/TChan.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/TChan.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrent.STM.TChan` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TChan + ( -- * MonadSTM + -- ** TChans + type TChan + -- * Construction + , newTChan + , newBroadcastTChan + , newTChanIO + , newBroadcastTChanIO + , dupTChan + , cloneTChan + -- ** Reading and writing + , readTChan + , tryReadTChan + , peekTChan + , tryPeekTChan + , writeTChan + , unGetTChan + , isEmptyTChan + ) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/src/Control/Concurrent/Class/MonadSTM/TMVar.hs b/src/Control/Concurrent/Class/MonadSTM/TMVar.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/TMVar.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrent.STM.TMVar` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TMVar + ( -- * MonadSTM + type TMVar + , newTMVar + , newEmptyTMVar + , newTMVarIO + , newEmptyTMVarIO + , takeTMVar + , tryTakeTMVar + , putTMVar + , tryPutTMVar + , readTMVar + , tryReadTMVar + , swapTMVar + , isEmptyTMVar + -- * MonadLabelledSTM + , labelTMVar + , labelTMVarIO + -- * MonadTraceSTM + , traceTMVar + , traceTMVarIO + ) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/src/Control/Concurrent/Class/MonadSTM/TQueue.hs b/src/Control/Concurrent/Class/MonadSTM/TQueue.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/TQueue.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrnet.STM.TVar` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TQueue + ( -- * MonadSTM + type TQueue + , newTQueue + , newTQueueIO + , readTQueue + , tryReadTQueue + , peekTQueue + , tryPeekTQueue + , flushTQueue + , writeTQueue + , unGetTQueue + , isEmptyTQueue + -- * MonadLabelledSTM + , labelTQueue + , labelTQueueIO + -- * MonadTraceSTM + , traceTQueue + , traceTQueueIO + ) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/src/Control/Concurrent/Class/MonadSTM/TSem.hs b/src/Control/Concurrent/Class/MonadSTM/TSem.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/TSem.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrent.STM.TSem` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TSem + ( -- * MonadSTM + type TSem + , newTSem + , waitTSem + , signalTSem + , signalTSemN + -- * MonadLabelledSTM + , labelTSem + , labelTSemIO + -- * MonadTraceSTM + , traceTSem + , traceTSemIO + ) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/src/Control/Concurrent/Class/MonadSTM/TVar.hs b/src/Control/Concurrent/Class/MonadSTM/TVar.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/Class/MonadSTM/TVar.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrent.STM.TVar` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TVar + ( -- * MonadSTM + type TVar + , newTVar + , newTVarIO + , readTVar + , readTVarIO + , writeTVar + , modifyTVar + , modifyTVar' + , stateTVar + , swapTVar + , check + -- * MonadLabelSTM + , labelTVar + , labelTVarIO + -- * MonadTraceSTM + , traceTVar + , traceTVarIO + ) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/src/Control/Monad/Class/MonadAsync.hs b/src/Control/Monad/Class/MonadAsync.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadAsync.hs @@ -0,0 +1,613 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilyDependencies #-} +-- MonadAsync's ReaderT instance is undecidable. +{-# LANGUAGE UndecidableInstances #-} +module Control.Monad.Class.MonadAsync + ( MonadAsync (..) + , AsyncCancelled (..) + , ExceptionInLinkedThread (..) + , link + , linkOnly + , link2 + , link2Only + , mapConcurrently + , forConcurrently + , mapConcurrently_ + , forConcurrently_ + , replicateConcurrently + , replicateConcurrently_ + , Concurrently (..) + ) where + +import Prelude hiding (read) + +import Control.Applicative (Alternative (..), liftA2) +import Control.Monad (forever) +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadSTM +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer + +import Control.Monad.Reader (ReaderT (..)) +import Control.Monad.Trans (lift) + +import Control.Concurrent.Async (AsyncCancelled (..)) +import qualified Control.Concurrent.Async as Async +import qualified Control.Exception as E + +import Data.Bifunctor (first) +import Data.Foldable (fold) +import Data.Functor (void) +import Data.Kind (Type) + +class ( MonadSTM m + , MonadThread m + ) => MonadAsync m where + + {-# MINIMAL async, asyncBound, asyncOn, asyncThreadId, cancel, cancelWith, + 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) + default waitEitherSTM :: MonadThrow (STM m) => Async m a -> Async m b -> STM m (Either a b) + default waitEitherSTM_ :: MonadThrow (STM m) => Async m a -> Async m b -> STM m () + default waitBothSTM :: MonadThrow (STM m) => Async m a -> Async m b -> STM m (a, b) + + waitAnySTM as = + foldr orElse retry $ + map (\a -> do r <- waitSTM a; return (a, r)) as + + waitAnyCatchSTM as = + foldr orElse retry $ + map (\a -> do r <- waitCatchSTM a; return (a, r)) as + + waitEitherSTM left right = + (Left <$> waitSTM left) + `orElse` + (Right <$> waitSTM right) + + waitEitherSTM_ left right = + (void $ waitSTM left) + `orElse` + (void $ waitSTM right) + + waitEitherCatchSTM left right = + (Left <$> waitCatchSTM left) + `orElse` + (Right <$> waitCatchSTM right) + + waitBothSTM left right = do + a <- waitSTM left + `orElse` + (waitSTM right >> retry) + b <- waitSTM right + return (a,b) + + -- | 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 + default withAsync :: MonadMask m => m a -> (Async m a -> m b) -> m b + default withAsyncBound:: MonadMask m => m a -> (Async m a -> m b) -> m b + default withAsyncOn :: MonadMask m => Int -> m a -> (Async m a -> m b) -> m b + default withAsyncWithUnmask + :: MonadMask m => ((forall c. m c -> m c) -> m a) + -> (Async m a -> m b) -> m b + default withAsyncOnWithUnmask + :: MonadMask m => Int + -> ((forall c. m c -> m c) -> m a) + -> (Async m a -> m b) -> m b + default uninterruptibleCancel + :: MonadMask m => Async m a -> m () + default waitAnyCancel :: MonadThrow m => [Async m a] -> m (Async m a, a) + default waitAnyCatchCancel :: MonadThrow m => [Async m a] + -> m (Async m a, Either SomeException a) + default waitEitherCancel :: MonadThrow m => Async m a -> Async m b + -> m (Either a b) + default waitEitherCatchCancel :: MonadThrow m => Async m a -> Async m b + -> m (Either (Either SomeException a) + (Either SomeException b)) + default compareAsyncs :: Ord (ThreadId m) + => Async m a -> Async m b -> Ordering + + withAsync action inner = mask $ \restore -> do + a <- async (restore action) + restore (inner a) + `finally` uninterruptibleCancel a + + withAsyncBound action inner = mask $ \restore -> do + a <- asyncBound (restore action) + restore (inner a) + `finally` uninterruptibleCancel a + + withAsyncOn n action inner = mask $ \restore -> do + a <- asyncOn n (restore action) + restore (inner a) + `finally` uninterruptibleCancel a + + + withAsyncWithUnmask action inner = mask $ \restore -> do + a <- asyncWithUnmask action + restore (inner a) + `finally` uninterruptibleCancel a + + withAsyncOnWithUnmask n action inner = mask $ \restore -> do + a <- asyncOnWithUnmask n action + restore (inner a) + `finally` uninterruptibleCancel a + + wait = atomically . waitSTM + poll = atomically . pollSTM + waitCatch = atomically . waitCatchSTM + + uninterruptibleCancel = uninterruptibleMask_ . cancel + + waitAny = atomically . waitAnySTM + waitAnyCatch = atomically . waitAnyCatchSTM + waitEither left right = atomically (waitEitherSTM left right) + waitEither_ left right = atomically (waitEitherSTM_ left right) + waitEitherCatch left right = atomically (waitEitherCatchSTM left right) + waitBoth left right = atomically (waitBothSTM left right) + + waitAnyCancel asyncs = + waitAny asyncs `finally` mapM_ cancel asyncs + + waitAnyCatchCancel asyncs = + waitAnyCatch asyncs `finally` mapM_ cancel asyncs + + waitEitherCancel left right = + waitEither left right `finally` (cancel left >> cancel right) + + waitEitherCatchCancel left right = + waitEitherCatch left right `finally` (cancel left >> cancel right) + + race left right = withAsync left $ \a -> + withAsync right $ \b -> + waitEither a b + + race_ left right = withAsync left $ \a -> + withAsync right $ \b -> + waitEither_ a b + + concurrently left right = withAsync left $ \a -> + withAsync right $ \b -> + waitBoth a b + + concurrently_ left right = void $ concurrently left right + + compareAsyncs a b = asyncThreadId a `compare` asyncThreadId b + +-- | Similar to 'Async.Concurrently' but which works for any 'MonadAsync' +-- instance. +-- +newtype Concurrently m a = Concurrently { runConcurrently :: m a } + +instance Functor m => Functor (Concurrently m) where + fmap f (Concurrently ma) = Concurrently (fmap f ma) + +instance MonadAsync m => Applicative (Concurrently m) where + pure = Concurrently . pure + + Concurrently fn <*> Concurrently as = + Concurrently $ + (\(f, a) -> f a) + `fmap` + concurrently fn as + +instance ( MonadAsync m + , MonadTimer m + ) => Alternative (Concurrently m) where + empty = Concurrently $ forever (threadDelay 86400) + Concurrently as <|> Concurrently bs = + Concurrently $ either id id <$> as `race` bs + +instance ( Semigroup a + , MonadAsync m + ) => Semigroup (Concurrently m a) where + (<>) = liftA2 (<>) + +instance ( Monoid a + , MonadAsync m + ) => Monoid (Concurrently m a) where + 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 + + +-- +-- Instance for IO uses the existing async library implementations +-- + +instance MonadAsync IO where + + type Async IO = Async.Async + + async = Async.async + asyncBound = Async.asyncBound + asyncOn = Async.asyncOn + asyncThreadId = Async.asyncThreadId + withAsync = Async.withAsync + withAsyncBound = Async.withAsyncBound + withAsyncOn = Async.withAsyncOn + + waitSTM = Async.waitSTM + pollSTM = Async.pollSTM + waitCatchSTM = Async.waitCatchSTM + + waitAnySTM = Async.waitAnySTM + waitAnyCatchSTM = Async.waitAnyCatchSTM + waitEitherSTM = Async.waitEitherSTM + waitEitherSTM_ = Async.waitEitherSTM_ + waitEitherCatchSTM = Async.waitEitherCatchSTM + waitBothSTM = Async.waitBothSTM + + wait = Async.wait + poll = Async.poll + waitCatch = Async.waitCatch + cancel = Async.cancel + cancelWith = Async.cancelWith + uninterruptibleCancel = Async.uninterruptibleCancel + + waitAny = Async.waitAny + waitAnyCatch = Async.waitAnyCatch + waitAnyCancel = Async.waitAnyCancel + waitAnyCatchCancel = Async.waitAnyCatchCancel + waitEither = Async.waitEither + waitEitherCatch = Async.waitEitherCatch + waitEitherCancel = Async.waitEitherCancel + waitEitherCatchCancel = Async.waitEitherCatchCancel + waitEither_ = Async.waitEither_ + waitBoth = Async.waitBoth + + race = Async.race + race_ = Async.race_ + concurrently = Async.concurrently + concurrently_ = Async.concurrently_ + + asyncWithUnmask = Async.asyncWithUnmask + asyncOnWithUnmask = Async.asyncOnWithUnmask + withAsyncWithUnmask = Async.withAsyncWithUnmask + withAsyncOnWithUnmask = Async.withAsyncOnWithUnmask + + compareAsyncs = Async.compareAsyncs + + +-- +-- Linking +-- +-- Adapted from "Control.Concurrent.Async" +-- +-- We don't use the implementation of linking from 'Control.Concurrent.Async' +-- directly because if we /did/ use the real implementation, then the mock +-- implementation and the real implementation would not be able to throw the +-- same exception, because the exception type used by the real implementation +-- is +-- +-- > data ExceptionInLinkedThread = +-- > forall a . ExceptionInLinkedThread (Async a) SomeException +-- +-- containing a reference to the real 'Async' type. +-- + +-- | Exception from child thread re-raised in parent thread +-- +-- We record the thread ID of the child thread as a 'String'. This avoids +-- an @m@ parameter in the type, which is important: 'ExceptionInLinkedThread' +-- must be an instance of 'Exception', requiring it to be 'Typeable'; if @m@ +-- appeared in the type, we would require @m@ to be 'Typeable', which does not +-- work with with the simulator, as it would require a 'Typeable' constraint +-- on the @s@ parameter of 'IOSim'. +data ExceptionInLinkedThread = ExceptionInLinkedThread String SomeException + +instance Show ExceptionInLinkedThread where + showsPrec p (ExceptionInLinkedThread a e) = + showParen (p >= 11) $ + showString "ExceptionInLinkedThread " . + showsPrec 11 a . + showString " " . + showsPrec 11 e + +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 + tid <- myThreadId + void $ forkRepeat ("linkToOnly " <> show linkedThreadId) $ do + r <- waitCatch a + case r of + Left e | shouldThrow e -> throwTo tid (exceptionInLinkedThread e) + _otherwise -> return () + where + linkedThreadId :: ThreadId m + linkedThreadId = asyncThreadId a + + exceptionInLinkedThread :: SomeException -> ExceptionInLinkedThread + 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 = + void $ forkRepeat ("link2Only " <> show (tl, tr)) $ do + r <- waitEitherCatch left right + case r of + Left (Left e) | shouldThrow e -> + throwTo tr (ExceptionInLinkedThread (show tl) e) + Right (Left e) | shouldThrow e -> + throwTo tl (ExceptionInLinkedThread (show tr) e) + _ -> return () + where + tl = asyncThreadId left + tr = asyncThreadId right + +isCancel :: SomeException -> Bool +isCancel e + | Just AsyncCancelled <- fromException e = True + | otherwise = False + +forkRepeat :: (MonadFork m, MonadMask m) => String -> m a -> m (ThreadId m) +forkRepeat label action = + mask $ \restore -> + let go = do r <- tryAll (restore action) + case r of + Left _ -> go + _ -> return () + in forkIO (labelThisThread label >> go) + +tryAll :: MonadCatch m => m a -> m (Either SomeException a) +tryAll = try + + +-- +-- ReaderT instance +-- + +newtype AsyncReaderT r (m :: Type -> Type) a = + AsyncReaderT { getAsyncReaderT :: Async m a } + +instance ( MonadAsync m + , MonadCatch (STM m) + , MonadFork m + , MonadMask m + ) => MonadAsync (ReaderT r m) where + type Async (ReaderT r m) = AsyncReaderT r m + asyncThreadId (AsyncReaderT a) = asyncThreadId a + + async (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> async (ma r) + asyncBound (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncBound (ma r) + asyncOn n (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncOn n (ma r) + withAsync (ReaderT ma) f = ReaderT $ \r -> withAsync (ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + withAsyncBound (ReaderT ma) f = ReaderT $ \r -> withAsyncBound (ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + withAsyncOn n (ReaderT ma) f = ReaderT $ \r -> withAsyncOn n (ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + + asyncWithUnmask f = ReaderT $ \r -> fmap AsyncReaderT + $ asyncWithUnmask + $ \unmask -> runReaderT (f (liftF unmask)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + asyncOnWithUnmask n f = ReaderT $ \r -> fmap AsyncReaderT + $ asyncOnWithUnmask n + $ \unmask -> runReaderT (f (liftF unmask)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + withAsyncWithUnmask action f = + ReaderT $ \r -> withAsyncWithUnmask (\unmask -> case action (liftF unmask) of + ReaderT ma -> ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + withAsyncOnWithUnmask n action f = + ReaderT $ \r -> withAsyncOnWithUnmask n (\unmask -> case action (liftF unmask) of + ReaderT ma -> ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + waitCatchSTM = lift . waitCatchSTM . getAsyncReaderT + pollSTM = lift . pollSTM . getAsyncReaderT + + race (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race (ma r) (mb r) + race_ (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race_ (ma r) (mb r) + concurrently (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> concurrently (ma r) (mb r) + + wait = lift . wait . getAsyncReaderT + poll = lift . poll . getAsyncReaderT + waitCatch = lift . waitCatch . getAsyncReaderT + cancel = lift . cancel . getAsyncReaderT + uninterruptibleCancel = lift . uninterruptibleCancel + . getAsyncReaderT + cancelWith = (lift .: cancelWith) + . getAsyncReaderT + waitAny = fmap (first AsyncReaderT) + . lift . waitAny + . map getAsyncReaderT + waitAnyCatch = fmap (first AsyncReaderT) + . lift . waitAnyCatch + . map getAsyncReaderT + waitAnyCancel = fmap (first AsyncReaderT) + . lift . waitAnyCancel + . map getAsyncReaderT + waitAnyCatchCancel = fmap (first AsyncReaderT) + . lift . waitAnyCatchCancel + . map getAsyncReaderT + waitEither = on (lift .: waitEither) getAsyncReaderT + waitEitherCatch = on (lift .: waitEitherCatch) getAsyncReaderT + waitEitherCancel = on (lift .: waitEitherCancel) getAsyncReaderT + waitEitherCatchCancel = on (lift .: waitEitherCatchCancel) getAsyncReaderT + waitEither_ = on (lift .: waitEither_) getAsyncReaderT + waitBoth = on (lift .: waitBoth) getAsyncReaderT + + +-- +-- Utilities +-- + +(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) +(f .: g) x y = f (g x y) + + +-- | A higher order version of 'Data.Function.on' +-- +on :: (f a -> f b -> c) + -> (forall x. g x -> f x) + -> (g a -> g b -> c) +on f g = \a b -> f (g a) (g b) diff --git a/src/Control/Monad/Class/MonadEventlog.hs b/src/Control/Monad/Class/MonadEventlog.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadEventlog.hs @@ -0,0 +1,36 @@ +module Control.Monad.Class.MonadEventlog + ( MonadEventlog (..) + ) where + +import Control.Monad.Reader + +import qualified Debug.Trace as IO (traceEventIO, traceMarkerIO) + +class Monad m => MonadEventlog m where + + -- | Emits a message to the eventlog, if eventlog profiling is available and + -- enabled at runtime. + traceEventIO :: String -> m () + + -- | Emits a marker to the eventlog, if eventlog profiling is available and + -- enabled at runtime. + -- + -- The 'String' is the name of the marker. The name is just used in the + -- profiling tools to help you keep clear which marker is which. + traceMarkerIO :: String -> m () + +-- +-- Instances for IO +-- + +instance MonadEventlog IO where + traceEventIO = IO.traceEventIO + traceMarkerIO = IO.traceMarkerIO + +-- +-- Instance for ReaderT +-- + +instance MonadEventlog m => MonadEventlog (ReaderT r m) where + traceEventIO = lift . traceEventIO + traceMarkerIO = lift . traceMarkerIO diff --git a/src/Control/Monad/Class/MonadFork.hs b/src/Control/Monad/Class/MonadFork.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadFork.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Control.Monad.Class.MonadFork + ( MonadThread (..) + , labelThisThread + , MonadFork (..) + ) where + +import qualified Control.Concurrent as IO +import Control.Exception (AsyncException (ThreadKilled), Exception) +import Control.Monad.Reader (ReaderT (..), lift) +import Data.Kind (Type) +import qualified GHC.Conc.Sync as IO (labelThread) + + +class (Monad m, Eq (ThreadId m), + Ord (ThreadId m), + Show (ThreadId m)) => MonadThread m where + + type ThreadId m :: Type + + 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 + + forkIO :: m () -> m (ThreadId m) + forkOn :: Int -> m () -> m (ThreadId m) + forkIOWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m) + throwTo :: Exception e => ThreadId m -> e -> m () + + killThread :: ThreadId m -> m () + killThread tid = throwTo tid ThreadKilled + + yield :: m () + + +instance MonadThread IO where + type ThreadId IO = IO.ThreadId + myThreadId = IO.myThreadId + labelThread = IO.labelThread + +instance MonadFork IO where + forkIO = IO.forkIO + forkOn = IO.forkOn + forkIOWithUnmask = IO.forkIOWithUnmask + throwTo = IO.throwTo + killThread = IO.killThread + yield = IO.yield + +instance MonadThread m => MonadThread (ReaderT r m) where + type ThreadId (ReaderT r m) = ThreadId m + myThreadId = lift myThreadId + labelThread t l = lift (labelThread t l) + +instance MonadFork m => MonadFork (ReaderT e m) where + forkIO (ReaderT f) = ReaderT $ \e -> forkIO (f e) + forkOn n (ReaderT f) = ReaderT $ \e -> forkOn n (f e) + forkIOWithUnmask k = ReaderT $ \e -> forkIOWithUnmask $ \restore -> + let restore' :: ReaderT e m a -> ReaderT e m a + restore' (ReaderT f) = ReaderT $ restore . f + in runReaderT (k restore') e + throwTo e t = lift (throwTo e t) + yield = lift yield diff --git a/src/Control/Monad/Class/MonadMVar.hs b/src/Control/Monad/Class/MonadMVar.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadMVar.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +module Control.Monad.Class.MonadMVar (MonadMVar (..)) where + +import qualified Control.Concurrent.MVar as IO +import Control.Monad.Class.MonadThrow + +import Control.Monad.Reader (ReaderT (..)) +import Control.Monad.Trans (lift) + +import Data.Kind (Type) + + +class Monad m => MonadMVar m where + {-# MINIMAL newEmptyMVar, + takeMVar, tryTakeMVar, + putMVar, tryPutMVar, + readMVar, tryReadMVar, + isEmptyMVar #-} + + 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 + -- | 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) + newMVar a = do + v <- newEmptyMVar + putMVar v a + return v + {-# INLINE newMVar #-} + + default swapMVar :: MonadMask m => MVar m a -> a -> m a + swapMVar mvar new = + mask_ $ do + old <- takeMVar mvar + putMVar mvar new + return old + {-# INLINE swapMVar #-} + + default withMVar :: MonadMask m => MVar m a -> (a -> m b) -> m b + withMVar m io = + mask $ \restore -> do + a <- takeMVar m + b <- restore (io a) `onException` putMVar m a + putMVar m a + return b + {-# INLINE withMVar #-} + + default withMVarMasked :: MonadMask m => MVar m a -> (a -> m b) -> m b + withMVarMasked m io = + mask_ $ do + a <- takeMVar m + b <- io a `onException` putMVar m a + putMVar m a + return b + {-# INLINE withMVarMasked #-} + + default modifyMVar_ :: MonadMask m => MVar m a -> (a -> m a) -> m () + modifyMVar_ m io = + mask $ \restore -> do + a <- takeMVar m + a' <- restore (io a) `onException` putMVar m a + putMVar m a' + {-# INLINE modifyMVar_ #-} + + default modifyMVar :: (MonadMask m, MonadEvaluate m) + => MVar m a -> (a -> m (a,b)) -> m b + modifyMVar m io = + mask $ \restore -> do + a <- takeMVar m + (a',b) <- restore (io a >>= evaluate) `onException` putMVar m a + putMVar m a' + return b + {-# INLINE modifyMVar #-} + + default modifyMVarMasked_ :: MonadMask m => MVar m a -> (a -> m a) -> m () + modifyMVarMasked_ m io = + mask_ $ do + a <- takeMVar m + a' <- io a `onException` putMVar m a + putMVar m a' + {-# INLINE modifyMVarMasked_ #-} + + default modifyMVarMasked :: (MonadMask m, MonadEvaluate m) + => MVar m a -> (a -> m (a,b)) -> m b + modifyMVarMasked m io = + mask_ $ do + a <- takeMVar m + (a',b) <- (io a >>= evaluate) `onException` putMVar m a + putMVar m a' + return b + {-# INLINE modifyMVarMasked #-} + + +instance MonadMVar IO where + type MVar IO = IO.MVar + newEmptyMVar = IO.newEmptyMVar + newMVar = IO.newMVar + takeMVar = IO.takeMVar + putMVar = IO.putMVar + readMVar = IO.readMVar + swapMVar = IO.swapMVar + tryTakeMVar = IO.tryTakeMVar + tryPutMVar = IO.tryPutMVar + tryReadMVar = IO.tryReadMVar + isEmptyMVar = IO.isEmptyMVar + withMVar = IO.withMVar + withMVarMasked = IO.withMVarMasked + modifyMVar_ = IO.modifyMVar_ + modifyMVar = IO.modifyMVar + modifyMVarMasked_ = IO.modifyMVarMasked_ + modifyMVarMasked = IO.modifyMVarMasked + + +-- +-- ReaderT instance +-- + +newtype WrappedMVar r (m :: Type -> Type) a = WrappedMVar { unwrapMVar :: MVar m a } + +instance ( MonadMask m + , MonadMVar m + ) => MonadMVar (ReaderT r m) where + type MVar (ReaderT r m) = WrappedMVar r m + newEmptyMVar = WrappedMVar <$> lift newEmptyMVar + newMVar = fmap WrappedMVar . lift . newMVar + takeMVar = lift . takeMVar . unwrapMVar + putMVar = lift .: (putMVar . unwrapMVar) + readMVar = lift . readMVar . unwrapMVar + tryReadMVar = lift . tryReadMVar . unwrapMVar + swapMVar = lift .: (swapMVar . unwrapMVar) + tryTakeMVar = lift . tryTakeMVar . unwrapMVar + tryPutMVar = lift .: (tryPutMVar . unwrapMVar) + isEmptyMVar = lift . isEmptyMVar . unwrapMVar + withMVar (WrappedMVar v) f = ReaderT $ \r -> + withMVar v (\a -> runReaderT (f a) r) + withMVarMasked (WrappedMVar v) f = ReaderT $ \r -> + withMVarMasked v (\a -> runReaderT (f a) r) + modifyMVar_ (WrappedMVar v) f = ReaderT $ \r -> + modifyMVar_ v (\a -> runReaderT (f a) r) + modifyMVar (WrappedMVar v) f = ReaderT $ \r -> + modifyMVar v (\a -> runReaderT (f a) r) + modifyMVarMasked_ (WrappedMVar v) f = ReaderT $ \r -> + modifyMVarMasked_ v (\a -> runReaderT (f a) r) + modifyMVarMasked (WrappedMVar v) f = ReaderT $ \r -> + modifyMVarMasked v (\a -> runReaderT (f a) r) + + + + +-- +-- Utilities +-- + +(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) +(f .: g) x y = f (g x y) diff --git a/src/Control/Monad/Class/MonadST.hs b/src/Control/Monad/Class/MonadST.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadST.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE RankNTypes #-} +module Control.Monad.Class.MonadST (MonadST (..)) where + +import Control.Monad.Reader + +import Control.Monad.ST (ST, stToIO) + + +-- | This class is for abstracting over 'stToIO' which allows running 'ST' +-- actions in 'IO'. In this case it is to allow running 'ST' actions within +-- another monad @m@. +-- +-- The type of 'stToIO' is: +-- +-- > stToIO : ST RealWorld a -> IO a +-- +-- Abstracting over this is tricky because we need to not care about both +-- the @IO@, and also the @RealWorld@. +-- +-- A solution is to write an action that is given the @liftST@ as an argument +-- and where that action itself is polymorphic in the @s@ parameter. This +-- allows us to instantiate it with @RealWorld@ in the @IO@ case, and the local +-- @s@ in a case where we are embedding into another @ST@ action. +-- +class Monad m => MonadST m where + withLiftST :: (forall s. (forall a. ST s a -> m a) -> b) -> b + +instance MonadST IO where + withLiftST = \f -> f stToIO + +instance MonadST (ST s) where + withLiftST = \f -> f id + +instance MonadST m => MonadST (ReaderT r m) where + withLiftST f = withLiftST $ \g -> f (lift . g) diff --git a/src/Control/Monad/Class/MonadSTM.hs b/src/Control/Monad/Class/MonadSTM.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadSTM.hs @@ -0,0 +1,33 @@ +-- | This module corresponds to "Control.Monad.STM" in "stm" package +-- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- undecidable instances needed for 'WrappedSTM' instances of 'MonadThrow' and +-- 'MonadCatch' type classes. +{-# LANGUAGE UndecidableInstances #-} +module Control.Monad.Class.MonadSTM + ( MonadSTM (STM, atomically, retry, orElse, check) + , throwSTM + -- * non standard extensions + -- + -- $non-standard-extensions + , MonadLabelledSTM + , 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/src/Control/Monad/Class/MonadSTM/Internal.hs b/src/Control/Monad/Class/MonadSTM/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadSTM/Internal.hs @@ -0,0 +1,1239 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} + +-- needed for `ReaderT` instance +{-# LANGUAGE UndecidableInstances #-} + +-- Internal module. It's only exposed as it provides various default types for +-- defining new instances, otherwise prefer to use +-- 'Control.Concurrent.Class.MonadSTM'. +-- +module Control.Monad.Class.MonadSTM.Internal + ( MonadSTM (..) + , MonadLabelledSTM (..) + , MonadInspectSTM (..) + , TraceValue (TraceValue, TraceDynamic, TraceString, DontTrace, traceDynamic, traceString) + , MonadTraceSTM (..) + -- * MonadThrow aliases + , throwSTM + , catchSTM + -- * Default implementations + -- $default-implementations + -- + -- ** Default 'TMVar' implementation + , TMVarDefault (..) + , newTMVarDefault + , newEmptyTMVarDefault + , takeTMVarDefault + , tryTakeTMVarDefault + , putTMVarDefault + , tryPutTMVarDefault + , readTMVarDefault + , tryReadTMVarDefault + , swapTMVarDefault + , isEmptyTMVarDefault + , labelTMVarDefault + , traceTMVarDefault + -- ** Default 'TBQueue' implementation + , TQueueDefault (..) + , newTQueueDefault + , writeTQueueDefault + , readTQueueDefault + , tryReadTQueueDefault + , isEmptyTQueueDefault + , peekTQueueDefault + , tryPeekTQueueDefault + , flushTQueueDefault + , unGetTQueueDefault + , labelTQueueDefault + -- ** Default 'TBQueue' implementation + , TBQueueDefault (..) + , newTBQueueDefault + , writeTBQueueDefault + , readTBQueueDefault + , tryReadTBQueueDefault + , peekTBQueueDefault + , tryPeekTBQueueDefault + , isEmptyTBQueueDefault + , isFullTBQueueDefault + , lengthTBQueueDefault + , flushTBQueueDefault + , unGetTBQueueDefault + , labelTBQueueDefault + -- ** Default 'TArray' implementation + , TArrayDefault (..) + -- ** Default 'TSem' implementation + , TSemDefault (..) + , newTSemDefault + , waitTSemDefault + , signalTSemDefault + , signalTSemNDefault + , labelTSemDefault + -- ** Default 'TChan' implementation + , TChanDefault (..) + , 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 +import qualified Control.Concurrent.STM.TBQueue as STM +import qualified Control.Concurrent.STM.TChan as STM +import qualified Control.Concurrent.STM.TMVar as STM +import qualified Control.Concurrent.STM.TQueue as STM +import qualified Control.Concurrent.STM.TSem as STM +import qualified Control.Concurrent.STM.TVar as STM +import Control.Monad (unless, when) +import qualified Control.Monad.STM as STM + +import Control.Monad.Reader (ReaderT (..)) +import Control.Monad.Trans (lift) + +import qualified Control.Monad.Class.MonadThrow as MonadThrow + +import Control.Exception +import Data.Array (Array, bounds) +import qualified Data.Array as Array +import Data.Array.Base (IArray (numElements), MArray (..), + arrEleBottom, listArray, unsafeAt) +import Data.Foldable (traverse_) +import Data.Ix (Ix, rangeSize) +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import GHC.Stack +import Numeric.Natural (Natural) + + +-- | The STM primitives parametrised by a monad `m`. +-- +class (Monad m, Monad (STM m)) => MonadSTM m where + -- | 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 () + modifyTVar v f = readTVar v >>= writeTVar v . f + + modifyTVar' :: TVar m a -> (a -> a) -> STM m () + modifyTVar' v f = readTVar v >>= \x -> writeTVar v $! f x + + -- | @since io-classes-0.2.0.0 + stateTVar :: TVar m s -> (s -> (a, s)) -> STM m a + stateTVar = stateTVarDefault + + swapTVar :: TVar m a -> a -> STM m a + swapTVar = swapTVarDefault + + -- | See `STM.check`. + check :: Bool -> STM m () + check True = return () + check _ = retry + + -- Additional derived STM APIs + type TMVar m :: Type -> Type + newTMVar :: a -> STM m (TMVar m a) + newEmptyTMVar :: STM m (TMVar m a) + takeTMVar :: TMVar m a -> STM m a + tryTakeTMVar :: TMVar m a -> STM m (Maybe a) + putTMVar :: TMVar m a -> a -> STM m () + tryPutTMVar :: TMVar m a -> a -> STM m Bool + readTMVar :: TMVar m a -> STM m a + tryReadTMVar :: TMVar m a -> STM m (Maybe a) + swapTMVar :: TMVar m a -> a -> STM m a + isEmptyTMVar :: TMVar m a -> STM m Bool + + type TQueue m :: Type -> Type + newTQueue :: STM m (TQueue m a) + readTQueue :: TQueue m a -> STM m a + tryReadTQueue :: TQueue m a -> STM m (Maybe a) + peekTQueue :: TQueue m a -> STM m a + tryPeekTQueue :: TQueue m a -> STM m (Maybe a) + flushTQueue :: TQueue m a -> STM m [a] + writeTQueue :: TQueue m a -> a -> STM m () + isEmptyTQueue :: TQueue m a -> STM m Bool + unGetTQueue :: TQueue m a -> a -> STM m () + + type TBQueue m :: Type -> Type + newTBQueue :: Natural -> STM m (TBQueue m a) + readTBQueue :: TBQueue m a -> STM m a + tryReadTBQueue :: TBQueue m a -> STM m (Maybe a) + peekTBQueue :: TBQueue m a -> STM m a + tryPeekTBQueue :: TBQueue m a -> STM m (Maybe a) + flushTBQueue :: TBQueue m a -> STM m [a] + writeTBQueue :: TBQueue m a -> a -> STM m () + -- | @since 0.2.0.0 + lengthTBQueue :: TBQueue m a -> STM m Natural + isEmptyTBQueue :: TBQueue m a -> STM m Bool + isFullTBQueue :: TBQueue m a -> STM m Bool + unGetTBQueue :: TBQueue m a -> a -> STM m () + + type TArray m :: Type -> Type -> Type + + type TSem m :: Type + newTSem :: Integer -> STM m (TSem m) + waitTSem :: TSem m -> STM m () + signalTSem :: TSem m -> STM m () + signalTSemN :: Natural -> TSem m -> STM m () + + type TChan m :: Type -> Type + newTChan :: STM m (TChan m a) + newBroadcastTChan :: STM m (TChan m a) + dupTChan :: TChan m a -> STM m (TChan m a) + cloneTChan :: TChan m a -> STM m (TChan m a) + readTChan :: TChan m a -> STM m a + tryReadTChan :: TChan m a -> STM m (Maybe a) + peekTChan :: TChan m a -> STM m a + tryPeekTChan :: TChan m a -> STM m (Maybe a) + writeTChan :: TChan m a -> a -> STM m () + unGetTChan :: TChan m a -> a -> STM m () + isEmptyTChan :: TChan m a -> STM m Bool + + + -- Helpful derived functions with default implementations + + newTVarIO :: a -> m (TVar m a) + readTVarIO :: TVar m a -> m a + newTMVarIO :: a -> m (TMVar m a) + newEmptyTMVarIO :: m (TMVar m a) + newTQueueIO :: m (TQueue m a) + newTBQueueIO :: Natural -> m (TBQueue m a) + newTChanIO :: m (TChan m a) + newBroadcastTChanIO :: m (TChan m a) + + -- + -- default implementations + -- + + newTVarIO = atomically . newTVar + readTVarIO = atomically . readTVar + newTMVarIO = atomically . newTMVar + newEmptyTMVarIO = atomically newEmptyTMVar + newTQueueIO = atomically newTQueue + newTBQueueIO = atomically . newTBQueue + newTChanIO = atomically newTChan + newBroadcastTChanIO = atomically newBroadcastTChan + + + +stateTVarDefault :: MonadSTM m => TVar m s -> (s -> (a, s)) -> STM m a +stateTVarDefault var f = do + s <- readTVar var + let (a, s') = f s + writeTVar var s' + return a + +swapTVarDefault :: MonadSTM m => TVar m a -> a -> STM m a +swapTVarDefault var new = do + old <- readTVar var + writeTVar var new + return old + + +-- | 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 () + labelTBQueue :: TBQueue m a -> String -> STM m () + labelTArray :: (Ix i, Show i) + => TArray m i e -> String -> STM m () + labelTSem :: TSem m -> String -> STM m () + labelTChan :: TChan m a -> String -> STM m () + + labelTVarIO :: TVar m a -> String -> m () + labelTMVarIO :: TMVar m a -> String -> m () + labelTQueueIO :: TQueue m a -> String -> m () + labelTBQueueIO :: TBQueue m a -> String -> m () + labelTArrayIO :: (Ix i, Show i) + => TArray m i e -> String -> m () + labelTSemIO :: TSem m -> String -> m () + labelTChanIO :: TChan m a -> String -> m () + + -- + -- default implementations + -- + + default labelTMVar :: TMVar m ~ TMVarDefault m + => TMVar m a -> String -> STM m () + labelTMVar = labelTMVarDefault + + default labelTQueue :: TQueue m ~ TQueueDefault m + => TQueue m a -> String -> STM m () + labelTQueue = labelTQueueDefault + + default labelTBQueue :: TBQueue m ~ TBQueueDefault m + => TBQueue m a -> String -> STM m () + labelTBQueue = labelTBQueueDefault + + default labelTSem :: TSem m ~ TSemDefault m + => TSem m -> String -> STM m () + labelTSem = labelTSemDefault + + default labelTChan :: TChan m ~ TChanDefault m + => TChan m a -> String -> STM m () + labelTChan = labelTChanDefault + + default labelTArray :: ( TArray m ~ TArrayDefault m + , Ix i + , Show i + ) + => TArray m i e -> String -> STM m () + labelTArray = labelTArrayDefault + + default labelTVarIO :: TVar m a -> String -> m () + labelTVarIO = \v l -> atomically (labelTVar v l) + + default labelTMVarIO :: TMVar m a -> String -> m () + labelTMVarIO = \v l -> atomically (labelTMVar v l) + + default labelTQueueIO :: TQueue m a -> String -> m () + labelTQueueIO = \v l -> atomically (labelTQueue v l) + + default labelTBQueueIO :: TBQueue m a -> String -> m () + labelTBQueueIO = \v l -> atomically (labelTBQueue v l) + + default labelTArrayIO :: (Ix i, Show i) + => TArray m i e -> String -> m () + labelTArrayIO = \v l -> atomically (labelTArray v l) + + default labelTSemIO :: TSem m -> String -> m () + labelTSemIO = \v l -> atomically (labelTSem v l) + + default labelTChanIO :: TChan m a -> String -> m () + labelTChanIO = \v l -> atomically (labelTChan v l) + + +-- | 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 + +instance MonadInspectSTM IO where + type InspectMonad IO = IO + inspectTVar _ = readTVarIO + -- issue #3198: tryReadTMVarIO + inspectTMVar _ = atomically . tryReadTMVar + + +-- | 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'. 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 + => { traceDynamic :: Maybe tr + , traceString :: Maybe String + } + -> TraceValue + + +-- | Use only a dynamic tracer. +-- +pattern TraceDynamic :: () => forall tr. Typeable tr => tr -> TraceValue +pattern TraceDynamic tr <- TraceValue { traceDynamic = Just tr } + where + TraceDynamic tr = TraceValue { traceDynamic = Just tr, traceString = Nothing } + +-- | Use only string tracing. +-- +pattern TraceString :: String -> TraceValue +pattern TraceString tr <- TraceValue { traceString = Just tr } + where + TraceString tr = TraceValue { traceDynamic = (Nothing :: Maybe ()) + , traceString = Just tr + } + +-- | Do not trace the value. +-- +pattern DontTrace :: TraceValue +pattern DontTrace <- TraceValue Nothing Nothing + where + DontTrace = TraceValue (Nothing :: Maybe ()) Nothing + +-- | 'MonadTraceSTM' allows to trace values of stm variables when stm +-- transaction is committed. This allows to verify invariants when a variable +-- is committed. +-- +class MonadInspectSTM m + => MonadTraceSTM m where + {-# 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. + -- + -- The simplest example is: + -- + -- > + -- > traceTVar (Proxy @m) tvar (\_ -> TraceString . show) + -- > + -- + -- Note that the interpretation of `TraceValue` depends on the monad `m` + -- itself (see 'TraceValue'). + -- + traceTVar :: proxy m + -> TVar m a + -> (Maybe a -> a -> InspectMonad m TraceValue) + -- ^ callback which receives initial value or 'Nothing' (if it + -- is a newly created 'TVar'), and the committed value. + -> STM m () + + + traceTMVar :: proxy m + -> TMVar m a + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> STM m () + + traceTQueue :: proxy m + -> TQueue m a + -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> STM m () + + traceTBQueue :: proxy m + -> TBQueue m a + -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> STM m () + + traceTSem :: proxy m + -> TSem m + -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> STM m () + + default traceTMVar :: TMVar m a ~ TMVarDefault m a + => proxy m + -> TMVar m a + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> STM m () + traceTMVar = traceTMVarDefault + + default traceTSem :: TSem m ~ TSemDefault m + => proxy m + -> TSem m + -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> STM m () + traceTSem = traceTSemDefault + + + traceTVarIO :: TVar m a + -> (Maybe a -> a -> InspectMonad m TraceValue) + -> m () + + traceTMVarIO :: TMVar m a + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> m () + + traceTQueueIO :: TQueue m a + -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> m () + + traceTBQueueIO :: TBQueue m a + -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> m () + + traceTSemIO :: TSem m + -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> m () + + default traceTVarIO :: TVar m a + -> (Maybe a -> a -> InspectMonad m TraceValue) + -> m () + traceTVarIO = \v f -> atomically (traceTVar Proxy v f) + + default traceTMVarIO :: TMVar m a + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> m () + traceTMVarIO = \v f -> atomically (traceTMVar Proxy v f) + + default traceTQueueIO :: TQueue m a + -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> m () + traceTQueueIO = \v f -> atomically (traceTQueue Proxy v f) + + default traceTBQueueIO :: TBQueue m a + -> (Maybe [a] -> [a] -> InspectMonad m TraceValue) + -> m () + traceTBQueueIO = \v f -> atomically (traceTBQueue Proxy v f) + + default traceTSemIO :: TSem m + -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> m () + traceTSemIO = \v f -> atomically (traceTSem Proxy v f) + + +-- +-- Instance for IO uses the existing STM library implementations +-- + +instance MonadSTM IO where + type STM IO = STM.STM + + atomically = wrapBlockedIndefinitely . STM.atomically + + type TVar IO = STM.TVar + type TMVar IO = STM.TMVar + type TQueue IO = STM.TQueue + type TBQueue IO = STM.TBQueue + type TArray IO = STM.TArray + type TSem IO = STM.TSem + type TChan IO = STM.TChan + + newTVar = STM.newTVar + readTVar = STM.readTVar + writeTVar = STM.writeTVar + retry = STM.retry + orElse = STM.orElse + modifyTVar = STM.modifyTVar + modifyTVar' = STM.modifyTVar' + stateTVar = STM.stateTVar + swapTVar = STM.swapTVar + check = STM.check + newTMVar = STM.newTMVar + newEmptyTMVar = STM.newEmptyTMVar + takeTMVar = STM.takeTMVar + tryTakeTMVar = STM.tryTakeTMVar + putTMVar = STM.putTMVar + tryPutTMVar = STM.tryPutTMVar + readTMVar = STM.readTMVar + tryReadTMVar = STM.tryReadTMVar + swapTMVar = STM.swapTMVar + isEmptyTMVar = STM.isEmptyTMVar + newTQueue = STM.newTQueue + readTQueue = STM.readTQueue + tryReadTQueue = STM.tryReadTQueue + peekTQueue = STM.peekTQueue + tryPeekTQueue = STM.tryPeekTQueue + flushTQueue = STM.flushTQueue + writeTQueue = STM.writeTQueue + isEmptyTQueue = STM.isEmptyTQueue + unGetTQueue = STM.unGetTQueue + newTBQueue = STM.newTBQueue + readTBQueue = STM.readTBQueue + tryReadTBQueue = STM.tryReadTBQueue + peekTBQueue = STM.peekTBQueue + tryPeekTBQueue = STM.tryPeekTBQueue + writeTBQueue = STM.writeTBQueue + flushTBQueue = STM.flushTBQueue + lengthTBQueue = STM.lengthTBQueue + isEmptyTBQueue = STM.isEmptyTBQueue + isFullTBQueue = STM.isFullTBQueue + unGetTBQueue = STM.unGetTBQueue + newTSem = STM.newTSem + waitTSem = STM.waitTSem + signalTSem = STM.signalTSem + signalTSemN = STM.signalTSemN + + newTChan = STM.newTChan + newBroadcastTChan = STM.newBroadcastTChan + dupTChan = STM.dupTChan + cloneTChan = STM.cloneTChan + readTChan = STM.readTChan + tryReadTChan = STM.tryReadTChan + peekTChan = STM.peekTChan + tryPeekTChan = STM.tryPeekTChan + writeTChan = STM.writeTChan + unGetTChan = STM.unGetTChan + isEmptyTChan = STM.isEmptyTChan + + newTVarIO = STM.newTVarIO + readTVarIO = STM.readTVarIO + newTMVarIO = STM.newTMVarIO + newEmptyTMVarIO = STM.newEmptyTMVarIO + newTQueueIO = STM.newTQueueIO + newTBQueueIO = STM.newTBQueueIO + newTChanIO = STM.newTChanIO + newBroadcastTChanIO = STM.newBroadcastTChanIO + +-- | noop instance +-- +instance MonadLabelledSTM IO where + labelTVar = \_ _ -> return () + labelTMVar = \_ _ -> return () + labelTQueue = \_ _ -> return () + labelTBQueue = \_ _ -> return () + labelTArray = \_ _ -> return () + labelTSem = \_ _ -> return () + labelTChan = \_ _ -> return () + + labelTVarIO = \_ _ -> return () + labelTMVarIO = \_ _ -> return () + labelTQueueIO = \_ _ -> return () + labelTBQueueIO = \_ _ -> return () + labelTArrayIO = \_ _ -> return () + labelTSemIO = \_ _ -> return () + labelTChanIO = \_ _ -> return () + +-- | noop instance +-- +instance MonadTraceSTM IO where + traceTVar = \_ _ _ -> return () + traceTMVar = \_ _ _ -> return () + traceTQueue = \_ _ _ -> return () + traceTBQueue = \_ _ _ -> return () + traceTSem = \_ _ _ -> return () + + traceTVarIO = \_ _ -> return () + traceTMVarIO = \_ _ -> return () + traceTQueueIO = \_ _ -> return () + traceTBQueueIO = \_ _ -> return () + traceTSemIO = \_ _ -> return () + +-- | Wrapper around 'BlockedIndefinitelyOnSTM' that stores a call stack +data BlockedIndefinitely = BlockedIndefinitely { + blockedIndefinitelyCallStack :: CallStack + , blockedIndefinitelyException :: BlockedIndefinitelyOnSTM + } + deriving Show + +instance Exception BlockedIndefinitely where + displayException (BlockedIndefinitely cs e) = unlines [ + displayException e + , prettyCallStack cs + ] + +wrapBlockedIndefinitely :: HasCallStack => IO a -> IO a +wrapBlockedIndefinitely = handle (throwIO . BlockedIndefinitely callStack) + +-- +-- Default TMVar implementation in terms of TVars +-- + +newtype TMVarDefault m a = TMVar (TVar m (Maybe a)) + +labelTMVarDefault + :: MonadLabelledSTM m + => TMVarDefault m a -> String -> STM m () +labelTMVarDefault (TMVar tvar) = labelTVar tvar + +traceTMVarDefault + :: MonadTraceSTM m + => proxy m + -> TMVarDefault m a + -> (Maybe (Maybe a) -> Maybe a -> InspectMonad m TraceValue) + -> STM m () +traceTMVarDefault p (TMVar t) f = traceTVar p t f + +newTMVarDefault :: MonadSTM m => a -> STM m (TMVarDefault m a) +newTMVarDefault a = do + t <- newTVar (Just a) + return (TMVar t) + +newEmptyTMVarDefault :: MonadSTM m => STM m (TMVarDefault m a) +newEmptyTMVarDefault = do + t <- newTVar Nothing + return (TMVar t) + +takeTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m a +takeTMVarDefault (TMVar t) = do + m <- readTVar t + case m of + Nothing -> retry + Just a -> do writeTVar t Nothing; return a + +tryTakeTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m (Maybe a) +tryTakeTMVarDefault (TMVar t) = do + m <- readTVar t + case m of + Nothing -> return Nothing + Just a -> do writeTVar t Nothing; return (Just a) + +putTMVarDefault :: MonadSTM m => TMVarDefault m a -> a -> STM m () +putTMVarDefault (TMVar t) a = do + m <- readTVar t + case m of + Nothing -> do writeTVar t (Just a); return () + Just _ -> retry + +tryPutTMVarDefault :: MonadSTM m => TMVarDefault m a -> a -> STM m Bool +tryPutTMVarDefault (TMVar t) a = do + m <- readTVar t + case m of + Nothing -> do writeTVar t (Just a); return True + Just _ -> return False + +readTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m a +readTMVarDefault (TMVar t) = do + m <- readTVar t + case m of + Nothing -> retry + Just a -> return a + +tryReadTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m (Maybe a) +tryReadTMVarDefault (TMVar t) = readTVar t + +swapTMVarDefault :: MonadSTM m => TMVarDefault m a -> a -> STM m a +swapTMVarDefault (TMVar t) new = do + m <- readTVar t + case m of + Nothing -> retry + Just old -> do writeTVar t (Just new); return old + +isEmptyTMVarDefault :: MonadSTM m => TMVarDefault m a -> STM m Bool +isEmptyTMVarDefault (TMVar t) = do + m <- readTVar t + case m of + Nothing -> return True + Just _ -> return False + +-- +-- Default TQueue implementation in terms of TVars (used by sim) +-- + +data TQueueDefault m a = TQueue !(TVar m [a]) + !(TVar m [a]) + +labelTQueueDefault + :: MonadLabelledSTM m + => TQueueDefault m a -> String -> STM m () +labelTQueueDefault (TQueue read write) label = do + labelTVar read (label ++ "-read") + labelTVar write (label ++ "-write") + +newTQueueDefault :: MonadSTM m => STM m (TQueueDefault m a) +newTQueueDefault = do + read <- newTVar [] + write <- newTVar [] + return (TQueue read write) + +writeTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m () +writeTQueueDefault (TQueue _read write) a = do + listend <- readTVar write + writeTVar write (a:listend) + +readTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m a +readTQueueDefault queue = maybe retry return =<< tryReadTQueueDefault queue + +tryReadTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m (Maybe a) +tryReadTQueueDefault (TQueue read write) = do + xs <- readTVar read + case xs of + (x:xs') -> do + writeTVar read xs' + return (Just x) + [] -> do + ys <- readTVar write + case reverse ys of + [] -> return Nothing + (z:zs) -> do + writeTVar write [] + writeTVar read zs + return (Just z) + +isEmptyTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m Bool +isEmptyTQueueDefault (TQueue read write) = do + xs <- readTVar read + case xs of + (_:_) -> return False + [] -> do ys <- readTVar write + case ys of + [] -> return True + _ -> return False + +peekTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m a +peekTQueueDefault (TQueue read _write) = do + xs <- readTVar read + case xs of + (x:_) -> return x + _ -> retry + +tryPeekTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m (Maybe a) +tryPeekTQueueDefault (TQueue read _write) = do + xs <- readTVar read + case xs of + (x:_) -> return (Just x) + _ -> return Nothing + + +flushTQueueDefault :: MonadSTM m => TQueueDefault m a -> STM m [a] +flushTQueueDefault (TQueue read write) = do + xs <- readTVar read + ys <- readTVar write + unless (null xs) $ writeTVar read [] + unless (null ys) $ writeTVar write [] + return (xs ++ reverse ys) + +unGetTQueueDefault :: MonadSTM m => TQueueDefault m a -> a -> STM m () +unGetTQueueDefault (TQueue read _write) a = modifyTVar read (a:) + + + +-- +-- Default TBQueue implementation in terms of TVars +-- + +data TBQueueDefault m a = TBQueue + !(TVar m Natural) -- read capacity + !(TVar m [a]) -- elements waiting for read + !(TVar m Natural) -- write capacity + !(TVar m [a]) -- written elements + !Natural + +labelTBQueueDefault + :: MonadLabelledSTM m + => TBQueueDefault m a -> String -> STM m () +labelTBQueueDefault (TBQueue rsize read wsize write _size) label = do + labelTVar rsize (label ++ "-rsize") + labelTVar read (label ++ "-read") + labelTVar wsize (label ++ "-wsize") + labelTVar write (label ++ "-write") + +newTBQueueDefault :: MonadSTM m => Natural -> STM m (TBQueueDefault m a) +newTBQueueDefault size = do + rsize <- newTVar 0 + read <- newTVar [] + wsize <- newTVar size + write <- newTVar [] + return (TBQueue rsize read wsize write size) + +readTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m a +readTBQueueDefault queue = maybe retry return =<< tryReadTBQueueDefault queue + +tryReadTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m (Maybe a) +tryReadTBQueueDefault (TBQueue rsize read _wsize write _size) = do + xs <- readTVar read + r <- readTVar rsize + writeTVar rsize $! r + 1 + case xs of + (x:xs') -> do + writeTVar read xs' + return (Just x) + [] -> do + ys <- readTVar write + case reverse ys of + [] -> return Nothing + + -- NB. lazy: we want the transaction to be + -- short, otherwise it will conflict + (z:zs) -> do + writeTVar write [] + writeTVar read zs + return (Just z) + +peekTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m a +peekTBQueueDefault (TBQueue _rsize read _wsize _write _size) = do + xs <- readTVar read + case xs of + (x:_) -> return x + _ -> retry + +tryPeekTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m (Maybe a) +tryPeekTBQueueDefault (TBQueue _rsize read _wsize _write _size) = do + xs <- readTVar read + case xs of + (x:_) -> return (Just x) + _ -> return Nothing + +writeTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> a -> STM m () +writeTBQueueDefault (TBQueue rsize _read wsize write _size) a = do + w <- readTVar wsize + if (w > 0) + then do writeTVar wsize $! w - 1 + else do + r <- readTVar rsize + if (r > 0) + then do writeTVar rsize 0 + writeTVar wsize $! r - 1 + else retry + listend <- readTVar write + writeTVar write (a:listend) + +isEmptyTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Bool +isEmptyTBQueueDefault (TBQueue _rsize read _wsize write _size) = do + xs <- readTVar read + case xs of + (_:_) -> return False + [] -> do ys <- readTVar write + case ys of + [] -> return True + _ -> return False + +isFullTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Bool +isFullTBQueueDefault (TBQueue rsize _read wsize _write _size) = do + w <- readTVar wsize + if (w > 0) + then return False + else do + r <- readTVar rsize + if (r > 0) + then return False + else return True + +lengthTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m Natural +lengthTBQueueDefault (TBQueue rsize _read wsize _write size) = do + r <- readTVar rsize + w <- readTVar wsize + return $! size - r - w + + +flushTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> STM m [a] +flushTBQueueDefault (TBQueue rsize read wsize write size) = do + xs <- readTVar read + ys <- readTVar write + if null xs && null ys + then return [] + else do + writeTVar read [] + writeTVar write [] + writeTVar rsize 0 + writeTVar wsize size + return (xs ++ reverse ys) + +unGetTBQueueDefault :: MonadSTM m => TBQueueDefault m a -> a -> STM m () +unGetTBQueueDefault (TBQueue rsize read wsize _write _size) a = do + r <- readTVar rsize + if (r > 0) + then do writeTVar rsize $! r - 1 + else do + w <- readTVar wsize + if (w > 0) + then writeTVar wsize $! w - 1 + else retry + xs <- readTVar read + writeTVar read (a:xs) + + +-- +-- Default `TArray` implementation +-- + +-- | Default implementation of 'TArray'. +-- +data TArrayDefault m i e = TArray (Array i (TVar m e)) + deriving Typeable + +deriving instance (Eq (TVar m e), Ix i) => Eq (TArrayDefault m i e) + +instance (Monad stm, MonadSTM m, stm ~ STM m) + => MArray (TArrayDefault m) e stm where + getBounds (TArray a) = return (bounds a) + newArray b e = do + a <- rep (rangeSize b) (newTVar e) + return $ TArray (listArray b a) + newArray_ b = do + a <- rep (rangeSize b) (newTVar arrEleBottom) + return $ TArray (listArray b a) + unsafeRead (TArray a) i = readTVar $ unsafeAt a i + unsafeWrite (TArray a) i e = writeTVar (unsafeAt a i) e + getNumElements (TArray a) = return (numElements a) + +rep :: Monad m => Int -> m a -> m [a] +rep n m = go n [] + where + go 0 xs = return xs + go i xs = do + x <- m + go (i-1) (x:xs) + +labelTArrayDefault :: ( MonadLabelledSTM m + , Ix i + , Show i + ) + => TArrayDefault m i e -> String -> STM m () +labelTArrayDefault (TArray arr) name = do + let as = Array.assocs arr + traverse_ (\(i, v) -> labelTVar v (name ++ ":" ++ show i)) as + + +-- +-- Default `TSem` implementation +-- + +newtype TSemDefault m = TSem (TVar m Integer) + +labelTSemDefault :: MonadLabelledSTM m => TSemDefault m -> String -> STM m () +labelTSemDefault (TSem t) = labelTVar t + +traceTSemDefault :: MonadTraceSTM m + => proxy m + -> TSemDefault m + -> (Maybe Integer -> Integer -> InspectMonad m TraceValue) + -> STM m () +traceTSemDefault proxy (TSem t) k = traceTVar proxy t k + +newTSemDefault :: MonadSTM m => Integer -> STM m (TSemDefault m) +newTSemDefault i = TSem <$> (newTVar $! i) + +waitTSemDefault :: MonadSTM m => TSemDefault m -> STM m () +waitTSemDefault (TSem t) = do + i <- readTVar t + when (i <= 0) retry + writeTVar t $! (i-1) + +signalTSemDefault :: MonadSTM m => TSemDefault m -> STM m () +signalTSemDefault (TSem t) = do + i <- readTVar t + writeTVar t $! i+1 + +signalTSemNDefault :: MonadSTM m => Natural -> TSemDefault m -> STM m () +signalTSemNDefault 0 _ = return () +signalTSemNDefault 1 s = signalTSemDefault s +signalTSemNDefault n (TSem t) = do + i <- readTVar t + writeTVar t $! i+(toInteger n) + +-- +-- Default `TChan` implementation +-- + +type TVarList m a = TVar m (TList m a) +data TList m a = TNil | TCons a (TVarList m a) + +data TChanDefault m a = TChan (TVar m (TVarList m a)) (TVar m (TVarList m a)) + +labelTChanDefault :: MonadLabelledSTM m => TChanDefault m a -> String -> STM m () +labelTChanDefault (TChan read write) name = do + labelTVar read (name ++ ":read") + labelTVar write (name ++ ":write") + +newTChanDefault :: MonadSTM m => STM m (TChanDefault m a) +newTChanDefault = do + hole <- newTVar TNil + read <- newTVar hole + write <- newTVar hole + return (TChan read write) + +newBroadcastTChanDefault :: MonadSTM m => STM m (TChanDefault m a) +newBroadcastTChanDefault = do + write_hole <- newTVar TNil + read <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first") + write <- newTVar write_hole + return (TChan read write) + +writeTChanDefault :: MonadSTM m => TChanDefault m a -> a -> STM m () +writeTChanDefault (TChan _read write) a = do + listend <- readTVar write -- listend == TVar pointing to TNil + new_listend <- newTVar TNil + writeTVar listend (TCons a new_listend) + writeTVar write new_listend + +readTChanDefault :: MonadSTM m => TChanDefault m a -> STM m a +readTChanDefault (TChan read _write) = do + listhead <- readTVar read + head_ <- readTVar listhead + case head_ of + TNil -> retry + TCons a tail_ -> do + writeTVar read tail_ + return a + +tryReadTChanDefault :: MonadSTM m => TChanDefault m a -> STM m (Maybe a) +tryReadTChanDefault (TChan read _write) = do + listhead <- readTVar read + head_ <- readTVar listhead + case head_ of + TNil -> return Nothing + TCons a tl -> do + writeTVar read tl + return (Just a) + +peekTChanDefault :: MonadSTM m => TChanDefault m a -> STM m a +peekTChanDefault (TChan read _write) = do + listhead <- readTVar read + head_ <- readTVar listhead + case head_ of + TNil -> retry + TCons a _ -> return a + +tryPeekTChanDefault :: MonadSTM m => TChanDefault m a -> STM m (Maybe a) +tryPeekTChanDefault (TChan read _write) = do + listhead <- readTVar read + head_ <- readTVar listhead + case head_ of + TNil -> return Nothing + TCons a _ -> return (Just a) + +dupTChanDefault :: MonadSTM m => TChanDefault m a -> STM m (TChanDefault m a) +dupTChanDefault (TChan _read write) = do + hole <- readTVar write + new_read <- newTVar hole + return (TChan new_read write) + +unGetTChanDefault :: MonadSTM m => TChanDefault m a -> a -> STM m () +unGetTChanDefault (TChan read _write) a = do + listhead <- readTVar read + newhead <- newTVar (TCons a listhead) + writeTVar read newhead + +isEmptyTChanDefault :: MonadSTM m => TChanDefault m a -> STM m Bool +isEmptyTChanDefault (TChan read _write) = do + listhead <- readTVar read + head_ <- readTVar listhead + case head_ of + TNil -> return True + TCons _ _ -> return False + +cloneTChanDefault :: MonadSTM m => TChanDefault m a -> STM m (TChanDefault m a) +cloneTChanDefault (TChan read write) = do + readpos <- readTVar read + new_read <- newTVar readpos + return (TChan new_read write) + + +-- | 'throwIO' specialised to @stm@ monad. +-- +throwSTM :: (MonadSTM m, MonadThrow.MonadThrow (STM m), Exception e) + => e -> STM m a +throwSTM = MonadThrow.throwIO + + +-- | 'catch' specialized for an @stm@ monad. +-- +catchSTM :: (MonadSTM m, MonadThrow.MonadCatch (STM m), Exception e) + => STM m a -> (e -> STM m a) -> STM m a +catchSTM = MonadThrow.catch + +-- +-- ReaderT instance +-- + + +-- | The underlying stm monad is also transformed. +-- +instance MonadSTM m => MonadSTM (ReaderT r m) where + type STM (ReaderT r m) = ReaderT r (STM m) + atomically (ReaderT stm) = ReaderT $ \r -> atomically (stm r) + + type TVar (ReaderT r m) = TVar m + newTVar = lift . newTVar + readTVar = lift . readTVar + writeTVar = lift .: writeTVar + retry = lift retry + orElse (ReaderT a) (ReaderT b) = ReaderT $ \r -> a r `orElse` b r + + modifyTVar = lift .: modifyTVar + modifyTVar' = lift .: modifyTVar' + stateTVar = lift .: stateTVar + swapTVar = lift .: swapTVar + check = lift . check + + type TMVar (ReaderT r m) = TMVar m + newTMVar = lift . newTMVar + newEmptyTMVar = lift newEmptyTMVar + takeTMVar = lift . takeTMVar + tryTakeTMVar = lift . tryTakeTMVar + putTMVar = lift .: putTMVar + tryPutTMVar = lift .: tryPutTMVar + readTMVar = lift . readTMVar + tryReadTMVar = lift . tryReadTMVar + swapTMVar = lift .: swapTMVar + isEmptyTMVar = lift . isEmptyTMVar + + type TQueue (ReaderT r m) = TQueue m + newTQueue = lift newTQueue + readTQueue = lift . readTQueue + tryReadTQueue = lift . tryReadTQueue + peekTQueue = lift . peekTQueue + tryPeekTQueue = lift . tryPeekTQueue + flushTQueue = lift . flushTQueue + writeTQueue v = lift . writeTQueue v + isEmptyTQueue = lift . isEmptyTQueue + unGetTQueue = lift .: unGetTQueue + + type TBQueue (ReaderT r m) = TBQueue m + newTBQueue = lift . newTBQueue + readTBQueue = lift . readTBQueue + tryReadTBQueue = lift . tryReadTBQueue + peekTBQueue = lift . peekTBQueue + tryPeekTBQueue = lift . tryPeekTBQueue + flushTBQueue = lift . flushTBQueue + writeTBQueue = lift .: writeTBQueue + lengthTBQueue = lift . lengthTBQueue + isEmptyTBQueue = lift . isEmptyTBQueue + isFullTBQueue = lift . isFullTBQueue + unGetTBQueue = lift .: unGetTBQueue + + type TArray (ReaderT r m) = TArray m + + type TSem (ReaderT r m) = TSem m + newTSem = lift . newTSem + waitTSem = lift . waitTSem + signalTSem = lift . signalTSem + signalTSemN = lift .: signalTSemN + + type TChan (ReaderT r m) = TChan m + newTChan = lift newTChan + newBroadcastTChan = lift newBroadcastTChan + dupTChan = lift . dupTChan + cloneTChan = lift . cloneTChan + readTChan = lift . readTChan + tryReadTChan = lift . tryReadTChan + peekTChan = lift . peekTChan + tryPeekTChan = lift . tryPeekTChan + writeTChan = lift .: writeTChan + unGetTChan = lift .: unGetTChan + isEmptyTChan = lift . isEmptyTChan + + +(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) +(f .: g) x y = f (g x y) diff --git a/src/Control/Monad/Class/MonadSay.hs b/src/Control/Monad/Class/MonadSay.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadSay.hs @@ -0,0 +1,13 @@ +module Control.Monad.Class.MonadSay where + +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as BSC + +class Monad m => MonadSay m where + say :: String -> m () + +instance MonadSay IO where + say = BSC.putStrLn . BSC.pack + +instance MonadSay m => MonadSay (ReaderT r m) where + say = lift . say diff --git a/src/Control/Monad/Class/MonadTest.hs b/src/Control/Monad/Class/MonadTest.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadTest.hs @@ -0,0 +1,17 @@ +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 () + +instance MonadTest IO + +instance MonadTest m => MonadTest (ReaderT e m) where + exploreRaces = lift exploreRaces + diff --git a/src/Control/Monad/Class/MonadThrow.hs b/src/Control/Monad/Class/MonadThrow.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadThrow.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} + +module Control.Monad.Class.MonadThrow + ( MonadThrow (..) + , MonadCatch (..) + , MonadMask (..) + , MonadMaskingState (..) + , MonadEvaluate (..) + , MaskingState (..) + , Exception (..) + , SomeException + , ExitCase (..) + , Handler (..) + , catches + ) where + +import Control.Exception (Exception (..), MaskingState, SomeException) +import qualified Control.Exception as IO +import Control.Monad (liftM) + +import Control.Monad.Reader (ReaderT (..), lift) + +import Control.Monad.STM (STM) +import qualified Control.Monad.STM as STM + +-- | Throwing exceptions, and resource handling in the presence of exceptions. +-- +-- Does not include the ability to respond to exceptions. +-- +class Monad m => MonadThrow m where + + {-# MINIMAL throwIO #-} + throwIO :: Exception e => e -> m a + + bracket :: m a -> (a -> m b) -> (a -> m c) -> m c + bracket_ :: m a -> m b -> m c -> m c + finally :: m a -> m b -> m a + + default bracket :: MonadCatch m => m a -> (a -> m b) -> (a -> m c) -> m c + + bracket before after = + liftM fst . + generalBracket + before + (\a _exitCase -> after a) + + bracket_ before after thing = bracket before (const after) (const thing) + + a `finally` sequel = + bracket_ (return ()) sequel a + +-- | Catching exceptions. +-- +-- Covers standard utilities to respond to exceptions. +-- +class MonadThrow m => MonadCatch m where + + {-# MINIMAL catch #-} + + catch :: Exception e => m a -> (e -> m a) -> m a + catchJust :: Exception e => (e -> Maybe b) -> m a -> (b -> m a) -> m a + + try :: Exception e => m a -> m (Either e a) + tryJust :: Exception e => (e -> Maybe b) -> m a -> m (Either b a) + + handle :: Exception e => (e -> m a) -> m a -> m a + handleJust :: Exception e => (e -> Maybe b) -> (b -> m a) -> m a -> m a + + onException :: m a -> m b -> m a + bracketOnError :: m a -> (a -> m b) -> (a -> m c) -> m c + + -- | General form of bracket + -- + -- See + -- for discussion and motivation. + generalBracket :: m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c) + + default generalBracket + :: MonadMask m + => m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c) + + catchJust p a handler = + catch a handler' + where + handler' e = case p e of + Nothing -> throwIO e + Just b -> handler b + + try a = catch (Right `fmap` a) (return . Left) + + tryJust p a = do + r <- try a + case r of + Right v -> return (Right v) + Left e -> case p e of + Nothing -> throwIO e + Just b -> return (Left b) + + handle = flip catch + handleJust p = flip (catchJust p) + + onException action what = + action `catch` \e -> do + _ <- what + throwIO (e :: SomeException) + + bracketOnError acquire release = liftM fst . generalBracket + acquire + (\a exitCase -> case exitCase of + ExitCaseSuccess _ -> return () + _ -> do + _ <- release a + return ()) + + generalBracket acquire release use = + mask $ \unmasked -> do + resource <- acquire + b <- unmasked (use resource) `catch` \e -> do + _ <- release resource (ExitCaseException e) + throwIO e + c <- release resource (ExitCaseSuccess b) + return (b, c) + + +-- | The default handler type for 'catches', whcih is a generalisation of +-- 'IO.Handler'. +-- +data Handler m a = forall e. Exception e => Handler (e -> m a) + +deriving instance (Functor m) => Functor (Handler m) + +-- | Like 'catches' but for 'MonadCatch' rather than only 'IO'. +-- +catches :: forall m a. MonadCatch m + => m a -> [Handler m a] -> m a +catches ma handlers = ma `catch` catchesHandler handlers +{-# SPECIALISE catches :: IO a -> [Handler IO a] -> IO a #-} + +-- | Used in the default 'catches' implementation. +-- +catchesHandler :: MonadCatch m + => [Handler m a] + -> SomeException + -> m a +catchesHandler handlers e = foldr tryHandler (throwIO e) handlers + where tryHandler (Handler handler) res + = case fromException e of + Just e' -> handler e' + Nothing -> res +{-# SPECIALISE catchesHandler :: [Handler IO a] -> SomeException -> IO a #-} + + +-- | Used in 'generalBracket' +-- +-- See @exceptions@ package for discussion and motivation. +data ExitCase a + = ExitCaseSuccess a + | ExitCaseException SomeException + | ExitCaseAbort + deriving (Show, Functor) + +-- | Support for safely working in the presence of asynchronous exceptions. +-- +-- This is typically not needed directly as the utilities in 'MonadThrow' and +-- 'MonadCatch' cover most use cases. +-- +class MonadCatch m => MonadMask m where + + {-# MINIMAL mask, uninterruptibleMask #-} + mask, uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b + + mask_, uninterruptibleMask_ :: m a -> m a + mask_ action = mask $ \_ -> action + uninterruptibleMask_ action = uninterruptibleMask $ \_ -> action + + +class MonadMask m => MonadMaskingState m where + {-# MINIMAL getMaskingState, interruptible #-} + getMaskingState :: m MaskingState + interruptible :: m a -> m a + allowInterrupt :: m () + + allowInterrupt = interruptible (return ()) + + + +-- | Monads which can 'evaluate'. +-- +class MonadThrow m => MonadEvaluate m where + evaluate :: a -> m a + +-- +-- Instance for IO uses the existing base library implementations +-- + +instance MonadThrow IO where + + throwIO = IO.throwIO + + bracket = IO.bracket + bracket_ = IO.bracket_ + finally = IO.finally + + +instance MonadCatch IO where + + catch = IO.catch + + catchJust = IO.catchJust + try = IO.try + tryJust = IO.tryJust + handle = IO.handle + handleJust = IO.handleJust + onException = IO.onException + bracketOnError = IO.bracketOnError + -- use default implementation of 'generalBracket' (base does not define one) + + +instance MonadMask IO where + + mask = IO.mask + mask_ = IO.mask_ + + uninterruptibleMask = IO.uninterruptibleMask + uninterruptibleMask_ = IO.uninterruptibleMask_ + +instance MonadMaskingState IO where + getMaskingState = IO.getMaskingState + interruptible = IO.interruptible + allowInterrupt = IO.allowInterrupt + +instance MonadEvaluate IO where + evaluate = IO.evaluate + +-- +-- Instance for STM uses STM primitives and default implementations +-- + +instance MonadThrow STM where + throwIO = STM.throwSTM + +instance MonadCatch STM where + catch = STM.catchSTM + + generalBracket acquire release use = do + resource <- acquire + b <- use resource `catch` \e -> do + _ <- release resource (ExitCaseException e) + throwIO e + c <- release resource (ExitCaseSuccess b) + return (b, c) + + +-- +-- ReaderT instances +-- + +instance MonadThrow m => MonadThrow (ReaderT r m) where + throwIO = lift . throwIO + bracket acquire release use = ReaderT $ \env -> + bracket + ( runReaderT acquire env) + (\a -> runReaderT (release a) env) + (\a -> runReaderT (use a) env) + +instance MonadCatch m => MonadCatch (ReaderT r m) where + catch act handler = ReaderT $ \env -> + catch + ( runReaderT act env) + (\e -> runReaderT (handler e) env) + + generalBracket acquire release use = ReaderT $ \env -> + generalBracket + ( runReaderT acquire env) + (\a e -> runReaderT (release a e) env) + (\a -> runReaderT (use a) env) + +instance MonadMask m => MonadMask (ReaderT r m) where + mask a = ReaderT $ \e -> mask $ \u -> runReaderT (a $ q u) e + where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a + q u (ReaderT b) = ReaderT (u . b) + uninterruptibleMask a = + ReaderT $ \e -> uninterruptibleMask $ \u -> runReaderT (a $ q u) e + where q :: (m a -> m a) -> ReaderT e m a -> ReaderT e m a + q u (ReaderT b) = ReaderT (u . b) + +instance MonadEvaluate m => MonadEvaluate (ReaderT r m) where + evaluate = lift . evaluate diff --git a/src/Control/Monad/Class/MonadTime.hs b/src/Control/Monad/Class/MonadTime.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadTime.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Control.Monad.Class.MonadTime + ( MonadTime (..) + , MonadMonotonicTimeNSec (..) + -- * 'NominalTime' and its action on 'UTCTime' + , UTCTime + , diffUTCTime + , addUTCTime + , NominalDiffTime + ) where + +import Control.Monad.Reader + +import Data.Time.Clock (NominalDiffTime, UTCTime, + addUTCTime, diffUTCTime) +import qualified Data.Time.Clock as Time +import Data.Word (Word64) +import qualified GHC.Clock as IO (getMonotonicTimeNSec) + + +class Monad m => MonadMonotonicTimeNSec m where + -- | Time in a monotonic clock, with high precision. The epoch for this + -- clock is arbitrary and does not correspond to any wall clock or calendar. + -- + -- The time is measured in nano seconds as does `getMonotonicTimeNSec` from + -- "base". + -- + getMonotonicTimeNSec :: m Word64 + +class Monad m => MonadTime m where + -- | Wall clock time. + -- + getCurrentTime :: m UTCTime + +-- +-- Instances for IO +-- + +instance MonadMonotonicTimeNSec IO where + getMonotonicTimeNSec = IO.getMonotonicTimeNSec + +instance MonadTime IO where + getCurrentTime = Time.getCurrentTime + +-- +-- MTL instances +-- + +instance MonadMonotonicTimeNSec m => MonadMonotonicTimeNSec (ReaderT r m) where + getMonotonicTimeNSec = lift getMonotonicTimeNSec + +instance MonadTime m => MonadTime (ReaderT r m) where + getCurrentTime = lift getCurrentTime diff --git a/src/Control/Monad/Class/MonadTimer.hs b/src/Control/Monad/Class/MonadTimer.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Class/MonadTimer.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Control.Monad.Class.MonadTimer + ( MonadDelay (..) + , MonadTimer (..) + ) where + +import qualified Control.Concurrent as IO +import Control.Concurrent.Class.MonadSTM +import qualified Control.Concurrent.STM.TVar as STM + +import Control.Monad.Reader (ReaderT (..)) +import Control.Monad.Trans (lift) + +import qualified System.Timeout as IO + +class Monad m => MonadDelay m where + threadDelay :: Int -> m () + +class (MonadDelay m, MonadSTM m) => MonadTimer m where + + registerDelay :: Int -> m (TVar m Bool) + + timeout :: Int -> m a -> m (Maybe a) + +-- +-- Instances for IO +-- + +-- | With 'threadDelay' one can use arbitrary large 'DiffTime's, which is an +-- advantage over 'IO.threadDelay'. +-- +instance MonadDelay IO where + threadDelay = IO.threadDelay + + +instance MonadTimer IO where + + registerDelay = STM.registerDelay + timeout = IO.timeout + +-- +-- Transformer's instances +-- + +instance MonadDelay m => MonadDelay (ReaderT r m) where + threadDelay = lift . threadDelay + +instance MonadTimer m => MonadTimer (ReaderT r m) where + registerDelay = lift . registerDelay + timeout d f = ReaderT $ \r -> timeout d (runReaderT f r)