packages feed

io-classes 1.8.0.1 → 1.9.0.0

raw patch · 47 files changed

+3193/−3034 lines, 47 filesdep ~time

Dependency ranges changed: time

Files

CHANGELOG.md view
@@ -1,7 +1,27 @@ # Revsion history of io-classes -### 1.8.0.1+## next release +### Breaking changes++### 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@@ -25,13 +45,13 @@   type classes. * Support ghc-9.12 -### 1.7.0.0+## 1.7.0.0  ### Breaking changes  * Renamed `io-classes:io-classes-mtl` as `io-classes:mtl`. -### 1.6.0.0+## 1.6.0.0  ### Breaking changes
io-classes.cabal view
@@ -1,6 +1,6 @@ cabal-version:       3.4 name:                io-classes-version:             1.8.0.1+version:             1.9.0.0 synopsis:            Type classes for concurrency with STM, ST and timing description:   IO Monad class hierarchy compatible with:@@ -63,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.@@ -87,6 +87,7 @@                        Control.Monad.Class.MonadTime                        Control.Monad.Class.MonadTimer                        Control.Monad.Class.MonadTest+                       Control.Monad.Class.MonadUnique   default-language:    GHC2021   default-extensions:  LambdaCase   build-depends:       base  >=4.16 && <4.22,@@ -96,7 +97,7 @@                        mtl   >=2.2 && <2.4,                        primitive >= 0.7 && <0.11,                        stm   >=2.5 && <2.5.2 || ^>=2.5.3,-                       time  >=1.9.1 && <1.13+                       time  >=1.9.1 && <1.16   if impl(ghc >= 9.10)     build-depends:     ghc-internal @@ -174,6 +175,7 @@                    ,  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/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,34 @@+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
+ 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 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/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
si-timers/src/Control/Monad/Class/MonadTime/SI.hs view
@@ -26,22 +26,26 @@  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.+-- | 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, Show, Generic)+  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
si-timers/src/Control/Monad/Class/MonadTimer/SI.hs view
@@ -5,6 +5,7 @@     -- * Auxiliary functions   , diffTimeToMicrosecondsAsInt   , microsecondsAsIntToDiffTime+  , roundDiffTimeToMicroseconds     -- * Re-exports   , DiffTime   , MonadFork@@ -54,9 +55,24 @@ 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.@@ -68,6 +84,9 @@ -- 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@@ -103,6 +122,11 @@ 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
si-timers/test/Test/MonadTimer.hs view
@@ -17,6 +17,8 @@         prop_diffTimeToMicrosecondsAsIntLeftInverse     , testProperty "diffTimeToMicroseconds right inverse"         prop_diffTimeToMicrosecondsAsIntRightInverse+    , testProperty "roundToMicroseconds"+        prop_roundDiffTimeToMicroseconds     ]  newtype IntDistr = IntDistr Int@@ -88,3 +90,21 @@          -> "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,234 +0,0 @@-{-# 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)
− 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,31 +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-  , debugTraceTMVar-  , debugTraceTMVarIO-  ) 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,28 +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-  , debugTraceTVar-  , debugTraceTVarIO-  ) where--import Control.Monad.Class.MonadSTM.Internal
− src/Control/Monad/Class/MonadAsync.hs 
@@ -1,616 +0,0 @@-{-# 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)
− 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,95 +0,0 @@-{-# 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
− src/Control/Monad/Class/MonadST.hs 
@@ -1,57 +0,0 @@-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,29 +0,0 @@-{-# 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.
− src/Control/Monad/Class/MonadSTM/Internal.hs 
@@ -1,1306 +0,0 @@-{-# 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 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 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
− 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,328 +0,0 @@-{-# 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 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
− src/Control/Monad/Class/MonadTime.hs 
@@ -1,55 +0,0 @@--- | <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,62 +0,0 @@-{-# 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)