packages feed

io-classes (empty) → 1.0.0.0

raw patch · 25 files changed

+3305/−0 lines, 25 filesdep +arraydep +asyncdep +base

Dependencies added: array, async, base, bytestring, mtl, stm, time

Files

+ CHANGELOG.md view
@@ -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.
+ LICENSE view
@@ -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
+ NOTICE view
@@ -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.+
+ README.md view
@@ -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
+ io-classes.cabal view
@@ -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
+ src/Control/Concurrent/Class/MonadSTM.hs view
@@ -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+
+ src/Control/Concurrent/Class/MonadSTM/TArray.hs view
@@ -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
+ src/Control/Concurrent/Class/MonadSTM/TBQueue.hs view
@@ -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
+ src/Control/Concurrent/Class/MonadSTM/TChan.hs view
@@ -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
+ src/Control/Concurrent/Class/MonadSTM/TMVar.hs view
@@ -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
+ src/Control/Concurrent/Class/MonadSTM/TQueue.hs view
@@ -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
+ src/Control/Concurrent/Class/MonadSTM/TSem.hs view
@@ -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
+ src/Control/Concurrent/Class/MonadSTM/TVar.hs view
@@ -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
+ src/Control/Monad/Class/MonadAsync.hs view
@@ -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.+  -- <http://hackage.haskell.org/package/async-2.2.1/docs/src/Control.Concurrent.Async.html#waitEitherCatch>+  --+  -- 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)
+ src/Control/Monad/Class/MonadEventlog.hs view
@@ -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
+ src/Control/Monad/Class/MonadFork.hs view
@@ -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
+ src/Control/Monad/Class/MonadMVar.hs view
@@ -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)
+ src/Control/Monad/Class/MonadST.hs view
@@ -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)
+ src/Control/Monad/Class/MonadSTM.hs view
@@ -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.
+ src/Control/Monad/Class/MonadSTM/Internal.hs view
@@ -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)
+ src/Control/Monad/Class/MonadSay.hs view
@@ -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
+ src/Control/Monad/Class/MonadTest.hs view
@@ -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+
+ src/Control/Monad/Class/MonadThrow.hs view
@@ -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 <http://hackage.haskell.org/package/exceptions-0.10.0/docs/Control-Monad-Catch.html#v:generalBracket>+  -- 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
+ src/Control/Monad/Class/MonadTime.hs view
@@ -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
+ src/Control/Monad/Class/MonadTimer.hs view
@@ -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)