packages feed

io-classes 1.5.0.0 → 1.10.1.0

raw patch · 72 files changed

Files

CHANGELOG.md view
@@ -1,5 +1,78 @@ # Revsion history of io-classes +## next++### Breaking changes++### Non-breaking changes++## 1.10.1.0++### Non-breaking changes++* Support `ghc-9.14`++## 1.10.0.0++### Breaking changes++* Added `flushEventLog` to `MonadEventLog` class.+* Added `Monad` constraint to `MonadEventlog` class.++### Non-breaking changes++## 1.9.0.0++### Breaking changes++* Changed `Time` show instance, which now is designed for pasting+*  counterexamples from terminal to an editor.++### Non-breaking changes++* Improved performance of `tryReadTBQueueDefault`.+* Added module `Control.Monad.Class.MonadUnique` generalising `Data.Unique`.+* mtl: Added module `Control.Monad.Class.MonadUnique.Trans` providing monad transformer instances for `MonadUnique`.+* Added `roundDiffTimeToMicroseconds` utility function to `si-timers` package (in the `MonadTimer.SI` module).++## 1.8.0.1++* Added support for `ghc-9.2`.++### 1.8.0.0++### Breaking changes++* Provided `MonadTraceMVar`+* Renamed `InspectMonad` to `InspectMonadSTM`+* Added `threadLabel` to `MonadThread`+* Added `MonadLabelledMVar` class.+* Added `labelMVar` to `Control.Concurrent.Class.MonadMVar.Strict`+* Added `debugTraceTVar`, `debugTraceTMVar`, `debugTraceTVarIO`, `debugTraceTMVarIO` for `Show`-based tracing.+* `MonadEvaluate` is not a supper-class of `MonadThrow` anymore.+* Moved all `MonadMaskingState` methods to `MonadMask`. `MonadMaskingState` is+  available but deprecated, it will be removed in one of the future releases.+* `io-classes:mtl` instances support the extended `MonadMask` instance.++### Non-breaking changes++* Added monad transformer instances for `MonadInspectSTM` & `MonadTraceSTM`+  type classes.+* Support ghc-9.12++## 1.7.0.0++### Breaking changes++* Renamed `io-classes:io-classes-mtl` as `io-classes:mtl`.++## 1.6.0.0++### Breaking changes++* `strict-stm`, `strict-mvar` and `si-timers` are now public sublibraries of `io-classes` package.+* Moved `io-classes-mtl` to `io-classes` as a public sublibrary.+ ## 1.5.0.0  ### Breaking changes@@ -11,6 +84,19 @@ ### Non-breaking change  * Add `writeTMVar` to `MonadSTM`.++* `strict-stm`, `strict-mvar` and `si-timers` were moved to `io-classes` as+  **public sublibraries**.  You can import then in `*.cabal` files with the+  following syntax `io-classes:strict-stm` or `io-classes:{strict-stm,+  si-timers}`.  See the _Multiple public libraries_ subsection of [_Internal+  Libraries_][sublibs] section in the `cabal` documentation.++  Note: some time in the future we will deprecate `Hackage` packages+  `strict-stm`, `strict-mvar` and `si-timers`.  If one will want to use the+  namespace for a non `io-classes` related packages please contact the+  maintainer.++[sublibs]: https://cabal.readthedocs.io/en/stable/cabal-package.html#sublibs  ## 1.4.1.0
README.md view
@@ -1,4 +1,4 @@-# IO Monad Class Hierarchy+# IO Monad Class Hierarchy: `io-classes` package  This package provides a monad class hierarchy which is an interface for both the [`io-sim`] and [`IO`] monads.  It was developed with the following@@ -10,18 +10,35 @@   as timer API; * provide zero-cost abstractions. -We provide also non-standard extensions of this API:+We provide also non-standard extensions of this API in **sublibraries**: -* [`strict-stm`]: strict `TVar`'s, and other mutable `STM` variables, with+* [`io-classes:strict-stm`](https://input-output-hk.github.io/io-sim/io-classes/strict-stm/index.html) strict `TVar`'s, and other mutable `STM` variables, with   support of the [`nothunks`] library;-* [`si-timers`]: timers api:+* [`io-classes:strict-mvar`](https://input-output-hk.github.io/io-sim/io-classes/strict-mvar/index.html): strict `MVar`s+* [`io-classes:si-timers`](https://input-output-hk.github.io/io-sim/io-classes/si-timers/index.html): 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.+* [`io-classes:mtl`](https://input-output-hk.github.io/io-sim/io-classes/mtl/index.html):+  MTL instances. +[`io-classes:strict-stm`](https://input-output-hk.github.io/io-sim/io-classes/strict-stm/index.html)+and [`nothunks`] were successfully used in a large+code base to eliminate space leaks and keep that property over long development+cycles.++## Documentation++Hackage doesn't yet support public sublibraries, thus Haddocks are published+[here][io-classes-haddocks].++### Support material++* [Philipp Kant (@kantp) at Bobconf 2022][bob-conf]+* [Armando Santos (@bolt12) at ZuriHac 2022][zuriHac-2022]+ ## Exception Class Hierarchy  This package provides an alternative class hierarchy giving access to@@ -46,6 +63,8 @@ monotonic time as well as exposes 32-bit safe timer API (on 32-bit systems time in microseconds represented as an `Int` can only hold timeouts of ~35 minutes). +[`si-timers`] sublibrary provides cancellable timers API, see [`registerDelayCancellable`].+ `Control.Monad.Class.MonadTimer.NonStandard.MonadTimeout` provides a low-level timeout abstraction.  On systems that support a native timer manager, it's used to implement its API, which is very efficient even for low-latency timeouts.@@ -60,26 +79,38 @@  ## Software Transactional Memory API -We provide two interfaces to `stm` API: lazy, included in `io-classes`; and-strict one provided by [`strict-stm`].-+We provide two interfaces to `stm` API: lazy, included in [`io-classes`][lazy-stm]; and+strict one provided by [`io-classes:strict-stm`](https://input-output-hk.github.io/io-sim/io-classes/strict-stm/index.html).  ## Threads API  We draw a line between `base` API and `async` API.  The former is provided by-[MonadFork](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadFork.html#t:MonadFork)-the latter by-[MonadAsync](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadFork.html#t:MonadAsync).-Both are shallow abstractions around APIs exposed by the `base` and `async`-packages.+[MonadFork] the latter by+[MonadAsync] Both are shallow abstractions around APIs exposed by the `base`+and `async` packages. +## `MVar` API +We also provide lazy and strict `MVar`s:++* [lazy `MVar`][MonadMVar] API+* [strict `MVar`][strict-mvar] API is provided in the [io-classes:strict-mvar] sublibrary.++ ## Some other APIs -* [MonadEventlog]: provides an API to the [Debug.Trace] event log interface.-* [MonadST]: provides a way to lift `ST`-computations.-* [MonadSay]: dummy debugging interface+* [MonadEventlog][MonadEventlog]: provides an API to the [Debug.Trace] event log interface.+* [MonadST][MonadST]: provides a way to lift `ST`-computations.+* [MonadSay][MonadSay]: dummy debugging interface ++## Monad Transformers++We provide support for monad transformers, see [io-classes:mtl] sublibrary.+Although at this stage it might have its limitations and so there might be some+rough edges.  PRs are welcomed, [contributing].++ ## Differences from `base`, `async`, or `exceptions` packages  ### Major differences@@ -126,13 +157,6 @@ * `MonadInspectSTM` which allows inspecting values of `STM` mutable variables   when they are committed. ([`io-sim`], not provided by `GHC`). --## Monad Transformers--We provide support for monad transformers (although at this stage it might have-its limitations and so there might be some rough edges.  PRs are welcomed,-[contributing]).- [SI]: https://www.wikiwand.com/en/International_System_of_Units  [`DiffTime`]: https://hackage.haskell.org/package/time-1.10/docs/Data-Time-Clock.html#t:DiffTime [`IO`]: https://hackage.haskell.org/package/base-4.14.0.0/docs/GHC-IO.html#t:IO@@ -140,17 +164,27 @@ [`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+[io-classes:strict-mvar]: https://input-output-hk.github.io/io-sim/io-classes/strict-mvar/index.html+[io-classes:mtl]: https://input-output-hk.github.io/io-sim/io-classes/mtl/index.html [`stm`]: https://hackage.haskell.org/package/stm-[`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+[lazy-stm]: https://input-output-hk.github.io/io-sim/io-classes/Control-Concurrent-Class-MonadSTM.html+[`threadDelay`]: https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadTimer.html#v:threadDelay [`time`]: https://hackage.haskell.org/package/time [contributing]: https://www.github.com/input-output-hk/io-sim/tree/master/CONTRIBUTING.md [`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 [io-deadlock]: https://hackage.haskell.org/package/base-4.19.0.0/docs/Control-Exception.html#t:Deadlock -[MonadEventlog]: https://hackage.haskell.org/package/io-sim-classes/docs/Control-Monad-Class-MonadEventlog.html#t:MonadEventlog+[MonadEventlog]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadEventlog.html#t:MonadEventlog [Debug.Trace]: https://hackage.haskell.org/package/base/docs/Debug-Trace.html-[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+[MonadAsync]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadAsync.html#t:MonadAsync+[MonadFork]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadFork.html#t:MonadFork+[MonadMVar]: https://input-output-hk.github.io/io-sim/io-classes/Control-Concurrent-Class-MonadMVar.html#t:MonadMVar+[`registerDelayCancellable`]: http://input-output-hk.github.io/io-sim/io-classes/si-timers/Control-Monad-Class-MonadTimer-SI.html#v:registerDelayCancellable+[strict-mvar]: https://input-output-hk.github.io/io-sim/io-classes/strict-mvar/Control-Concurrent-Class-MonadMVar-Strict.html+[MonadST]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadST.html#t:MonadST+[MonadSay]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadSay.html#t:MonadSay+[io-classes-haddocks]: https://input-output-hk.github.io/io-sim++[bob-conf]: https://youtu.be/uedUGeWN4ZM+[zuriHac-2022]: https://youtu.be/tKIYQgJnGkA
io-classes.cabal view
@@ -1,25 +1,44 @@-cabal-version:       3.0+cabal-version:       3.4 name:                io-classes-version:             1.5.0.0+version:             1.10.1.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](https://hackage.haskell.org/package/base),-  [async](https://hackage.haskell.org/package/async),-  [stm](https://hackage.haskell.org/package/stm),-  [exceptions](https://hackage.haskell.org/package/exceptions) &-  [time](https://hackage.haskell.org/package/time) packages.+  IO Monad class hierarchy compatible with:++    * [io-sim](https://hackage.haskell.org/package/io-sim),+    * [base](https://hackage.haskell.org/package/base),+    * [async](https://hackage.haskell.org/package/async),+    * [stm](https://hackage.haskell.org/package/stm),+    * [exceptions](https://hackage.haskell.org/package/exceptions) &+    * [time](https://hackage.haskell.org/package/time)++  packages.++  = Sublibraries+  @io-classes@ provides non-standard extensions distributed in public+  sublibraries++    * @io-classes:io-classes@ - the main library compatible with the above+      packages+    * @io-classes:strict-stm@ - strict @STM@ API+    * @io-classes:strict-mvar@ - strict @MVar@ API+    * @io-classes:si-timers@ - SI-unit based time / timers API, cancellable timers+    * @io-classes:mtl@ - MTL instances, some of which are experiemental++  = Documentation+  Haddocks of all public sublibraries are published+  [here](https://input-output-hk.github.io/io-sim).+ license:             Apache-2.0 license-files:       LICENSE NOTICE-copyright:           2019-2024 Input Output Global Inc (IOG)-author:              Alexander Vieth, Duncan Coutts, Marcin Szamotulski, Thomas Winant+copyright:           2019-2025 Input Output Global Inc (IOG)+author:              Alexander Vieth, Duncan Coutts, Marcin Szamotulski, Neil Davies, Thomas Winant maintainer:          Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category:            Control build-type:          Simple-extra-doc-files:     CHANGELOG.md README.md+extra-doc-files:     CHANGELOG.md README.md strict-stm/README.md strict-mvar/README.md bug-reports:         https://github.com/input-output-hk/io-sim/issues-tested-with:         GHC == { 8.10, 9.2, 9.4, 9.6, 9.8, 9.10 }+tested-with:         GHC == { 9.6, 9.8, 9.10, 9.12, 9.14 }  source-repository head   type:     git@@ -44,7 +63,7 @@  library   import:              warnings-  hs-source-dirs:      src+  hs-source-dirs:      io-classes    -- At this experiment/prototype stage everything is exposed.   -- This has to be tidied up once the design becomes clear.@@ -68,41 +87,147 @@                        Control.Monad.Class.MonadTime                        Control.Monad.Class.MonadTimer                        Control.Monad.Class.MonadTest-  default-language:    Haskell2010-  default-extensions:  ImportQualifiedPost-  other-extensions:    CPP-                       DataKinds-                       DefaultSignatures-                       DeriveFunctor-                       DeriveGeneric-                       DerivingStrategies-                       ExistentialQuantification-                       ExplicitNamespaces-                       FlexibleContexts-                       FlexibleInstances-                       FunctionalDependencies-                       GADTs-                       GeneralisedNewtypeDeriving-                       MultiParamTypeClasses-                       NamedFieldPuns-                       QuantifiedConstraints-                       RankNTypes-                       ScopedTypeVariables-                       StandaloneDeriving-                       TypeFamilies-                       TypeFamilyDependencies-                       TypeOperators-                       UndecidableInstances-  build-depends:       base  >=4.9 && <4.21,+                       Control.Monad.Class.MonadUnique+  default-language:    GHC2021+  default-extensions:  LambdaCase+  build-depends:       base  >=4.16 && <4.23,                        array,-                       async >=2.1,+                       async >=2.1 && <2.3,                        bytestring,                        mtl   >=2.2 && <2.4,                        primitive >= 0.7 && <0.11,-                       stm   >=2.5 && <2.6,-                       time  >=1.9.1 && <1.13+                       stm   >=2.5 && <2.5.2 || ^>=2.5.3,+                       time  >=1.9.1 && <1.16   if impl(ghc >= 9.10)     build-depends:     ghc-internal    if flag(asserts)     ghc-options: -fno-ignore-asserts++library strict-stm+  import:              warnings+  visibility:          public+  hs-source-dirs:      strict-stm++  exposed-modules:     Control.Concurrent.Class.MonadSTM.Strict+                       Control.Concurrent.Class.MonadSTM.Strict.TArray+                       Control.Concurrent.Class.MonadSTM.Strict.TBQueue+                       Control.Concurrent.Class.MonadSTM.Strict.TChan+                       Control.Concurrent.Class.MonadSTM.Strict.TMVar+                       Control.Concurrent.Class.MonadSTM.Strict.TQueue+                       Control.Concurrent.Class.MonadSTM.Strict.TVar+  reexported-modules:  Control.Concurrent.Class.MonadSTM.TSem as Control.Concurrent.Class.MonadSTM.Strict.TSem+  default-language:    GHC2021+  default-extensions:  LambdaCase+  if impl(ghc < 9.4)+    default-extensions: GADTs+  build-depends:       base,+                       array,++                       io-classes:io-classes,++  if flag(asserts)+    ghc-options: -fno-ignore-asserts++library strict-mvar+  import:              warnings+  visibility:          public+  hs-source-dirs:      strict-mvar/src++  exposed-modules:     Control.Concurrent.Class.MonadMVar.Strict+  default-language:    GHC2021+  default-extensions:  LambdaCase+  if impl(ghc < 9.4)+    default-extensions: GADTs+  build-depends:       base,+                       io-classes:io-classes,++library si-timers+  import:              warnings+  visibility:          public+  hs-source-dirs:      si-timers/src+  exposed-modules:     Control.Monad.Class.MonadTime.SI+                       Control.Monad.Class.MonadTimer.SI+  other-modules:       Control.Monad.Class.MonadTimer.NonStandard+  default-language:    GHC2021+  default-extensions:  LambdaCase+  build-depends:       base,+                       deepseq,+                       mtl,+                       nothunks,+                       stm,+                       time,++                       io-classes:io-classes+  if flag(asserts)+     ghc-options:      -fno-ignore-asserts++library mtl+    import:           warnings+    visibility:       public+    exposed-modules:  Control.Monad.Class.Trans+                   ,  Control.Monad.Class.MonadEventlog.Trans+                   ,  Control.Monad.Class.MonadSay.Trans+                   ,  Control.Monad.Class.MonadST.Trans+                   ,  Control.Monad.Class.MonadSTM.Trans+                   ,  Control.Monad.Class.MonadThrow.Trans+                   ,  Control.Monad.Class.MonadTime.Trans+                   ,  Control.Monad.Class.MonadTime.SI.Trans+                   ,  Control.Monad.Class.MonadTimer.Trans+                   ,  Control.Monad.Class.MonadTimer.SI.Trans+                   ,  Control.Monad.Class.MonadUnique.Trans+    build-depends:    base,+                      array,+                      mtl,++                      io-classes:{io-classes,si-timers}++    hs-source-dirs:   mtl+    default-language: GHC2021+    default-extensions: LambdaCase++library testlib+  import:              warnings+  visibility:          public+  hs-source-dirs:      test+  exposed-modules:     Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF+  default-language:    GHC2021+  default-extensions:  LambdaCase+  build-depends:       base,+                       nothunks,+                       QuickCheck,+                       io-classes:strict-mvar+  if flag(asserts)+     ghc-options:      -fno-ignore-asserts++test-suite test-strict-mvar+  import:              warnings+  type:                exitcode-stdio-1.0+  hs-source-dirs:      strict-mvar/test+  main-is:             Main.hs+  default-language:    GHC2021+  default-extensions:  LambdaCase+  build-depends:       base,+                       QuickCheck,+                       tasty,+                       tasty-quickcheck,+                       io-classes:testlib++-- Since `io-sim` depends on `si-times` (`io-sim` depends on `Time`) some tests of+-- are in `io-sim:test`: this is a good enough reason to pull `io-sim:test`+-- into a seprate package.+test-suite test-si-timers+  import:              warnings+  type:                exitcode-stdio-1.0+  hs-source-dirs:      si-timers/test+  main-is:             Main.hs+  other-modules:       Test.MonadTimer+  default-language:    GHC2021+  default-extensions:  LambdaCase+  build-depends:       base,++                       QuickCheck,+                       tasty,+                       tasty-quickcheck,++                       io-classes:si-timers
+ io-classes/Control/Concurrent/Class/MonadMVar.hs view
@@ -0,0 +1,234 @@+{-# LANGUAGE DefaultSignatures      #-}+{-# LANGUAGE TypeFamilyDependencies #-}++module Control.Concurrent.Class.MonadMVar+  ( MonadMVar (..)+    -- * non-standard extensions+  , MonadInspectMVar (..)+  , MonadTraceMVar (..)+  , MonadLabelledMVar (..)+  ) where++import Control.Concurrent.MVar qualified as IO+import Control.Monad.Class.MonadThrow++import Control.Monad.Reader (ReaderT (..))+import Control.Monad.Trans (lift)++import Control.Concurrent.Class.MonadSTM (TraceValue)+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 #-}++--+-- IO instance+--++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)++--+-- MonadInspectMVar+--++-- | This type class is intended for+-- ['io-sim'](https://hackage.haskell.org/package/io-sim), where one might want+-- to access an 'MVar' in the underlying 'ST' monad.+class (MonadMVar m, Monad (InspectMVarMonad m)) => MonadInspectMVar m where+  type InspectMVarMonad m :: Type -> Type+  -- | Return the value of an 'MVar' as an 'InspectMVarMonad' computation. Can+  -- be 'Nothing' if the 'MVar' is empty.+  inspectMVar :: proxy m -> MVar m a -> InspectMVarMonad m (Maybe a)++instance MonadInspectMVar IO where+  type InspectMVarMonad IO = IO+  inspectMVar _ = tryReadMVar++class MonadTraceMVar m where+  traceMVarIO :: proxy+              -> MVar m a+              -> (Maybe (Maybe a) -> Maybe a -> InspectMVarMonad m TraceValue)+              -> m ()++instance MonadTraceMVar IO where+  traceMVarIO = \_ _ _ -> pure ()++-- | Labelled `MVar`s+--+-- The `IO` instances is no-op, the `IOSim` instance enhances simulation trace.+-- This is very useful when analysing low lever concurrency issues (e.g.+-- deadlocks, livelocks etc).+class MonadMVar m+   => MonadLabelledMVar m where+  -- | Name an `MVar`+  labelMVar :: MVar m a -> String -> m ()++instance MonadLabelledMVar IO where+  labelMVar = \_ _ -> pure ()+--+-- Utilities+--++(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)+(f .: g) x y = f (g x y)
+ io-classes/Control/Concurrent/Class/MonadSTM.hs view
@@ -0,0 +1,12 @@+-- | This module corresponds to "Control.Concurrent.STM" in "stm" package+--+module Control.Concurrent.Class.MonadSTM (module STM) where++import Control.Concurrent.Class.MonadSTM.TArray as STM+import Control.Concurrent.Class.MonadSTM.TBQueue as STM+import Control.Concurrent.Class.MonadSTM.TChan as STM+import Control.Concurrent.Class.MonadSTM.TMVar as STM+import Control.Concurrent.Class.MonadSTM.TQueue as STM+import Control.Concurrent.Class.MonadSTM.TVar as STM+import Control.Monad.Class.MonadSTM as STM+
+ io-classes/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
+ io-classes/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
+ io-classes/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
+ io-classes/Control/Concurrent/Class/MonadSTM/TMVar.hs view
@@ -0,0 +1,31 @@+{-# 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+  , writeTMVar+  , isEmptyTMVar+    -- * MonadLabelledSTM+  , labelTMVar+  , labelTMVarIO+    -- * MonadTraceSTM+  , traceTMVar+  , traceTMVarIO+  , debugTraceTMVar+  , debugTraceTMVarIO+  ) where++import Control.Monad.Class.MonadSTM.Internal
+ io-classes/Control/Concurrent/Class/MonadSTM/TQueue.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE ExplicitNamespaces #-}++-- | This module corresponds to `Control.Concurrent.STM.TQueue` 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
+ io-classes/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
+ io-classes/Control/Concurrent/Class/MonadSTM/TVar.hs view
@@ -0,0 +1,28 @@+{-# 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+  , debugTraceTVar+  , debugTraceTVarIO+  ) where++import Control.Monad.Class.MonadSTM.Internal
+ io-classes/Control/Monad/Class/MonadAsync.hs view
@@ -0,0 +1,616 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DefaultSignatures      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE TypeFamilyDependencies #-}+-- MonadAsync's ReaderT instance is undecidable.+{-# LANGUAGE UndecidableInstances   #-}++-- | <https://hackage.haskell.org/package/async async> API compatible with both+-- 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.+--+module Control.Monad.Class.MonadAsync+  ( MonadAsync (..)+  , AsyncCancelled (..)+  , ExceptionInLinkedThread (..)+  , link+  , linkOnly+  , link2+  , link2Only+  , mapConcurrently+  , forConcurrently+  , mapConcurrently_+  , forConcurrently_+  , replicateConcurrently+  , replicateConcurrently_+  , Concurrently (..)+  ) where++import Prelude hiding (read)++#if MIN_VERSION_base(4,18,0)+import Control.Applicative (Alternative (..))+#else+import Control.Applicative (Alternative (..), liftA2)+#endif+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 Control.Concurrent.Async qualified as Async+import Control.Exception qualified 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)
+ io-classes/Control/Monad/Class/MonadEventlog.hs view
@@ -0,0 +1,40 @@+module Control.Monad.Class.MonadEventlog (MonadEventlog (..)) where++import Control.Monad.Reader++import Debug.Trace qualified as IO++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 ()++  -- | Immediately flush the event log, if enabled.+  --+  flushEventLog :: m ()++--+-- Instances for IO+--++instance MonadEventlog IO where+  traceEventIO  = IO.traceEventIO+  traceMarkerIO = IO.traceMarkerIO+  flushEventLog = IO.flushEventLog++--+-- Instance for ReaderT+--++instance MonadEventlog m => MonadEventlog (ReaderT r m) where+  traceEventIO  = lift . traceEventIO+  traceMarkerIO = lift . traceMarkerIO+  flushEventLog = lift   flushEventLog
+ io-classes/Control/Monad/Class/MonadFork.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE TypeFamilies #-}++-- | A generalisation of+-- <https://hackage.haskell.org/package/base/docs/Control-Concurrent.html Control.Concurrent>+-- API to both 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.+--+module Control.Monad.Class.MonadFork+  ( MonadThread (..)+  , labelThisThread+  , MonadFork (..)+  ) where++import Control.Concurrent qualified as IO+import Control.Exception (AsyncException (ThreadKilled), Exception,+           SomeException)+import Control.Monad.Reader (ReaderT (..), lift)+import Data.Kind (Type)+import GHC.Conc.Sync qualified as IO+++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 ()++  -- | Requires ghc-9.6.1 or newer.+  --+  -- @since 1.8.0.0+  threadLabel    :: ThreadId m -> m (Maybe String)++-- | Apply the label to the current thread+labelThisThread :: MonadThread m => String -> m ()+labelThisThread label = myThreadId >>= \tid -> labelThread tid label+++class MonadThread m => MonadFork m where++  forkIO             :: m () -> m (ThreadId m)+  forkOn             :: Int -> m () -> m (ThreadId m)+  forkIOWithUnmask   :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m)+  forkFinally        :: m a -> (Either SomeException a -> m ()) -> m (ThreadId m)+  throwTo            :: Exception e => ThreadId m -> e -> m ()++  killThread         :: ThreadId m -> m ()+  killThread tid     =  throwTo tid ThreadKilled++  yield              :: m ()++  getNumCapabilities :: m Int+++instance MonadThread IO where+  type ThreadId IO = IO.ThreadId+  myThreadId   = IO.myThreadId+  labelThread  = IO.labelThread+#if MIN_VERSION_base(4,18,0)+  threadLabel = IO.threadLabel+#else+  threadLabel = \_ -> pure Nothing+#endif++instance MonadFork IO where+  forkIO             = IO.forkIO+  forkOn             = IO.forkOn+  forkIOWithUnmask   = IO.forkIOWithUnmask+  forkFinally        = IO.forkFinally+  throwTo            = IO.throwTo+  killThread         = IO.killThread+  yield              = IO.yield+  getNumCapabilities = IO.getNumCapabilities++instance MonadThread m => MonadThread (ReaderT r m) where+  type ThreadId (ReaderT r m) = ThreadId m+  myThreadId      = lift myThreadId+  labelThread t l = lift (labelThread t l)+  threadLabel     = lift . threadLabel++instance MonadFork m => MonadFork (ReaderT e m) where+  forkIO (ReaderT f)   = ReaderT $ \e -> forkIO (f e)+  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+  forkFinally f k      = ReaderT $ \e -> forkFinally (runReaderT f e)+                                       $ \err -> runReaderT (k err) e+  throwTo e t = lift (throwTo e t)+  yield       = lift yield++  getNumCapabilities = lift getNumCapabilities
+ io-classes/Control/Monad/Class/MonadST.hs view
@@ -0,0 +1,57 @@+module Control.Monad.Class.MonadST (MonadST (..)) where++import Control.Monad.Reader++import Control.Monad.Primitive+import Control.Monad.ST (ST)+++-- | 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 normal type of 'stToIO' is:+--+-- > stToIO :: ST RealWorld a -> IO a+--+-- We have two approaches to abstracting over this, a new and an older+-- (deprecated) method. The new method borrows the @primitive@ package's+-- 'PrimMonad' and 'PrimState' type family. This gives us:+--+-- > stToIO :: ST (PrimState m) a -> m a+--+-- Which for 'IO' is exactly the same as above. For 'ST' it is identity, while+-- for @IOSim@ it is+--+-- > stToIO :: ST s a -> IOSim s a+--+-- The older (deprecated) method is tricky because we need to not care about+-- both the @IO@, and also the @RealWorld@, and it does so avoiding mentioning+-- any @s@ type (which is what the 'PrimState' type family gives access to).+-- The 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 PrimMonad m => MonadST m where+  -- | @since 1.4.1.0+  stToIO :: ST (PrimState m) a -> m a++  -- | Deprecated. Use 'stToIO' instead.+  withLiftST :: (forall s. (forall a. ST s a -> m a) -> b) -> b+  withLiftST = \k -> k stToIO++{-# DEPRECATED withLiftST "Use the simpler 'stToIO' instead." #-}++instance MonadST IO where+  stToIO = stToPrim++instance MonadST (ST s) where+  stToIO = stToPrim+  withLiftST = \f -> f id++instance (MonadST m, PrimMonad m) => MonadST (ReaderT r m) where+  stToIO :: ST (PrimState m) a -> ReaderT r m a+  stToIO f = lift (stToPrim f)++  withLiftST f = withLiftST $ \g -> f (lift . g)
+ io-classes/Control/Monad/Class/MonadSTM.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE GADTs                #-}+-- undecidable instances needed for 'WrappedSTM' instances of 'MonadThrow' and+-- 'MonadCatch' type classes.+{-# LANGUAGE UndecidableInstances #-}++-- | This module corresponds to "Control.Monad.STM" in "stm" package+--+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.
+ io-classes/Control/Monad/Class/MonadSTM/Internal.hs view
@@ -0,0 +1,1309 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE DefaultSignatures      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeFamilyDependencies #-}++-- 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+  , writeTMVarDefault+  , isEmptyTMVarDefault+  , labelTMVarDefault+  , traceTMVarDefault+    -- ** Default 'TQueue' 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+    -- * Trace tvar and tmvar+  , debugTraceTVar+  , debugTraceTVarIO+  , debugTraceTMVar+  , debugTraceTMVarIO+  ) where++import Prelude hiding (read)++import Control.Concurrent.STM.TArray qualified as STM+import Control.Concurrent.STM.TBQueue qualified as STM+import Control.Concurrent.STM.TChan qualified as STM+import Control.Concurrent.STM.TMVar qualified as STM+import Control.Concurrent.STM.TQueue qualified as STM+import Control.Concurrent.STM.TSem qualified as STM+import Control.Concurrent.STM.TVar qualified as STM+import Control.Monad (unless, when)+import Control.Monad.STM qualified as STM++import Control.Monad.Reader (ReaderT (..))+import Control.Monad.Trans (lift)++import Control.Monad.Class.MonadThrow qualified as MonadThrow++import Control.Exception+import Data.Array (Array, bounds)+import Data.Array qualified 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)+++-- $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.+++-- | 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+  writeTMVar      :: TMVar m a -> a -> STM m ()+  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 (InspectMonadSTM m)+      )+    => MonadInspectSTM m where+    type InspectMonadSTM m :: Type -> Type+    -- | Return the value of a `TVar` as an `InspectMonad` computation.+    --+    -- `inspectTVar` is useful if the value of a `TVar` observed by `traceTVar`+    -- contains other `TVar`s.+    inspectTVar  :: proxy m -> TVar  m a -> InspectMonadSTM m a+    -- | Return the value of a `TMVar` as an `InspectMonad` computation.+    inspectTMVar :: proxy m -> TMVar m a -> InspectMonadSTM m (Maybe a)+    -- TODO: inspectTQueue, inspectTBQueue++instance MonadInspectSTM IO where+    type InspectMonadSTM 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 -> InspectMonadSTM 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) -> InspectMonadSTM m TraceValue)+               -> STM m ()++  traceTQueue  :: proxy m+               -> TQueue m a+               -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)+               -> STM m ()++  traceTBQueue :: proxy m+               -> TBQueue m a+               -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)+               -> STM m ()++  traceTSem    :: proxy m+               -> TSem m+               -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)+               -> STM m ()++  default traceTMVar :: TMVar m a ~ TMVarDefault m a+                     => proxy m+                     -> TMVar m a+                     -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue)+                     -> STM m ()+  traceTMVar = traceTMVarDefault++  default traceTSem :: TSem m ~ TSemDefault m+                    => proxy m+                    -> TSem m+                    -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)+                    -> STM m ()+  traceTSem = traceTSemDefault+++  traceTVarIO    :: TVar m a+                 -> (Maybe a -> a -> InspectMonadSTM m TraceValue)+                 -> m ()++  traceTMVarIO   :: TMVar m a+                 -> (Maybe (Maybe a) -> Maybe a -> InspectMonadSTM m TraceValue)+                 -> m ()++  traceTQueueIO  :: TQueue m a+                 -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)+                 -> m ()++  traceTBQueueIO :: TBQueue m a+                 -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)+                 -> m ()++  traceTSemIO    :: TSem m+                 -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)+                 -> m ()++  default traceTVarIO :: TVar m a+                      -> (Maybe a -> a -> InspectMonadSTM m TraceValue)+                      -> m ()+  traceTVarIO = \v f -> atomically (traceTVar Proxy v f)++  default traceTMVarIO :: TMVar m a+                       -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)+                       -> m ()+  traceTMVarIO = \v f -> atomically (traceTMVar Proxy v f)++  default traceTQueueIO :: TQueue m a+                        -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)+                        -> m ()+  traceTQueueIO = \v f -> atomically (traceTQueue Proxy v f)++  default traceTBQueueIO :: TBQueue m a+                         -> (Maybe [a] -> [a] -> InspectMonadSTM m TraceValue)+                         -> m ()+  traceTBQueueIO = \v f -> atomically (traceTBQueue Proxy v f)++  default traceTSemIO :: TSem m+                      -> (Maybe Integer -> Integer -> InspectMonadSTM m TraceValue)+                      -> m ()+  traceTSemIO = \v f -> atomically (traceTSem Proxy v f)++debugTraceTVar :: (MonadTraceSTM m, Show a)+               => proxy m+               -> TVar m a+               -> STM m ()+debugTraceTVar p tvar =+  traceTVar p tvar (\pv v -> pure $ TraceString $ case (pv, v) of+          (Nothing, _)     -> error "Unreachable"+          (Just st', st'') -> "Modified: " <> show st' <> " -> " <> show st''+      )++debugTraceTVarIO :: (MonadTraceSTM m, Show a)+               => TVar m a+               -> m ()+debugTraceTVarIO tvar =+  traceTVarIO tvar (\pv v -> pure $ TraceString $ case (pv, v) of+          (Nothing, _)     -> error "Unreachable"+          (Just st', st'') -> "Modified: " <> show st' <> " -> " <> show st''+      )++debugTraceTMVar :: (MonadTraceSTM m, Show a)+               => proxy m+               -> TMVar m a+               -> STM m ()+debugTraceTMVar p tmvar =+  traceTMVar p tmvar (\pv v -> pure $ TraceString $ case (pv, v) of+          (Nothing, _) -> error "Unreachable"+          (Just Nothing, Just st') -> "Put: " <> show st'+          (Just Nothing, Nothing) -> "Remains empty"+          (Just Just{}, Nothing) -> "Take"+          (Just (Just st'), Just st'') -> "Modified: " <> show st' <> " -> " <> show st''+      )++debugTraceTMVarIO :: (Show a, MonadTraceSTM m)+                 => TMVar m a+                 -> m ()+debugTraceTMVarIO tmvar =+  traceTMVarIO tmvar (\pv v -> pure $ TraceString $ case (pv, v) of+          (Nothing, _) -> error "Unreachable"+          (Just Nothing, Just st') -> "Put: " <> show st'+          (Just Nothing, Nothing) -> "Remains empty"+          (Just Just{}, Nothing) -> "Take"+          (Just (Just st'), Just st'') -> "Modified: " <> show st' <> " -> " <> show st''+      )++--+-- Instance for IO uses the existing STM library implementations+--++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+#if MIN_VERSION_stm(2, 5, 1)+  writeTMVar     = STM.writeTMVar+#else+  writeTMVar     = writeTMVar'+#endif+  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 -> InspectMonadSTM 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++writeTMVarDefault :: MonadSTM m => TMVarDefault m a -> a -> STM m ()+writeTMVarDefault (TMVar t) new = writeTVar t (Just new)++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 ys of+        [] -> return Nothing+        _  -> do+          -- NB. lazy: we want the transaction to be+          -- short, otherwise it will conflict+          let ~(z,zs) = case reverse ys of+                z':zs' -> (z',zs')+                _      -> error "tryReadTBQueueDefault: impossible"++          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 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 -> InspectMonadSTM 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+    writeTMVar     = lift .: writeTMVar+    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++instance MonadInspectSTM m => MonadInspectSTM (ReaderT r m) where+  type InspectMonadSTM (ReaderT r m) = InspectMonadSTM m+  inspectTVar  _ = inspectTVar  (Proxy :: Proxy m)+  inspectTMVar _ = inspectTMVar (Proxy :: Proxy m)++instance MonadTraceSTM m => MonadTraceSTM (ReaderT r m) where+  traceTVar    _ = lift .: traceTVar    Proxy+  traceTMVar   _ = lift .: traceTMVar   Proxy+  traceTQueue  _ = lift .: traceTQueue  Proxy+  traceTBQueue _ = lift .: traceTBQueue Proxy+  traceTSem    _ = lift .: traceTSem    Proxy++(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)+(f .: g) x y = f (g x y)++-- TODO: writeTMVar was introduced in stm-2.5.1. But io-sim supports stm older than that+-- Therefore this can be removed once we don't need backwards compatibility with stm.+#if !MIN_VERSION_stm(2,5,1)+writeTMVar' :: STM.TMVar a -> a -> STM.STM ()+writeTMVar' t new = STM.tryTakeTMVar t >> STM.putTMVar t new+#endif
+ io-classes/Control/Monad/Class/MonadSay.hs view
@@ -0,0 +1,13 @@+module Control.Monad.Class.MonadSay where++import Control.Monad.Reader+import Data.ByteString.Char8 qualified 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
+ io-classes/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+
+ io-classes/Control/Monad/Class/MonadThrow.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies      #-}++-- | A generalisation of+-- <https://hackage.haskell.org/package/base/docs/Control-Exception.html Control.Exception>+-- API to both 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.+--+module Control.Monad.Class.MonadThrow+  ( MonadThrow (..)+  , MonadCatch (..)+  , MonadMask (..)+  , MonadMaskingState+  , MonadEvaluate (..)+  , MaskingState (..)+  , Exception (..)+  , SomeException+  , ExitCase (..)+  , Handler (..)+  , catches+  ) where++import Control.Exception (Exception (..), MaskingState, SomeException)+import Control.Exception qualified as IO+import Control.Monad (liftM)++import Control.Monad.Reader (ReaderT (..), lift, runReaderT)++import Control.Monad.STM (STM)+import Control.Monad.STM qualified as STM++#if __GLASGOW_HASKELL__ >= 910+import GHC.Internal.Exception.Context (ExceptionAnnotation)+#endif++-- | 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++#if __GLASGOW_HASKELL__ >= 910+  {-# MINIMAL throwIO, annotateIO #-}+#else+  {-# MINIMAL throwIO #-}+#endif++  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+#if __GLASGOW_HASKELL__ >= 910+  -- | See 'IO.annotateIO'.+  --+  -- @since 1.5.0.0+  annotateIO :: forall e a. ExceptionAnnotation e => e -> m a -> m a+#endif++  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,+              getMaskingState,+              interruptible #-}++  mask, uninterruptibleMask :: ((forall a. m a -> m a) -> m b) -> m b++  mask_, uninterruptibleMask_ :: m a -> m a+  mask_                action = mask                $ \_ -> action+  uninterruptibleMask_ action = uninterruptibleMask $ \_ -> action++  getMaskingState :: m MaskingState+  interruptible   :: m a -> m a++  allowInterrupt  :: m ()+  allowInterrupt = interruptible (return ())++class MonadMask m => MonadMaskingState m+{-# DEPRECATED MonadMaskingState "Use MonadMask instead" #-}+++-- | Monads which can 'evaluate'.+--+class Monad 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+#if __GLASGOW_HASKELL__ >= 910+  annotateIO = IO.annotateIO+#endif+++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_++  getMaskingState = IO.getMaskingState+  interruptible   = IO.interruptible+  allowInterrupt  = IO.allowInterrupt++instance MonadMaskingState IO++instance MonadEvaluate IO where+  evaluate = IO.evaluate++--+-- Instance for STM uses STM primitives and default implementations+--++instance MonadThrow STM where+  throwIO = STM.throwSTM+#if __GLASGOW_HASKELL__ >= 910+  annotateIO ann io = io `catch` \e -> throwIO (IO.addExceptionContext ann e)+#endif++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)+#if __GLASGOW_HASKELL__ >= 910+  annotateIO ann io = ReaderT $ \env ->+    annotateIO ann (runReaderT io env)+#endif++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)++  getMaskingState = lift getMaskingState+  interruptible a =+    ReaderT $ \e -> interruptible (runReaderT a e)+  allowInterrupt  = lift allowInterrupt++instance (Monad m, MonadEvaluate m) => MonadEvaluate (ReaderT r m) where+  evaluate = lift . evaluate
+ io-classes/Control/Monad/Class/MonadTime.hs view
@@ -0,0 +1,55 @@+-- | <https://hackage.haskell.org/package/time time> and+-- <https://hackage.haskell.org/package/base base> time API compatible with both+-- 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.+--+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 Data.Time.Clock qualified as Time+import Data.Word (Word64)+import GHC.Clock qualified 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
+ io-classes/Control/Monad/Class/MonadTimer.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies      #-}++-- | Provides classes to handle delays and timeouts which generalised+-- <https://hackage.haskell.org/package/base base> API to both 'IO' and+-- <https://hackage.haskell.org/package/io-sim IOSim>.+--+module Control.Monad.Class.MonadTimer+  ( MonadDelay (..)+  , MonadTimer (..)+  ) where++import Control.Concurrent qualified as IO+import Control.Concurrent.Class.MonadSTM+import Control.Concurrent.STM.TVar qualified as STM++import Control.Monad.Reader (ReaderT (..))+import Control.Monad.Trans (lift)++import System.Timeout qualified as IO++-- | A typeclass to delay current thread.+class Monad m => MonadDelay m where++  -- | Suspends the current thread for a given number of microseconds+  -- (GHC only).+  --+  -- See `IO.threadDelay`.+  threadDelay :: Int -> m ()++-- | A typeclass providing utilities for /timeouts/.+class (MonadDelay m, MonadSTM m) => MonadTimer m where++  -- | See `STM.registerDelay`.+  registerDelay :: Int -> m (TVar m Bool)++  -- | See `IO.timeout`.+  timeout :: Int -> m a -> m (Maybe a)++--+-- Instances for IO+--++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)
+ io-classes/Control/Monad/Class/MonadUnique.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DefaultSignatures      #-}+{-# LANGUAGE TypeFamilyDependencies #-}++-- | A generalisation of the+-- <https://hackage.haskell.org/package/base/docs/Data-Unique.html Data.Unique>+-- API to both 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.+--+module Control.Monad.Class.MonadUnique+  ( MonadUnique (..)+  , UniqueFor (..)+  ) where++-- base+import Data.Kind (Type)+import Data.Unique qualified as IO++-- transformers+import Control.Monad.Reader (MonadTrans (..), ReaderT (..), lift)+++class (Monad m, Eq (Unique m), Ord (Unique m)) => MonadUnique m where+  type Unique m = (unique :: Type) | unique -> m+  newUnique  :: m (Unique m)+  hashUnique :: Unique m -> Int++  default+    newUnique+      :: (m ~ t n, Unique m ~ UniqueFor t n, MonadTrans t, MonadUnique n)+      => m (Unique m)+  default+    hashUnique+      :: (m ~ t n, Unique m ~ UniqueFor t n, MonadUnique n)+      => Unique m -> Int+  newUnique  = lift (MkUniqueFor <$> newUnique)+  hashUnique = hashUnique . unMkUniqueFor++instance MonadUnique IO where+  type Unique IO = IO.Unique+  newUnique  = IO.newUnique+  hashUnique = IO.hashUnique+++newtype UniqueFor t m = MkUniqueFor{ unMkUniqueFor :: Unique m }+deriving instance MonadUnique m => Eq  (UniqueFor r m)+deriving instance MonadUnique m => Ord (UniqueFor r m)++instance MonadUnique m => MonadUnique (ReaderT r m) where+  type Unique (ReaderT r m) = UniqueFor (ReaderT r) m
+ mtl/Control/Monad/Class/MonadEventlog/Trans.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Control.Monad.Class.MonadEventlog.Trans () where++import Control.Monad.Cont (ContT)+import Control.Monad.Except (ExceptT)+import Control.Monad.RWS.Lazy qualified as Lazy+import Control.Monad.RWS.Strict qualified as Strict+import Control.Monad.State.Lazy qualified as Lazy+import Control.Monad.State.Strict qualified as Strict+import Control.Monad.Trans (lift)+import Control.Monad.Writer.Lazy qualified as Lazy+import Control.Monad.Writer.Strict qualified as Strict++import Control.Monad.Class.MonadEventlog++-- | @since 0.1.0.0+instance MonadEventlog m => MonadEventlog (ContT r m) where+  traceEventIO  = lift . traceEventIO+  traceMarkerIO = lift . traceMarkerIO+  flushEventLog = lift   flushEventLog++-- | @since 0.1.0.0+instance MonadEventlog m => MonadEventlog (ExceptT e m) where+  traceEventIO  = lift . traceEventIO+  traceMarkerIO = lift . traceMarkerIO+  flushEventLog = lift   flushEventLog++-- | @since 0.1.0.0+instance (Monoid w, MonadEventlog m) => MonadEventlog (Lazy.RWST r w s m) where+  traceEventIO  = lift . traceEventIO+  traceMarkerIO = lift . traceMarkerIO+  flushEventLog = lift   flushEventLog++-- | @since 0.1.0.0+instance (Monoid w, MonadEventlog m) => MonadEventlog (Strict.RWST r w s m) where+  traceEventIO  = lift . traceEventIO+  traceMarkerIO = lift . traceMarkerIO+  flushEventLog = lift   flushEventLog++-- | @since 0.1.0.0+instance MonadEventlog m => MonadEventlog (Lazy.StateT s m) where+  traceEventIO  = lift . traceEventIO+  traceMarkerIO = lift . traceMarkerIO+  flushEventLog = lift   flushEventLog++-- | @since 0.1.0.0+instance MonadEventlog m => MonadEventlog (Strict.StateT s m) where+  traceEventIO  = lift . traceEventIO+  traceMarkerIO = lift . traceMarkerIO+  flushEventLog = lift   flushEventLog++-- | @since 0.1.0.0+instance (Monoid w, MonadEventlog m) => MonadEventlog (Lazy.WriterT w m) where+  traceEventIO  = lift . traceEventIO+  traceMarkerIO = lift . traceMarkerIO+  flushEventLog = lift   flushEventLog++-- | @since 0.1.0.0+instance (Monoid w, MonadEventlog m) => MonadEventlog (Strict.WriterT w m) where+  traceEventIO  = lift . traceEventIO+  traceMarkerIO = lift . traceMarkerIO+  flushEventLog = lift   flushEventLog
+ mtl/Control/Monad/Class/MonadST/Trans.hs view
@@ -0,0 +1,48 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-deprecations #-}+module Control.Monad.Class.MonadST.Trans () where++import Control.Monad.Cont (ContT)+import Control.Monad.Except (ExceptT)+import Control.Monad.RWS.Lazy qualified as Lazy+import Control.Monad.RWS.Strict qualified as Strict+import Control.Monad.State.Lazy qualified as Lazy+import Control.Monad.State.Strict qualified as Strict+import Control.Monad.Trans (lift)+import Control.Monad.Writer.Lazy qualified as Lazy+import Control.Monad.Writer.Strict qualified as Strict++import Control.Monad.Class.MonadST+++instance MonadST m => MonadST (ContT r m) where+  stToIO = lift . stToIO+  withLiftST f = withLiftST $ \g -> f (lift . g)++instance MonadST m => MonadST (ExceptT e m) where+  stToIO = lift . stToIO+  withLiftST f = withLiftST $ \g -> f (lift . g)++instance (Monoid w, MonadST m) => MonadST (Lazy.RWST r w s m) where+  stToIO = lift . stToIO+  withLiftST f = withLiftST $ \g -> f (lift . g)++instance (Monoid w, MonadST m) => MonadST (Strict.RWST r w s m) where+  stToIO = lift . stToIO+  withLiftST f = withLiftST $ \g -> f (lift . g)++instance MonadST m => MonadST (Lazy.StateT s m) where+  stToIO = lift . stToIO+  withLiftST f = withLiftST $ \g -> f (lift . g)++instance MonadST m => MonadST (Strict.StateT s m) where+  stToIO = lift . stToIO+  withLiftST f = withLiftST $ \g -> f (lift . g)++instance (Monoid w, MonadST m) => MonadST (Lazy.WriterT w m) where+  stToIO = lift . stToIO+  withLiftST f = withLiftST $ \g -> f (lift . g)++instance (Monoid w, MonadST m) => MonadST (Strict.WriterT w m) where+  stToIO = lift . stToIO+  withLiftST f = withLiftST $ \g -> f (lift . g)
+ mtl/Control/Monad/Class/MonadSTM/Trans.hs view
@@ -0,0 +1,808 @@+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}++-- undecidable instances needed for 'ContTSTM' instances of+-- 'MonadThrow' and 'MonadCatch' type classes.+{-# LANGUAGE UndecidableInstances  #-}+{-# OPTIONS_GHC -Wno-orphans            #-}++module Control.Monad.Class.MonadSTM.Trans (ContTSTM (..)) where++import Control.Monad.Cont (ContT (..))+import Control.Monad.Except (ExceptT (..), runExceptT)+import Control.Monad.RWS.Lazy qualified as Lazy+import Control.Monad.RWS.Strict qualified as Strict+import Control.Monad.State.Lazy qualified as Lazy+import Control.Monad.State.Strict qualified as Strict+import Control.Monad.Trans (lift)+import Control.Monad.Writer.Lazy qualified as Lazy+import Control.Monad.Writer.Strict qualified as Strict++import Control.Monad.Class.MonadSTM.Internal+import Control.Monad.Class.MonadThrow qualified as MonadThrow++import Data.Array.Base (MArray (..))+import Data.Function (on)+import Data.Kind (Type)+import Data.Proxy (Proxy (..))+++-- | A newtype wrapper for an 'STM' monad for 'ContT'+--+newtype ContTSTM r (m :: Type -> Type) a = ContTSTM { getContTSTM :: STM m a }++deriving instance MonadSTM m => Functor     (ContTSTM r m)+deriving instance MonadSTM m => Applicative (ContTSTM r m)+deriving instance MonadSTM m => Monad       (ContTSTM r m)++instance ( Semigroup a, MonadSTM m ) => Semigroup (ContTSTM r m a) where+    a <> b = (<>) <$> a <*> b+instance ( Monoid a, MonadSTM m )    => Monoid (ContTSTM r m a) where+    mempty = pure mempty++instance ( MonadSTM m, MArray e a (STM m) ) => MArray e a (ContTSTM r m) where+    getBounds         = ContTSTM . getBounds+    getNumElements    = ContTSTM . getNumElements+    unsafeRead arr    = ContTSTM . unsafeRead arr+    unsafeWrite arr i = ContTSTM . unsafeWrite arr i+    newArray idxs     = ContTSTM . newArray idxs+++-- note: this (and the following) instance requires 'UndecidableInstances'+-- extension because it violates 3rd Paterson condition, however `STM m` will+-- resolve to a concrete type of kind (Type -> Type), and thus no larger than+-- `m` itself, e.g. for `m ~ ReaderT r f`, `STM m ~ WrappedSTM Reader r f`.+-- Instance resolution will terminate as soon as the monad transformer stack+-- depth is exhausted.+instance ( MonadSTM m+         , MonadThrow.MonadThrow (STM m)+         , MonadThrow.MonadCatch (STM m)+         ) => MonadThrow.MonadThrow (ContTSTM r m) where+  throwIO = ContTSTM . MonadThrow.throwIO+#if __GLASGOW_HASKELL__ >= 910+  annotateIO ann (ContTSTM stm) = ContTSTM (MonadThrow.annotateIO ann stm)+#endif++instance ( MonadSTM m+         , MonadThrow.MonadThrow (STM m)+         , MonadThrow.MonadCatch (STM m)+         ) => MonadThrow.MonadCatch (ContTSTM r m) where+  catch action handler = ContTSTM+                       $ MonadThrow.catch (getContTSTM action) (getContTSTM . handler)+  generalBracket acquire release use = ContTSTM $+    MonadThrow.generalBracket (getContTSTM    acquire)+                              (getContTSTM .: release)+                              (getContTSTM .  use)++-- | @'ContT' r m@ monad is using underlying @'STM' m@ monad as its stm monad,+-- without transforming it.+--+instance MonadSTM m => MonadSTM (ContT r m) where+    type STM (ContT r m) = ContTSTM r m+    atomically = lift . atomically . getContTSTM++    type TVar (ContT r m) = TVar m+    newTVar        = ContTSTM .  newTVar+    readTVar       = ContTSTM .  readTVar+    writeTVar      = ContTSTM .: writeTVar+    retry          = ContTSTM    retry+    orElse         = ContTSTM .: on orElse getContTSTM++    modifyTVar     = ContTSTM .: modifyTVar+    modifyTVar'    = ContTSTM .: modifyTVar'+    stateTVar      = ContTSTM .: stateTVar+    swapTVar       = ContTSTM .: swapTVar+    check          = ContTSTM .  check++    type TMVar (ContT r m) = TMVar m+    newTMVar       = ContTSTM .  newTMVar+    newEmptyTMVar  = ContTSTM    newEmptyTMVar+    takeTMVar      = ContTSTM .  takeTMVar+    tryTakeTMVar   = ContTSTM .  tryTakeTMVar+    putTMVar       = ContTSTM .: putTMVar+    tryPutTMVar    = ContTSTM .: tryPutTMVar+    readTMVar      = ContTSTM .  readTMVar+    tryReadTMVar   = ContTSTM .  tryReadTMVar+    swapTMVar      = ContTSTM .: swapTMVar+    writeTMVar     = ContTSTM .: writeTMVar+    isEmptyTMVar   = ContTSTM .  isEmptyTMVar++    type TQueue (ContT r m) = TQueue m+    newTQueue      = ContTSTM newTQueue+    readTQueue     = ContTSTM . readTQueue+    tryReadTQueue  = ContTSTM . tryReadTQueue+    peekTQueue     = ContTSTM . peekTQueue+    tryPeekTQueue  = ContTSTM . tryPeekTQueue+    flushTQueue    = ContTSTM .  flushTQueue+    writeTQueue v  = ContTSTM . writeTQueue v+    isEmptyTQueue  = ContTSTM . isEmptyTQueue+    unGetTQueue    = ContTSTM .: unGetTQueue++    type TBQueue (ContT r m) = TBQueue m+    newTBQueue     = ContTSTM .  newTBQueue+    readTBQueue    = ContTSTM .  readTBQueue+    tryReadTBQueue = ContTSTM .  tryReadTBQueue+    peekTBQueue    = ContTSTM .  peekTBQueue+    tryPeekTBQueue = ContTSTM .  tryPeekTBQueue+    flushTBQueue   = ContTSTM .  flushTBQueue+    writeTBQueue   = ContTSTM .: writeTBQueue+    lengthTBQueue  = ContTSTM .  lengthTBQueue+    isEmptyTBQueue = ContTSTM .  isEmptyTBQueue+    isFullTBQueue  = ContTSTM .  isFullTBQueue+    unGetTBQueue   = ContTSTM .: unGetTBQueue++    type TArray (ContT r m) = TArray m++    type TSem (ContT r m) = TSem m+    newTSem        = ContTSTM .  newTSem+    waitTSem       = ContTSTM .  waitTSem+    signalTSem     = ContTSTM .  signalTSem+    signalTSemN    = ContTSTM .: signalTSemN++    type TChan (ContT r m) = TChan m+    newTChan          = ContTSTM    newTChan+    newBroadcastTChan = ContTSTM    newBroadcastTChan+    dupTChan          = ContTSTM .  dupTChan+    cloneTChan        = ContTSTM .  cloneTChan+    readTChan         = ContTSTM .  readTChan+    tryReadTChan      = ContTSTM .  tryReadTChan+    peekTChan         = ContTSTM .  peekTChan+    tryPeekTChan      = ContTSTM .  tryPeekTChan+    writeTChan        = ContTSTM .: writeTChan+    unGetTChan        = ContTSTM .: unGetTChan+    isEmptyTChan      = ContTSTM .  isEmptyTChan+++instance MonadInspectSTM m => MonadInspectSTM (ContT r m) where+  type InspectMonadSTM (ContT r m) = InspectMonadSTM m+  inspectTVar  _ = inspectTVar  (Proxy @m)+  inspectTMVar _ = inspectTMVar (Proxy @m)++instance MonadTraceSTM m => MonadTraceSTM (ContT r m) where+  traceTVar    _ = ContTSTM .: traceTVar    (Proxy @m)+  traceTMVar   _ = ContTSTM .: traceTMVar   (Proxy @m)+  traceTQueue  _ = ContTSTM .: traceTQueue  (Proxy @m)+  traceTBQueue _ = ContTSTM .: traceTBQueue (Proxy @m)+  traceTSem    _ = ContTSTM .: traceTSem    (Proxy @m)+++-- | The underlying stm monad is also transformed.+--+instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.WriterT w m) where+    type STM (Lazy.WriterT w m) = Lazy.WriterT w (STM m)+    atomically (Lazy.WriterT stm) = Lazy.WriterT (atomically stm)++    type TVar (Lazy.WriterT w m) = TVar m+    newTVar        = lift .  newTVar+    readTVar       = lift .  readTVar+    writeTVar      = lift .: writeTVar+    retry          = lift    retry+    orElse (Lazy.WriterT a) (Lazy.WriterT b) = Lazy.WriterT $ a `orElse` b++    modifyTVar     = lift .: modifyTVar+    modifyTVar'    = lift .: modifyTVar'+    stateTVar      = lift .: stateTVar+    swapTVar       = lift .: swapTVar+    check          = lift .  check++    type TMVar (Lazy.WriterT w 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+    writeTMVar     = lift .: writeTMVar+    isEmptyTMVar   = lift .  isEmptyTMVar++    type TQueue (Lazy.WriterT w 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 (Lazy.WriterT w 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 (Lazy.WriterT w m) = TArray m++    type TSem (Lazy.WriterT w m) = TSem m+    newTSem        = lift .  newTSem+    waitTSem       = lift .  waitTSem+    signalTSem     = lift .  signalTSem+    signalTSemN    = lift .: signalTSemN++    type TChan (Lazy.WriterT w 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+++instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Lazy.WriterT w m) where+  type InspectMonadSTM (Lazy.WriterT w m) = InspectMonadSTM m+  inspectTVar  _ = inspectTVar  (Proxy @m)+  inspectTMVar _ = inspectTMVar (Proxy @m)++instance (Monoid w, MonadTraceSTM m) => MonadTraceSTM (Lazy.WriterT w m) where+  traceTVar    _ = lift .: traceTVar    (Proxy @m)+  traceTMVar   _ = lift .: traceTMVar   (Proxy @m)+  traceTQueue  _ = lift .: traceTQueue  (Proxy @m)+  traceTBQueue _ = lift .: traceTBQueue (Proxy @m)+  traceTSem    _ = lift .: traceTSem    (Proxy @m)+++-- | The underlying stm monad is also transformed.+--+instance (Monoid w, MonadSTM m) => MonadSTM (Strict.WriterT w m) where+    type STM (Strict.WriterT w m) = Strict.WriterT w (STM m)+    atomically (Strict.WriterT stm) = Strict.WriterT (atomically stm)++    type TVar (Strict.WriterT w m) = TVar m+    newTVar        = lift .  newTVar+    readTVar       = lift .  readTVar+    writeTVar      = lift .: writeTVar+    retry          = lift    retry+    orElse (Strict.WriterT a) (Strict.WriterT b) = Strict.WriterT $ a `orElse` b++    modifyTVar     = lift .: modifyTVar+    modifyTVar'    = lift .: modifyTVar'+    stateTVar      = lift .: stateTVar+    swapTVar       = lift .: swapTVar+    check          = lift .  check++    type TMVar (Strict.WriterT w 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+    writeTMVar     = lift .: writeTMVar+    isEmptyTMVar   = lift .  isEmptyTMVar++    type TQueue (Strict.WriterT w 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 (Strict.WriterT w 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 (Strict.WriterT w m) = TArray m++    type TSem (Strict.WriterT w m) = TSem m+    newTSem        = lift .  newTSem+    waitTSem       = lift .  waitTSem+    signalTSem     = lift .  signalTSem+    signalTSemN    = lift .: signalTSemN++    type TChan (Strict.WriterT w 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+++instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Strict.WriterT w m) where+  type InspectMonadSTM (Strict.WriterT w m) = InspectMonadSTM m+  inspectTVar  _ = inspectTVar  (Proxy @m)+  inspectTMVar _ = inspectTMVar (Proxy @m)++instance (Monoid w, MonadTraceSTM m) => MonadTraceSTM (Strict.WriterT w m) where+  traceTVar    _ = lift .: traceTVar    (Proxy @m)+  traceTMVar   _ = lift .: traceTMVar   (Proxy @m)+  traceTQueue  _ = lift .: traceTQueue  (Proxy @m)+  traceTBQueue _ = lift .: traceTBQueue (Proxy @m)+  traceTSem    _ = lift .: traceTSem    (Proxy @m)+++-- | The underlying stm monad is also transformed.+--+instance MonadSTM m => MonadSTM (Lazy.StateT s m) where+    type STM (Lazy.StateT s m) = Lazy.StateT s (STM m)+    atomically (Lazy.StateT stm) = Lazy.StateT $ \s -> atomically (stm s)++    type TVar (Lazy.StateT s m) = TVar m+    newTVar        = lift .  newTVar+    readTVar       = lift .  readTVar+    writeTVar      = lift .: writeTVar+    retry          = lift    retry+    orElse (Lazy.StateT a) (Lazy.StateT b) = Lazy.StateT $ \s -> a s `orElse` b s++    modifyTVar     = lift .: modifyTVar+    modifyTVar'    = lift .: modifyTVar'+    stateTVar      = lift .: stateTVar+    swapTVar       = lift .: swapTVar+    check          = lift .  check++    type TMVar (Lazy.StateT s 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+    writeTMVar     = lift .: writeTMVar+    isEmptyTMVar   = lift .  isEmptyTMVar++    type TQueue (Lazy.StateT s 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 (Lazy.StateT s 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 (Lazy.StateT s m) = TArray m++    type TSem (Lazy.StateT s m) = TSem m+    newTSem        = lift .  newTSem+    waitTSem       = lift .  waitTSem+    signalTSem     = lift .  signalTSem+    signalTSemN    = lift .: signalTSemN++    type TChan (Lazy.StateT s 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+++instance MonadInspectSTM m => MonadInspectSTM (Lazy.StateT s m) where+  type InspectMonadSTM (Lazy.StateT s m) = InspectMonadSTM m+  inspectTVar  _ = inspectTVar  (Proxy @m)+  inspectTMVar _ = inspectTMVar (Proxy @m)++instance MonadTraceSTM m => MonadTraceSTM (Lazy.StateT s m) where+  traceTVar    _ = lift .: traceTVar    (Proxy @m)+  traceTMVar   _ = lift .: traceTMVar   (Proxy @m)+  traceTQueue  _ = lift .: traceTQueue  (Proxy @m)+  traceTBQueue _ = lift .: traceTBQueue (Proxy @m)+  traceTSem    _ = lift .: traceTSem    (Proxy @m)+++-- | The underlying stm monad is also transformed.+--+instance MonadSTM m => MonadSTM (Strict.StateT s m) where+    type STM (Strict.StateT s m) = Strict.StateT s (STM m)+    atomically (Strict.StateT stm) = Strict.StateT $ \s -> atomically (stm s)++    type TVar (Strict.StateT s m) = TVar m+    newTVar        = lift .  newTVar+    readTVar       = lift .  readTVar+    writeTVar      = lift .: writeTVar+    retry          = lift    retry+    orElse (Strict.StateT a) (Strict.StateT b) = Strict.StateT $ \s -> a s `orElse` b s++    modifyTVar     = lift .: modifyTVar+    modifyTVar'    = lift .: modifyTVar'+    stateTVar      = lift .: stateTVar+    swapTVar       = lift .: swapTVar+    check          = lift .  check++    type TMVar (Strict.StateT s 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+    writeTMVar     = lift .: writeTMVar+    isEmptyTMVar   = lift .  isEmptyTMVar++    type TQueue (Strict.StateT s 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 (Strict.StateT s 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 (Strict.StateT s m) = TArray m++    type TSem (Strict.StateT s m) = TSem m+    newTSem        = lift .  newTSem+    waitTSem       = lift .  waitTSem+    signalTSem     = lift .  signalTSem+    signalTSemN    = lift .: signalTSemN++    type TChan (Strict.StateT s 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+++instance MonadInspectSTM m => MonadInspectSTM (Strict.StateT s m) where+  type InspectMonadSTM (Strict.StateT s m) = InspectMonadSTM m+  inspectTVar  _ = inspectTVar  (Proxy @m)+  inspectTMVar _ = inspectTMVar (Proxy @m)++instance MonadTraceSTM m => MonadTraceSTM (Strict.StateT s m) where+  traceTVar    _ = lift .: traceTVar    (Proxy @m)+  traceTMVar   _ = lift .: traceTMVar   (Proxy @m)+  traceTQueue  _ = lift .: traceTQueue  (Proxy @m)+  traceTBQueue _ = lift .: traceTBQueue (Proxy @m)+  traceTSem    _ = lift .: traceTSem    (Proxy @m)+++-- | The underlying stm monad is also transformed.+--+instance MonadSTM m => MonadSTM (ExceptT e m) where+    type STM (ExceptT e m) = ExceptT e (STM m)+    atomically = ExceptT . atomically . runExceptT++    type TVar (ExceptT e m) = TVar m+    newTVar        = lift .  newTVar+    readTVar       = lift .  readTVar+    writeTVar      = lift .: writeTVar+    retry          = lift    retry+    orElse         = ExceptT .: on orElse runExceptT++    modifyTVar     = lift .: modifyTVar+    modifyTVar'    = lift .: modifyTVar'+    stateTVar      = lift .: stateTVar+    swapTVar       = lift .: swapTVar+    check          = lift .  check++    type TMVar (ExceptT e 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+    writeTMVar     = lift .: writeTMVar+    isEmptyTMVar   = lift .  isEmptyTMVar++    type TQueue (ExceptT e 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 (ExceptT e 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 (ExceptT e m) = TArray m++    type TSem (ExceptT e m) = TSem m+    newTSem        = lift .  newTSem+    waitTSem       = lift .  waitTSem+    signalTSem     = lift .  signalTSem+    signalTSemN    = lift .: signalTSemN++    type TChan (ExceptT e 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+++instance MonadInspectSTM m => MonadInspectSTM (ExceptT e m) where+  type InspectMonadSTM (ExceptT e m) = InspectMonadSTM m+  inspectTVar  _ = inspectTVar  (Proxy @m)+  inspectTMVar _ = inspectTMVar (Proxy @m)++instance MonadTraceSTM m => MonadTraceSTM (ExceptT e m) where+  traceTVar    _ = lift .: traceTVar    (Proxy @m)+  traceTMVar   _ = lift .: traceTMVar   (Proxy @m)+  traceTQueue  _ = lift .: traceTQueue  (Proxy @m)+  traceTBQueue _ = lift .: traceTBQueue (Proxy @m)+  traceTSem    _ = lift .: traceTSem    (Proxy @m)+++-- | The underlying stm monad is also transformed.+--+instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.RWST r w s m) where+    type STM (Lazy.RWST r w s m) = Lazy.RWST r w s (STM m)+    atomically (Lazy.RWST stm) = Lazy.RWST $ \r s -> atomically (stm r s)++    type TVar (Lazy.RWST r w s m) = TVar m+    newTVar        = lift .  newTVar+    readTVar       = lift .  readTVar+    writeTVar      = lift .: writeTVar+    retry          = lift    retry+    orElse (Lazy.RWST a) (Lazy.RWST b) = Lazy.RWST $ \r s -> a r s `orElse` b r s++    modifyTVar     = lift .: modifyTVar+    modifyTVar'    = lift .: modifyTVar'+    stateTVar      = lift .: stateTVar+    swapTVar       = lift .: swapTVar+    check          = lift .  check++    type TMVar (Lazy.RWST r w s 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+    writeTMVar     = lift .: writeTMVar+    isEmptyTMVar   = lift .  isEmptyTMVar++    type TQueue (Lazy.RWST r w s 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 (Lazy.RWST r w s 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 (Lazy.RWST r w s m) = TArray m++    type TSem (Lazy.RWST r w s m) = TSem m+    newTSem        = lift .  newTSem+    waitTSem       = lift .  waitTSem+    signalTSem     = lift .  signalTSem+    signalTSemN    = lift .: signalTSemN++    type TChan (Lazy.RWST r w s 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+++instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Lazy.RWST r w s m) where+  type InspectMonadSTM (Lazy.RWST r w s m) = InspectMonadSTM m+  inspectTVar  _ = inspectTVar  (Proxy @m)+  inspectTMVar _ = inspectTMVar (Proxy @m)++instance (Monoid w, MonadTraceSTM m) => MonadTraceSTM (Lazy.RWST r w s m) where+  traceTVar    _ = lift .: traceTVar    (Proxy @m)+  traceTMVar   _ = lift .: traceTMVar   (Proxy @m)+  traceTQueue  _ = lift .: traceTQueue  (Proxy @m)+  traceTBQueue _ = lift .: traceTBQueue (Proxy @m)+  traceTSem    _ = lift .: traceTSem    (Proxy @m)+++-- | The underlying stm monad is also transformed.+--+instance (Monoid w, MonadSTM m) => MonadSTM (Strict.RWST r w s m) where+    type STM (Strict.RWST r w s m) = Strict.RWST r w s (STM m)+    atomically (Strict.RWST stm) = Strict.RWST $ \r s -> atomically (stm r s)++    type TVar (Strict.RWST r w s m) = TVar m+    newTVar        = lift .  newTVar+    readTVar       = lift .  readTVar+    writeTVar      = lift .: writeTVar+    retry          = lift    retry+    orElse (Strict.RWST a) (Strict.RWST b) = Strict.RWST $ \r s -> a r s `orElse` b r s++    modifyTVar     = lift .: modifyTVar+    modifyTVar'    = lift .: modifyTVar'+    stateTVar      = lift .: stateTVar+    swapTVar       = lift .: swapTVar+    check          = lift .  check++    type TMVar (Strict.RWST r w s 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+    writeTMVar     = lift .: writeTMVar+    isEmptyTMVar   = lift .  isEmptyTMVar++    type TQueue (Strict.RWST r w s 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 (Strict.RWST r w s 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 (Strict.RWST r w s m) = TArray m++    type TSem (Strict.RWST r w s m) = TSem m+    newTSem        = lift .  newTSem+    waitTSem       = lift .  waitTSem+    signalTSem     = lift .  signalTSem+    signalTSemN    = lift .: signalTSemN++    type TChan (Strict.RWST r w s 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+++instance (Monoid w, MonadInspectSTM m) => MonadInspectSTM (Strict.RWST r w s m) where+  type InspectMonadSTM (Strict.RWST r w s m) = InspectMonadSTM m+  inspectTVar  _ = inspectTVar  (Proxy @m)+  inspectTMVar _ = inspectTMVar (Proxy @m)++instance (Monoid w, MonadTraceSTM m) => MonadTraceSTM (Strict.RWST r w s m) where+  traceTVar    _ = lift .: traceTVar    (Proxy @m)+  traceTMVar   _ = lift .: traceTMVar   (Proxy @m)+  traceTQueue  _ = lift .: traceTQueue  (Proxy @m)+  traceTBQueue _ = lift .: traceTBQueue (Proxy @m)+  traceTSem    _ = lift .: traceTSem    (Proxy @m)+++(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)+(f .: g) x y = f (g x y)
+ mtl/Control/Monad/Class/MonadSay/Trans.hs view
@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Control.Monad.Class.MonadSay.Trans () where++import Control.Monad.Cont+import Control.Monad.Except+import Control.Monad.RWS+import Control.Monad.State+import Control.Monad.Writer++import Control.Monad.Class.MonadSay++-- | @since 0.1.0.0+instance MonadSay m => MonadSay (ContT r m) where+  say  = lift . say++-- | @since 0.1.0.0+instance MonadSay m => MonadSay (ExceptT e m) where+  say  = lift . say++-- | @since 0.1.0.0+instance (Monoid w, MonadSay m) => MonadSay (RWST r w s m) where+  say  = lift . say++-- | @since 0.1.0.0+instance MonadSay m => MonadSay (StateT s m) where+  say  = lift . say++-- | @since 0.1.0.0+instance (Monoid w, MonadSay m) => MonadSay (WriterT w m) where+  say  = lift . say
+ mtl/Control/Monad/Class/MonadThrow/Trans.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-orphans #-}+module Control.Monad.Class.MonadThrow.Trans () where++import Control.Monad.Except (ExceptT (..), runExceptT)+import Control.Monad.RWS.Lazy qualified as Lazy+import Control.Monad.RWS.Strict qualified as Strict+import Control.Monad.State.Lazy qualified as Lazy+import Control.Monad.State.Strict qualified as Strict+import Control.Monad.Trans (lift)+import Control.Monad.Writer.Lazy qualified as Lazy+import Control.Monad.Writer.Strict qualified as Strict++import Control.Monad.Class.MonadThrow++--+-- ExceptT Instances+--+-- These all follow the @exceptions@ package to the letter+--++instance MonadCatch m => MonadThrow (ExceptT e m) where+  throwIO = lift . throwIO+#if __GLASGOW_HASKELL__ >= 910+  annotateIO ann (ExceptT io) = ExceptT (annotateIO ann io)+#endif+++instance MonadCatch m => MonadCatch (ExceptT e m) where+  catch (ExceptT m) f = ExceptT $ catch m (runExceptT . f)++  generalBracket acquire release use = ExceptT $ do+    (eb, ec) <- generalBracket+      (runExceptT acquire)+      (\eresource exitCase -> case eresource of+        Left e -> return (Left e) -- nothing to release, acquire didn't succeed+        Right resource -> case exitCase of+          ExitCaseSuccess (Right b) -> runExceptT (release resource (ExitCaseSuccess b))+          ExitCaseException e       -> runExceptT (release resource (ExitCaseException e))+          _                         -> runExceptT (release resource ExitCaseAbort))+      (either (return . Left) (runExceptT . use))+    return $ do+      -- The order in which we perform those two 'Either' effects determines+      -- which error will win if they are both 'Left's. We want the error from+      -- 'release' to win.+      c <- ec+      b <- eb+      return (b, c)++instance MonadMask m => MonadMask (ExceptT e m) where+  mask f = ExceptT $ mask $ \u -> runExceptT $ f (q u)+    where+      q :: (m (Either e a) -> m (Either e a))+        -> ExceptT e m a -> ExceptT e m a+      q u (ExceptT b) = ExceptT (u b)+  uninterruptibleMask f = ExceptT $ uninterruptibleMask $ \u -> runExceptT $ f (q u)+    where+      q :: (m (Either e a) -> m (Either e a))+        -> ExceptT e m a -> ExceptT e m a+      q u (ExceptT b) = ExceptT (u b)++  getMaskingState = lift getMaskingState+  interruptible   = ExceptT . interruptible . runExceptT+  allowInterrupt  = lift allowInterrupt+++--+-- Lazy.WriterT instances+--++-- | @since 1.0.0.0+instance (Monoid w, MonadCatch m) => MonadThrow (Lazy.WriterT w m) where+  throwIO = lift . throwIO++#if __GLASGOW_HASKELL__ >= 910+  annotateIO ann (Lazy.WriterT io) = Lazy.WriterT (annotateIO ann io)+#endif++-- | @since 1.0.0.0+instance (Monoid w, MonadCatch m) => MonadCatch (Lazy.WriterT w m) where+  catch (Lazy.WriterT m) f = Lazy.WriterT $ catch m (Lazy.runWriterT . f)++  generalBracket acquire release use = Lazy.WriterT $ fmap f $+      generalBracket+        (Lazy.runWriterT acquire)+        (\(resource, w) e ->+          case e of+            ExitCaseSuccess (b, w') ->+              g w' <$> Lazy.runWriterT (release resource (ExitCaseSuccess b))+            ExitCaseException err ->+              g w  <$> Lazy.runWriterT (release resource (ExitCaseException err))+            ExitCaseAbort ->+              g w  <$> Lazy.runWriterT (release resource ExitCaseAbort))+        (\(resource, w)   -> g w <$> Lazy.runWriterT (use resource))+    where f ((x,_),(y,w)) = ((x,y),w)+          g w (a,w') = (a,w<>w')++-- | @since 1.0.0.0+instance (Monoid w, MonadMask m) => MonadMask (Lazy.WriterT w m) where+  mask f = Lazy.WriterT $ mask $ \u -> Lazy.runWriterT $ f (q u)+    where+      q :: (forall x. m x -> m x)+        -> Lazy.WriterT w m a -> Lazy.WriterT w m a+      q u (Lazy.WriterT b) = Lazy.WriterT (u b)+  uninterruptibleMask f = Lazy.WriterT $ uninterruptibleMask $ \u -> Lazy.runWriterT $ f (q u)+    where+      q :: (forall x. m x -> m x)+        -> Lazy.WriterT w m a -> Lazy.WriterT w m a+      q u (Lazy.WriterT b) = Lazy.WriterT (u b)++  getMaskingState = lift getMaskingState+  interruptible   = Lazy.WriterT . interruptible . Lazy.runWriterT+  allowInterrupt  = lift allowInterrupt+++--+-- Strict.WriterT instances+--++-- | @since 1.0.0.0+instance (Monoid w, MonadCatch m) => MonadThrow (Strict.WriterT w m) where+  throwIO = lift . throwIO+#if __GLASGOW_HASKELL__ >= 910+  annotateIO ann (Strict.WriterT io) = Strict.WriterT (annotateIO ann io)+#endif++-- | @since 1.0.0.0+instance (Monoid w, MonadCatch m) => MonadCatch (Strict.WriterT w m) where+  catch (Strict.WriterT m) f = Strict.WriterT $ catch m (Strict.runWriterT . f)++  generalBracket acquire release use = Strict.WriterT $ fmap f $+      generalBracket+        (Strict.runWriterT acquire)+        (\(resource, w) e ->+          case e of+            ExitCaseSuccess (b, w') ->+              g w' <$> Strict.runWriterT (release resource (ExitCaseSuccess b))+            ExitCaseException err ->+              g w  <$> Strict.runWriterT (release resource (ExitCaseException err))+            ExitCaseAbort ->+              g w  <$> Strict.runWriterT (release resource ExitCaseAbort))+        (\(resource, w)   -> g w <$> Strict.runWriterT (use resource))+    where f ((x,_),(y,w)) = ((x,y),w)+          g w (a,w') = (a,w<>w')++-- | @since 1.0.0.0+instance (Monoid w, MonadMask m) => MonadMask (Strict.WriterT w m) where+  mask f = Strict.WriterT $ mask $ \u -> Strict.runWriterT $ f (q u)+    where+      q :: (forall x. m x -> m x)+        -> Strict.WriterT w m a -> Strict.WriterT w m a+      q u (Strict.WriterT b) = Strict.WriterT (u b)+  uninterruptibleMask f = Strict.WriterT $ uninterruptibleMask $ \u -> Strict.runWriterT $ f (q u)+    where+      q :: (forall x. m x -> m x)+        -> Strict.WriterT w m a -> Strict.WriterT w m a+      q u (Strict.WriterT b) = Strict.WriterT (u b)++  getMaskingState = lift getMaskingState+  interruptible   = Strict.WriterT . interruptible . Strict.runWriterT+  allowInterrupt  = lift allowInterrupt+++--+-- Lazy.RWST Instances+--++-- | @since 1.0.0.0+instance (Monoid w, MonadCatch m) => MonadThrow (Lazy.RWST r w s m) where+  throwIO = lift . throwIO+#if __GLASGOW_HASKELL__ >= 910+  annotateIO ann (Lazy.RWST io) = Lazy.RWST (\r s -> annotateIO ann (io r s))+#endif++-- | @since 1.0.0.0+instance (Monoid w, MonadCatch m) => MonadCatch (Lazy.RWST r w s m) where+  catch (Lazy.RWST m) f = Lazy.RWST $ \r s -> catch (m r s) (\e -> Lazy.runRWST (f e) r s)++  -- | general bracket ignores the state produced by the release callback+  generalBracket acquire release use = Lazy.RWST $ \r s ->+      f <$> generalBracket+              (Lazy.runRWST acquire r s)+              (\(resource, s', w') e ->+                case e of+                  ExitCaseSuccess (b, s'', w'') ->+                    g w'' <$> Lazy.runRWST (release resource (ExitCaseSuccess b)) r s''+                  ExitCaseException err ->+                    g w'  <$> Lazy.runRWST (release resource (ExitCaseException err)) r s'+                  ExitCaseAbort ->+                    g w'  <$> Lazy.runRWST (release resource  ExitCaseAbort) r s')+              (\(a, s', w')   -> g w' <$> Lazy.runRWST (use a) r s')+    where+      f ((x,_,_),(y,s,w)) = ((x,y),s,w)+      g w (x,s,w') = (x,s,w<>w')++-- | @since 1.0.0.0+instance (Monoid w, MonadMask m) => MonadMask (Lazy.RWST r w s m) where+  mask f = Lazy.RWST $ \r s -> mask $ \u -> Lazy.runRWST (f (q u)) r s+    where+      q :: (forall x. m x -> m x)+        -> Lazy.RWST r w s m a -> Lazy.RWST r w s m a+      q u (Lazy.RWST b) = Lazy.RWST $ \r s -> u (b r s)+  uninterruptibleMask f = Lazy.RWST $ \r s -> uninterruptibleMask $ \u -> Lazy.runRWST (f (q u)) r s+    where+      q :: (forall x. m x -> m x)+        -> Lazy.RWST r w s m a -> Lazy.RWST r w s m a+      q u (Lazy.RWST b) = Lazy.RWST $ \r s -> u (b r s)++  getMaskingState = lift getMaskingState+  interruptible f = Lazy.RWST $ \r s -> interruptible (Lazy.runRWST f r s)+  allowInterrupt  = lift allowInterrupt+++--+-- Strict.RWST Instances+--++-- | @since 1.0.0.0+instance (Monoid w, MonadCatch m) => MonadThrow (Strict.RWST r w s m) where+  throwIO = lift . throwIO+#if __GLASGOW_HASKELL__ >= 910+  annotateIO ann (Strict.RWST io) = Strict.RWST (\r s -> annotateIO ann (io r s))+#endif++-- | @since 1.0.0.0+instance (Monoid w, MonadCatch m) => MonadCatch (Strict.RWST r w s m) where+  catch (Strict.RWST m) f = Strict.RWST $ \r s -> catch (m r s) (\e -> Strict.runRWST (f e) r s)++  -- | general bracket ignores the state produced by the release callback+  generalBracket acquire release use = Strict.RWST $ \r s ->+      f <$> generalBracket+              (Strict.runRWST acquire r s)+              (\(resource, s', w') e ->+                case e of+                  ExitCaseSuccess (b, s'', w'') ->+                    g w'' <$> Strict.runRWST (release resource (ExitCaseSuccess b)) r s''+                  ExitCaseException err ->+                    g w'  <$> Strict.runRWST (release resource (ExitCaseException err)) r s'+                  ExitCaseAbort ->+                    g w'  <$> Strict.runRWST (release resource  ExitCaseAbort) r s')+              (\(a, s', w')   -> g w' <$> Strict.runRWST (use a) r s')+    where+      f ((x,_,_),(y,s,w)) = ((x,y),s,w)+      g w (x,s,w') = (x,s,w<>w')++-- | @since 1.0.0.0+instance (Monoid w, MonadMask m) => MonadMask (Strict.RWST r w s m) where+  mask f = Strict.RWST $ \r s -> mask $ \u -> Strict.runRWST (f (q u)) r s+    where+      q :: (forall x. m x -> m x)+        -> Strict.RWST r w s m a -> Strict.RWST r w s m a+      q u (Strict.RWST b) = Strict.RWST $ \r s -> u (b r s)+  uninterruptibleMask f = Strict.RWST $ \r s -> uninterruptibleMask $ \u -> Strict.runRWST (f (q u)) r s+    where+      q :: (forall x. m x -> m x)+        -> Strict.RWST r w s m a -> Strict.RWST r w s m a+      q u (Strict.RWST b) = Strict.RWST $ \r s -> u (b r s)++  getMaskingState = lift getMaskingState+  interruptible f = Strict.RWST $ \r s -> interruptible (Strict.runRWST f r s)+  allowInterrupt  = lift allowInterrupt+++--+-- Lazy.StateT instances+--++-- | @since 1.0.0.0+instance MonadCatch m => MonadThrow (Lazy.StateT s m) where+  throwIO = lift . throwIO+#if __GLASGOW_HASKELL__ >= 910+  annotateIO ann (Lazy.StateT io) = Lazy.StateT (\s -> annotateIO ann (io s))+#endif++-- | @since 1.0.0.0+instance MonadCatch m => MonadCatch (Lazy.StateT s m) where+  catch (Lazy.StateT m) f = Lazy.StateT $ \s -> catch (m s) (\e -> Lazy.runStateT (f e) s)++  -- | general bracket ignores the state produced by the release callback+  generalBracket acquire release use = Lazy.StateT $ \s -> fmap f $+      generalBracket+        (Lazy.runStateT acquire s)+        (\(resource, s') e ->+          case e of+            ExitCaseSuccess (b, s'') ->+              Lazy.runStateT (release resource (ExitCaseSuccess b)) s''+            ExitCaseException err ->+              Lazy.runStateT (release resource (ExitCaseException err)) s'+            ExitCaseAbort ->+              Lazy.runStateT (release resource ExitCaseAbort) s')+        (\(a, s')   -> Lazy.runStateT (use a) s')+    where f ((x,_),(y,s)) = ((x,y),s)++-- | @since 1.0.0.0+instance MonadMask m => MonadMask (Lazy.StateT s m) where+  mask f = Lazy.StateT $ \s -> mask $ \u -> Lazy.runStateT (f (q u)) s+    where+      q :: (forall x. m x -> m x)+        -> Lazy.StateT s m a -> Lazy.StateT s m a+      q u (Lazy.StateT b) = Lazy.StateT $ \s -> u (b s)+  uninterruptibleMask f = Lazy.StateT $ \s -> uninterruptibleMask $ \u -> Lazy.runStateT (f (q u)) s+    where+      q :: (forall x. m x -> m x)+        -> Lazy.StateT s m a -> Lazy.StateT s m a+      q u (Lazy.StateT b) = Lazy.StateT $ \s -> u (b s)++  getMaskingState = lift getMaskingState+  interruptible f = Lazy.StateT $ \s -> interruptible (Lazy.runStateT f s)+  allowInterrupt  = lift allowInterrupt+++--+-- Strict.StateT instances+--++-- | @since 1.0.0.0+instance MonadCatch m => MonadThrow (Strict.StateT s m) where+  throwIO = lift . throwIO+#if __GLASGOW_HASKELL__ >= 910+  annotateIO ann (Strict.StateT io) = Strict.StateT (\s -> annotateIO ann (io s))+#endif++-- | @since 1.0.0.0+instance MonadCatch m => MonadCatch (Strict.StateT s m) where+  catch (Strict.StateT m) f = Strict.StateT $ \s -> catch (m s) (\e -> Strict.runStateT (f e) s)++  -- | general bracket ignores the state produced by the release callback+  generalBracket acquire release use = Strict.StateT $ \s -> fmap f $+      generalBracket+        (Strict.runStateT acquire s)+        (\(resource, s') e ->+          case e of+            ExitCaseSuccess (b, s'') ->+              Strict.runStateT (release resource (ExitCaseSuccess b)) s''+            ExitCaseException err ->+              Strict.runStateT (release resource (ExitCaseException err)) s'+            ExitCaseAbort ->+              Strict.runStateT (release resource ExitCaseAbort) s')+        (\(a, s')   -> Strict.runStateT (use a) s')+    where f ((x,_),(y,s)) = ((x,y),s)++-- | @since 1.0.0.0+instance MonadMask m => MonadMask (Strict.StateT s m) where+  mask f = Strict.StateT $ \s -> mask $ \u -> Strict.runStateT (f (q u)) s+    where+      q :: (forall x. m x -> m x)+        -> Strict.StateT s m a -> Strict.StateT s m a+      q u (Strict.StateT b) = Strict.StateT $ \s -> u (b s)+  uninterruptibleMask f = Strict.StateT $ \s -> uninterruptibleMask $ \u -> Strict.runStateT (f (q u)) s+    where+      q :: (forall x. m x -> m x)+        -> Strict.StateT s m a -> Strict.StateT s m a+      q u (Strict.StateT b) = Strict.StateT $ \s -> u (b s)+++  getMaskingState = lift getMaskingState+  interruptible f = Strict.StateT $ \s -> interruptible (Strict.runStateT f s)+  allowInterrupt  = lift allowInterrupt
+ mtl/Control/Monad/Class/MonadTime/SI/Trans.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Control.Monad.Class.MonadTime.SI.Trans () where++import Control.Monad.Cont (ContT)+import Control.Monad.Except (ExceptT)+import Control.Monad.RWS.Lazy qualified as Lazy+import Control.Monad.RWS.Strict qualified as Strict+import Control.Monad.State.Lazy qualified as Lazy+import Control.Monad.State.Strict qualified as Strict+import Control.Monad.Trans (lift)+import Control.Monad.Writer.Lazy qualified as Lazy+import Control.Monad.Writer.Strict qualified as Strict++import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTime.Trans ()++instance MonadMonotonicTime m => MonadMonotonicTime (ExceptT e m) where+  getMonotonicTime = lift getMonotonicTime++instance MonadMonotonicTime m => MonadMonotonicTime (Lazy.StateT s m) where+  getMonotonicTime = lift getMonotonicTime++instance MonadMonotonicTime m => MonadMonotonicTime (Strict.StateT s m) where+  getMonotonicTime = lift getMonotonicTime++instance (Monoid w, MonadMonotonicTime m) => MonadMonotonicTime (Lazy.WriterT w m) where+  getMonotonicTime = lift getMonotonicTime++instance (Monoid w, MonadMonotonicTime m) => MonadMonotonicTime (Strict.WriterT w m) where+  getMonotonicTime = lift getMonotonicTime++instance (Monoid w, MonadMonotonicTime m) => MonadMonotonicTime (Lazy.RWST r w s m) where+  getMonotonicTime = lift getMonotonicTime++instance (Monoid w, MonadMonotonicTime m) => MonadMonotonicTime (Strict.RWST r w s m) where+  getMonotonicTime = lift getMonotonicTime++instance MonadMonotonicTime m => MonadMonotonicTime (ContT r m) where+  getMonotonicTime = lift getMonotonicTime
+ mtl/Control/Monad/Class/MonadTime/Trans.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Control.Monad.Class.MonadTime.Trans () where++import Control.Monad.Cont (ContT)+import Control.Monad.Except (ExceptT)+import Control.Monad.RWS.Lazy qualified as Lazy+import Control.Monad.RWS.Strict qualified as Strict+import Control.Monad.State.Lazy qualified as Lazy+import Control.Monad.State.Strict qualified as Strict+import Control.Monad.Trans (lift)+import Control.Monad.Writer.Lazy qualified as Lazy+import Control.Monad.Writer.Strict qualified as Strict++import Control.Monad.Class.MonadTime++instance MonadMonotonicTimeNSec m => MonadMonotonicTimeNSec (ExceptT e m) where+  getMonotonicTimeNSec = lift getMonotonicTimeNSec++instance MonadMonotonicTimeNSec m => MonadMonotonicTimeNSec (Lazy.StateT s m) where+  getMonotonicTimeNSec = lift getMonotonicTimeNSec++instance MonadMonotonicTimeNSec m => MonadMonotonicTimeNSec (Strict.StateT s m) where+  getMonotonicTimeNSec = lift getMonotonicTimeNSec++instance (Monoid w, MonadMonotonicTimeNSec m) => MonadMonotonicTimeNSec (Lazy.WriterT w m) where+  getMonotonicTimeNSec = lift getMonotonicTimeNSec++instance (Monoid w, MonadMonotonicTimeNSec m) => MonadMonotonicTimeNSec (Strict.WriterT w m) where+  getMonotonicTimeNSec = lift getMonotonicTimeNSec++instance (Monoid w, MonadMonotonicTimeNSec m) => MonadMonotonicTimeNSec (Lazy.RWST r w s m) where+  getMonotonicTimeNSec = lift getMonotonicTimeNSec++instance (Monoid w, MonadMonotonicTimeNSec m) => MonadMonotonicTimeNSec (Strict.RWST r w s m) where+  getMonotonicTimeNSec = lift getMonotonicTimeNSec++instance MonadMonotonicTimeNSec m => MonadMonotonicTimeNSec (ContT r m) where+  getMonotonicTimeNSec = lift getMonotonicTimeNSec++instance MonadTime m => MonadTime (ExceptT e m) where+  getCurrentTime   = lift getCurrentTime++instance MonadTime m => MonadTime (Lazy.StateT s m) where+  getCurrentTime = lift getCurrentTime++instance MonadTime m => MonadTime (Strict.StateT s m) where+  getCurrentTime = lift getCurrentTime++instance (Monoid w, MonadTime m) => MonadTime (Lazy.WriterT w m) where+  getCurrentTime = lift getCurrentTime++instance (Monoid w, MonadTime m) => MonadTime (Strict.WriterT w m) where+  getCurrentTime = lift getCurrentTime++instance (Monoid w, MonadTime m) => MonadTime (Lazy.RWST r w s m) where+  getCurrentTime = lift getCurrentTime++instance (Monoid w, MonadTime m) => MonadTime (Strict.RWST r w s m) where+  getCurrentTime = lift getCurrentTime++instance MonadTime m => MonadTime (ContT r m) where+  getCurrentTime   = lift getCurrentTime
+ mtl/Control/Monad/Class/MonadTimer/SI/Trans.hs view
@@ -0,0 +1,66 @@+-- undecidable instances needed for 'ContTSTM' instances of+-- 'MonadThrow' and 'MonadCatch' type classes.+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans      #-}++module Control.Monad.Class.MonadTimer.SI.Trans () where++import Control.Monad.Cont (ContT (..))+import Control.Monad.Except (ExceptT (..))+import Control.Monad.RWS (RWST (..))+import Control.Monad.State (StateT (..))+import Control.Monad.Trans (lift)+import Control.Monad.Writer (WriterT (..))++import Control.Monad.Class.MonadTimer.SI++import Control.Monad.Class.MonadTime.SI.Trans ()+import Control.Monad.Class.MonadTimer.Trans ()++import Data.Bifunctor (bimap)+++instance MonadDelay m => MonadDelay (ContT r m) where+  threadDelay = lift . threadDelay+instance (Monoid w, MonadDelay m) => MonadDelay (WriterT w m) where+  threadDelay = lift . threadDelay+instance MonadDelay m => MonadDelay (StateT s m) where+  threadDelay = lift . threadDelay+instance MonadDelay m => MonadDelay (ExceptT e m) where+  threadDelay = lift . threadDelay+instance (Monoid w, MonadDelay m) => MonadDelay (RWST r w s m) where+  threadDelay = lift . threadDelay++instance (Monoid w, MonadTimer m) => MonadTimer (WriterT w m) where+  registerDelay            = lift . registerDelay+  registerDelayCancellable = fmap (bimap lift lift)+                           . lift+                           . registerDelayCancellable+  timeout d f   = WriterT $ do+    r <- timeout d (runWriterT f)+    return $ case r of+      Nothing     -> (Nothing, mempty)+      Just (a, w) -> (Just a, w)++instance MonadTimer m => MonadTimer (StateT s m) where+  registerDelay            = lift . registerDelay+  registerDelayCancellable = fmap (bimap lift lift)+                           . lift+                           . registerDelayCancellable+  timeout d f = StateT $ \s -> do+    r <- timeout d (runStateT f s)+    return $ case r of+      Nothing      -> (Nothing, s)+      Just (a, s') -> (Just a, s')++instance (Monoid w, MonadTimer m) => MonadTimer (RWST r w s m) where+  registerDelay            = lift . registerDelay+  registerDelayCancellable = fmap (bimap lift lift)+                           . lift+                           . registerDelayCancellable+  timeout d (RWST f) = RWST $ \r s -> do+    res <- timeout d (f r s)+    return $ case res of+      Nothing         -> (Nothing, s, mempty)+      Just (a, s', w) -> (Just a, s', w)+
+ mtl/Control/Monad/Class/MonadTimer/Trans.hs view
@@ -0,0 +1,92 @@+-- undecidable instances needed for 'ContTSTM' instances of+-- 'MonadThrow' and 'MonadCatch' type classes.+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-orphans      #-}++module Control.Monad.Class.MonadTimer.Trans () where++import Control.Monad.Cont (ContT (..))+import Control.Monad.Except (ExceptT (..))+import Control.Monad.RWS.Lazy qualified as Lazy+import Control.Monad.RWS.Strict qualified as Strict+import Control.Monad.State.Lazy qualified as Lazy+import Control.Monad.State.Strict qualified as Strict+import Control.Monad.Trans (lift)+import Control.Monad.Writer.Lazy qualified as Lazy+import Control.Monad.Writer.Strict qualified as Strict++import Control.Monad.Class.MonadTimer++import Control.Monad.Class.MonadSTM.Trans ()++instance MonadDelay m => MonadDelay (ContT r m) where+  threadDelay = lift . threadDelay++instance (Monoid w, MonadDelay m) => MonadDelay (Lazy.WriterT w m) where+  threadDelay = lift . threadDelay++instance (Monoid w, MonadDelay m) => MonadDelay (Strict.WriterT w m) where+  threadDelay = lift . threadDelay++instance MonadDelay m => MonadDelay (Lazy.StateT s m) where+  threadDelay = lift . threadDelay++instance MonadDelay m => MonadDelay (Strict.StateT s m) where+  threadDelay = lift . threadDelay++instance MonadDelay m => MonadDelay (ExceptT e m) where+  threadDelay = lift . threadDelay++instance (Monoid w, MonadDelay m) => MonadDelay (Lazy.RWST r w s m) where+  threadDelay = lift . threadDelay++instance (Monoid w, MonadDelay m) => MonadDelay (Strict.RWST r w s m) where+  threadDelay = lift . threadDelay++instance (Monoid w, MonadTimer m) => MonadTimer (Lazy.WriterT w m) where+  registerDelay = lift . registerDelay+  timeout d f   = Lazy.WriterT $ do+    r <- timeout d (Lazy.runWriterT f)+    return $ case r of+      Nothing     -> (Nothing, mempty)+      Just (a, w) -> (Just a, w)++instance (Monoid w, MonadTimer m) => MonadTimer (Strict.WriterT w m) where+  registerDelay = lift . registerDelay+  timeout d f   = Strict.WriterT $ do+    r <- timeout d (Strict.runWriterT f)+    return $ case r of+      Nothing     -> (Nothing, mempty)+      Just (a, w) -> (Just a, w)++instance MonadTimer m => MonadTimer (Lazy.StateT s m) where+  registerDelay = lift . registerDelay+  timeout d f = Lazy.StateT $ \s -> do+    r <- timeout d (Lazy.runStateT f s)+    return $ case r of+      Nothing      -> (Nothing, s)+      Just (a, s') -> (Just a, s')++instance MonadTimer m => MonadTimer (Strict.StateT s m) where+  registerDelay = lift . registerDelay+  timeout d f = Strict.StateT $ \s -> do+    r <- timeout d (Strict.runStateT f s)+    return $ case r of+      Nothing      -> (Nothing, s)+      Just (a, s') -> (Just a, s')++instance (Monoid w, MonadTimer m) => MonadTimer (Lazy.RWST r w s m) where+  registerDelay = lift . registerDelay+  timeout d (Lazy.RWST f) = Lazy.RWST $ \r s -> do+    res <- timeout d (f r s)+    return $ case res of+      Nothing         -> (Nothing, s, mempty)+      Just (a, s', w) -> (Just a, s', w)++instance (Monoid w, MonadTimer m) => MonadTimer (Strict.RWST r w s m) where+  registerDelay = lift . registerDelay+  timeout d (Strict.RWST f) = Strict.RWST $ \r s -> do+    res <- timeout d (f r s)+    return $ case res of+      Nothing         -> (Nothing, s, mempty)+      Just (a, s', w) -> (Just a, s', w)
+ mtl/Control/Monad/Class/MonadUnique/Trans.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE TypeFamilies #-}++module Control.Monad.Class.MonadUnique.Trans () where++import Control.Monad.Cont (ContT)+import Control.Monad.Except (ExceptT)+import Control.Monad.RWS.Lazy qualified as Lazy+import Control.Monad.RWS.Strict qualified as Strict+import Control.Monad.State.Lazy qualified as Lazy+import Control.Monad.State.Strict qualified as Strict+import Control.Monad.Writer.Lazy qualified as Lazy+import Control.Monad.Writer.Strict qualified as Strict++import Control.Monad.Class.MonadUnique+++instance MonadUnique m => MonadUnique (ContT r m) where+  type Unique (ContT r m) = UniqueFor (ContT r) m++instance MonadUnique m => MonadUnique (ExceptT e m) where+  type Unique (ExceptT e m) = UniqueFor (ExceptT e) m++instance (MonadUnique m, Monoid w) => MonadUnique (Lazy.RWST r w s m) where+  type Unique (Lazy.RWST r w s m) = UniqueFor (Lazy.RWST r w s) m++instance (MonadUnique m, Monoid w) => MonadUnique (Strict.RWST r w s m) where+  type Unique (Strict.RWST r w s m) = UniqueFor (Strict.RWST r w s) m++instance MonadUnique m => MonadUnique (Lazy.StateT s m) where+  type Unique (Lazy.StateT s m) = UniqueFor (Lazy.StateT s) m++instance MonadUnique m => MonadUnique (Strict.StateT s m) where+  type Unique (Strict.StateT s m) = UniqueFor (Strict.StateT s) m++instance (MonadUnique m, Monoid w) => MonadUnique (Lazy.WriterT w m) where+  type Unique (Lazy.WriterT w m) = UniqueFor (Lazy.WriterT w) m++instance (MonadUnique m, Monoid w) => MonadUnique (Strict.WriterT w m) where+  type Unique (Strict.WriterT w m) = UniqueFor (Strict.WriterT w) m
+ mtl/Control/Monad/Class/Trans.hs view
@@ -0,0 +1,13 @@+-- | Export all orphaned instances.+--+module Control.Monad.Class.Trans (module X) where++import Control.Monad.Class.MonadEventlog.Trans as X ()+import Control.Monad.Class.MonadSay.Trans as X ()+import Control.Monad.Class.MonadST.Trans as X ()+import Control.Monad.Class.MonadSTM.Trans as X+import Control.Monad.Class.MonadThrow.Trans as X ()+import Control.Monad.Class.MonadTime.SI.Trans as X ()+import Control.Monad.Class.MonadTime.Trans as X ()+import Control.Monad.Class.MonadTimer.SI.Trans as X ()+import Control.Monad.Class.MonadTimer.Trans as X ()
+ si-timers/src/Control/Monad/Class/MonadTime/SI.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DefaultSignatures  #-}+{-# LANGUAGE DeriveAnyClass     #-}+{-# LANGUAGE DerivingStrategies #-}++module Control.Monad.Class.MonadTime.SI+  ( MonadTime (..)+  , MonadMonotonicTime (..)+    -- * 'DiffTime' and its action on 'Time'+  , Time (..)+  , diffTime+  , addTime+  , DiffTime+    -- * 'NominalTime' and its action on 'UTCTime'+  , UTCTime+  , diffUTCTime+  , addUTCTime+  , NominalDiffTime+  ) where++import Control.DeepSeq (NFData (..))+import Control.Monad.Reader++import Control.Monad.Class.MonadTime (MonadMonotonicTimeNSec, MonadTime (..),+           NominalDiffTime, UTCTime, addUTCTime, diffUTCTime)+import Control.Monad.Class.MonadTime qualified as MonadTime++import NoThunks.Class (NoThunks (..))++import Data.Fixed (Pico, showFixed)+import Data.Time.Clock (DiffTime)+import Data.Time.Clock qualified as Time+import Data.Word (Word64)+import GHC.Generics (Generic (..))+++-- | A point in time in a monotonic clock counted in seconds.+--+-- The epoch for this clock is arbitrary and does not correspond to any wall+-- clock or calendar, and is /not guaranteed/ to be the same epoch across+-- program runs. It is represented as the 'DiffTime' from this arbitrary epoch.+--+newtype Time = Time DiffTime+  deriving stock    (Eq, Ord, Generic)+  deriving newtype  NFData+  deriving anyclass NoThunks++instance Show Time where+  show (Time t) = "Time " ++ showFixed True (realToFrac t :: Pico)++-- | The time duration between two points in time (positive or negative).+diffTime :: Time -> Time -> DiffTime+diffTime (Time t) (Time t') = t - t'++-- | Add a duration to a point in time, giving another time.+addTime :: DiffTime -> Time -> Time+addTime d (Time t) = Time (d + t)++infixr 9 `addTime`++class MonadMonotonicTimeNSec m => MonadMonotonicTime m where+  getMonotonicTime :: m Time++  default getMonotonicTime :: m Time+  getMonotonicTime =+        conv <$> MonadTime.getMonotonicTimeNSec+      where+        conv :: Word64 -> Time+        conv = Time . Time.picosecondsToDiffTime . (* 1_000) . toInteger++instance MonadMonotonicTime IO where++--+-- MTL instances+--++instance MonadMonotonicTime m => MonadMonotonicTime (ReaderT r m) where+  getMonotonicTime = lift getMonotonicTime
+ si-timers/src/Control/Monad/Class/MonadTimer/NonStandard.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE TypeFamilies       #-}++#if  defined(__GLASGOW_HASKELL__) && \+    !defined(mingw32_HOST_OS) && \+    !defined(__GHCJS__) && \+    !defined(js_HOST_ARCH) && \+    !defined(wasm32_HOST_ARCH)+#define GHC_TIMERS_API+#endif++-- | A non-standard interface for timer api.+--+-- This module also provides a polyfill which allows to use timer api also on+-- non-threaded RTS regardless of the architecture \/ OS.  Currently we support+-- `*nix`, `macOS`, `Windows` (and, unofficially `GHCJS`).+--+-- We use it to provide @'Control.Monad.Class.MonadTimer.MonadTimer' 'IO'@+-- instance and to implement a cancellable timers, see+-- 'Control.Monad.Class.MonadTimer.SI.registerDelayCancellable'.+--+-- You can expect we will deprecate it at some point (e.g. once GHC gets+-- a better support for timers especially across different execution+-- environments).+--+module Control.Monad.Class.MonadTimer.NonStandard+  ( TimeoutState (..)+  , newTimeout+  , readTimeout+  , cancelTimeout+  , awaitTimeout+  , NewTimeout+  , ReadTimeout+  , CancelTimeout+  , AwaitTimeout+  ) where++import Control.Concurrent.STM qualified as STM+#ifndef GHC_TIMERS_API+import Control.Monad (when)+#endif+import Control.Monad.Class.MonadSTM++#ifdef GHC_TIMERS_API+import GHC.Event qualified as GHC (TimeoutKey, getSystemTimerManager,+           registerTimeout, unregisterTimeout)+#else+import GHC.Conc.IO qualified as GHC (registerDelay)+#endif+++-- | State of a timeout: pending, fired or cancelled.+--+data TimeoutState = TimeoutPending | TimeoutFired | TimeoutCancelled+  deriving (Eq, Ord, Show)+++-- | The type of the timeout handle, used with 'newTimeout', 'readTimeout', and+-- 'cancelTimeout'.+--+#ifdef GHC_TIMERS_API+data Timeout = TimeoutIO !(STM.TVar TimeoutState) !GHC.TimeoutKey+#else+data Timeout = TimeoutIO !(STM.TVar (STM.TVar Bool)) !(STM.TVar Bool)+#endif++-- | Create a new timeout which will fire at the given time duration in+-- the future.+--+-- The timeout will start in the 'TimeoutPending' state and either+-- fire at or after the given time leaving it in the 'TimeoutFired' state,+-- or it may be cancelled with 'cancelTimeout', leaving it in the+-- 'TimeoutCancelled' state.+--+-- Timeouts /cannot/ be reset to the pending state once fired or cancelled+-- (as this would be very racy). You should create a new timeout if you need+-- this functionality.+--+-- When native timer manager is supported (on `*nix` systems), it only holds+-- a `TVar` with `TimeoutState` and `GHC.TimeoutKey`.+--+newTimeout :: NewTimeout IO Timeout+type NewTimeout m timeout = Int -> m timeout+++-- | Read the current state of a timeout. This does not block, but returns+-- the current state. It is your responsibility to use 'retry' to wait.+--+-- Alternatively you may wish to use the convenience utility 'awaitTimeout'+-- to wait for just the fired or cancelled outcomes.+--+-- You should consider the cancelled state if you plan to use 'cancelTimeout'.+--+readTimeout :: ReadTimeout IO Timeout+type ReadTimeout m timeout = timeout -> STM m TimeoutState+++-- | Cancel a timeout (unless it has already fired), putting it into the+-- 'TimeoutCancelled' state. Code reading and acting on the timeout state+-- need to handle such cancellation appropriately.+--+-- It is safe to race this concurrently against the timer firing. It will+-- have no effect if the timer fires first.+--+cancelTimeout :: CancelTimeout IO Timeout+type CancelTimeout m timeout = timeout -> m ()++-- | Returns @True@ when the timeout is fired, or @False@ if it is cancelled.+awaitTimeout :: AwaitTimeout IO Timeout+type AwaitTimeout m timeout = timeout -> STM m Bool+++#ifdef GHC_TIMERS_API++readTimeout (TimeoutIO var _key) = STM.readTVar var++newTimeout = \d -> do+    var <- STM.newTVarIO TimeoutPending+    mgr <- GHC.getSystemTimerManager+    key <- GHC.registerTimeout mgr d (STM.atomically (timeoutAction var))+    return (TimeoutIO var key)+  where+    timeoutAction var = do+      x <- STM.readTVar var+      case x of+        TimeoutPending   -> STM.writeTVar var TimeoutFired+        TimeoutFired     -> error "MonadTimer(IO): invariant violation"+        TimeoutCancelled -> return ()++cancelTimeout (TimeoutIO var key) = do+    STM.atomically $ do+      x <- STM.readTVar var+      case x of+        TimeoutPending   -> STM.writeTVar var TimeoutCancelled+        TimeoutFired     -> return ()+        TimeoutCancelled -> return ()+    mgr <- GHC.getSystemTimerManager+    GHC.unregisterTimeout mgr key++#else++readTimeout (TimeoutIO timeoutvarvar cancelvar) = do+  canceled <- STM.readTVar cancelvar+  fired    <- STM.readTVar =<< STM.readTVar timeoutvarvar+  case (canceled, fired) of+    (True, _)  -> return TimeoutCancelled+    (_, False) -> return TimeoutPending+    (_, True)  -> return TimeoutFired++newTimeout d = do+  timeoutvar    <- GHC.registerDelay d+  timeoutvarvar <- STM.newTVarIO timeoutvar+  cancelvar     <- STM.newTVarIO False+  return (TimeoutIO timeoutvarvar cancelvar)++cancelTimeout (TimeoutIO timeoutvarvar cancelvar) =+  STM.atomically $ do+    fired <- STM.readTVar =<< STM.readTVar timeoutvarvar+    when (not fired) $ STM.writeTVar cancelvar True++#endif++awaitTimeout t  = do s <- readTimeout t+                     case s of+                       TimeoutPending   -> retry+                       TimeoutFired     -> return True+                       TimeoutCancelled -> return False
+ si-timers/src/Control/Monad/Class/MonadTimer/SI.hs view
@@ -0,0 +1,291 @@+module Control.Monad.Class.MonadTimer.SI+  ( -- * Type classes+    MonadDelay (..)+  , MonadTimer (..)+    -- * Auxiliary functions+  , diffTimeToMicrosecondsAsInt+  , microsecondsAsIntToDiffTime+  , roundDiffTimeToMicroseconds+    -- * Re-exports+  , DiffTime+  , MonadFork+  , MonadMonotonicTime+  , MonadTime+  , TimeoutState (..)+    -- * Default implementations+  , defaultRegisterDelay+  , defaultRegisterDelayCancellable+  ) where++import Control.Concurrent.Class.MonadSTM+import Control.Exception (assert)+import Control.Monad.Class.MonadFork+import Control.Monad.Class.MonadTime.SI+import Control.Monad.Class.MonadTimer qualified as MonadTimer+import Control.Monad.Class.MonadTimer.NonStandard (TimeoutState (..))+import Control.Monad.Class.MonadTimer.NonStandard qualified as NonStandard++import Control.Monad.Reader++import Data.Bifunctor (bimap)+import Data.Functor (($>))+import Data.Time.Clock (diffTimeToPicoseconds)++++-- | Convert 'DiffTime' in seconds to microseconds represented by an 'Int'.+--+-- Note that on 32bit systems it can only represent `2^31-1` seconds, which is+-- only ~35 minutes.+--+-- It doesn't prevent under- or overflows; when assertions are on it will thrown+-- an assertion exception.+--+diffTimeToMicrosecondsAsInt :: DiffTime -> Int+diffTimeToMicrosecondsAsInt d =+    let usec :: Integer+        usec = diffTimeToPicoseconds d `div` 1_000_000 in+    assert (usec <= fromIntegral (maxBound :: Int)+         && usec >= fromIntegral (minBound :: Int)) $+    fromIntegral usec+++-- | Convert time in microseconds in 'DiffTime' (measured in seconds).+--+microsecondsAsIntToDiffTime :: Int -> DiffTime+microsecondsAsIntToDiffTime = (/ 1_000_000) . fromIntegral++-- | Round to microseconds.+--+-- For negative diff times it rounds towards negative infinity, which is+-- desirable for `MonadTimer` API.+--+roundDiffTimeToMicroseconds :: DiffTime -> DiffTime+roundDiffTimeToMicroseconds d = fromIntegral usec / 1_000_000+  where+    -- microseconds+    usec :: Integer+    usec = diffTimeToPicoseconds d `div` 1_000_000+++class ( MonadTimer.MonadDelay m+      , MonadMonotonicTime m+      ) => MonadDelay m where+  -- | All instances SHOULD round delays down to the nearest microsecond so the+  -- behaviour matches the `IO` instance.+  threadDelay :: DiffTime -> m ()++-- | Thread delay. This implementation will not over- or underflow.+--+-- For delay larger than what `Int` can represent (see+-- `diffTimeToMicrosecondsAsInt`), it will recursively call+-- `Control.Monad.Class.MonadTimer.threadDelay`.+--+-- For delays smaller than `minBound :: Int` seconds, `minBound :: Int` will be+-- used instead.+--+-- NOTE: since `MonadTimer.threadDelay` uses microsecond precision (as does+-- GHC), so does this instance.+--+instance MonadDelay IO where+  threadDelay :: forall m.+                 MonadDelay m+              => DiffTime -> m ()+  threadDelay d | d <= 0        = return ()++  threadDelay d | d <= maxDelay =+      MonadTimer.threadDelay (diffTimeToMicrosecondsAsInt d)+    where+      maxDelay :: DiffTime+      maxDelay = microsecondsAsIntToDiffTime maxBound++  threadDelay d = do+      c <- getMonotonicTime+      let u = d `addTime` c+      go c u+    where+      maxDelay :: DiffTime+      maxDelay = microsecondsAsIntToDiffTime maxBound++      go :: Time -> Time -> m ()+      go c u = do+        if d' >= maxDelay+          then do+            MonadTimer.threadDelay maxBound+            c' <- getMonotonicTime+            go  c' u+          else+            MonadTimer.threadDelay (diffTimeToMicrosecondsAsInt d')+        where+          d' = u `diffTime` c++instance MonadDelay m => MonadDelay (ReaderT r m) where+  threadDelay = lift . threadDelay++-- | `MonadTimer` API based on SI units (seconds).+--+-- NOTE: all instances SHOULD round delays down to the nearest microsecond so+-- the behaviour matches the `IO` instance.+--+class ( MonadTimer.MonadTimer m+      , MonadMonotonicTime m+      ) => MonadTimer m where++  -- | A register delay function which safe on 32-bit systems.+  registerDelay            :: DiffTime -> m (TVar m Bool)++  -- | A cancellable register delay which is safe on 32-bit systems and efficient+  -- for delays smaller than what `Int` can represent (especially on systems which+  -- support native timer manager).+  --+  registerDelayCancellable :: DiffTime -> m (STM m TimeoutState, m ())++  -- | A timeout function.+  --+  -- __TODO__: /'IO' instance is not safe on 32-bit systems./+  timeout                  :: DiffTime -> m a -> m (Maybe a)+++-- | A default implementation of `registerDelay` which supports delays longer+-- then `Int`; this is especially important on 32-bit systems where maximum+-- delay expressed in microseconds is around 35 minutes.+--+defaultRegisterDelay :: forall m timeout.+                        ( MonadFork m+                        , MonadMonotonicTime m+                        , MonadSTM m+                        )+                     => NonStandard.NewTimeout m timeout+                     -> NonStandard.AwaitTimeout m timeout+                     -> DiffTime+                     -> m (TVar m Bool)+defaultRegisterDelay newTimeout awaitTimeout d = do+    c <- getMonotonicTime+    v <- atomically $ newTVar False+    tid <- forkIO $ go v c (d `addTime` c)+    labelThread tid "delay-thread"+    return v+  where+    maxDelay :: DiffTime+    maxDelay = microsecondsAsIntToDiffTime maxBound++    go :: TVar m Bool -> Time -> Time -> m ()+    go v c u | u `diffTime` c >= maxDelay = do+      _ <- newTimeout maxBound >>= atomically . awaitTimeout+      c' <- getMonotonicTime+      go v c' u++    go v c u = do+      t <- newTimeout (diffTimeToMicrosecondsAsInt $ u `diffTime` c)+      atomically $ do+        _ <- awaitTimeout t+        writeTVar v True+++-- | A cancellable register delay which is safe on 32-bit systems and efficient+-- for delays smaller than what `Int` can represent (especially on systems which+-- support native timer manager).+--+defaultRegisterDelayCancellable :: forall m timeout.+                                   ( MonadFork m+                                   , MonadMonotonicTime m+                                   , MonadSTM m+                                   )+                                => NonStandard.NewTimeout    m timeout+                                -> NonStandard.ReadTimeout   m timeout+                                -> NonStandard.CancelTimeout m timeout+                                -> NonStandard.AwaitTimeout  m timeout+                                -> DiffTime+                                -> m (STM m TimeoutState, m ())++defaultRegisterDelayCancellable newTimeout readTimeout cancelTimeout _awaitTimeout d | d <= maxDelay = do+    t <- newTimeout (diffTimeToMicrosecondsAsInt d)+    return (readTimeout t, cancelTimeout t)+  where+    maxDelay :: DiffTime+    maxDelay = microsecondsAsIntToDiffTime maxBound++defaultRegisterDelayCancellable newTimeout _readTimeout _cancelTimeout awaitTimeout d = do+    -- current time+    c <- getMonotonicTime+    -- timeout state+    v <- newTVarIO TimeoutPending+    tid <- forkIO $ go v c (d `addTime` c)+    labelThread tid "delay-thread"+    let cancel = atomically $ readTVar v >>= \case+          TimeoutCancelled -> return ()+          TimeoutFired     -> return ()+          TimeoutPending   -> writeTVar v TimeoutCancelled+    return (readTVar v, cancel)+  where+    maxDelay :: DiffTime+    maxDelay = microsecondsAsIntToDiffTime maxBound++    go :: TVar m TimeoutState+       -> Time+       -> Time+       -> m ()+    go v c u | u `diffTime` c >= maxDelay = do+      t <- newTimeout maxBound+      ts <- atomically $ do+        (readTVar v >>= \case+           a@TimeoutCancelled -> return a+           TimeoutFired       -> error "registerDelayCancellable: invariant violation!"+           TimeoutPending     -> retry)+        `orElse`+        -- the overall timeout is still pending when 't' fires+        (awaitTimeout t $> TimeoutPending)+      case ts of+        TimeoutPending -> do+          c' <- getMonotonicTime+          go v c' u+        _ -> return ()++    go v c u = do+      t <- newTimeout (diffTimeToMicrosecondsAsInt $ u `diffTime` c)+      atomically $ do+        ts <- (readTVar v >>= \case+                 a@TimeoutCancelled -> return a+                 TimeoutFired       -> error "registerDelayCancellable: invariant violation!"+                 TimeoutPending     -> retry)+              `orElse`+              -- the overall timeout fires when 't' fires+              (awaitTimeout t $> TimeoutFired)+        case ts of+          TimeoutFired -> writeTVar v TimeoutFired+          _            -> return ()+++-- | Like 'GHC.Conc.registerDelay' but safe on 32-bit systems.  When the delay+-- is larger than what `Int` can represent it will fork a thread which will+-- write to the returned 'TVar' once the delay has passed.  When the delay is+-- small enough it will use the `MonadTimer`'s `registerDelay` (e.g. for `IO`+-- monad it will use the `GHC`'s `GHC.Conc.registerDelay`).+--+-- __TODO__: /'timeout' is not safe on 32-bit systems./+instance MonadTimer IO where+  registerDelay d+      | d <= maxDelay =+        MonadTimer.registerDelay (diffTimeToMicrosecondsAsInt d)+      | otherwise =+        defaultRegisterDelay+          NonStandard.newTimeout+          NonStandard.awaitTimeout+          d+    where+      maxDelay :: DiffTime+      maxDelay = microsecondsAsIntToDiffTime maxBound++  registerDelayCancellable =+    defaultRegisterDelayCancellable+      NonStandard.newTimeout+      NonStandard.readTimeout+      NonStandard.cancelTimeout+      NonStandard.awaitTimeout++  timeout = MonadTimer.timeout . diffTimeToMicrosecondsAsInt++instance MonadTimer m => MonadTimer (ReaderT r m) where+  registerDelay            = lift . registerDelay+  registerDelayCancellable = fmap (bimap lift lift) . lift . registerDelayCancellable+  timeout d f              = ReaderT $ \r -> timeout d (runReaderT f r)
+ si-timers/test/Main.hs view
@@ -0,0 +1,15 @@+module Main (main) where++import Test.Tasty++import Test.MonadTimer qualified++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests =+  testGroup "io-classes"+    [ Test.MonadTimer.tests+    ]+
+ si-timers/test/Test/MonadTimer.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE MultiWayIf         #-}+{-# LANGUAGE NumericUnderscores #-}++module Test.MonadTimer (tests) where++import Control.Monad.Class.MonadTimer.SI+import GHC.Real++import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck (testProperty)++tests :: TestTree+tests =+    testGroup "Control.Monad.Class.MonadTimer"+    [ testProperty "diffTimeToMicroseconds left inverse"+        prop_diffTimeToMicrosecondsAsIntLeftInverse+    , testProperty "diffTimeToMicroseconds right inverse"+        prop_diffTimeToMicrosecondsAsIntRightInverse+    , testProperty "roundToMicroseconds"+        prop_roundDiffTimeToMicroseconds+    ]++newtype IntDistr = IntDistr Int+    deriving (Show, Eq)++instance Arbitrary IntDistr where+    arbitrary = oneof+      [ IntDistr <$> arbitrary+      , IntDistr . (maxBound - ) . getNonNegative <$> (arbitrary :: Gen (NonNegative Int))+      , IntDistr . (minBound + ) . getNonNegative <$> (arbitrary :: Gen (NonNegative Int))+      ]++    shrink (IntDistr a) = IntDistr `map` shrink a++prop_diffTimeToMicrosecondsAsIntLeftInverse :: IntDistr -> Bool+prop_diffTimeToMicrosecondsAsIntLeftInverse (IntDistr usec) =+    usec == diffTimeToMicrosecondsAsInt (microsecondsAsIntToDiffTime usec)+++newtype DiffTimeDistr = DiffTimeDistr DiffTime+    deriving (Show, Eq)++instance Arbitrary DiffTimeDistr where+    arbitrary = frequency+        [ -- arbitrary DiffTime+          (6, DiffTimeDistr . fromRational <$> arbitrary)+          -- large positive DiffTimes, but smaller than `maxBound :: Int` microseconds+        , (3, DiffTimeDistr+               . (fromRational (toRational (maxBound :: Int) / 1_000_000) - )+               . fromRational+               . getNonNegative+              <$> resize 100 arbitrary+          )+          -- large negative DiffTimes, but larger than `minBound :: Int` microseconds+        , (3, DiffTimeDistr+               . (fromRational (toRational (minBound :: Int) / 1_000_000) + )+               . fromRational+               . getNonNegative+              <$> arbitrary+          )+          -- smaller than 1 :% 1_000_000+        , (1, DiffTimeDistr . fromRational . (/ 1_000_000) <$> resize 1 arbitrary)+        ]++    shrink (DiffTimeDistr a) = (DiffTimeDistr . fromRational) `map` shrink (toRational a)++prop_diffTimeToMicrosecondsAsIntRightInverse :: DiffTimeDistr -> Property+prop_diffTimeToMicrosecondsAsIntRightInverse (DiffTimeDistr a) =+    label (labelRational (toRational a)) $+      abs (toRational a - a') < (1 :% 1_000_000)+      .&&.+      r === microsecondsAsIntToDiffTime (diffTimeToMicrosecondsAsInt r)+++  where+    a' = toRational (microsecondsAsIntToDiffTime (diffTimeToMicrosecondsAsInt a))++    -- 'a' rounded to microseconds+    r :: DiffTime+    r = fromRational (toRational x / 1_000_000)+      where+        x :: Integer+        x = round $ (toRational a * 1_000_000)++    labelRational x =+      if | abs x < 1 :% 1_000_000+         -> "small"+         | abs x > toRational (maxBound :: Int) / 1_000_000 - 100+         -> "large"+         | otherwise+         -> "average"+++prop_roundDiffTimeToMicroseconds :: DiffTimeDistr -> Property+prop_roundDiffTimeToMicroseconds (DiffTimeDistr d) =+    -- rounded is less or equal to d+    --+    -- NOTE: this guarantees that if `d < 0` then `d' < 0` which is+    -- important for `MonadTimer (IOSim s)` instance.+    d' <= d+    .&&.+    -- difference is less than 1 microsecond+    abs (d - d') < 0.000_001+    .&&.+    -- rounded has no fractional microseconds+    case properFraction (d' * 1_000_000) of+      (_ :: Integer, f) -> f === 0+  where+    d' = roundDiffTimeToMicroseconds d
− src/Control/Concurrent/Class/MonadMVar.hs 
@@ -1,212 +0,0 @@-{-# LANGUAGE DefaultSignatures      #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE QuantifiedConstraints  #-}-{-# LANGUAGE TypeFamilyDependencies #-}--module Control.Concurrent.Class.MonadMVar-  ( MonadMVar (..)-  , MonadInspectMVar (..)-  ) where--import Control.Concurrent.MVar qualified 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 #-}------- IO instance-----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)------- MonadInspectMVar------- | This type class is intended for--- ['io-sim'](https://hackage.haskell.org/package/io-sim), where one might want--- to access an 'MVar' in the underlying 'ST' monad.-class (MonadMVar m, Monad (InspectMVarMonad m)) => MonadInspectMVar m where-  type InspectMVarMonad m :: Type -> Type-  -- | Return the value of an 'MVar' as an 'InspectMVarMonad' computation. Can-  -- be 'Nothing' if the 'MVar' is empty.-  inspectMVar :: proxy m -> MVar m a -> InspectMVarMonad m (Maybe a)--instance MonadInspectMVar IO where-  type InspectMVarMonad IO = IO-  inspectMVar _ = tryReadMVar------- Utilities-----(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)-(f .: g) x y = f (g x y)
− src/Control/Concurrent/Class/MonadSTM.hs 
@@ -1,14 +0,0 @@--- | 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 
@@ -1,7 +0,0 @@-{-# 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 
@@ -1,28 +0,0 @@-{-# 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 
@@ -1,26 +0,0 @@-{-# 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 
@@ -1,29 +0,0 @@-{-# 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-  , writeTMVar-  , isEmptyTMVar-    -- * MonadLabelledSTM-  , labelTMVar-  , labelTMVarIO-    -- * MonadTraceSTM-  , traceTMVar-  , traceTMVarIO-  ) where--import Control.Monad.Class.MonadSTM.Internal
− src/Control/Concurrent/Class/MonadSTM/TQueue.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE ExplicitNamespaces #-}---- | This module corresponds to `Control.Concurrent.STM.TQueue` 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 
@@ -1,20 +0,0 @@-{-# 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 
@@ -1,26 +0,0 @@-{-# 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 
@@ -1,621 +0,0 @@-{-# 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   #-}---- | <https://hackage.haskell.org/package/async async> API compatible with both--- 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.----module Control.Monad.Class.MonadAsync-  ( MonadAsync (..)-  , AsyncCancelled (..)-  , ExceptionInLinkedThread (..)-  , link-  , linkOnly-  , link2-  , link2Only-  , mapConcurrently-  , forConcurrently-  , mapConcurrently_-  , forConcurrently_-  , replicateConcurrently-  , replicateConcurrently_-  , Concurrently (..)-  ) where--import Prelude hiding (read)--#if MIN_VERSION_base(4,18,0)-import Control.Applicative (Alternative (..))-#else-import Control.Applicative (Alternative (..), liftA2)-#endif-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 Control.Concurrent.Async qualified as Async-import Control.Exception qualified 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 
@@ -1,34 +0,0 @@-module Control.Monad.Class.MonadEventlog (MonadEventlog (..)) where--import Control.Monad.Reader--import Debug.Trace qualified 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 
@@ -1,81 +0,0 @@-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}---- | A generalisation of--- <https://hackage.haskell.org/package/base/docs/Control-Concurrent.html Control.Concurrent>--- API to both 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.----module Control.Monad.Class.MonadFork-  ( MonadThread (..)-  , labelThisThread-  , MonadFork (..)-  ) where--import Control.Concurrent qualified as IO-import Control.Exception (AsyncException (ThreadKilled), Exception,-           SomeException)-import Control.Monad.Reader (ReaderT (..), lift)-import Data.Kind (Type)-import GHC.Conc.Sync qualified as IO (labelThread)---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)-  forkFinally      :: m a -> (Either SomeException a -> m ()) -> m (ThreadId m)-  throwTo          :: Exception e => ThreadId m -> e -> m ()--  killThread       :: ThreadId m -> m ()-  killThread tid = throwTo tid ThreadKilled--  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-  forkFinally      = IO.forkFinally-  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-  forkFinally f k     = ReaderT $ \e -> forkFinally (runReaderT f e)-                                      $ \err -> runReaderT (k err) e-  throwTo e t = lift (throwTo e t)-  yield       = lift yield
− src/Control/Monad/Class/MonadST.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE InstanceSigs        #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Control.Monad.Class.MonadST (MonadST (..)) where--import Control.Monad.Reader--import Control.Monad.Primitive-import Control.Monad.ST (ST)----- | 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 normal type of 'stToIO' is:------ > stToIO :: ST RealWorld a -> IO a------ We have two approaches to abstracting over this, a new and an older--- (deprecated) method. The new method borrows the @primitive@ package's--- 'PrimMonad' and 'PrimState' type family. This gives us:------ > stToIO :: ST (PrimState m) a -> m a------ Which for 'IO' is exactly the same as above. For 'ST' it is identity, while--- for @IOSim@ it is------ > stToIO :: ST s a -> IOSim s a------ The older (deprecated) method is tricky because we need to not care about--- both the @IO@, and also the @RealWorld@, and it does so avoiding mentioning--- any @s@ type (which is what the 'PrimState' type family gives access to).--- The 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 PrimMonad m => MonadST m where-  -- | @since 1.4.1.0-  stToIO :: ST (PrimState m) a -> m a--  -- | Deprecated. Use 'stToIO' instead.-  withLiftST :: (forall s. (forall a. ST s a -> m a) -> b) -> b-  withLiftST = \k -> k stToIO--{-# DEPRECATED withLiftST "Use the simpler 'stToIO' instead." #-}--instance MonadST IO where-  stToIO = stToPrim--instance MonadST (ST s) where-  stToIO = stToPrim-  withLiftST = \f -> f id--instance (MonadST m, PrimMonad m) => MonadST (ReaderT r m) where-  stToIO :: ST (PrimState m) a -> ReaderT r m a-  stToIO f = lift (stToPrim f)--  withLiftST f = withLiftST $ \g -> f (lift . g)
− src/Control/Monad/Class/MonadSTM.hs 
@@ -1,33 +0,0 @@--- | 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 
@@ -1,1259 +0,0 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DefaultSignatures          #-}-{-# LANGUAGE DerivingStrategies         #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE NamedFieldPuns             #-}-{-# LANGUAGE PatternSynonyms            #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeFamilyDependencies     #-}-{-# LANGUAGE TypeOperators              #-}---- 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-  , writeTMVarDefault-  , isEmptyTMVarDefault-  , labelTMVarDefault-  , traceTMVarDefault-    -- ** Default 'TQueue' 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--import Prelude hiding (read)--import Control.Concurrent.STM.TArray qualified as STM-import Control.Concurrent.STM.TBQueue qualified as STM-import Control.Concurrent.STM.TChan qualified as STM-import Control.Concurrent.STM.TMVar qualified as STM-import Control.Concurrent.STM.TQueue qualified as STM-import Control.Concurrent.STM.TSem qualified as STM-import Control.Concurrent.STM.TVar qualified as STM-import Control.Monad (unless, when)-import Control.Monad.STM qualified as STM--import Control.Monad.Reader (ReaderT (..))-import Control.Monad.Trans (lift)--import Control.Monad.Class.MonadThrow qualified as MonadThrow--import Control.Exception-import Data.Array (Array, bounds)-import Data.Array qualified 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)----- $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.----- | 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-  writeTMVar      :: TMVar m a -> a -> STM m ()-  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-#if MIN_VERSION_stm(2, 5, 1)-  writeTMVar     = STM.writeTMVar-#else-  writeTMVar     = writeTMVar'-#endif-  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--writeTMVarDefault :: MonadSTM m => TMVarDefault m a -> a -> STM m ()-writeTMVarDefault (TMVar t) new = writeTVar t (Just new)--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-    writeTMVar     = lift .: writeTMVar-    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)---- TODO: writeTMVar was introduced in stm-2.5.1. But io-sim supports stm older than that--- Therefore this can be removed once we don't need backwards compatibility with stm.-#if !MIN_VERSION_stm(2,5,1)-writeTMVar' :: STM.TMVar a -> a -> STM.STM ()-writeTMVar' t new = STM.tryTakeTMVar t >> STM.putTMVar t new-#endif
− src/Control/Monad/Class/MonadSay.hs 
@@ -1,13 +0,0 @@-module Control.Monad.Class.MonadSay where--import Control.Monad.Reader-import Data.ByteString.Char8 qualified 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 
@@ -1,17 +0,0 @@-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 
@@ -1,322 +0,0 @@-{-# LANGUAGE CPP                       #-}-{-# LANGUAGE DefaultSignatures         #-}-{-# LANGUAGE DeriveFunctor             #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RankNTypes                #-}-{-# LANGUAGE ScopedTypeVariables       #-}-{-# LANGUAGE StandaloneDeriving        #-}-{-# LANGUAGE TupleSections             #-}-{-# LANGUAGE TypeFamilies              #-}---- | A generalisation of--- <https://hackage.haskell.org/package/base/docs/Control-Exception.html Control.Exception>--- API to both 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.----module Control.Monad.Class.MonadThrow-  ( MonadThrow (..)-  , MonadCatch (..)-  , MonadMask (..)-  , MonadMaskingState (..)-  , MonadEvaluate (..)-  , MaskingState (..)-  , Exception (..)-  , SomeException-  , ExitCase (..)-  , Handler (..)-  , catches-  ) where--import Control.Exception (Exception (..), MaskingState, SomeException)-import Control.Exception qualified as IO-import Control.Monad (liftM)--import Control.Monad.Reader (ReaderT (..), lift, runReaderT)--import Control.Monad.STM (STM)-import Control.Monad.STM qualified as STM--#if __GLASGOW_HASKELL__ >= 910-import GHC.Internal.Exception.Context (ExceptionAnnotation)-#endif---- | 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--#if __GLASGOW_HASKELL__ >= 910-  {-# MINIMAL throwIO, annotateIO #-}-#else-  {-# MINIMAL throwIO #-}-#endif--  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-#if __GLASGOW_HASKELL__ >= 910-  annotateIO :: forall e a. ExceptionAnnotation e => e -> m a -> m a-#endif--  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-#if __GLASGOW_HASKELL__ >= 910-  annotateIO = IO.annotateIO-#endif---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-#if __GLASGOW_HASKELL__ >= 910-  annotateIO ann io = io `catch` \e -> throwIO (IO.addExceptionContext ann e)-#endif--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)-#if __GLASGOW_HASKELL__ >= 910-  annotateIO ann io = ReaderT $ \env ->-    annotateIO ann (runReaderT io env)-#endif--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 
@@ -1,57 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---- | <https://hackage.haskell.org/package/time time> and--- <https://hackage.haskell.org/package/base base> time API compatible with both--- 'IO' and <https://hackage.haskell.org/package/io-sim IOSim>.----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 Data.Time.Clock qualified as Time-import Data.Word (Word64)-import GHC.Clock qualified 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 
@@ -1,65 +0,0 @@-{-# LANGUAGE DefaultSignatures   #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies        #-}---- | Provides classes to handle delays and timeouts which generalised--- <https://hackage.haskell.org/package/base base> API to both 'IO' and--- <https://hackage.haskell.org/package/io-sim IOSim>.----module Control.Monad.Class.MonadTimer-  ( MonadDelay (..)-  , MonadTimer (..)-  ) where--import Control.Concurrent qualified as IO-import Control.Concurrent.Class.MonadSTM-import Control.Concurrent.STM.TVar qualified as STM--import Control.Monad.Reader (ReaderT (..))-import Control.Monad.Trans (lift)--import System.Timeout qualified as IO---- | A typeclass to delay current thread.-class Monad m => MonadDelay m where--  -- | Suspends the current thread for a given number of microseconds-  -- (GHC only).-  ---  -- See `IO.threadDelay`.-  threadDelay :: Int -> m ()---- | A typeclass providing utilities for /timeouts/.-class (MonadDelay m, MonadSTM m) => MonadTimer m where--  -- | See `STM.registerDelay`.-  registerDelay :: Int -> m (TVar m Bool)--  -- | See `IO.timeout`.-  timeout :: Int -> m a -> m (Maybe a)------- Instances for IO-----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)
+ strict-mvar/README.md view
@@ -0,0 +1,7 @@+# Strict Mutable Variables++The `io-classes:strict-mvar` package provides a strict interface to mutable+variables (`MVar`). It builds on top of `io-classes:io-classes`, and thus it+provides the interface for `MVar`s implementations from both+[base](https://hackage.haskell.org/package/base-4.17.0.0/docs/Control-Concurrent-MVar.html)+and [io-sim](https://github.com/input-output-hk/io-sim).
+ strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs view
@@ -0,0 +1,127 @@+-- | This module corresponds to "Control.Concurrent.MVar" in the @base@ package.+module Control.Concurrent.Class.MonadMVar.Strict+  ( -- * StrictMVar+    StrictMVar+  , LazyMVar+  , castStrictMVar+  , toLazyMVar+  , fromLazyMVar+  , newEmptyMVar+  , newMVar+  , takeMVar+  , putMVar+  , readMVar+  , swapMVar+  , tryTakeMVar+  , tryPutMVar+  , isEmptyMVar+  , withMVar+  , withMVarMasked+  , modifyMVar_+  , modifyMVar+  , modifyMVarMasked_+  , modifyMVarMasked+  , tryReadMVar+  , labelMVar+    -- * Re-exports+  , MonadMVar+  ) where++import Control.Concurrent.Class.MonadMVar (MonadLabelledMVar, MonadMVar)+import Control.Concurrent.Class.MonadMVar qualified as Lazy++--+-- StrictMVar+--++type LazyMVar m = Lazy.MVar m++newtype StrictMVar m a = StrictMVar {+    mvar      :: LazyMVar m a+  }++castStrictMVar :: LazyMVar m ~ LazyMVar n+               => StrictMVar m a -> StrictMVar n a+castStrictMVar v = StrictMVar (mvar v)++-- | Get the underlying @MVar@+--+-- Since we obviously cannot guarantee that updates to this 'LazyMVar' will be+-- strict, this should be used with caution.+toLazyMVar :: StrictMVar m a -> LazyMVar m a+toLazyMVar = mvar++-- | Create a 'StrictMVar' from a 'LazyMVar'+--+-- It is not guaranteed that the 'LazyMVar' contains a value that is in WHNF, so+-- there is no guarantee that the resulting 'StrictMVar' contains a value that+-- is in WHNF. This should be used with caution.+fromLazyMVar :: Lazy.MVar m a -> StrictMVar m a+fromLazyMVar = StrictMVar++labelMVar :: MonadLabelledMVar m => StrictMVar m a -> String -> m ()+labelMVar (StrictMVar m) = Lazy.labelMVar m++newEmptyMVar :: MonadMVar m => m (StrictMVar m a)+newEmptyMVar = fromLazyMVar <$> Lazy.newEmptyMVar++newMVar :: MonadMVar m => a -> m (StrictMVar m a)+newMVar !a = fromLazyMVar <$> Lazy.newMVar a++takeMVar :: MonadMVar m => StrictMVar m a -> m a+takeMVar = Lazy.takeMVar . mvar++putMVar :: MonadMVar m => StrictMVar m a -> a -> m ()+putMVar v !a = Lazy.putMVar (mvar v) a++readMVar :: MonadMVar m => StrictMVar m a -> m a+readMVar v = Lazy.readMVar (mvar v)++swapMVar :: MonadMVar m => StrictMVar m a -> a -> m a+swapMVar v !a = Lazy.swapMVar (mvar v) a++tryTakeMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a)+tryTakeMVar v = Lazy.tryTakeMVar (mvar v)++tryPutMVar :: MonadMVar m => StrictMVar m a -> a -> m Bool+tryPutMVar v !a = Lazy.tryPutMVar (mvar v) a++isEmptyMVar :: MonadMVar m => StrictMVar m a -> m Bool+isEmptyMVar v = Lazy.isEmptyMVar (mvar v)++withMVar :: MonadMVar m => StrictMVar m a -> (a -> m b) -> m b+withMVar v = Lazy.withMVar (mvar v)++withMVarMasked :: MonadMVar m => StrictMVar m a -> (a -> m b) -> m b+withMVarMasked v = Lazy.withMVarMasked (mvar v)++modifyMVar_ :: MonadMVar m => StrictMVar m a -> (a -> m a) -> m ()+modifyMVar_ v io = Lazy.modifyMVar_ (mvar v) io'+  where+    io' a = do+      !a' <- io a+      pure a'++modifyMVar :: MonadMVar m => StrictMVar m a -> (a -> m (a, b)) -> m b+modifyMVar v io = Lazy.modifyMVar (mvar v) io'+  where+    io' a = do+      (!a', b) <- io a+      pure (a', b)++modifyMVarMasked_ :: MonadMVar m => StrictMVar m a -> (a -> m a) -> m ()+modifyMVarMasked_ v io = Lazy.modifyMVarMasked_ (mvar v) io'+  where+    io' a = do+      !a' <- io a+      pure a'++modifyMVarMasked :: MonadMVar m => StrictMVar m a -> (a -> m (a,b)) -> m b+modifyMVarMasked v io = Lazy.modifyMVarMasked (mvar v) io'+  where+    io' a = do+      (!a', b) <- io a+      pure (a', b)++tryReadMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a)+tryReadMVar v = Lazy.tryReadMVar (mvar v)
+ strict-mvar/test/Main.hs view
@@ -0,0 +1,35 @@+module Main where++import Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF++import Test.QuickCheck.Monadic (monadicIO)+import Test.Tasty+import Test.Tasty.QuickCheck+++main :: IO ()+main = defaultMain $ testGroup "strict-mvar" [tests]++tests :: TestTree+tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict"+        [ testGroup "WHNF"+          [ testGroup "IO"+            [ testProperty "prop_newMVar" $+                monadicIO .: prop_newMVar+            , testProperty "prop_putMVar" $+                monadicIO .: prop_putMVar+            , testProperty "prop_swapMVar" $+                monadicIO .: prop_swapMVar+            , testProperty "prop_tryPutMVar" $+                monadicIO .: prop_tryPutMVar+            , testProperty "prop_modifyMVar_" $+                monadicIO .: prop_modifyMVar_+            , testProperty "prop_modifyMVar" $+                monadicIO .: prop_modifyMVar+            , testProperty "prop_modifyMVarMasked_" $+                monadicIO .: prop_modifyMVarMasked_+            , testProperty "prop_modifyMVarMasked" $+                monadicIO .: prop_modifyMVarMasked+            ]+          ]+        ]
+ strict-stm/Control/Concurrent/Class/MonadSTM/Strict.hs view
@@ -0,0 +1,15 @@+-- | This module corresponds to `Control.Concurrent.STM` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict (module STM) where++import Control.Concurrent.Class.MonadSTM.Strict.TArray as STM+import Control.Concurrent.Class.MonadSTM.Strict.TBQueue as STM+import Control.Concurrent.Class.MonadSTM.Strict.TChan as STM+import Control.Concurrent.Class.MonadSTM.Strict.TMVar as STM+import Control.Concurrent.Class.MonadSTM.Strict.TQueue as STM+import Control.Concurrent.Class.MonadSTM.Strict.TVar as STM+import Control.Monad.Class.MonadSTM as STM hiding (traceTBQueue, traceTBQueueIO,+           traceTMVar, traceTMVarIO, traceTQueue, traceTQueueIO, traceTVar,+           traceTVarIO)++
+ strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module corresponds to `Control.Concurrent.STM.TArray` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TArray+  ( StrictTArray+  , LazyTArray+  , toLazyTArray+  , fromLazyTArray+  ) where+++import Control.Concurrent.Class.MonadSTM.TArray qualified as Lazy++import Data.Array.Base (MArray (..))+++type LazyTArray  m = Lazy.TArray m++newtype StrictTArray m i e = StrictTArray { toLazyTArray :: LazyTArray m i e }++fromLazyTArray :: LazyTArray m i e -> StrictTArray m i e+fromLazyTArray = StrictTArray++instance ( MArray (Lazy.TArray m) e stm+         , Monad stm+         )+      => MArray (StrictTArray m) e stm where+    getBounds (StrictTArray arr) = getBounds arr+    newArray  b !e = StrictTArray <$> newArray b e+    newArray_ b    = StrictTArray <$> newArray_ b+    unsafeRead     (StrictTArray arr) i    = unsafeRead arr i+    unsafeWrite    (StrictTArray arr) i !e = unsafeWrite arr i e+    getNumElements (StrictTArray arr)      = getNumElements arr+
+ strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs view
@@ -0,0 +1,101 @@+-- | This module corresponds to `Control.Concurrent.STM.TBQueue` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TBQueue+  ( -- * MonadSTM+    StrictTBQueue+  , LazyTBQueue+  , toLazyTBQueue+  , fromLazyTBQueue+  , castStrictTBQueue+  , newTBQueue+  , newTBQueueIO+  , readTBQueue+  , tryReadTBQueue+  , peekTBQueue+  , tryPeekTBQueue+  , flushTBQueue+  , writeTBQueue+  , lengthTBQueue+  , isEmptyTBQueue+  , isFullTBQueue+  , unGetTBQueue+    -- * MonadLabelledSTM+  , labelTBQueue+  , labelTBQueueIO+    -- * MonadTraceSTM+  , traceTBQueue+  , traceTBQueueIO+  ) where+++import Control.Concurrent.Class.MonadSTM.TBQueue qualified as Lazy+import Control.Monad.Class.MonadSTM hiding (traceTBQueue, traceTBQueueIO)++import Numeric.Natural (Natural)+++type LazyTBQueue m = Lazy.TBQueue m++newtype StrictTBQueue m a = StrictTBQueue { toLazyTBQueue :: LazyTBQueue m a }++fromLazyTBQueue :: LazyTBQueue m a -> StrictTBQueue m a+fromLazyTBQueue = StrictTBQueue++castStrictTBQueue :: LazyTBQueue m ~ LazyTBQueue n+                  => StrictTBQueue m a -> StrictTBQueue n a+castStrictTBQueue (StrictTBQueue var) = StrictTBQueue var++labelTBQueue :: MonadLabelledSTM m => StrictTBQueue m a -> String -> STM m ()+labelTBQueue (StrictTBQueue queue) = Lazy.labelTBQueue queue++labelTBQueueIO :: MonadLabelledSTM m => StrictTBQueue m a -> String -> m ()+labelTBQueueIO (StrictTBQueue queue) = Lazy.labelTBQueueIO queue++traceTBQueue :: MonadTraceSTM m+             => proxy m+             -> StrictTBQueue m a+             -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)+             -> STM m ()+traceTBQueue p (StrictTBQueue queue) = Lazy.traceTBQueue p queue++traceTBQueueIO :: MonadTraceSTM m+               => StrictTBQueue m a+               -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)+               -> m ()+traceTBQueueIO (StrictTBQueue queue) = Lazy.traceTBQueueIO queue++newTBQueue :: MonadSTM m => Natural -> STM m (StrictTBQueue m a)+newTBQueue n = StrictTBQueue <$> Lazy.newTBQueue n++newTBQueueIO :: MonadSTM m => Natural -> m (StrictTBQueue m a)+newTBQueueIO = atomically . newTBQueue++readTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m a+readTBQueue = Lazy.readTBQueue . toLazyTBQueue++tryReadTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m (Maybe a)+tryReadTBQueue = Lazy.tryReadTBQueue . toLazyTBQueue++peekTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m a+peekTBQueue = Lazy.peekTBQueue . toLazyTBQueue++tryPeekTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m (Maybe a)+tryPeekTBQueue = Lazy.tryPeekTBQueue . toLazyTBQueue++flushTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m [a]+flushTBQueue = Lazy.flushTBQueue . toLazyTBQueue++writeTBQueue :: MonadSTM m => StrictTBQueue m a -> a -> STM m ()+writeTBQueue (StrictTBQueue tqueue) !a = Lazy.writeTBQueue tqueue a++lengthTBQueue  :: MonadSTM m => StrictTBQueue m a -> STM m Natural+lengthTBQueue = Lazy.lengthTBQueue . toLazyTBQueue++isEmptyTBQueue  :: MonadSTM m => StrictTBQueue m a -> STM m Bool+isEmptyTBQueue = Lazy.isEmptyTBQueue . toLazyTBQueue++isFullTBQueue  :: MonadSTM m => StrictTBQueue m a -> STM m Bool+isFullTBQueue = Lazy.isFullTBQueue . toLazyTBQueue++unGetTBQueue :: MonadSTM m => StrictTBQueue m a -> a -> STM m ()+unGetTBQueue (StrictTBQueue queue) !a = Lazy.unGetTBQueue queue a
+ strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs view
@@ -0,0 +1,69 @@+-- | This module corresponds to `Control.Concurrent.STM.TChan` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TChan+  ( StrictTChan+  , LazyTChan+  , toLazyTChan+  , fromLazyTChan+  , castStrictTChan+  , newTChan+  , newBroadcastTChan+  , writeTChan+  , readTChan+  , tryReadTChan+  , peekTChan+  , tryPeekTChan+  , dupTChan+  , unGetTChan+  , isEmptyTChan+  , cloneTChan+  ) where+++import Control.Concurrent.Class.MonadSTM.TChan qualified as Lazy+import Control.Monad.Class.MonadSTM+++type LazyTChan   m = Lazy.TChan m++newtype StrictTChan m a = StrictTChan { toLazyTChan :: LazyTChan m a }++fromLazyTChan :: LazyTChan m a -> StrictTChan m a+fromLazyTChan = StrictTChan++castStrictTChan :: LazyTChan m ~ LazyTChan n+                => StrictTChan m a -> StrictTChan n a+castStrictTChan (StrictTChan var) = StrictTChan var++newTChan :: MonadSTM m => STM m (StrictTChan m a)+newTChan = StrictTChan <$> Lazy.newTChan++newBroadcastTChan :: MonadSTM m => STM m (StrictTChan m a)+newBroadcastTChan = StrictTChan <$> Lazy.newBroadcastTChan++writeTChan :: MonadSTM m => StrictTChan m a -> a -> STM m ()+writeTChan (StrictTChan chan) !a = Lazy.writeTChan chan a++readTChan :: MonadSTM m => StrictTChan m a -> STM m a+readTChan = Lazy.readTChan . toLazyTChan++tryReadTChan :: MonadSTM m => StrictTChan m a -> STM m (Maybe a)+tryReadTChan = Lazy.tryReadTChan . toLazyTChan++peekTChan :: MonadSTM m => StrictTChan m a -> STM m a+peekTChan = Lazy.peekTChan . toLazyTChan++tryPeekTChan :: MonadSTM m => StrictTChan m a -> STM m (Maybe a)+tryPeekTChan = Lazy.tryPeekTChan . toLazyTChan++dupTChan :: MonadSTM m => StrictTChan m a -> STM m (StrictTChan m a)+dupTChan = fmap fromLazyTChan . Lazy.dupTChan . toLazyTChan++unGetTChan :: MonadSTM m => StrictTChan m a -> a -> STM m ()+unGetTChan (StrictTChan chan) !a = Lazy.unGetTChan chan a++isEmptyTChan :: MonadSTM m => StrictTChan m a -> STM m Bool+isEmptyTChan = Lazy.isEmptyTChan . toLazyTChan++cloneTChan :: MonadSTM m => StrictTChan m a -> STM m (StrictTChan m a)+cloneTChan = fmap fromLazyTChan . Lazy.cloneTChan . toLazyTChan
+ strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs view
@@ -0,0 +1,117 @@+-- | This module corresponds to `Control.Concurrent.STM.TMVar` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TMVar+  ( -- * StrictTMVar+    StrictTMVar+  , LazyTMVar+  , toLazyTMVar+  , fromLazyTMVar+  , castStrictTMVar+  , newTMVar+  , newEmptyTMVar+  , newTMVarIO+  , newEmptyTMVarIO+  , takeTMVar+  , tryTakeTMVar+  , putTMVar+  , tryPutTMVar+  , readTMVar+  , tryReadTMVar+  , swapTMVar+  , writeTMVar+  , isEmptyTMVar+    -- * MonadLabelledSTM+  , labelTMVar+  , labelTMVarIO+    -- * MonadTraceSTM+  , traceTMVar+  , traceTMVarIO+  , debugTraceTMVar+  , debugTraceTMVarIO+  ) where+++import Control.Concurrent.Class.MonadSTM.TMVar qualified as Lazy+import Control.Monad.Class.MonadSTM hiding (traceTMVar, traceTMVarIO)+++type LazyTMVar   m = Lazy.TMVar m++-- | 'TMVar' that keeps its value in WHNF at all times+newtype StrictTMVar m a = StrictTMVar { toLazyTMVar :: LazyTMVar m a }++fromLazyTMVar :: LazyTMVar m a -> StrictTMVar m a+fromLazyTMVar = StrictTMVar++labelTMVar :: MonadLabelledSTM m => StrictTMVar m a -> String -> STM m ()+labelTMVar (StrictTMVar tvar) = Lazy.labelTMVar tvar++labelTMVarIO :: MonadLabelledSTM m => StrictTMVar m a -> String -> m ()+labelTMVarIO v = atomically . labelTMVar v++traceTMVar :: MonadTraceSTM m+           => proxy m+           -> StrictTMVar m a+           -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)+           -> STM m ()+traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var++debugTraceTMVar :: (MonadTraceSTM m, Show a)+               => proxy m+               -> StrictTMVar m a+               -> STM m ()+debugTraceTMVar p (StrictTMVar var) = Lazy.debugTraceTMVar p var++traceTMVarIO :: MonadTraceSTM m+             => StrictTMVar m a+             -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonadSTM m TraceValue)+             -> m ()+traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var++debugTraceTMVarIO :: (MonadTraceSTM m, Show a)+                 => StrictTMVar m a+                 -> m ()+debugTraceTMVarIO (StrictTMVar var) = Lazy.debugTraceTMVarIO var++castStrictTMVar :: LazyTMVar m ~ LazyTMVar n+                => StrictTMVar m a -> StrictTMVar n a+castStrictTMVar (StrictTMVar var) = StrictTMVar var++newTMVar :: MonadSTM m => a -> STM m (StrictTMVar m a)+newTMVar !a = StrictTMVar <$> Lazy.newTMVar a++newTMVarIO :: MonadSTM m => a -> m (StrictTMVar m a)+newTMVarIO !a = StrictTMVar <$> Lazy.newTMVarIO a++newEmptyTMVar :: MonadSTM m => STM m (StrictTMVar m a)+newEmptyTMVar = StrictTMVar <$> Lazy.newEmptyTMVar++newEmptyTMVarIO :: MonadSTM m => m (StrictTMVar m a)+newEmptyTMVarIO = StrictTMVar <$> Lazy.newEmptyTMVarIO++takeTMVar :: MonadSTM m => StrictTMVar m a -> STM m a+takeTMVar (StrictTMVar tmvar) = Lazy.takeTMVar tmvar++tryTakeTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a)+tryTakeTMVar (StrictTMVar tmvar) = Lazy.tryTakeTMVar tmvar++putTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m ()+putTMVar (StrictTMVar tmvar) !a = Lazy.putTMVar tmvar a++tryPutTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m Bool+tryPutTMVar (StrictTMVar tmvar) !a = Lazy.tryPutTMVar tmvar a++readTMVar :: MonadSTM m => StrictTMVar m a -> STM m a+readTMVar (StrictTMVar tmvar) = Lazy.readTMVar tmvar++tryReadTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a)+tryReadTMVar (StrictTMVar tmvar) = Lazy.tryReadTMVar tmvar++swapTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m a+swapTMVar (StrictTMVar tmvar) !a = Lazy.swapTMVar tmvar a++writeTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m ()+writeTMVar (StrictTMVar tmvar) !a = Lazy.writeTMVar tmvar a++isEmptyTMVar :: MonadSTM m => StrictTMVar m a -> STM m Bool+isEmptyTMVar (StrictTMVar tmvar) = Lazy.isEmptyTMVar tmvar
+ strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs view
@@ -0,0 +1,92 @@+-- | This module corresponds to `Control.Concurrent.STM.TQueue` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TQueue+  ( -- * MonadSTM+    StrictTQueue+  , LazyTQueue+  , toLazyTQueue+  , fromLazyTQueue+  , castStrictTQueue+  , newTQueue+  , newTQueueIO+  , readTQueue+  , tryReadTQueue+  , peekTQueue+  , tryPeekTQueue+  , flushTQueue+  , writeTQueue+  , unGetTQueue+  , isEmptyTQueue+    -- * MonadLabelledSTM+  , labelTQueue+  , labelTQueueIO+    -- * MonadTraceSTM+  , traceTQueue+  , traceTQueueIO+  ) where+++import Control.Concurrent.Class.MonadSTM.TQueue qualified as Lazy+import Control.Monad.Class.MonadSTM hiding (traceTQueue, traceTQueueIO)+++type LazyTQueue  m = Lazy.TQueue m++newtype StrictTQueue m a = StrictTQueue { toLazyTQueue :: LazyTQueue m a }++fromLazyTQueue :: LazyTQueue m a -> StrictTQueue m a+fromLazyTQueue = StrictTQueue++castStrictTQueue :: LazyTQueue m ~ LazyTQueue n+                 => StrictTQueue m a -> StrictTQueue n a+castStrictTQueue (StrictTQueue var) = StrictTQueue var++labelTQueue :: MonadLabelledSTM m => StrictTQueue m a -> String -> STM m ()+labelTQueue (StrictTQueue queue) = Lazy.labelTQueue queue++labelTQueueIO :: MonadLabelledSTM m => StrictTQueue m a -> String -> m ()+labelTQueueIO (StrictTQueue queue) = Lazy.labelTQueueIO queue++traceTQueue :: MonadTraceSTM m+            => proxy m+            -> StrictTQueue m a+            -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)+            -> STM m ()+traceTQueue p (StrictTQueue queue) = Lazy.traceTQueue p queue++traceTQueueIO :: MonadTraceSTM m+              => StrictTQueue m a+              -> ((Maybe [a]) -> [a] -> InspectMonadSTM m TraceValue)+              -> m ()+traceTQueueIO (StrictTQueue queue) = Lazy.traceTQueueIO queue++newTQueue :: MonadSTM m => STM m (StrictTQueue m a)+newTQueue = StrictTQueue <$> Lazy.newTQueue++newTQueueIO :: MonadSTM m => m (StrictTQueue m a)+newTQueueIO = atomically newTQueue++readTQueue :: MonadSTM m => StrictTQueue m a -> STM m a+readTQueue = Lazy.readTQueue . toLazyTQueue++tryReadTQueue :: MonadSTM m => StrictTQueue m a -> STM m (Maybe a)+tryReadTQueue = Lazy.tryReadTQueue . toLazyTQueue++peekTQueue :: MonadSTM m => StrictTQueue m a -> STM m a+peekTQueue = Lazy.peekTQueue . toLazyTQueue++tryPeekTQueue :: MonadSTM m => StrictTQueue m a -> STM m (Maybe a)+tryPeekTQueue = Lazy.tryPeekTQueue . toLazyTQueue++flushTQueue :: MonadSTM m => StrictTQueue m a -> STM m [a]+flushTQueue = Lazy.flushTQueue . toLazyTQueue++writeTQueue :: MonadSTM m => StrictTQueue m a -> a -> STM m ()+writeTQueue (StrictTQueue tqueue) !a = Lazy.writeTQueue tqueue a++isEmptyTQueue  :: MonadSTM m => StrictTQueue m a -> STM m Bool+isEmptyTQueue = Lazy.isEmptyTQueue . toLazyTQueue++unGetTQueue :: MonadSTM m => StrictTQueue m a -> a -> STM m ()+unGetTQueue (StrictTQueue queue) !a = Lazy.unGetTQueue queue a+
+ strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs view
@@ -0,0 +1,116 @@+-- | This module corresponds to `Control.Concurrent.STM.TVar` in "stm" package+--+module Control.Concurrent.Class.MonadSTM.Strict.TVar+  ( -- * StrictTVar+    StrictTVar+  , LazyTVar+  , toLazyTVar+  , fromLazyTVar+  , castStrictTVar+  , newTVar+  , newTVarIO+  , readTVar+  , readTVarIO+  , writeTVar+  , modifyTVar+  , stateTVar+  , swapTVar+  , check+    -- * MonadLabelSTM+  , labelTVar+  , labelTVarIO+    -- * MonadTraceSTM+  , traceTVar+  , traceTVarIO+  , debugTraceTVar+  , debugTraceTVarIO+  ) where++import Control.Concurrent.Class.MonadSTM.TVar qualified as Lazy+import Control.Monad.Class.MonadSTM hiding (traceTVar, traceTVarIO)++type LazyTVar m = Lazy.TVar m++newtype StrictTVar m a = StrictTVar {+    tvar :: LazyTVar m a+  }++labelTVar :: MonadLabelledSTM m => StrictTVar m a -> String -> STM m ()+labelTVar StrictTVar { tvar } = Lazy.labelTVar tvar++labelTVarIO :: MonadLabelledSTM m => StrictTVar m a -> String -> m ()+labelTVarIO v = atomically . labelTVar v++traceTVar :: MonadTraceSTM m+          => proxy m+          -> StrictTVar m a+          -> (Maybe a -> a -> InspectMonadSTM m TraceValue)+          -> STM m ()+traceTVar p StrictTVar {tvar} = Lazy.traceTVar p tvar++debugTraceTVar :: (MonadTraceSTM m, Show a)+              => proxy m+              -> StrictTVar m a+              -> STM m ()+debugTraceTVar p StrictTVar {tvar} = Lazy.debugTraceTVar p tvar++traceTVarIO :: MonadTraceSTM m+            => StrictTVar m a+            -> (Maybe a -> a -> InspectMonadSTM m TraceValue)+            -> m ()+traceTVarIO StrictTVar {tvar} = Lazy.traceTVarIO tvar++debugTraceTVarIO :: (MonadTraceSTM m, Show a)+                => StrictTVar m a+                -> m ()+debugTraceTVarIO StrictTVar {tvar} = Lazy.debugTraceTVarIO tvar++-- | Cast the monad if both use the same representation of `TVar`s.+--+-- This function is useful for monad transformers stacks if the `TVar` is used+-- in different monad stacks.+--+castStrictTVar :: LazyTVar m ~ LazyTVar n+               => StrictTVar m a -> StrictTVar n a+castStrictTVar StrictTVar {tvar} = StrictTVar {tvar}++-- | Get the underlying @TVar@+--+-- Since we obviously cannot guarantee that updates to this 'LazyTVar' will be+-- strict, this should be used with caution.+toLazyTVar :: StrictTVar m a -> LazyTVar m a+toLazyTVar StrictTVar { tvar } = tvar++fromLazyTVar :: LazyTVar m a -> StrictTVar m a+fromLazyTVar = StrictTVar++newTVar :: MonadSTM m => a -> STM m (StrictTVar m a)+newTVar !a = StrictTVar <$> Lazy.newTVar a++newTVarIO :: MonadSTM m => a -> m (StrictTVar m a)+newTVarIO !a = StrictTVar <$> Lazy.newTVarIO a++readTVar :: MonadSTM m => StrictTVar m a -> STM m a+readTVar StrictTVar { tvar } = Lazy.readTVar tvar++readTVarIO :: MonadSTM m => StrictTVar m a -> m a+readTVarIO StrictTVar { tvar } = Lazy.readTVarIO tvar++writeTVar :: MonadSTM m => StrictTVar m a -> a -> STM m ()+writeTVar v !a = Lazy.writeTVar (tvar v) a++modifyTVar :: MonadSTM m => StrictTVar m a -> (a -> a) -> STM m ()+modifyTVar v f = readTVar v >>= writeTVar v . f++stateTVar :: MonadSTM m => StrictTVar m s -> (s -> (a, s)) -> STM m a+stateTVar v f = do+    a <- readTVar v+    let (b, a') = f a+    writeTVar v a'+    return b++swapTVar :: MonadSTM m => StrictTVar m a -> a -> STM m a+swapTVar v a' = do+    a <- readTVar v+    writeTVar v a'+    return a
+ strict-stm/README.md view
@@ -0,0 +1,18 @@+# Strict Software Transaction Memory++The `io-classes:strict-stm` package provides a strict interface to software transaction+memory.  It builds on top of [`io-classes:io-classes`] and thus it provides the interface+for both [`stm`] as well as [`io-sim`].++# Novel testing / space-leak elimination approach++The strict interface provides a novel way of testing/eliminating space-leaks+which might lurk in `stm` shared mutable variables.  Together with the+[`nothunks`] library it was successfully used to eliminate and keep a large+system ([`cardano-node`]) space leak free.++[`cardano-node`]: https://www.github.com/input-output-hk/cardano-node+[`io-classes:io-classes`]: https://hackage.haskell.org/package/io-classes+[`io-sim`]: https://hackage.haskell.org/package/io-sim+[`nothunks`]: https://hackage.haskell.org/package/nothunks+[`stm`]: https://hackage.haskell.org/package/stm
+ test/Test/Control/Concurrent/Class/MonadMVar/Strict/WHNF.hs view
@@ -0,0 +1,123 @@+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++-- | Test whether functions on 'StrictMVar's correctly force values to WHNF+-- before they are put inside the 'StrictMVar'.+module Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF+  ( prop_newMVar+  , prop_putMVar+  , prop_swapMVar+  , prop_tryPutMVar+  , prop_modifyMVar_+  , prop_modifyMVar+  , prop_modifyMVarMasked_+  , prop_modifyMVarMasked+  , (.:)+  ) where++import Control.Concurrent.Class.MonadMVar.Strict+import Control.Monad (void)+import Data.Typeable (Typeable)+import NoThunks.Class (OnlyCheckWhnf (OnlyCheckWhnf), unsafeNoThunks)+import Test.QuickCheck+import Test.QuickCheck.Monadic (PropertyM, monitor, run)++{-------------------------------------------------------------------------------+  Utilities+-------------------------------------------------------------------------------}++infixr 9 .:++(.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z)+(.:) g f x0 x1 = g (f x0 x1)++isInWHNF :: (MonadMVar m, Typeable a) => StrictMVar m a -> PropertyM m Bool+isInWHNF v = do+    x <- run $ readMVar v+    case unsafeNoThunks (OnlyCheckWhnf x) of+      Nothing    -> pure True+      Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo)+                 >> pure False++{-------------------------------------------------------------------------------+  Properties+-------------------------------------------------------------------------------}++prop_newMVar ::+     MonadMVar m+  => Int+  -> Fun Int Int+  -> PropertyM m Bool+prop_newMVar x f = do+    v <- run $ newMVar (applyFun f x)+    isInWHNF v++prop_putMVar ::+     MonadMVar m+  => Int+  -> Fun Int Int+  -> PropertyM m Bool+prop_putMVar x f = do+    v <- run newEmptyMVar+    run $ putMVar v (applyFun f x)+    isInWHNF v++prop_swapMVar ::+     MonadMVar m+  => Int+  -> Fun Int Int+  -> PropertyM m Bool+prop_swapMVar x f = do+    v <- run $ newMVar x+    void $ run $ swapMVar v (applyFun f x)+    isInWHNF v++prop_tryPutMVar ::+     MonadMVar m+  => Int+  -> Fun Int Int+  -> PropertyM m Bool+prop_tryPutMVar x f = do+    v <- run newEmptyMVar+    b <- run $ tryPutMVar v (applyFun f x)+    b' <- isInWHNF v+    pure (b && b')++prop_modifyMVar_ ::+     MonadMVar m+  => Int+  -> Fun Int Int+  -> PropertyM m Bool+prop_modifyMVar_ x f =do+    v <-  run $ newMVar x+    run $ modifyMVar_ v (pure . applyFun f)+    isInWHNF v++prop_modifyMVar ::+     MonadMVar m+  => Int+  -> Fun Int (Int, Char)+  -> PropertyM m Bool+prop_modifyMVar x f =do+    v <-  run $ newMVar x+    void $ run $ modifyMVar v (pure . applyFun f)+    isInWHNF v++prop_modifyMVarMasked_ ::+     MonadMVar m+  => Int+  -> Fun Int Int+  -> PropertyM m Bool+prop_modifyMVarMasked_ x f =do+    v <-  run $ newMVar x+    void $ run $ modifyMVarMasked_ v (pure . applyFun f)+    isInWHNF v++prop_modifyMVarMasked ::+     MonadMVar m+  => Int+  -> Fun Int (Int, Char)+  -> PropertyM m Bool+prop_modifyMVarMasked x f =do+    v <-  run $ newMVar x+    void $ run $ modifyMVarMasked v (pure . applyFun f)+    isInWHNF v