diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/io-classes.cabal b/io-classes.cabal --- a/io-classes.cabal +++ b/io-classes.cabal @@ -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, diff --git a/io-classes/Control/Concurrent/Class/MonadMVar.hs b/io-classes/Control/Concurrent/Class/MonadMVar.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Concurrent/Class/MonadMVar.hs @@ -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) diff --git a/io-classes/Control/Concurrent/Class/MonadSTM.hs b/io-classes/Control/Concurrent/Class/MonadSTM.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Concurrent/Class/MonadSTM.hs @@ -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 + diff --git a/io-classes/Control/Concurrent/Class/MonadSTM/TArray.hs b/io-classes/Control/Concurrent/Class/MonadSTM/TArray.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Concurrent/Class/MonadSTM/TArray.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrent.STM.TArray` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TArray (type TArray) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/io-classes/Control/Concurrent/Class/MonadSTM/TBQueue.hs b/io-classes/Control/Concurrent/Class/MonadSTM/TBQueue.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Concurrent/Class/MonadSTM/TBQueue.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrent.STM.TVar` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TBQueue + ( -- * MonadSTM + type TBQueue + , newTBQueue + , newTBQueueIO + , readTBQueue + , tryReadTBQueue + , peekTBQueue + , tryPeekTBQueue + , flushTBQueue + , writeTBQueue + , lengthTBQueue + , isEmptyTBQueue + , isFullTBQueue + , unGetTBQueue + -- * MonadLabelledSTM + , labelTBQueue + , labelTBQueueIO + -- * MonadTraceSTM + , traceTBQueue + , traceTBQueueIO + ) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/io-classes/Control/Concurrent/Class/MonadSTM/TChan.hs b/io-classes/Control/Concurrent/Class/MonadSTM/TChan.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Concurrent/Class/MonadSTM/TChan.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrent.STM.TChan` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TChan + ( -- * MonadSTM + -- ** TChans + type TChan + -- * Construction + , newTChan + , newBroadcastTChan + , newTChanIO + , newBroadcastTChanIO + , dupTChan + , cloneTChan + -- ** Reading and writing + , readTChan + , tryReadTChan + , peekTChan + , tryPeekTChan + , writeTChan + , unGetTChan + , isEmptyTChan + ) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/io-classes/Control/Concurrent/Class/MonadSTM/TMVar.hs b/io-classes/Control/Concurrent/Class/MonadSTM/TMVar.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Concurrent/Class/MonadSTM/TMVar.hs @@ -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 diff --git a/io-classes/Control/Concurrent/Class/MonadSTM/TQueue.hs b/io-classes/Control/Concurrent/Class/MonadSTM/TQueue.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Concurrent/Class/MonadSTM/TQueue.hs @@ -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 diff --git a/io-classes/Control/Concurrent/Class/MonadSTM/TSem.hs b/io-classes/Control/Concurrent/Class/MonadSTM/TSem.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Concurrent/Class/MonadSTM/TSem.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- | This module corresponds to `Control.Concurrent.STM.TSem` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.TSem + ( -- * MonadSTM + type TSem + , newTSem + , waitTSem + , signalTSem + , signalTSemN + -- * MonadLabelledSTM + , labelTSem + , labelTSemIO + -- * MonadTraceSTM + , traceTSem + , traceTSemIO + ) where + +import Control.Monad.Class.MonadSTM.Internal diff --git a/io-classes/Control/Concurrent/Class/MonadSTM/TVar.hs b/io-classes/Control/Concurrent/Class/MonadSTM/TVar.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Concurrent/Class/MonadSTM/TVar.hs @@ -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 diff --git a/io-classes/Control/Monad/Class/MonadAsync.hs b/io-classes/Control/Monad/Class/MonadAsync.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadAsync.hs @@ -0,0 +1,616 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeFamilyDependencies #-} +-- MonadAsync's ReaderT instance is undecidable. +{-# LANGUAGE UndecidableInstances #-} + +-- | API compatible with both +-- 'IO' and . +-- +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. + -- + -- + -- See 'Async.waitEitherCatch'. + waitEitherCatch :: Async m a -> Async m b -> m (Either (Either SomeException a) + (Either SomeException b)) + -- | See 'Async.waitEitherCancel'. + waitEitherCancel :: Async m a -> Async m b -> m (Either a b) + -- | See 'Async.waitEitherCatchCancel'. + waitEitherCatchCancel :: Async m a -> Async m b -> m (Either (Either SomeException a) + (Either SomeException b)) + -- | See 'Async.waitEither_'. + waitEither_ :: Async m a -> Async m b -> m () + -- | See 'Async.waitBoth'. + waitBoth :: Async m a -> Async m b -> m (a, b) + + -- | See 'Async.race'. + race :: m a -> m b -> m (Either a b) + -- | See 'Async.race_'. + race_ :: m a -> m b -> m () + -- | See 'Async.concurrently'. + concurrently :: m a -> m b -> m (a,b) + -- | See 'Async.concurrently_'. + concurrently_ :: m a -> m b -> m () + + -- | See 'Async.concurrently_'. + asyncWithUnmask :: ((forall b . m b -> m b) -> m a) -> m (Async m a) + -- | See 'Async.asyncOnWithUnmask'. + asyncOnWithUnmask :: Int -> ((forall b . m b -> m b) -> m a) -> m (Async m a) + -- | See 'Async.withAsyncWithUnmask'. + withAsyncWithUnmask :: ((forall c. m c -> m c) -> m a) -> (Async m a -> m b) -> m b + -- | See 'Async.withAsyncOnWithUnmask'. + withAsyncOnWithUnmask :: Int -> ((forall c. m c -> m c) -> m a) -> (Async m a -> m b) -> m b + + -- | See 'Async.compareAsyncs'. + compareAsyncs :: Async m a -> Async m b -> Ordering + + -- default implementations + default withAsync :: MonadMask m => m a -> (Async m a -> m b) -> m b + default withAsyncBound:: MonadMask m => m a -> (Async m a -> m b) -> m b + default withAsyncOn :: MonadMask m => Int -> m a -> (Async m a -> m b) -> m b + default withAsyncWithUnmask + :: MonadMask m => ((forall c. m c -> m c) -> m a) + -> (Async m a -> m b) -> m b + default withAsyncOnWithUnmask + :: MonadMask m => Int + -> ((forall c. m c -> m c) -> m a) + -> (Async m a -> m b) -> m b + default uninterruptibleCancel + :: MonadMask m => Async m a -> m () + default waitAnyCancel :: MonadThrow m => [Async m a] -> m (Async m a, a) + default waitAnyCatchCancel :: MonadThrow m => [Async m a] + -> m (Async m a, Either SomeException a) + default waitEitherCancel :: MonadThrow m => Async m a -> Async m b + -> m (Either a b) + default waitEitherCatchCancel :: MonadThrow m => Async m a -> Async m b + -> m (Either (Either SomeException a) + (Either SomeException b)) + default compareAsyncs :: Ord (ThreadId m) + => Async m a -> Async m b -> Ordering + + withAsync action inner = mask $ \restore -> do + a <- async (restore action) + restore (inner a) + `finally` uninterruptibleCancel a + + withAsyncBound action inner = mask $ \restore -> do + a <- asyncBound (restore action) + restore (inner a) + `finally` uninterruptibleCancel a + + withAsyncOn n action inner = mask $ \restore -> do + a <- asyncOn n (restore action) + restore (inner a) + `finally` uninterruptibleCancel a + + + withAsyncWithUnmask action inner = mask $ \restore -> do + a <- asyncWithUnmask action + restore (inner a) + `finally` uninterruptibleCancel a + + withAsyncOnWithUnmask n action inner = mask $ \restore -> do + a <- asyncOnWithUnmask n action + restore (inner a) + `finally` uninterruptibleCancel a + + wait = atomically . waitSTM + poll = atomically . pollSTM + waitCatch = atomically . waitCatchSTM + + uninterruptibleCancel = uninterruptibleMask_ . cancel + + waitAny = atomically . waitAnySTM + waitAnyCatch = atomically . waitAnyCatchSTM + waitEither left right = atomically (waitEitherSTM left right) + waitEither_ left right = atomically (waitEitherSTM_ left right) + waitEitherCatch left right = atomically (waitEitherCatchSTM left right) + waitBoth left right = atomically (waitBothSTM left right) + + waitAnyCancel asyncs = + waitAny asyncs `finally` mapM_ cancel asyncs + + waitAnyCatchCancel asyncs = + waitAnyCatch asyncs `finally` mapM_ cancel asyncs + + waitEitherCancel left right = + waitEither left right `finally` (cancel left >> cancel right) + + waitEitherCatchCancel left right = + waitEitherCatch left right `finally` (cancel left >> cancel right) + + race left right = withAsync left $ \a -> + withAsync right $ \b -> + waitEither a b + + race_ left right = withAsync left $ \a -> + withAsync right $ \b -> + waitEither_ a b + + concurrently left right = withAsync left $ \a -> + withAsync right $ \b -> + waitBoth a b + + concurrently_ left right = void $ concurrently left right + + compareAsyncs a b = asyncThreadId a `compare` asyncThreadId b + +-- | Similar to 'Async.Concurrently' but which works for any 'MonadAsync' +-- instance. +-- +newtype Concurrently m a = Concurrently { runConcurrently :: m a } + +instance Functor m => Functor (Concurrently m) where + fmap f (Concurrently ma) = Concurrently (fmap f ma) + +instance MonadAsync m => Applicative (Concurrently m) where + pure = Concurrently . pure + + Concurrently fn <*> Concurrently as = + Concurrently $ + (\(f, a) -> f a) + `fmap` + concurrently fn as + +instance ( MonadAsync m + , MonadTimer m + ) => Alternative (Concurrently m) where + empty = Concurrently $ forever (threadDelay 86400) + Concurrently as <|> Concurrently bs = + Concurrently $ either id id <$> as `race` bs + +instance ( Semigroup a + , MonadAsync m + ) => Semigroup (Concurrently m a) where + (<>) = liftA2 (<>) + +instance ( Monoid a + , MonadAsync m + ) => Monoid (Concurrently m a) where + mempty = pure mempty + + +-- | See 'Async.mapConcurrently'. +mapConcurrently :: (Traversable t, MonadAsync m) => (a -> m b) -> t a -> m (t b) +mapConcurrently f = runConcurrently . traverse (Concurrently . f) + +-- | See 'Async.forConcurrently'. +forConcurrently :: (Traversable t, MonadAsync m) => t a -> (a -> m b) -> m (t b) +forConcurrently = flip mapConcurrently + +-- | See 'Async.mapConcurrently_'. +mapConcurrently_ :: (Foldable f, MonadAsync m) => (a -> m b) -> f a -> m () +mapConcurrently_ f = runConcurrently . foldMap (Concurrently . void . f) + +-- | See 'Async.forConcurrently_'. +forConcurrently_ :: (Foldable f, MonadAsync m) => f a -> (a -> m b) -> m () +forConcurrently_ = flip mapConcurrently_ + +-- | See 'Async.replicateConcurrently'. +replicateConcurrently :: MonadAsync m => Int -> m a -> m [a] +replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently + +-- | See 'Async.replicateConcurrently_'. +replicateConcurrently_ :: MonadAsync m => Int -> m a -> m () +replicateConcurrently_ cnt = runConcurrently . fold . replicate cnt . Concurrently . void + + +-- +-- Instance for IO uses the existing async library implementations +-- + +instance MonadAsync IO where + + type Async IO = Async.Async + + async = Async.async + asyncBound = Async.asyncBound + asyncOn = Async.asyncOn + asyncThreadId = Async.asyncThreadId + withAsync = Async.withAsync + withAsyncBound = Async.withAsyncBound + withAsyncOn = Async.withAsyncOn + + waitSTM = Async.waitSTM + pollSTM = Async.pollSTM + waitCatchSTM = Async.waitCatchSTM + + waitAnySTM = Async.waitAnySTM + waitAnyCatchSTM = Async.waitAnyCatchSTM + waitEitherSTM = Async.waitEitherSTM + waitEitherSTM_ = Async.waitEitherSTM_ + waitEitherCatchSTM = Async.waitEitherCatchSTM + waitBothSTM = Async.waitBothSTM + + wait = Async.wait + poll = Async.poll + waitCatch = Async.waitCatch + cancel = Async.cancel + cancelWith = Async.cancelWith + uninterruptibleCancel = Async.uninterruptibleCancel + + waitAny = Async.waitAny + waitAnyCatch = Async.waitAnyCatch + waitAnyCancel = Async.waitAnyCancel + waitAnyCatchCancel = Async.waitAnyCatchCancel + waitEither = Async.waitEither + waitEitherCatch = Async.waitEitherCatch + waitEitherCancel = Async.waitEitherCancel + waitEitherCatchCancel = Async.waitEitherCatchCancel + waitEither_ = Async.waitEither_ + waitBoth = Async.waitBoth + + race = Async.race + race_ = Async.race_ + concurrently = Async.concurrently + concurrently_ = Async.concurrently_ + + asyncWithUnmask = Async.asyncWithUnmask + asyncOnWithUnmask = Async.asyncOnWithUnmask + withAsyncWithUnmask = Async.withAsyncWithUnmask + withAsyncOnWithUnmask = Async.withAsyncOnWithUnmask + + compareAsyncs = Async.compareAsyncs + + +-- +-- Linking +-- +-- Adapted from "Control.Concurrent.Async" +-- +-- We don't use the implementation of linking from 'Control.Concurrent.Async' +-- directly because if we /did/ use the real implementation, then the mock +-- implementation and the real implementation would not be able to throw the +-- same exception, because the exception type used by the real implementation +-- is +-- +-- > data ExceptionInLinkedThread = +-- > forall a . ExceptionInLinkedThread (Async a) SomeException +-- +-- containing a reference to the real 'Async' type. +-- + +-- | Exception from child thread re-raised in parent thread +-- +-- We record the thread ID of the child thread as a 'String'. This avoids +-- an @m@ parameter in the type, which is important: 'ExceptionInLinkedThread' +-- must be an instance of 'Exception', requiring it to be 'Typeable'; if @m@ +-- appeared in the type, we would require @m@ to be 'Typeable', which does not +-- work with with the simulator, as it would require a 'Typeable' constraint +-- on the @s@ parameter of 'IOSim'. +data ExceptionInLinkedThread = ExceptionInLinkedThread String SomeException + +instance Show ExceptionInLinkedThread where + showsPrec p (ExceptionInLinkedThread a e) = + showParen (p >= 11) $ + showString "ExceptionInLinkedThread " . + showsPrec 11 a . + showString " " . + showsPrec 11 e + +instance Exception ExceptionInLinkedThread where + fromException = E.asyncExceptionFromException + toException = E.asyncExceptionToException + +-- | Like 'Async.link'. +link :: (MonadAsync m, MonadFork m, MonadMask m) + => Async m a -> m () +link = linkOnly (not . isCancel) + +-- | Like 'Async.linkOnly'. +linkOnly :: forall m a. (MonadAsync m, MonadFork m, MonadMask m) + => (SomeException -> Bool) -> Async m a -> m () +linkOnly shouldThrow a = do + tid <- myThreadId + void $ forkRepeat ("linkToOnly " <> show linkedThreadId) $ do + r <- waitCatch a + case r of + Left e | shouldThrow e -> throwTo tid (exceptionInLinkedThread e) + _otherwise -> return () + where + linkedThreadId :: ThreadId m + linkedThreadId = asyncThreadId a + + exceptionInLinkedThread :: SomeException -> ExceptionInLinkedThread + exceptionInLinkedThread = + ExceptionInLinkedThread (show linkedThreadId) + +-- | Like 'Async.link2'. +link2 :: (MonadAsync m, MonadFork m, MonadMask m) + => Async m a -> Async m b -> m () +link2 = link2Only (not . isCancel) + +-- | Like 'Async.link2Only'. +link2Only :: (MonadAsync m, MonadFork m, MonadMask m) + => (SomeException -> Bool) -> Async m a -> Async m b -> m () +link2Only shouldThrow left right = + void $ forkRepeat ("link2Only " <> show (tl, tr)) $ do + r <- waitEitherCatch left right + case r of + Left (Left e) | shouldThrow e -> + throwTo tr (ExceptionInLinkedThread (show tl) e) + Right (Left e) | shouldThrow e -> + throwTo tl (ExceptionInLinkedThread (show tr) e) + _ -> return () + where + tl = asyncThreadId left + tr = asyncThreadId right + +isCancel :: SomeException -> Bool +isCancel e + | Just AsyncCancelled <- fromException e = True + | otherwise = False + +forkRepeat :: (MonadFork m, MonadMask m) => String -> m a -> m (ThreadId m) +forkRepeat label action = + mask $ \restore -> + let go = do r <- tryAll (restore action) + case r of + Left _ -> go + _ -> return () + in forkIO (labelThisThread label >> go) + +tryAll :: MonadCatch m => m a -> m (Either SomeException a) +tryAll = try + + +-- +-- ReaderT instance +-- + +newtype AsyncReaderT r (m :: Type -> Type) a = + AsyncReaderT { getAsyncReaderT :: Async m a } + +instance ( MonadAsync m + , MonadCatch (STM m) + , MonadFork m + , MonadMask m + ) => MonadAsync (ReaderT r m) where + type Async (ReaderT r m) = AsyncReaderT r m + asyncThreadId (AsyncReaderT a) = asyncThreadId a + + async (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> async (ma r) + asyncBound (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncBound (ma r) + asyncOn n (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncOn n (ma r) + withAsync (ReaderT ma) f = ReaderT $ \r -> withAsync (ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + withAsyncBound (ReaderT ma) f = ReaderT $ \r -> withAsyncBound (ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + withAsyncOn n (ReaderT ma) f = ReaderT $ \r -> withAsyncOn n (ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + + asyncWithUnmask f = ReaderT $ \r -> fmap AsyncReaderT + $ asyncWithUnmask + $ \unmask -> runReaderT (f (liftF unmask)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + asyncOnWithUnmask n f = ReaderT $ \r -> fmap AsyncReaderT + $ asyncOnWithUnmask n + $ \unmask -> runReaderT (f (liftF unmask)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + withAsyncWithUnmask action f = + ReaderT $ \r -> withAsyncWithUnmask (\unmask -> case action (liftF unmask) of + ReaderT ma -> ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + withAsyncOnWithUnmask n action f = + ReaderT $ \r -> withAsyncOnWithUnmask n (\unmask -> case action (liftF unmask) of + ReaderT ma -> ma r) + $ \a -> runReaderT (f (AsyncReaderT a)) r + where + liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a + liftF g (ReaderT r) = ReaderT (g . r) + + waitCatchSTM = lift . waitCatchSTM . getAsyncReaderT + pollSTM = lift . pollSTM . getAsyncReaderT + + race (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race (ma r) (mb r) + race_ (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race_ (ma r) (mb r) + concurrently (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> concurrently (ma r) (mb r) + + wait = lift . wait . getAsyncReaderT + poll = lift . poll . getAsyncReaderT + waitCatch = lift . waitCatch . getAsyncReaderT + cancel = lift . cancel . getAsyncReaderT + uninterruptibleCancel = lift . uninterruptibleCancel + . getAsyncReaderT + cancelWith = (lift .: cancelWith) + . getAsyncReaderT + waitAny = fmap (first AsyncReaderT) + . lift . waitAny + . map getAsyncReaderT + waitAnyCatch = fmap (first AsyncReaderT) + . lift . waitAnyCatch + . map getAsyncReaderT + waitAnyCancel = fmap (first AsyncReaderT) + . lift . waitAnyCancel + . map getAsyncReaderT + waitAnyCatchCancel = fmap (first AsyncReaderT) + . lift . waitAnyCatchCancel + . map getAsyncReaderT + waitEither = on (lift .: waitEither) getAsyncReaderT + waitEitherCatch = on (lift .: waitEitherCatch) getAsyncReaderT + waitEitherCancel = on (lift .: waitEitherCancel) getAsyncReaderT + waitEitherCatchCancel = on (lift .: waitEitherCatchCancel) getAsyncReaderT + waitEither_ = on (lift .: waitEither_) getAsyncReaderT + waitBoth = on (lift .: waitBoth) getAsyncReaderT + + +-- +-- Utilities +-- + +(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) +(f .: g) x y = f (g x y) + + +-- | A higher order version of 'Data.Function.on' +-- +on :: (f a -> f b -> c) + -> (forall x. g x -> f x) + -> (g a -> g b -> c) +on f g = \a b -> f (g a) (g b) diff --git a/io-classes/Control/Monad/Class/MonadEventlog.hs b/io-classes/Control/Monad/Class/MonadEventlog.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadEventlog.hs @@ -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 diff --git a/io-classes/Control/Monad/Class/MonadFork.hs b/io-classes/Control/Monad/Class/MonadFork.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadFork.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +-- | A generalisation of +-- +-- API to both 'IO' and . +-- +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 diff --git a/io-classes/Control/Monad/Class/MonadST.hs b/io-classes/Control/Monad/Class/MonadST.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadST.hs @@ -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) diff --git a/io-classes/Control/Monad/Class/MonadSTM.hs b/io-classes/Control/Monad/Class/MonadSTM.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadSTM.hs @@ -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. diff --git a/io-classes/Control/Monad/Class/MonadSTM/Internal.hs b/io-classes/Control/Monad/Class/MonadSTM/Internal.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadSTM/Internal.hs @@ -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 diff --git a/io-classes/Control/Monad/Class/MonadSay.hs b/io-classes/Control/Monad/Class/MonadSay.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadSay.hs @@ -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 diff --git a/io-classes/Control/Monad/Class/MonadTest.hs b/io-classes/Control/Monad/Class/MonadTest.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadTest.hs @@ -0,0 +1,17 @@ +module Control.Monad.Class.MonadTest (MonadTest (..)) where + +import Control.Monad.Reader + +-- | A helper monad for /IOSimPOR/. +class Monad m => MonadTest m where + -- | Mark a thread for schedule exploration. All threads that are forked by + -- it are also included in the exploration. + -- + exploreRaces :: m () + exploreRaces = return () + +instance MonadTest IO + +instance MonadTest m => MonadTest (ReaderT e m) where + exploreRaces = lift exploreRaces + diff --git a/io-classes/Control/Monad/Class/MonadThrow.hs b/io-classes/Control/Monad/Class/MonadThrow.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadThrow.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +-- | A generalisation of +-- +-- API to both 'IO' and . +-- +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 + -- 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 diff --git a/io-classes/Control/Monad/Class/MonadTime.hs b/io-classes/Control/Monad/Class/MonadTime.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadTime.hs @@ -0,0 +1,55 @@ +-- | and +-- time API compatible with both +-- 'IO' and . +-- +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 diff --git a/io-classes/Control/Monad/Class/MonadTimer.hs b/io-classes/Control/Monad/Class/MonadTimer.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadTimer.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Provides classes to handle delays and timeouts which generalised +-- API to both 'IO' and +-- . +-- +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) diff --git a/io-classes/Control/Monad/Class/MonadUnique.hs b/io-classes/Control/Monad/Class/MonadUnique.hs new file mode 100644 --- /dev/null +++ b/io-classes/Control/Monad/Class/MonadUnique.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +-- | A generalisation of the +-- +-- API to both 'IO' and . +-- +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 diff --git a/mtl/Control/Monad/Class/MonadUnique/Trans.hs b/mtl/Control/Monad/Class/MonadUnique/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/MonadUnique/Trans.hs @@ -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 diff --git a/si-timers/src/Control/Monad/Class/MonadTime/SI.hs b/si-timers/src/Control/Monad/Class/MonadTime/SI.hs --- a/si-timers/src/Control/Monad/Class/MonadTime/SI.hs +++ b/si-timers/src/Control/Monad/Class/MonadTime/SI.hs @@ -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 diff --git a/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs b/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs --- a/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs +++ b/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs @@ -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 diff --git a/si-timers/test/Test/MonadTimer.hs b/si-timers/test/Test/MonadTimer.hs --- a/si-timers/test/Test/MonadTimer.hs +++ b/si-timers/test/Test/MonadTimer.hs @@ -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 diff --git a/src/Control/Concurrent/Class/MonadMVar.hs b/src/Control/Concurrent/Class/MonadMVar.hs deleted file mode 100644 --- a/src/Control/Concurrent/Class/MonadMVar.hs +++ /dev/null @@ -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) diff --git a/src/Control/Concurrent/Class/MonadSTM.hs b/src/Control/Concurrent/Class/MonadSTM.hs deleted file mode 100644 --- a/src/Control/Concurrent/Class/MonadSTM.hs +++ /dev/null @@ -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 - diff --git a/src/Control/Concurrent/Class/MonadSTM/TArray.hs b/src/Control/Concurrent/Class/MonadSTM/TArray.hs deleted file mode 100644 --- a/src/Control/Concurrent/Class/MonadSTM/TArray.hs +++ /dev/null @@ -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 diff --git a/src/Control/Concurrent/Class/MonadSTM/TBQueue.hs b/src/Control/Concurrent/Class/MonadSTM/TBQueue.hs deleted file mode 100644 --- a/src/Control/Concurrent/Class/MonadSTM/TBQueue.hs +++ /dev/null @@ -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 diff --git a/src/Control/Concurrent/Class/MonadSTM/TChan.hs b/src/Control/Concurrent/Class/MonadSTM/TChan.hs deleted file mode 100644 --- a/src/Control/Concurrent/Class/MonadSTM/TChan.hs +++ /dev/null @@ -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 diff --git a/src/Control/Concurrent/Class/MonadSTM/TMVar.hs b/src/Control/Concurrent/Class/MonadSTM/TMVar.hs deleted file mode 100644 --- a/src/Control/Concurrent/Class/MonadSTM/TMVar.hs +++ /dev/null @@ -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 diff --git a/src/Control/Concurrent/Class/MonadSTM/TQueue.hs b/src/Control/Concurrent/Class/MonadSTM/TQueue.hs deleted file mode 100644 --- a/src/Control/Concurrent/Class/MonadSTM/TQueue.hs +++ /dev/null @@ -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 diff --git a/src/Control/Concurrent/Class/MonadSTM/TSem.hs b/src/Control/Concurrent/Class/MonadSTM/TSem.hs deleted file mode 100644 --- a/src/Control/Concurrent/Class/MonadSTM/TSem.hs +++ /dev/null @@ -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 diff --git a/src/Control/Concurrent/Class/MonadSTM/TVar.hs b/src/Control/Concurrent/Class/MonadSTM/TVar.hs deleted file mode 100644 --- a/src/Control/Concurrent/Class/MonadSTM/TVar.hs +++ /dev/null @@ -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 diff --git a/src/Control/Monad/Class/MonadAsync.hs b/src/Control/Monad/Class/MonadAsync.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadAsync.hs +++ /dev/null @@ -1,616 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilyDependencies #-} --- MonadAsync's ReaderT instance is undecidable. -{-# LANGUAGE UndecidableInstances #-} - --- | API compatible with both --- 'IO' and . --- -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. - -- - -- - -- See 'Async.waitEitherCatch'. - waitEitherCatch :: Async m a -> Async m b -> m (Either (Either SomeException a) - (Either SomeException b)) - -- | See 'Async.waitEitherCancel'. - waitEitherCancel :: Async m a -> Async m b -> m (Either a b) - -- | See 'Async.waitEitherCatchCancel'. - waitEitherCatchCancel :: Async m a -> Async m b -> m (Either (Either SomeException a) - (Either SomeException b)) - -- | See 'Async.waitEither_'. - waitEither_ :: Async m a -> Async m b -> m () - -- | See 'Async.waitBoth'. - waitBoth :: Async m a -> Async m b -> m (a, b) - - -- | See 'Async.race'. - race :: m a -> m b -> m (Either a b) - -- | See 'Async.race_'. - race_ :: m a -> m b -> m () - -- | See 'Async.concurrently'. - concurrently :: m a -> m b -> m (a,b) - -- | See 'Async.concurrently_'. - concurrently_ :: m a -> m b -> m () - - -- | See 'Async.concurrently_'. - asyncWithUnmask :: ((forall b . m b -> m b) -> m a) -> m (Async m a) - -- | See 'Async.asyncOnWithUnmask'. - asyncOnWithUnmask :: Int -> ((forall b . m b -> m b) -> m a) -> m (Async m a) - -- | See 'Async.withAsyncWithUnmask'. - withAsyncWithUnmask :: ((forall c. m c -> m c) -> m a) -> (Async m a -> m b) -> m b - -- | See 'Async.withAsyncOnWithUnmask'. - withAsyncOnWithUnmask :: Int -> ((forall c. m c -> m c) -> m a) -> (Async m a -> m b) -> m b - - -- | See 'Async.compareAsyncs'. - compareAsyncs :: Async m a -> Async m b -> Ordering - - -- default implementations - default withAsync :: MonadMask m => m a -> (Async m a -> m b) -> m b - default withAsyncBound:: MonadMask m => m a -> (Async m a -> m b) -> m b - default withAsyncOn :: MonadMask m => Int -> m a -> (Async m a -> m b) -> m b - default withAsyncWithUnmask - :: MonadMask m => ((forall c. m c -> m c) -> m a) - -> (Async m a -> m b) -> m b - default withAsyncOnWithUnmask - :: MonadMask m => Int - -> ((forall c. m c -> m c) -> m a) - -> (Async m a -> m b) -> m b - default uninterruptibleCancel - :: MonadMask m => Async m a -> m () - default waitAnyCancel :: MonadThrow m => [Async m a] -> m (Async m a, a) - default waitAnyCatchCancel :: MonadThrow m => [Async m a] - -> m (Async m a, Either SomeException a) - default waitEitherCancel :: MonadThrow m => Async m a -> Async m b - -> m (Either a b) - default waitEitherCatchCancel :: MonadThrow m => Async m a -> Async m b - -> m (Either (Either SomeException a) - (Either SomeException b)) - default compareAsyncs :: Ord (ThreadId m) - => Async m a -> Async m b -> Ordering - - withAsync action inner = mask $ \restore -> do - a <- async (restore action) - restore (inner a) - `finally` uninterruptibleCancel a - - withAsyncBound action inner = mask $ \restore -> do - a <- asyncBound (restore action) - restore (inner a) - `finally` uninterruptibleCancel a - - withAsyncOn n action inner = mask $ \restore -> do - a <- asyncOn n (restore action) - restore (inner a) - `finally` uninterruptibleCancel a - - - withAsyncWithUnmask action inner = mask $ \restore -> do - a <- asyncWithUnmask action - restore (inner a) - `finally` uninterruptibleCancel a - - withAsyncOnWithUnmask n action inner = mask $ \restore -> do - a <- asyncOnWithUnmask n action - restore (inner a) - `finally` uninterruptibleCancel a - - wait = atomically . waitSTM - poll = atomically . pollSTM - waitCatch = atomically . waitCatchSTM - - uninterruptibleCancel = uninterruptibleMask_ . cancel - - waitAny = atomically . waitAnySTM - waitAnyCatch = atomically . waitAnyCatchSTM - waitEither left right = atomically (waitEitherSTM left right) - waitEither_ left right = atomically (waitEitherSTM_ left right) - waitEitherCatch left right = atomically (waitEitherCatchSTM left right) - waitBoth left right = atomically (waitBothSTM left right) - - waitAnyCancel asyncs = - waitAny asyncs `finally` mapM_ cancel asyncs - - waitAnyCatchCancel asyncs = - waitAnyCatch asyncs `finally` mapM_ cancel asyncs - - waitEitherCancel left right = - waitEither left right `finally` (cancel left >> cancel right) - - waitEitherCatchCancel left right = - waitEitherCatch left right `finally` (cancel left >> cancel right) - - race left right = withAsync left $ \a -> - withAsync right $ \b -> - waitEither a b - - race_ left right = withAsync left $ \a -> - withAsync right $ \b -> - waitEither_ a b - - concurrently left right = withAsync left $ \a -> - withAsync right $ \b -> - waitBoth a b - - concurrently_ left right = void $ concurrently left right - - compareAsyncs a b = asyncThreadId a `compare` asyncThreadId b - --- | Similar to 'Async.Concurrently' but which works for any 'MonadAsync' --- instance. --- -newtype Concurrently m a = Concurrently { runConcurrently :: m a } - -instance Functor m => Functor (Concurrently m) where - fmap f (Concurrently ma) = Concurrently (fmap f ma) - -instance MonadAsync m => Applicative (Concurrently m) where - pure = Concurrently . pure - - Concurrently fn <*> Concurrently as = - Concurrently $ - (\(f, a) -> f a) - `fmap` - concurrently fn as - -instance ( MonadAsync m - , MonadTimer m - ) => Alternative (Concurrently m) where - empty = Concurrently $ forever (threadDelay 86400) - Concurrently as <|> Concurrently bs = - Concurrently $ either id id <$> as `race` bs - -instance ( Semigroup a - , MonadAsync m - ) => Semigroup (Concurrently m a) where - (<>) = liftA2 (<>) - -instance ( Monoid a - , MonadAsync m - ) => Monoid (Concurrently m a) where - mempty = pure mempty - - --- | See 'Async.mapConcurrently'. -mapConcurrently :: (Traversable t, MonadAsync m) => (a -> m b) -> t a -> m (t b) -mapConcurrently f = runConcurrently . traverse (Concurrently . f) - --- | See 'Async.forConcurrently'. -forConcurrently :: (Traversable t, MonadAsync m) => t a -> (a -> m b) -> m (t b) -forConcurrently = flip mapConcurrently - --- | See 'Async.mapConcurrently_'. -mapConcurrently_ :: (Foldable f, MonadAsync m) => (a -> m b) -> f a -> m () -mapConcurrently_ f = runConcurrently . foldMap (Concurrently . void . f) - --- | See 'Async.forConcurrently_'. -forConcurrently_ :: (Foldable f, MonadAsync m) => f a -> (a -> m b) -> m () -forConcurrently_ = flip mapConcurrently_ - --- | See 'Async.replicateConcurrently'. -replicateConcurrently :: MonadAsync m => Int -> m a -> m [a] -replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently - --- | See 'Async.replicateConcurrently_'. -replicateConcurrently_ :: MonadAsync m => Int -> m a -> m () -replicateConcurrently_ cnt = runConcurrently . fold . replicate cnt . Concurrently . void - - --- --- Instance for IO uses the existing async library implementations --- - -instance MonadAsync IO where - - type Async IO = Async.Async - - async = Async.async - asyncBound = Async.asyncBound - asyncOn = Async.asyncOn - asyncThreadId = Async.asyncThreadId - withAsync = Async.withAsync - withAsyncBound = Async.withAsyncBound - withAsyncOn = Async.withAsyncOn - - waitSTM = Async.waitSTM - pollSTM = Async.pollSTM - waitCatchSTM = Async.waitCatchSTM - - waitAnySTM = Async.waitAnySTM - waitAnyCatchSTM = Async.waitAnyCatchSTM - waitEitherSTM = Async.waitEitherSTM - waitEitherSTM_ = Async.waitEitherSTM_ - waitEitherCatchSTM = Async.waitEitherCatchSTM - waitBothSTM = Async.waitBothSTM - - wait = Async.wait - poll = Async.poll - waitCatch = Async.waitCatch - cancel = Async.cancel - cancelWith = Async.cancelWith - uninterruptibleCancel = Async.uninterruptibleCancel - - waitAny = Async.waitAny - waitAnyCatch = Async.waitAnyCatch - waitAnyCancel = Async.waitAnyCancel - waitAnyCatchCancel = Async.waitAnyCatchCancel - waitEither = Async.waitEither - waitEitherCatch = Async.waitEitherCatch - waitEitherCancel = Async.waitEitherCancel - waitEitherCatchCancel = Async.waitEitherCatchCancel - waitEither_ = Async.waitEither_ - waitBoth = Async.waitBoth - - race = Async.race - race_ = Async.race_ - concurrently = Async.concurrently - concurrently_ = Async.concurrently_ - - asyncWithUnmask = Async.asyncWithUnmask - asyncOnWithUnmask = Async.asyncOnWithUnmask - withAsyncWithUnmask = Async.withAsyncWithUnmask - withAsyncOnWithUnmask = Async.withAsyncOnWithUnmask - - compareAsyncs = Async.compareAsyncs - - --- --- Linking --- --- Adapted from "Control.Concurrent.Async" --- --- We don't use the implementation of linking from 'Control.Concurrent.Async' --- directly because if we /did/ use the real implementation, then the mock --- implementation and the real implementation would not be able to throw the --- same exception, because the exception type used by the real implementation --- is --- --- > data ExceptionInLinkedThread = --- > forall a . ExceptionInLinkedThread (Async a) SomeException --- --- containing a reference to the real 'Async' type. --- - --- | Exception from child thread re-raised in parent thread --- --- We record the thread ID of the child thread as a 'String'. This avoids --- an @m@ parameter in the type, which is important: 'ExceptionInLinkedThread' --- must be an instance of 'Exception', requiring it to be 'Typeable'; if @m@ --- appeared in the type, we would require @m@ to be 'Typeable', which does not --- work with with the simulator, as it would require a 'Typeable' constraint --- on the @s@ parameter of 'IOSim'. -data ExceptionInLinkedThread = ExceptionInLinkedThread String SomeException - -instance Show ExceptionInLinkedThread where - showsPrec p (ExceptionInLinkedThread a e) = - showParen (p >= 11) $ - showString "ExceptionInLinkedThread " . - showsPrec 11 a . - showString " " . - showsPrec 11 e - -instance Exception ExceptionInLinkedThread where - fromException = E.asyncExceptionFromException - toException = E.asyncExceptionToException - --- | Like 'Async.link'. -link :: (MonadAsync m, MonadFork m, MonadMask m) - => Async m a -> m () -link = linkOnly (not . isCancel) - --- | Like 'Async.linkOnly'. -linkOnly :: forall m a. (MonadAsync m, MonadFork m, MonadMask m) - => (SomeException -> Bool) -> Async m a -> m () -linkOnly shouldThrow a = do - tid <- myThreadId - void $ forkRepeat ("linkToOnly " <> show linkedThreadId) $ do - r <- waitCatch a - case r of - Left e | shouldThrow e -> throwTo tid (exceptionInLinkedThread e) - _otherwise -> return () - where - linkedThreadId :: ThreadId m - linkedThreadId = asyncThreadId a - - exceptionInLinkedThread :: SomeException -> ExceptionInLinkedThread - exceptionInLinkedThread = - ExceptionInLinkedThread (show linkedThreadId) - --- | Like 'Async.link2'. -link2 :: (MonadAsync m, MonadFork m, MonadMask m) - => Async m a -> Async m b -> m () -link2 = link2Only (not . isCancel) - --- | Like 'Async.link2Only'. -link2Only :: (MonadAsync m, MonadFork m, MonadMask m) - => (SomeException -> Bool) -> Async m a -> Async m b -> m () -link2Only shouldThrow left right = - void $ forkRepeat ("link2Only " <> show (tl, tr)) $ do - r <- waitEitherCatch left right - case r of - Left (Left e) | shouldThrow e -> - throwTo tr (ExceptionInLinkedThread (show tl) e) - Right (Left e) | shouldThrow e -> - throwTo tl (ExceptionInLinkedThread (show tr) e) - _ -> return () - where - tl = asyncThreadId left - tr = asyncThreadId right - -isCancel :: SomeException -> Bool -isCancel e - | Just AsyncCancelled <- fromException e = True - | otherwise = False - -forkRepeat :: (MonadFork m, MonadMask m) => String -> m a -> m (ThreadId m) -forkRepeat label action = - mask $ \restore -> - let go = do r <- tryAll (restore action) - case r of - Left _ -> go - _ -> return () - in forkIO (labelThisThread label >> go) - -tryAll :: MonadCatch m => m a -> m (Either SomeException a) -tryAll = try - - --- --- ReaderT instance --- - -newtype AsyncReaderT r (m :: Type -> Type) a = - AsyncReaderT { getAsyncReaderT :: Async m a } - -instance ( MonadAsync m - , MonadCatch (STM m) - , MonadFork m - , MonadMask m - ) => MonadAsync (ReaderT r m) where - type Async (ReaderT r m) = AsyncReaderT r m - asyncThreadId (AsyncReaderT a) = asyncThreadId a - - async (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> async (ma r) - asyncBound (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncBound (ma r) - asyncOn n (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncOn n (ma r) - withAsync (ReaderT ma) f = ReaderT $ \r -> withAsync (ma r) - $ \a -> runReaderT (f (AsyncReaderT a)) r - withAsyncBound (ReaderT ma) f = ReaderT $ \r -> withAsyncBound (ma r) - $ \a -> runReaderT (f (AsyncReaderT a)) r - withAsyncOn n (ReaderT ma) f = ReaderT $ \r -> withAsyncOn n (ma r) - $ \a -> runReaderT (f (AsyncReaderT a)) r - - asyncWithUnmask f = ReaderT $ \r -> fmap AsyncReaderT - $ asyncWithUnmask - $ \unmask -> runReaderT (f (liftF unmask)) r - where - liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a - liftF g (ReaderT r) = ReaderT (g . r) - - asyncOnWithUnmask n f = ReaderT $ \r -> fmap AsyncReaderT - $ asyncOnWithUnmask n - $ \unmask -> runReaderT (f (liftF unmask)) r - where - liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a - liftF g (ReaderT r) = ReaderT (g . r) - - withAsyncWithUnmask action f = - ReaderT $ \r -> withAsyncWithUnmask (\unmask -> case action (liftF unmask) of - ReaderT ma -> ma r) - $ \a -> runReaderT (f (AsyncReaderT a)) r - where - liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a - liftF g (ReaderT r) = ReaderT (g . r) - - withAsyncOnWithUnmask n action f = - ReaderT $ \r -> withAsyncOnWithUnmask n (\unmask -> case action (liftF unmask) of - ReaderT ma -> ma r) - $ \a -> runReaderT (f (AsyncReaderT a)) r - where - liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a - liftF g (ReaderT r) = ReaderT (g . r) - - waitCatchSTM = lift . waitCatchSTM . getAsyncReaderT - pollSTM = lift . pollSTM . getAsyncReaderT - - race (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race (ma r) (mb r) - race_ (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race_ (ma r) (mb r) - concurrently (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> concurrently (ma r) (mb r) - - wait = lift . wait . getAsyncReaderT - poll = lift . poll . getAsyncReaderT - waitCatch = lift . waitCatch . getAsyncReaderT - cancel = lift . cancel . getAsyncReaderT - uninterruptibleCancel = lift . uninterruptibleCancel - . getAsyncReaderT - cancelWith = (lift .: cancelWith) - . getAsyncReaderT - waitAny = fmap (first AsyncReaderT) - . lift . waitAny - . map getAsyncReaderT - waitAnyCatch = fmap (first AsyncReaderT) - . lift . waitAnyCatch - . map getAsyncReaderT - waitAnyCancel = fmap (first AsyncReaderT) - . lift . waitAnyCancel - . map getAsyncReaderT - waitAnyCatchCancel = fmap (first AsyncReaderT) - . lift . waitAnyCatchCancel - . map getAsyncReaderT - waitEither = on (lift .: waitEither) getAsyncReaderT - waitEitherCatch = on (lift .: waitEitherCatch) getAsyncReaderT - waitEitherCancel = on (lift .: waitEitherCancel) getAsyncReaderT - waitEitherCatchCancel = on (lift .: waitEitherCatchCancel) getAsyncReaderT - waitEither_ = on (lift .: waitEither_) getAsyncReaderT - waitBoth = on (lift .: waitBoth) getAsyncReaderT - - --- --- Utilities --- - -(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) -(f .: g) x y = f (g x y) - - --- | A higher order version of 'Data.Function.on' --- -on :: (f a -> f b -> c) - -> (forall x. g x -> f x) - -> (g a -> g b -> c) -on f g = \a b -> f (g a) (g b) diff --git a/src/Control/Monad/Class/MonadEventlog.hs b/src/Control/Monad/Class/MonadEventlog.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadEventlog.hs +++ /dev/null @@ -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 diff --git a/src/Control/Monad/Class/MonadFork.hs b/src/Control/Monad/Class/MonadFork.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadFork.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - --- | A generalisation of --- --- API to both 'IO' and . --- -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 diff --git a/src/Control/Monad/Class/MonadST.hs b/src/Control/Monad/Class/MonadST.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadST.hs +++ /dev/null @@ -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) diff --git a/src/Control/Monad/Class/MonadSTM.hs b/src/Control/Monad/Class/MonadSTM.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadSTM.hs +++ /dev/null @@ -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. diff --git a/src/Control/Monad/Class/MonadSTM/Internal.hs b/src/Control/Monad/Class/MonadSTM/Internal.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadSTM/Internal.hs +++ /dev/null @@ -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 diff --git a/src/Control/Monad/Class/MonadSay.hs b/src/Control/Monad/Class/MonadSay.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadSay.hs +++ /dev/null @@ -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 diff --git a/src/Control/Monad/Class/MonadTest.hs b/src/Control/Monad/Class/MonadTest.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadTest.hs +++ /dev/null @@ -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 - diff --git a/src/Control/Monad/Class/MonadThrow.hs b/src/Control/Monad/Class/MonadThrow.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadThrow.hs +++ /dev/null @@ -1,328 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeFamilies #-} - --- | A generalisation of --- --- API to both 'IO' and . --- -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 - -- 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 diff --git a/src/Control/Monad/Class/MonadTime.hs b/src/Control/Monad/Class/MonadTime.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadTime.hs +++ /dev/null @@ -1,55 +0,0 @@ --- | and --- time API compatible with both --- 'IO' and . --- -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 diff --git a/src/Control/Monad/Class/MonadTimer.hs b/src/Control/Monad/Class/MonadTimer.hs deleted file mode 100644 --- a/src/Control/Monad/Class/MonadTimer.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE TypeFamilies #-} - --- | Provides classes to handle delays and timeouts which generalised --- API to both 'IO' and --- . --- -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)