diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revsion history of io-classes +### 1.6.0.0 + +### Breaking changes + +* `strict-stm`, `strict-mvar` and `si-timers` are now public sublibraries of `io-classes` package. +* Moved `io-classes-mtl` to `io-classes` as a public sublibrary. + ## 1.5.0.0 ### Breaking changes @@ -11,6 +18,19 @@ ### Non-breaking change * Add `writeTMVar` to `MonadSTM`. + +* `strict-stm`, `strict-mvar` and `si-timers` were moved to `io-classes` as + **public sublibraries**. You can import then in `*.cabal` files with the + following syntax `io-classes:strict-stm` or `io-classes:{strict-stm, + si-timers}`. See the _Multiple public libraries_ subsection of [_Internal + Libraries_][sublibs] section in the `cabal` documentation. + + Note: some time in the future we will deprecate `Hackage` packages + `strict-stm`, `strict-mvar` and `si-timers`. If one will want to use the + namespace for a non `io-classes` related packages please contact the + maintainer. + +[sublibs]: https://cabal.readthedocs.io/en/stable/cabal-package.html#sublibs ## 1.4.1.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# IO Monad Class Hierarchy +# IO Monad Class Hierarchy: `io-classes` This package provides a monad class hierarchy which is an interface for both the [`io-sim`] and [`IO`] monads. It was developed with the following @@ -10,18 +10,35 @@ as timer API; * provide zero-cost abstractions. -We provide also non-standard extensions of this API: +We provide also non-standard extensions of this API in **sublibraries**: -* [`strict-stm`]: strict `TVar`'s, and other mutable `STM` variables, with +* [`io-classes:strict-stm`](https://input-output-hk.github.io/io-sim/io-classes/strict-stm/index.html) strict `TVar`'s, and other mutable `STM` variables, with support of the [`nothunks`] library; -* [`si-timers`]: timers api: +* [`io-classes:strict-mvar`](https://input-output-hk.github.io/io-sim/io-classes/strict-mvar/index.html): strict `MVar`s +* [`io-classes:si-timers`](https://input-output-hk.github.io/io-sim/io-classes/si-timers/index.html): timers api: + - 32-bit safe API using `DiffTime` measured in seconds (rather than time in microseconds represented as `Int` as in `base`) - cancellable timeouts. -[`strict-stm`] and [`nothunks`] were successfully used in a large code base to -eliminate space leaks and keep that property over long development cycles. +* [`io-classes:io-classes-mtl`](https://input-output-hk.github.io/io-sim/io-classes/io-classes-mtl/index.html): + MTL instances. +[`io-classes:strict-stm`](https://input-output-hk.github.io/io-sim/io-classes/strict-stm/index.html) +and [`nothunks`] were successfully used in a large +code base to eliminate space leaks and keep that property over long development +cycles. + +## Documentation + +Hackage doesn't yet support public sublibraries, thus Haddocks are published +[here][io-classes-haddocks]. + +### Support material + +* [Philipp Kant (@kantp) at Bobconf 2022][bob-conf] +* [Armando Santos (@bolt12) at ZuriHac 2022][zuriHac-2022] + ## Exception Class Hierarchy This package provides an alternative class hierarchy giving access to @@ -61,24 +78,23 @@ ## Software Transactional Memory API We provide two interfaces to `stm` API: lazy, included in `io-classes`; and -strict one provided by [`strict-stm`]. - +strict one provided by [`io-classes:strict-stm`](https://input-output-hk.github.io/io-sim/io-classes/strict-stm/index.html). ## Threads API We draw a line between `base` API and `async` API. The former is provided by [MonadFork](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadFork.html#t:MonadFork) the latter by -[MonadAsync](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadFork.html#t:MonadAsync). +[MonadAsync](https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadAsync.html#t:MonadAsync). Both are shallow abstractions around APIs exposed by the `base` and `async` packages. ## Some other APIs -* [MonadEventlog]: provides an API to the [Debug.Trace] event log interface. -* [MonadST]: provides a way to lift `ST`-computations. -* [MonadSay]: dummy debugging interface +* [MonadEventlog][MonadEventlog]: provides an API to the [Debug.Trace] event log interface. +* [MonadST][MonadST]: provides a way to lift `ST`-computations. +* [MonadSay][MonadSay]: dummy debugging interface ## Differences from `base`, `async`, or `exceptions` packages @@ -140,17 +156,20 @@ [`base`]: https://hackage.haskell.org/package/base [`exceptions`]: https://hackage.haskell.org/package/exceptions [`io-sim`]: https://hackage.haskell.org/package/io-sim -[`si-timers`]: https://hackage.haskell.org/package/si-timers +[io-classes:mtl]: https://input-output-hk.github.io/io-sim/io-classes/mtl/index.html [`stm`]: https://hackage.haskell.org/package/stm -[`strict-stm`]: https://hackage.haskell.org/package/strict-stm -[`threadDelay`]: https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadTimer.html#v:threadDela +[`threadDelay`]: https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadTimer.html#v:threadDelay [`time`]: https://hackage.haskell.org/package/time [contributing]: https://www.github.com/input-output-hk/io-sim/tree/master/CONTRIBUTING.md [`nothunks`]: https://hackage.haskell.org/package/nothunks [labelThread-base]: https://hackage.haskell.org/package/base-4.17.0.0/docs/GHC-Conc-Sync.html#v:labelThread [io-deadlock]: https://hackage.haskell.org/package/base-4.19.0.0/docs/Control-Exception.html#t:Deadlock -[MonadEventlog]: https://hackage.haskell.org/package/io-sim-classes/docs/Control-Monad-Class-MonadEventlog.html#t:MonadEventlog +[MonadEventlog]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadEventlog.html#t:MonadEventlog [Debug.Trace]: https://hackage.haskell.org/package/base/docs/Debug-Trace.html -[MonadST]: https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadST.html#t:MonadST -[MonadSay]: https://hackage.haskell.org/package/io-classes/docs/Control-Monad-Class-MonadSay.html#t:MonadSay +[MonadST]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadST.html#t:MonadST +[MonadSay]: https://input-output-hk.github.io/io-sim/io-classes/Control-Monad-Class-MonadSay.html#t:MonadSay +[io-classes-haddocks]: https://input-output-hk.github.io/io-sim + +[bob-conf]: https://youtu.be/uedUGeWN4ZM +[zuriHac-2022]: https://youtu.be/tKIYQgJnGkA diff --git a/io-classes.cabal b/io-classes.cabal --- a/io-classes.cabal +++ b/io-classes.cabal @@ -1,15 +1,19 @@ cabal-version: 3.0 name: io-classes -version: 1.5.0.0 +version: 1.6.0.0 synopsis: Type classes for concurrency with STM, ST and timing description: - IO Monad class hierarchy compatible with - [io-sim](https://hackage.haskell.org/package/io-sim), - [base](https://hackage.haskell.org/package/base), - [async](https://hackage.haskell.org/package/async), - [stm](https://hackage.haskell.org/package/stm), - [exceptions](https://hackage.haskell.org/package/exceptions) & - [time](https://hackage.haskell.org/package/time) packages. + IO Monad class hierarchy compatible with: + + * [io-sim](https://hackage.haskell.org/package/io-sim), + * [base](https://hackage.haskell.org/package/base), + * [async](https://hackage.haskell.org/package/async), + * [stm](https://hackage.haskell.org/package/stm), + * [exceptions](https://hackage.haskell.org/package/exceptions) & + * [time](https://hackage.haskell.org/package/time) + + packages. + license: Apache-2.0 license-files: LICENSE NOTICE copyright: 2019-2024 Input Output Global Inc (IOG) @@ -17,7 +21,7 @@ maintainer: Duncan Coutts duncan@well-typed.com, Marcin Szamotulski coot@coot.me category: Control build-type: Simple -extra-doc-files: CHANGELOG.md README.md +extra-doc-files: CHANGELOG.md README.md strict-stm/README.md strict-mvar/README.md bug-reports: https://github.com/input-output-hk/io-sim/issues tested-with: GHC == { 8.10, 9.2, 9.4, 9.6, 9.8, 9.10 } @@ -99,10 +103,164 @@ bytestring, mtl >=2.2 && <2.4, primitive >= 0.7 && <0.11, - stm >=2.5 && <2.6, + stm >=2.5 && <2.5.2 || >=2.5.3 && <2.6, time >=1.9.1 && <1.13 if impl(ghc >= 9.10) build-depends: ghc-internal if flag(asserts) ghc-options: -fno-ignore-asserts + +library strict-stm + visibility: public + hs-source-dirs: strict-stm + + exposed-modules: Control.Concurrent.Class.MonadSTM.Strict + Control.Concurrent.Class.MonadSTM.Strict.TArray + Control.Concurrent.Class.MonadSTM.Strict.TBQueue + Control.Concurrent.Class.MonadSTM.Strict.TChan + Control.Concurrent.Class.MonadSTM.Strict.TMVar + Control.Concurrent.Class.MonadSTM.Strict.TQueue + Control.Concurrent.Class.MonadSTM.Strict.TVar + reexported-modules: Control.Concurrent.Class.MonadSTM.TSem as Control.Concurrent.Class.MonadSTM.Strict.TSem + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + build-depends: base >= 4.9 && <4.21, + array, + stm >= 2.5 && <2.6, + + io-classes:io-classes, + ghc-options: -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + + if flag(asserts) + ghc-options: -fno-ignore-asserts + +library strict-mvar + visibility: public + hs-source-dirs: strict-mvar/src + + exposed-modules: Control.Concurrent.Class.MonadMVar.Strict + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + build-depends: base >= 4.9 && <4.21, + io-classes:io-classes, + ghc-options: -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + +library si-timers + import: warnings + visibility: public + hs-source-dirs: si-timers/src + exposed-modules: Control.Monad.Class.MonadTime.SI + Control.Monad.Class.MonadTimer.SI + other-modules: Control.Monad.Class.MonadTimer.NonStandard + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + other-extensions: BangPatterns, + CPP, + ConstraintKinds, + DefaultSignatures, + DeriveGeneric, + NumericUnderscores, + ScopedTypeVariables, + TypeFamilies + build-depends: base >=4.9 && <4.21, + deepseq, + mtl, + nothunks, + stm, + time >=1.9.1 && <1.13, + + io-classes:io-classes + if flag(asserts) + ghc-options: -fno-ignore-asserts + +-- https://github.com/haskell/cabal/issues/10277 +library io-classes-mtl + import: warnings + visibility: public + exposed-modules: Control.Monad.Class.Trans + , Control.Monad.Class.MonadEventlog.Trans + , Control.Monad.Class.MonadSay.Trans + , Control.Monad.Class.MonadST.Trans + , Control.Monad.Class.MonadSTM.Trans + , Control.Monad.Class.MonadThrow.Trans + , Control.Monad.Class.MonadTime.Trans + , Control.Monad.Class.MonadTime.SI.Trans + , Control.Monad.Class.MonadTimer.Trans + , Control.Monad.Class.MonadTimer.SI.Trans + build-depends: base >=4.9 && <4.21, + array, + mtl, + + io-classes:{io-classes,si-timers} + + hs-source-dirs: mtl + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + +library testlib + import: warnings + visibility: public + hs-source-dirs: test + exposed-modules: Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + build-depends: base >=4.9 && <4.21, + nothunks, + QuickCheck, + io-classes:strict-mvar + if flag(asserts) + ghc-options: -fno-ignore-asserts + +test-suite test-strict-mvar + type: exitcode-stdio-1.0 + hs-source-dirs: strict-mvar/test + main-is: Main.hs + + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + build-depends: base, + QuickCheck, + tasty, + tasty-quickcheck, + io-classes:testlib + + ghc-options: -Wall + -Wno-unticked-promoted-constructors + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -fno-ignore-asserts + +-- Since `io-sim` depends on `si-times` (`io-sim` depends on `Time`) some tests of +-- are in `io-sim:test`: this is a good enough reason to pull `io-sim:test` +-- into a seprate package. +test-suite test-si-timers + import: warnings + type: exitcode-stdio-1.0 + hs-source-dirs: si-timers/test + main-is: Main.hs + other-modules: Test.MonadTimer + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + build-depends: base, + + QuickCheck, + tasty, + tasty-quickcheck, + + si-timers diff --git a/mtl/Control/Monad/Class/MonadEventlog/Trans.hs b/mtl/Control/Monad/Class/MonadEventlog/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/MonadEventlog/Trans.hs @@ -0,0 +1,56 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Control.Monad.Class.MonadEventlog.Trans () where + +import Control.Monad.Cont (ContT) +import Control.Monad.Except (ExceptT) +import Control.Monad.RWS.Lazy qualified as Lazy +import Control.Monad.RWS.Strict qualified as Strict +import Control.Monad.State.Lazy qualified as Lazy +import Control.Monad.State.Strict qualified as Strict +import Control.Monad.Trans (lift) +import Control.Monad.Writer.Lazy qualified as Lazy +import Control.Monad.Writer.Strict qualified as Strict + +import Control.Monad.Class.MonadEventlog + +-- | @since 0.1.0.0 +instance MonadEventlog m => MonadEventlog (ContT r m) where + traceEventIO = lift . traceEventIO + traceMarkerIO = lift . traceMarkerIO + +-- | @since 0.1.0.0 +instance MonadEventlog m => MonadEventlog (ExceptT e m) where + traceEventIO = lift . traceEventIO + traceMarkerIO = lift . traceMarkerIO + +-- | @since 0.1.0.0 +instance (Monoid w, MonadEventlog m) => MonadEventlog (Lazy.RWST r w s m) where + traceEventIO = lift . traceEventIO + traceMarkerIO = lift . traceMarkerIO + +-- | @since 0.1.0.0 +instance (Monoid w, MonadEventlog m) => MonadEventlog (Strict.RWST r w s m) where + traceEventIO = lift . traceEventIO + traceMarkerIO = lift . traceMarkerIO + +-- | @since 0.1.0.0 +instance MonadEventlog m => MonadEventlog (Lazy.StateT s m) where + traceEventIO = lift . traceEventIO + traceMarkerIO = lift . traceMarkerIO + +-- | @since 0.1.0.0 +instance MonadEventlog m => MonadEventlog (Strict.StateT s m) where + traceEventIO = lift . traceEventIO + traceMarkerIO = lift . traceMarkerIO + +-- | @since 0.1.0.0 +instance (Monoid w, MonadEventlog m) => MonadEventlog (Lazy.WriterT w m) where + traceEventIO = lift . traceEventIO + traceMarkerIO = lift . traceMarkerIO + +-- | @since 0.1.0.0 +instance (Monoid w, MonadEventlog m) => MonadEventlog (Strict.WriterT w m) where + traceEventIO = lift . traceEventIO + traceMarkerIO = lift . traceMarkerIO + diff --git a/mtl/Control/Monad/Class/MonadST/Trans.hs b/mtl/Control/Monad/Class/MonadST/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/MonadST/Trans.hs @@ -0,0 +1,48 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +module Control.Monad.Class.MonadST.Trans () where + +import Control.Monad.Cont (ContT) +import Control.Monad.Except (ExceptT) +import Control.Monad.RWS.Lazy qualified as Lazy +import Control.Monad.RWS.Strict qualified as Strict +import Control.Monad.State.Lazy qualified as Lazy +import Control.Monad.State.Strict qualified as Strict +import Control.Monad.Trans (lift) +import Control.Monad.Writer.Lazy qualified as Lazy +import Control.Monad.Writer.Strict qualified as Strict + +import Control.Monad.Class.MonadST + + +instance MonadST m => MonadST (ContT r m) where + stToIO = lift . stToIO + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance MonadST m => MonadST (ExceptT e m) where + stToIO = lift . stToIO + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance (Monoid w, MonadST m) => MonadST (Lazy.RWST r w s m) where + stToIO = lift . stToIO + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance (Monoid w, MonadST m) => MonadST (Strict.RWST r w s m) where + stToIO = lift . stToIO + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance MonadST m => MonadST (Lazy.StateT s m) where + stToIO = lift . stToIO + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance MonadST m => MonadST (Strict.StateT s m) where + stToIO = lift . stToIO + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance (Monoid w, MonadST m) => MonadST (Lazy.WriterT w m) where + stToIO = lift . stToIO + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance (Monoid w, MonadST m) => MonadST (Strict.WriterT w m) where + stToIO = lift . stToIO + withLiftST f = withLiftST $ \g -> f (lift . g) diff --git a/mtl/Control/Monad/Class/MonadSTM/Trans.hs b/mtl/Control/Monad/Class/MonadSTM/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/MonadSTM/Trans.hs @@ -0,0 +1,711 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +-- undecidable instances needed for 'ContTSTM' instances of +-- 'MonadThrow' and 'MonadCatch' type classes. +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Control.Monad.Class.MonadSTM.Trans (ContTSTM (..)) where + +import Control.Monad.Cont (ContT (..)) +import Control.Monad.Except (ExceptT (..), runExceptT) +import Control.Monad.RWS.Lazy qualified as Lazy +import Control.Monad.RWS.Strict qualified as Strict +import Control.Monad.State.Lazy qualified as Lazy +import Control.Monad.State.Strict qualified as Strict +import Control.Monad.Trans (lift) +import Control.Monad.Writer.Lazy qualified as Lazy +import Control.Monad.Writer.Strict qualified as Strict + +import Control.Monad.Class.MonadSTM.Internal +import Control.Monad.Class.MonadThrow qualified as MonadThrow + +import Data.Array.Base (MArray (..)) +import Data.Function (on) +import Data.Kind (Type) + + +-- | A newtype wrapper for an 'STM' monad for 'ContT' +-- +newtype ContTSTM r (m :: Type -> Type) a = ContTSTM { getContTSTM :: STM m a } + +deriving instance MonadSTM m => Functor (ContTSTM r m) +deriving instance MonadSTM m => Applicative (ContTSTM r m) +deriving instance MonadSTM m => Monad (ContTSTM r m) + +instance ( Semigroup a, MonadSTM m ) => Semigroup (ContTSTM r m a) where + a <> b = (<>) <$> a <*> b +instance ( Monoid a, MonadSTM m ) => Monoid (ContTSTM r m a) where + mempty = pure mempty + +instance ( MonadSTM m, MArray e a (STM m) ) => MArray e a (ContTSTM r m) where + getBounds = ContTSTM . getBounds + getNumElements = ContTSTM . getNumElements + unsafeRead arr = ContTSTM . unsafeRead arr + unsafeWrite arr i = ContTSTM . unsafeWrite arr i +#if __GLASGOW_HASKELL__ >= 910 + newArray idxs = ContTSTM . newArray idxs +#endif + + +-- note: this (and the following) instance requires 'UndecidableInstances' +-- extension because it violates 3rd Paterson condition, however `STM m` will +-- resolve to a concrete type of kind (Type -> Type), and thus no larger than +-- `m` itself, e.g. for `m ~ ReaderT r f`, `STM m ~ WrappedSTM Reader r f`. +-- Instance resolution will terminate as soon as the monad transformer stack +-- depth is exhausted. +instance ( MonadSTM m + , MonadThrow.MonadThrow (STM m) + , MonadThrow.MonadCatch (STM m) + ) => MonadThrow.MonadThrow (ContTSTM r m) where + throwIO = ContTSTM . MonadThrow.throwIO +#if __GLASGOW_HASKELL__ >= 910 + annotateIO ann (ContTSTM stm) = ContTSTM (MonadThrow.annotateIO ann stm) +#endif + +instance ( MonadSTM m + , MonadThrow.MonadThrow (STM m) + , MonadThrow.MonadCatch (STM m) + ) => MonadThrow.MonadCatch (ContTSTM r m) where + catch action handler = ContTSTM + $ MonadThrow.catch (getContTSTM action) (getContTSTM . handler) + generalBracket acquire release use = ContTSTM $ + MonadThrow.generalBracket (getContTSTM acquire) + (getContTSTM .: release) + (getContTSTM . use) + +-- | @'ContT' r m@ monad is using underlying @'STM' m@ monad as its stm monad, +-- without transforming it. +-- +instance MonadSTM m => MonadSTM (ContT r m) where + type STM (ContT r m) = ContTSTM r m + atomically = lift . atomically . getContTSTM + + type TVar (ContT r m) = TVar m + newTVar = ContTSTM . newTVar + readTVar = ContTSTM . readTVar + writeTVar = ContTSTM .: writeTVar + retry = ContTSTM retry + orElse = ContTSTM .: on orElse getContTSTM + + modifyTVar = ContTSTM .: modifyTVar + modifyTVar' = ContTSTM .: modifyTVar' + stateTVar = ContTSTM .: stateTVar + swapTVar = ContTSTM .: swapTVar + check = ContTSTM . check + + type TMVar (ContT r m) = TMVar m + newTMVar = ContTSTM . newTMVar + newEmptyTMVar = ContTSTM newEmptyTMVar + takeTMVar = ContTSTM . takeTMVar + tryTakeTMVar = ContTSTM . tryTakeTMVar + putTMVar = ContTSTM .: putTMVar + tryPutTMVar = ContTSTM .: tryPutTMVar + readTMVar = ContTSTM . readTMVar + tryReadTMVar = ContTSTM . tryReadTMVar + swapTMVar = ContTSTM .: swapTMVar + writeTMVar = ContTSTM .: writeTMVar + isEmptyTMVar = ContTSTM . isEmptyTMVar + + type TQueue (ContT r m) = TQueue m + newTQueue = ContTSTM newTQueue + readTQueue = ContTSTM . readTQueue + tryReadTQueue = ContTSTM . tryReadTQueue + peekTQueue = ContTSTM . peekTQueue + tryPeekTQueue = ContTSTM . tryPeekTQueue + flushTQueue = ContTSTM . flushTQueue + writeTQueue v = ContTSTM . writeTQueue v + isEmptyTQueue = ContTSTM . isEmptyTQueue + unGetTQueue = ContTSTM .: unGetTQueue + + type TBQueue (ContT r m) = TBQueue m + newTBQueue = ContTSTM . newTBQueue + readTBQueue = ContTSTM . readTBQueue + tryReadTBQueue = ContTSTM . tryReadTBQueue + peekTBQueue = ContTSTM . peekTBQueue + tryPeekTBQueue = ContTSTM . tryPeekTBQueue + flushTBQueue = ContTSTM . flushTBQueue + writeTBQueue = ContTSTM .: writeTBQueue + lengthTBQueue = ContTSTM . lengthTBQueue + isEmptyTBQueue = ContTSTM . isEmptyTBQueue + isFullTBQueue = ContTSTM . isFullTBQueue + unGetTBQueue = ContTSTM .: unGetTBQueue + + type TArray (ContT r m) = TArray m + + type TSem (ContT r m) = TSem m + newTSem = ContTSTM . newTSem + waitTSem = ContTSTM . waitTSem + signalTSem = ContTSTM . signalTSem + signalTSemN = ContTSTM .: signalTSemN + + type TChan (ContT r m) = TChan m + newTChan = ContTSTM newTChan + newBroadcastTChan = ContTSTM newBroadcastTChan + dupTChan = ContTSTM . dupTChan + cloneTChan = ContTSTM . cloneTChan + readTChan = ContTSTM . readTChan + tryReadTChan = ContTSTM . tryReadTChan + peekTChan = ContTSTM . peekTChan + tryPeekTChan = ContTSTM . tryPeekTChan + writeTChan = ContTSTM .: writeTChan + unGetTChan = ContTSTM .: unGetTChan + isEmptyTChan = ContTSTM . isEmptyTChan + + +-- | The underlying stm monad is also transformed. +-- +instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.WriterT w m) where + type STM (Lazy.WriterT w m) = Lazy.WriterT w (STM m) + atomically (Lazy.WriterT stm) = Lazy.WriterT (atomically stm) + + type TVar (Lazy.WriterT w m) = TVar m + newTVar = lift . newTVar + readTVar = lift . readTVar + writeTVar = lift .: writeTVar + retry = lift retry + orElse (Lazy.WriterT a) (Lazy.WriterT b) = Lazy.WriterT $ a `orElse` b + + modifyTVar = lift .: modifyTVar + modifyTVar' = lift .: modifyTVar' + stateTVar = lift .: stateTVar + swapTVar = lift .: swapTVar + check = lift . check + + type TMVar (Lazy.WriterT w m) = TMVar m + newTMVar = lift . newTMVar + newEmptyTMVar = lift newEmptyTMVar + takeTMVar = lift . takeTMVar + tryTakeTMVar = lift . tryTakeTMVar + putTMVar = lift .: putTMVar + tryPutTMVar = lift .: tryPutTMVar + readTMVar = lift . readTMVar + tryReadTMVar = lift . tryReadTMVar + swapTMVar = lift .: swapTMVar + writeTMVar = lift .: writeTMVar + isEmptyTMVar = lift . isEmptyTMVar + + type TQueue (Lazy.WriterT w m) = TQueue m + newTQueue = lift newTQueue + readTQueue = lift . readTQueue + tryReadTQueue = lift . tryReadTQueue + peekTQueue = lift . peekTQueue + tryPeekTQueue = lift . tryPeekTQueue + flushTQueue = lift . flushTQueue + writeTQueue v = lift . writeTQueue v + isEmptyTQueue = lift . isEmptyTQueue + unGetTQueue = lift .: unGetTQueue + + type TBQueue (Lazy.WriterT w m) = TBQueue m + newTBQueue = lift . newTBQueue + readTBQueue = lift . readTBQueue + tryReadTBQueue = lift . tryReadTBQueue + peekTBQueue = lift . peekTBQueue + tryPeekTBQueue = lift . tryPeekTBQueue + flushTBQueue = lift . flushTBQueue + writeTBQueue = lift .: writeTBQueue + lengthTBQueue = lift . lengthTBQueue + isEmptyTBQueue = lift . isEmptyTBQueue + isFullTBQueue = lift . isFullTBQueue + unGetTBQueue = lift .: unGetTBQueue + + type TArray (Lazy.WriterT w m) = TArray m + + type TSem (Lazy.WriterT w m) = TSem m + newTSem = lift . newTSem + waitTSem = lift . waitTSem + signalTSem = lift . signalTSem + signalTSemN = lift .: signalTSemN + + type TChan (Lazy.WriterT w m) = TChan m + newTChan = lift newTChan + newBroadcastTChan = lift newBroadcastTChan + dupTChan = lift . dupTChan + cloneTChan = lift . cloneTChan + readTChan = lift . readTChan + tryReadTChan = lift . tryReadTChan + peekTChan = lift . peekTChan + tryPeekTChan = lift . tryPeekTChan + writeTChan = lift .: writeTChan + unGetTChan = lift .: unGetTChan + isEmptyTChan = lift . isEmptyTChan + + +-- | The underlying stm monad is also transformed. +-- +instance (Monoid w, MonadSTM m) => MonadSTM (Strict.WriterT w m) where + type STM (Strict.WriterT w m) = Strict.WriterT w (STM m) + atomically (Strict.WriterT stm) = Strict.WriterT (atomically stm) + + type TVar (Strict.WriterT w m) = TVar m + newTVar = lift . newTVar + readTVar = lift . readTVar + writeTVar = lift .: writeTVar + retry = lift retry + orElse (Strict.WriterT a) (Strict.WriterT b) = Strict.WriterT $ a `orElse` b + + modifyTVar = lift .: modifyTVar + modifyTVar' = lift .: modifyTVar' + stateTVar = lift .: stateTVar + swapTVar = lift .: swapTVar + check = lift . check + + type TMVar (Strict.WriterT w m) = TMVar m + newTMVar = lift . newTMVar + newEmptyTMVar = lift newEmptyTMVar + takeTMVar = lift . takeTMVar + tryTakeTMVar = lift . tryTakeTMVar + putTMVar = lift .: putTMVar + tryPutTMVar = lift .: tryPutTMVar + readTMVar = lift . readTMVar + tryReadTMVar = lift . tryReadTMVar + swapTMVar = lift .: swapTMVar + writeTMVar = lift .: writeTMVar + isEmptyTMVar = lift . isEmptyTMVar + + type TQueue (Strict.WriterT w m) = TQueue m + newTQueue = lift newTQueue + readTQueue = lift . readTQueue + tryReadTQueue = lift . tryReadTQueue + peekTQueue = lift . peekTQueue + tryPeekTQueue = lift . tryPeekTQueue + flushTQueue = lift . flushTQueue + writeTQueue v = lift . writeTQueue v + isEmptyTQueue = lift . isEmptyTQueue + unGetTQueue = lift .: unGetTQueue + + type TBQueue (Strict.WriterT w m) = TBQueue m + newTBQueue = lift . newTBQueue + readTBQueue = lift . readTBQueue + tryReadTBQueue = lift . tryReadTBQueue + peekTBQueue = lift . peekTBQueue + tryPeekTBQueue = lift . tryPeekTBQueue + flushTBQueue = lift . flushTBQueue + writeTBQueue = lift .: writeTBQueue + lengthTBQueue = lift . lengthTBQueue + isEmptyTBQueue = lift . isEmptyTBQueue + isFullTBQueue = lift . isFullTBQueue + unGetTBQueue = lift .: unGetTBQueue + + type TArray (Strict.WriterT w m) = TArray m + + type TSem (Strict.WriterT w m) = TSem m + newTSem = lift . newTSem + waitTSem = lift . waitTSem + signalTSem = lift . signalTSem + signalTSemN = lift .: signalTSemN + + type TChan (Strict.WriterT w m) = TChan m + newTChan = lift newTChan + newBroadcastTChan = lift newBroadcastTChan + dupTChan = lift . dupTChan + cloneTChan = lift . cloneTChan + readTChan = lift . readTChan + tryReadTChan = lift . tryReadTChan + peekTChan = lift . peekTChan + tryPeekTChan = lift . tryPeekTChan + writeTChan = lift .: writeTChan + unGetTChan = lift .: unGetTChan + isEmptyTChan = lift . isEmptyTChan + + +-- | The underlying stm monad is also transformed. +-- +instance MonadSTM m => MonadSTM (Lazy.StateT s m) where + type STM (Lazy.StateT s m) = Lazy.StateT s (STM m) + atomically (Lazy.StateT stm) = Lazy.StateT $ \s -> atomically (stm s) + + type TVar (Lazy.StateT s m) = TVar m + newTVar = lift . newTVar + readTVar = lift . readTVar + writeTVar = lift .: writeTVar + retry = lift retry + orElse (Lazy.StateT a) (Lazy.StateT b) = Lazy.StateT $ \s -> a s `orElse` b s + + modifyTVar = lift .: modifyTVar + modifyTVar' = lift .: modifyTVar' + stateTVar = lift .: stateTVar + swapTVar = lift .: swapTVar + check = lift . check + + type TMVar (Lazy.StateT s m) = TMVar m + newTMVar = lift . newTMVar + newEmptyTMVar = lift newEmptyTMVar + takeTMVar = lift . takeTMVar + tryTakeTMVar = lift . tryTakeTMVar + putTMVar = lift .: putTMVar + tryPutTMVar = lift .: tryPutTMVar + readTMVar = lift . readTMVar + tryReadTMVar = lift . tryReadTMVar + swapTMVar = lift .: swapTMVar + writeTMVar = lift .: writeTMVar + isEmptyTMVar = lift . isEmptyTMVar + + type TQueue (Lazy.StateT s m) = TQueue m + newTQueue = lift newTQueue + readTQueue = lift . readTQueue + tryReadTQueue = lift . tryReadTQueue + peekTQueue = lift . peekTQueue + tryPeekTQueue = lift . tryPeekTQueue + flushTQueue = lift . flushTQueue + writeTQueue v = lift . writeTQueue v + isEmptyTQueue = lift . isEmptyTQueue + unGetTQueue = lift .: unGetTQueue + + type TBQueue (Lazy.StateT s m) = TBQueue m + newTBQueue = lift . newTBQueue + readTBQueue = lift . readTBQueue + tryReadTBQueue = lift . tryReadTBQueue + peekTBQueue = lift . peekTBQueue + tryPeekTBQueue = lift . tryPeekTBQueue + flushTBQueue = lift . flushTBQueue + writeTBQueue = lift .: writeTBQueue + lengthTBQueue = lift . lengthTBQueue + isEmptyTBQueue = lift . isEmptyTBQueue + isFullTBQueue = lift . isFullTBQueue + unGetTBQueue = lift .: unGetTBQueue + + type TArray (Lazy.StateT s m) = TArray m + + type TSem (Lazy.StateT s m) = TSem m + newTSem = lift . newTSem + waitTSem = lift . waitTSem + signalTSem = lift . signalTSem + signalTSemN = lift .: signalTSemN + + type TChan (Lazy.StateT s m) = TChan m + newTChan = lift newTChan + newBroadcastTChan = lift newBroadcastTChan + dupTChan = lift . dupTChan + cloneTChan = lift . cloneTChan + readTChan = lift . readTChan + tryReadTChan = lift . tryReadTChan + peekTChan = lift . peekTChan + tryPeekTChan = lift . tryPeekTChan + writeTChan = lift .: writeTChan + unGetTChan = lift .: unGetTChan + isEmptyTChan = lift . isEmptyTChan + + +-- | The underlying stm monad is also transformed. +-- +instance MonadSTM m => MonadSTM (Strict.StateT s m) where + type STM (Strict.StateT s m) = Strict.StateT s (STM m) + atomically (Strict.StateT stm) = Strict.StateT $ \s -> atomically (stm s) + + type TVar (Strict.StateT s m) = TVar m + newTVar = lift . newTVar + readTVar = lift . readTVar + writeTVar = lift .: writeTVar + retry = lift retry + orElse (Strict.StateT a) (Strict.StateT b) = Strict.StateT $ \s -> a s `orElse` b s + + modifyTVar = lift .: modifyTVar + modifyTVar' = lift .: modifyTVar' + stateTVar = lift .: stateTVar + swapTVar = lift .: swapTVar + check = lift . check + + type TMVar (Strict.StateT s m) = TMVar m + newTMVar = lift . newTMVar + newEmptyTMVar = lift newEmptyTMVar + takeTMVar = lift . takeTMVar + tryTakeTMVar = lift . tryTakeTMVar + putTMVar = lift .: putTMVar + tryPutTMVar = lift .: tryPutTMVar + readTMVar = lift . readTMVar + tryReadTMVar = lift . tryReadTMVar + swapTMVar = lift .: swapTMVar + writeTMVar = lift .: writeTMVar + isEmptyTMVar = lift . isEmptyTMVar + + type TQueue (Strict.StateT s m) = TQueue m + newTQueue = lift newTQueue + readTQueue = lift . readTQueue + tryReadTQueue = lift . tryReadTQueue + peekTQueue = lift . peekTQueue + tryPeekTQueue = lift . tryPeekTQueue + flushTQueue = lift . flushTQueue + writeTQueue v = lift . writeTQueue v + isEmptyTQueue = lift . isEmptyTQueue + unGetTQueue = lift .: unGetTQueue + + type TBQueue (Strict.StateT s m) = TBQueue m + newTBQueue = lift . newTBQueue + readTBQueue = lift . readTBQueue + tryReadTBQueue = lift . tryReadTBQueue + peekTBQueue = lift . peekTBQueue + tryPeekTBQueue = lift . tryPeekTBQueue + flushTBQueue = lift . flushTBQueue + writeTBQueue = lift .: writeTBQueue + lengthTBQueue = lift . lengthTBQueue + isEmptyTBQueue = lift . isEmptyTBQueue + isFullTBQueue = lift . isFullTBQueue + unGetTBQueue = lift .: unGetTBQueue + + type TArray (Strict.StateT s m) = TArray m + + type TSem (Strict.StateT s m) = TSem m + newTSem = lift . newTSem + waitTSem = lift . waitTSem + signalTSem = lift . signalTSem + signalTSemN = lift .: signalTSemN + + type TChan (Strict.StateT s m) = TChan m + newTChan = lift newTChan + newBroadcastTChan = lift newBroadcastTChan + dupTChan = lift . dupTChan + cloneTChan = lift . cloneTChan + readTChan = lift . readTChan + tryReadTChan = lift . tryReadTChan + peekTChan = lift . peekTChan + tryPeekTChan = lift . tryPeekTChan + writeTChan = lift .: writeTChan + unGetTChan = lift .: unGetTChan + isEmptyTChan = lift . isEmptyTChan + + +-- | The underlying stm monad is also transformed. +-- +instance MonadSTM m => MonadSTM (ExceptT e m) where + type STM (ExceptT e m) = ExceptT e (STM m) + atomically = ExceptT . atomically . runExceptT + + type TVar (ExceptT e m) = TVar m + newTVar = lift . newTVar + readTVar = lift . readTVar + writeTVar = lift .: writeTVar + retry = lift retry + orElse = ExceptT .: on orElse runExceptT + + modifyTVar = lift .: modifyTVar + modifyTVar' = lift .: modifyTVar' + stateTVar = lift .: stateTVar + swapTVar = lift .: swapTVar + check = lift . check + + type TMVar (ExceptT e m) = TMVar m + newTMVar = lift . newTMVar + newEmptyTMVar = lift newEmptyTMVar + takeTMVar = lift . takeTMVar + tryTakeTMVar = lift . tryTakeTMVar + putTMVar = lift .: putTMVar + tryPutTMVar = lift .: tryPutTMVar + readTMVar = lift . readTMVar + tryReadTMVar = lift . tryReadTMVar + swapTMVar = lift .: swapTMVar + writeTMVar = lift .: writeTMVar + isEmptyTMVar = lift . isEmptyTMVar + + type TQueue (ExceptT e m) = TQueue m + newTQueue = lift newTQueue + readTQueue = lift . readTQueue + tryReadTQueue = lift . tryReadTQueue + peekTQueue = lift . peekTQueue + tryPeekTQueue = lift . tryPeekTQueue + flushTQueue = lift . flushTQueue + writeTQueue v = lift . writeTQueue v + isEmptyTQueue = lift . isEmptyTQueue + unGetTQueue = lift .: unGetTQueue + + type TBQueue (ExceptT e m) = TBQueue m + newTBQueue = lift . newTBQueue + readTBQueue = lift . readTBQueue + tryReadTBQueue = lift . tryReadTBQueue + peekTBQueue = lift . peekTBQueue + tryPeekTBQueue = lift . tryPeekTBQueue + flushTBQueue = lift . flushTBQueue + writeTBQueue = lift .: writeTBQueue + lengthTBQueue = lift . lengthTBQueue + isEmptyTBQueue = lift . isEmptyTBQueue + isFullTBQueue = lift . isFullTBQueue + unGetTBQueue = lift .: unGetTBQueue + + type TArray (ExceptT e m) = TArray m + + type TSem (ExceptT e m) = TSem m + newTSem = lift . newTSem + waitTSem = lift . waitTSem + signalTSem = lift . signalTSem + signalTSemN = lift .: signalTSemN + + type TChan (ExceptT e m) = TChan m + newTChan = lift newTChan + newBroadcastTChan = lift newBroadcastTChan + dupTChan = lift . dupTChan + cloneTChan = lift . cloneTChan + readTChan = lift . readTChan + tryReadTChan = lift . tryReadTChan + peekTChan = lift . peekTChan + tryPeekTChan = lift . tryPeekTChan + writeTChan = lift .: writeTChan + unGetTChan = lift .: unGetTChan + isEmptyTChan = lift . isEmptyTChan + + +-- | The underlying stm monad is also transformed. +-- +instance (Monoid w, MonadSTM m) => MonadSTM (Lazy.RWST r w s m) where + type STM (Lazy.RWST r w s m) = Lazy.RWST r w s (STM m) + atomically (Lazy.RWST stm) = Lazy.RWST $ \r s -> atomically (stm r s) + + type TVar (Lazy.RWST r w s m) = TVar m + newTVar = lift . newTVar + readTVar = lift . readTVar + writeTVar = lift .: writeTVar + retry = lift retry + orElse (Lazy.RWST a) (Lazy.RWST b) = Lazy.RWST $ \r s -> a r s `orElse` b r s + + modifyTVar = lift .: modifyTVar + modifyTVar' = lift .: modifyTVar' + stateTVar = lift .: stateTVar + swapTVar = lift .: swapTVar + check = lift . check + + type TMVar (Lazy.RWST r w s m) = TMVar m + newTMVar = lift . newTMVar + newEmptyTMVar = lift newEmptyTMVar + takeTMVar = lift . takeTMVar + tryTakeTMVar = lift . tryTakeTMVar + putTMVar = lift .: putTMVar + tryPutTMVar = lift .: tryPutTMVar + readTMVar = lift . readTMVar + tryReadTMVar = lift . tryReadTMVar + swapTMVar = lift .: swapTMVar + writeTMVar = lift .: writeTMVar + isEmptyTMVar = lift . isEmptyTMVar + + type TQueue (Lazy.RWST r w s m) = TQueue m + newTQueue = lift newTQueue + readTQueue = lift . readTQueue + tryReadTQueue = lift . tryReadTQueue + peekTQueue = lift . peekTQueue + tryPeekTQueue = lift . tryPeekTQueue + flushTQueue = lift . flushTQueue + writeTQueue v = lift . writeTQueue v + isEmptyTQueue = lift . isEmptyTQueue + unGetTQueue = lift .: unGetTQueue + + type TBQueue (Lazy.RWST r w s m) = TBQueue m + newTBQueue = lift . newTBQueue + readTBQueue = lift . readTBQueue + tryReadTBQueue = lift . tryReadTBQueue + peekTBQueue = lift . peekTBQueue + tryPeekTBQueue = lift . tryPeekTBQueue + flushTBQueue = lift . flushTBQueue + writeTBQueue = lift .: writeTBQueue + lengthTBQueue = lift . lengthTBQueue + isEmptyTBQueue = lift . isEmptyTBQueue + isFullTBQueue = lift . isFullTBQueue + unGetTBQueue = lift .: unGetTBQueue + + type TArray (Lazy.RWST r w s m) = TArray m + + type TSem (Lazy.RWST r w s m) = TSem m + newTSem = lift . newTSem + waitTSem = lift . waitTSem + signalTSem = lift . signalTSem + signalTSemN = lift .: signalTSemN + + type TChan (Lazy.RWST r w s m) = TChan m + newTChan = lift newTChan + newBroadcastTChan = lift newBroadcastTChan + dupTChan = lift . dupTChan + cloneTChan = lift . cloneTChan + readTChan = lift . readTChan + tryReadTChan = lift . tryReadTChan + peekTChan = lift . peekTChan + tryPeekTChan = lift . tryPeekTChan + writeTChan = lift .: writeTChan + unGetTChan = lift .: unGetTChan + isEmptyTChan = lift . isEmptyTChan + + +-- | The underlying stm monad is also transformed. +-- +instance (Monoid w, MonadSTM m) => MonadSTM (Strict.RWST r w s m) where + type STM (Strict.RWST r w s m) = Strict.RWST r w s (STM m) + atomically (Strict.RWST stm) = Strict.RWST $ \r s -> atomically (stm r s) + + type TVar (Strict.RWST r w s m) = TVar m + newTVar = lift . newTVar + readTVar = lift . readTVar + writeTVar = lift .: writeTVar + retry = lift retry + orElse (Strict.RWST a) (Strict.RWST b) = Strict.RWST $ \r s -> a r s `orElse` b r s + + modifyTVar = lift .: modifyTVar + modifyTVar' = lift .: modifyTVar' + stateTVar = lift .: stateTVar + swapTVar = lift .: swapTVar + check = lift . check + + type TMVar (Strict.RWST r w s m) = TMVar m + newTMVar = lift . newTMVar + newEmptyTMVar = lift newEmptyTMVar + takeTMVar = lift . takeTMVar + tryTakeTMVar = lift . tryTakeTMVar + putTMVar = lift .: putTMVar + tryPutTMVar = lift .: tryPutTMVar + readTMVar = lift . readTMVar + tryReadTMVar = lift . tryReadTMVar + swapTMVar = lift .: swapTMVar + writeTMVar = lift .: writeTMVar + isEmptyTMVar = lift . isEmptyTMVar + + type TQueue (Strict.RWST r w s m) = TQueue m + newTQueue = lift newTQueue + readTQueue = lift . readTQueue + tryReadTQueue = lift . tryReadTQueue + peekTQueue = lift . peekTQueue + tryPeekTQueue = lift . tryPeekTQueue + flushTQueue = lift . flushTQueue + writeTQueue v = lift . writeTQueue v + isEmptyTQueue = lift . isEmptyTQueue + unGetTQueue = lift .: unGetTQueue + + type TBQueue (Strict.RWST r w s m) = TBQueue m + newTBQueue = lift . newTBQueue + readTBQueue = lift . readTBQueue + tryReadTBQueue = lift . tryReadTBQueue + peekTBQueue = lift . peekTBQueue + tryPeekTBQueue = lift . tryPeekTBQueue + flushTBQueue = lift . flushTBQueue + writeTBQueue = lift .: writeTBQueue + lengthTBQueue = lift . lengthTBQueue + isEmptyTBQueue = lift . isEmptyTBQueue + isFullTBQueue = lift . isFullTBQueue + unGetTBQueue = lift .: unGetTBQueue + + type TArray (Strict.RWST r w s m) = TArray m + + type TSem (Strict.RWST r w s m) = TSem m + newTSem = lift . newTSem + waitTSem = lift . waitTSem + signalTSem = lift . signalTSem + signalTSemN = lift .: signalTSemN + + type TChan (Strict.RWST r w s m) = TChan m + newTChan = lift newTChan + newBroadcastTChan = lift newBroadcastTChan + dupTChan = lift . dupTChan + cloneTChan = lift . cloneTChan + readTChan = lift . readTChan + tryReadTChan = lift . tryReadTChan + peekTChan = lift . peekTChan + tryPeekTChan = lift . tryPeekTChan + writeTChan = lift .: writeTChan + unGetTChan = lift .: unGetTChan + isEmptyTChan = lift . isEmptyTChan + + +(.:) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d) +(f .: g) x y = f (g x y) diff --git a/mtl/Control/Monad/Class/MonadSay/Trans.hs b/mtl/Control/Monad/Class/MonadSay/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/MonadSay/Trans.hs @@ -0,0 +1,30 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Control.Monad.Class.MonadSay.Trans () where + +import Control.Monad.Cont +import Control.Monad.Except +import Control.Monad.RWS +import Control.Monad.State +import Control.Monad.Writer + +import Control.Monad.Class.MonadSay + +-- | @since 0.1.0.0 +instance MonadSay m => MonadSay (ContT r m) where + say = lift . say + +-- | @since 0.1.0.0 +instance MonadSay m => MonadSay (ExceptT e m) where + say = lift . say + +-- | @since 0.1.0.0 +instance (Monoid w, MonadSay m) => MonadSay (RWST r w s m) where + say = lift . say + +-- | @since 0.1.0.0 +instance MonadSay m => MonadSay (StateT s m) where + say = lift . say + +-- | @since 0.1.0.0 +instance (Monoid w, MonadSay m) => MonadSay (WriterT w m) where + say = lift . say diff --git a/mtl/Control/Monad/Class/MonadThrow/Trans.hs b/mtl/Control/Monad/Class/MonadThrow/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/MonadThrow/Trans.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Control.Monad.Class.MonadThrow.Trans () where + +import Control.Monad.Except (ExceptT (..), runExceptT) +import Control.Monad.RWS.Lazy qualified as Lazy +import Control.Monad.RWS.Strict qualified as Strict +import Control.Monad.State.Lazy qualified as Lazy +import Control.Monad.State.Strict qualified as Strict +import Control.Monad.Trans (lift) +import Control.Monad.Writer.Lazy qualified as Lazy +import Control.Monad.Writer.Strict qualified as Strict + +import Control.Monad.Class.MonadThrow + +-- +-- ExceptT Instances +-- +-- These all follow the @exceptions@ package to the letter +-- + +instance MonadCatch m => MonadThrow (ExceptT e m) where + throwIO = lift . throwIO +#if __GLASGOW_HASKELL__ >= 910 + annotateIO ann (ExceptT io) = ExceptT (annotateIO ann io) +#endif + + +instance MonadCatch m => MonadCatch (ExceptT e m) where + catch (ExceptT m) f = ExceptT $ catch m (runExceptT . f) + + generalBracket acquire release use = ExceptT $ do + (eb, ec) <- generalBracket + (runExceptT acquire) + (\eresource exitCase -> case eresource of + Left e -> return (Left e) -- nothing to release, acquire didn't succeed + Right resource -> case exitCase of + ExitCaseSuccess (Right b) -> runExceptT (release resource (ExitCaseSuccess b)) + ExitCaseException e -> runExceptT (release resource (ExitCaseException e)) + _ -> runExceptT (release resource ExitCaseAbort)) + (either (return . Left) (runExceptT . use)) + return $ do + -- The order in which we perform those two 'Either' effects determines + -- which error will win if they are both 'Left's. We want the error from + -- 'release' to win. + c <- ec + b <- eb + return (b, c) + +instance MonadMask m => MonadMask (ExceptT e m) where + mask f = ExceptT $ mask $ \u -> runExceptT $ f (q u) + where + q :: (m (Either e a) -> m (Either e a)) + -> ExceptT e m a -> ExceptT e m a + q u (ExceptT b) = ExceptT (u b) + uninterruptibleMask f = ExceptT $ uninterruptibleMask $ \u -> runExceptT $ f (q u) + where + q :: (m (Either e a) -> m (Either e a)) + -> ExceptT e m a -> ExceptT e m a + q u (ExceptT b) = ExceptT (u b) + +-- +-- Lazy.WriterT instances +-- + +-- | @since 1.0.0.0 +instance (Monoid w, MonadCatch m) => MonadThrow (Lazy.WriterT w m) where + throwIO = lift . throwIO + +#if __GLASGOW_HASKELL__ >= 910 + annotateIO ann (Lazy.WriterT io) = Lazy.WriterT (annotateIO ann io) +#endif + +-- | @since 1.0.0.0 +instance (Monoid w, MonadCatch m) => MonadCatch (Lazy.WriterT w m) where + catch (Lazy.WriterT m) f = Lazy.WriterT $ catch m (Lazy.runWriterT . f) + + generalBracket acquire release use = Lazy.WriterT $ fmap f $ + generalBracket + (Lazy.runWriterT acquire) + (\(resource, w) e -> + case e of + ExitCaseSuccess (b, w') -> + g w' <$> Lazy.runWriterT (release resource (ExitCaseSuccess b)) + ExitCaseException err -> + g w <$> Lazy.runWriterT (release resource (ExitCaseException err)) + ExitCaseAbort -> + g w <$> Lazy.runWriterT (release resource ExitCaseAbort)) + (\(resource, w) -> g w <$> Lazy.runWriterT (use resource)) + where f ((x,_),(y,w)) = ((x,y),w) + g w (a,w') = (a,w<>w') + +-- | @since 1.0.0.0 +instance (Monoid w, MonadMask m) => MonadMask (Lazy.WriterT w m) where + mask f = Lazy.WriterT $ mask $ \u -> Lazy.runWriterT $ f (q u) + where + q :: (forall x. m x -> m x) + -> Lazy.WriterT w m a -> Lazy.WriterT w m a + q u (Lazy.WriterT b) = Lazy.WriterT (u b) + uninterruptibleMask f = Lazy.WriterT $ uninterruptibleMask $ \u -> Lazy.runWriterT $ f (q u) + where + q :: (forall x. m x -> m x) + -> Lazy.WriterT w m a -> Lazy.WriterT w m a + q u (Lazy.WriterT b) = Lazy.WriterT (u b) + +-- +-- Strict.WriterT instances +-- + +-- | @since 1.0.0.0 +instance (Monoid w, MonadCatch m) => MonadThrow (Strict.WriterT w m) where + throwIO = lift . throwIO +#if __GLASGOW_HASKELL__ >= 910 + annotateIO ann (Strict.WriterT io) = Strict.WriterT (annotateIO ann io) +#endif + +-- | @since 1.0.0.0 +instance (Monoid w, MonadCatch m) => MonadCatch (Strict.WriterT w m) where + catch (Strict.WriterT m) f = Strict.WriterT $ catch m (Strict.runWriterT . f) + + generalBracket acquire release use = Strict.WriterT $ fmap f $ + generalBracket + (Strict.runWriterT acquire) + (\(resource, w) e -> + case e of + ExitCaseSuccess (b, w') -> + g w' <$> Strict.runWriterT (release resource (ExitCaseSuccess b)) + ExitCaseException err -> + g w <$> Strict.runWriterT (release resource (ExitCaseException err)) + ExitCaseAbort -> + g w <$> Strict.runWriterT (release resource ExitCaseAbort)) + (\(resource, w) -> g w <$> Strict.runWriterT (use resource)) + where f ((x,_),(y,w)) = ((x,y),w) + g w (a,w') = (a,w<>w') + +-- | @since 1.0.0.0 +instance (Monoid w, MonadMask m) => MonadMask (Strict.WriterT w m) where + mask f = Strict.WriterT $ mask $ \u -> Strict.runWriterT $ f (q u) + where + q :: (forall x. m x -> m x) + -> Strict.WriterT w m a -> Strict.WriterT w m a + q u (Strict.WriterT b) = Strict.WriterT (u b) + uninterruptibleMask f = Strict.WriterT $ uninterruptibleMask $ \u -> Strict.runWriterT $ f (q u) + where + q :: (forall x. m x -> m x) + -> Strict.WriterT w m a -> Strict.WriterT w m a + q u (Strict.WriterT b) = Strict.WriterT (u b) + + +-- +-- Lazy.RWST Instances +-- + +-- | @since 1.0.0.0 +instance (Monoid w, MonadCatch m) => MonadThrow (Lazy.RWST r w s m) where + throwIO = lift . throwIO +#if __GLASGOW_HASKELL__ >= 910 + annotateIO ann (Lazy.RWST io) = Lazy.RWST (\r s -> annotateIO ann (io r s)) +#endif + +-- | @since 1.0.0.0 +instance (Monoid w, MonadCatch m) => MonadCatch (Lazy.RWST r w s m) where + catch (Lazy.RWST m) f = Lazy.RWST $ \r s -> catch (m r s) (\e -> Lazy.runRWST (f e) r s) + + -- | general bracket ignores the state produced by the release callback + generalBracket acquire release use = Lazy.RWST $ \r s -> + f <$> generalBracket + (Lazy.runRWST acquire r s) + (\(resource, s', w') e -> + case e of + ExitCaseSuccess (b, s'', w'') -> + g w'' <$> Lazy.runRWST (release resource (ExitCaseSuccess b)) r s'' + ExitCaseException err -> + g w' <$> Lazy.runRWST (release resource (ExitCaseException err)) r s' + ExitCaseAbort -> + g w' <$> Lazy.runRWST (release resource ExitCaseAbort) r s') + (\(a, s', w') -> g w' <$> Lazy.runRWST (use a) r s') + where + f ((x,_,_),(y,s,w)) = ((x,y),s,w) + g w (x,s,w') = (x,s,w<>w') + +-- | @since 1.0.0.0 +instance (Monoid w, MonadMask m) => MonadMask (Lazy.RWST r w s m) where + mask f = Lazy.RWST $ \r s -> mask $ \u -> Lazy.runRWST (f (q u)) r s + where + q :: (forall x. m x -> m x) + -> Lazy.RWST r w s m a -> Lazy.RWST r w s m a + q u (Lazy.RWST b) = Lazy.RWST $ \r s -> u (b r s) + uninterruptibleMask f = Lazy.RWST $ \r s -> uninterruptibleMask $ \u -> Lazy.runRWST (f (q u)) r s + where + q :: (forall x. m x -> m x) + -> Lazy.RWST r w s m a -> Lazy.RWST r w s m a + q u (Lazy.RWST b) = Lazy.RWST $ \r s -> u (b r s) + + +-- +-- Strict.RWST Instances +-- + +-- | @since 1.0.0.0 +instance (Monoid w, MonadCatch m) => MonadThrow (Strict.RWST r w s m) where + throwIO = lift . throwIO +#if __GLASGOW_HASKELL__ >= 910 + annotateIO ann (Strict.RWST io) = Strict.RWST (\r s -> annotateIO ann (io r s)) +#endif + +-- | @since 1.0.0.0 +instance (Monoid w, MonadCatch m) => MonadCatch (Strict.RWST r w s m) where + catch (Strict.RWST m) f = Strict.RWST $ \r s -> catch (m r s) (\e -> Strict.runRWST (f e) r s) + + -- | general bracket ignores the state produced by the release callback + generalBracket acquire release use = Strict.RWST $ \r s -> + f <$> generalBracket + (Strict.runRWST acquire r s) + (\(resource, s', w') e -> + case e of + ExitCaseSuccess (b, s'', w'') -> + g w'' <$> Strict.runRWST (release resource (ExitCaseSuccess b)) r s'' + ExitCaseException err -> + g w' <$> Strict.runRWST (release resource (ExitCaseException err)) r s' + ExitCaseAbort -> + g w' <$> Strict.runRWST (release resource ExitCaseAbort) r s') + (\(a, s', w') -> g w' <$> Strict.runRWST (use a) r s') + where + f ((x,_,_),(y,s,w)) = ((x,y),s,w) + g w (x,s,w') = (x,s,w<>w') + +-- | @since 1.0.0.0 +instance (Monoid w, MonadMask m) => MonadMask (Strict.RWST r w s m) where + mask f = Strict.RWST $ \r s -> mask $ \u -> Strict.runRWST (f (q u)) r s + where + q :: (forall x. m x -> m x) + -> Strict.RWST r w s m a -> Strict.RWST r w s m a + q u (Strict.RWST b) = Strict.RWST $ \r s -> u (b r s) + uninterruptibleMask f = Strict.RWST $ \r s -> uninterruptibleMask $ \u -> Strict.runRWST (f (q u)) r s + where + q :: (forall x. m x -> m x) + -> Strict.RWST r w s m a -> Strict.RWST r w s m a + q u (Strict.RWST b) = Strict.RWST $ \r s -> u (b r s) + + +-- +-- Lazy.StateT instances +-- + +-- | @since 1.0.0.0 +instance MonadCatch m => MonadThrow (Lazy.StateT s m) where + throwIO = lift . throwIO +#if __GLASGOW_HASKELL__ >= 910 + annotateIO ann (Lazy.StateT io) = Lazy.StateT (\s -> annotateIO ann (io s)) +#endif + +-- | @since 1.0.0.0 +instance MonadCatch m => MonadCatch (Lazy.StateT s m) where + catch (Lazy.StateT m) f = Lazy.StateT $ \s -> catch (m s) (\e -> Lazy.runStateT (f e) s) + + -- | general bracket ignores the state produced by the release callback + generalBracket acquire release use = Lazy.StateT $ \s -> fmap f $ + generalBracket + (Lazy.runStateT acquire s) + (\(resource, s') e -> + case e of + ExitCaseSuccess (b, s'') -> + Lazy.runStateT (release resource (ExitCaseSuccess b)) s'' + ExitCaseException err -> + Lazy.runStateT (release resource (ExitCaseException err)) s' + ExitCaseAbort -> + Lazy.runStateT (release resource ExitCaseAbort) s') + (\(a, s') -> Lazy.runStateT (use a) s') + where f ((x,_),(y,s)) = ((x,y),s) + +-- | @since 1.0.0.0 +instance MonadMask m => MonadMask (Lazy.StateT s m) where + mask f = Lazy.StateT $ \s -> mask $ \u -> Lazy.runStateT (f (q u)) s + where + q :: (forall x. m x -> m x) + -> Lazy.StateT s m a -> Lazy.StateT s m a + q u (Lazy.StateT b) = Lazy.StateT $ \s -> u (b s) + uninterruptibleMask f = Lazy.StateT $ \s -> uninterruptibleMask $ \u -> Lazy.runStateT (f (q u)) s + where + q :: (forall x. m x -> m x) + -> Lazy.StateT s m a -> Lazy.StateT s m a + q u (Lazy.StateT b) = Lazy.StateT $ \s -> u (b s) + + +-- +-- Strict.StateT instances +-- + +-- | @since 1.0.0.0 +instance MonadCatch m => MonadThrow (Strict.StateT s m) where + throwIO = lift . throwIO +#if __GLASGOW_HASKELL__ >= 910 + annotateIO ann (Strict.StateT io) = Strict.StateT (\s -> annotateIO ann (io s)) +#endif + +-- | @since 1.0.0.0 +instance MonadCatch m => MonadCatch (Strict.StateT s m) where + catch (Strict.StateT m) f = Strict.StateT $ \s -> catch (m s) (\e -> Strict.runStateT (f e) s) + + -- | general bracket ignores the state produced by the release callback + generalBracket acquire release use = Strict.StateT $ \s -> fmap f $ + generalBracket + (Strict.runStateT acquire s) + (\(resource, s') e -> + case e of + ExitCaseSuccess (b, s'') -> + Strict.runStateT (release resource (ExitCaseSuccess b)) s'' + ExitCaseException err -> + Strict.runStateT (release resource (ExitCaseException err)) s' + ExitCaseAbort -> + Strict.runStateT (release resource ExitCaseAbort) s') + (\(a, s') -> Strict.runStateT (use a) s') + where f ((x,_),(y,s)) = ((x,y),s) + +-- | @since 1.0.0.0 +instance MonadMask m => MonadMask (Strict.StateT s m) where + mask f = Strict.StateT $ \s -> mask $ \u -> Strict.runStateT (f (q u)) s + where + q :: (forall x. m x -> m x) + -> Strict.StateT s m a -> Strict.StateT s m a + q u (Strict.StateT b) = Strict.StateT $ \s -> u (b s) + uninterruptibleMask f = Strict.StateT $ \s -> uninterruptibleMask $ \u -> Strict.runStateT (f (q u)) s + where + q :: (forall x. m x -> m x) + -> Strict.StateT s m a -> Strict.StateT s m a + q u (Strict.StateT b) = Strict.StateT $ \s -> u (b s) + diff --git a/mtl/Control/Monad/Class/MonadTime/SI/Trans.hs b/mtl/Control/Monad/Class/MonadTime/SI/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/MonadTime/SI/Trans.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Control.Monad.Class.MonadTime.SI.Trans () where + +import Control.Monad.Cont (ContT) +import Control.Monad.Except (ExceptT) +import Control.Monad.RWS.Lazy qualified as Lazy +import Control.Monad.RWS.Strict qualified as Strict +import Control.Monad.State.Lazy qualified as Lazy +import Control.Monad.State.Strict qualified as Strict +import Control.Monad.Trans (lift) +import Control.Monad.Writer.Lazy qualified as Lazy +import Control.Monad.Writer.Strict qualified as Strict + +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTime.Trans () + +instance MonadMonotonicTime m => MonadMonotonicTime (ExceptT e m) where + getMonotonicTime = lift getMonotonicTime + +instance MonadMonotonicTime m => MonadMonotonicTime (Lazy.StateT s m) where + getMonotonicTime = lift getMonotonicTime + +instance MonadMonotonicTime m => MonadMonotonicTime (Strict.StateT s m) where + getMonotonicTime = lift getMonotonicTime + +instance (Monoid w, MonadMonotonicTime m) => MonadMonotonicTime (Lazy.WriterT w m) where + getMonotonicTime = lift getMonotonicTime + +instance (Monoid w, MonadMonotonicTime m) => MonadMonotonicTime (Strict.WriterT w m) where + getMonotonicTime = lift getMonotonicTime + +instance (Monoid w, MonadMonotonicTime m) => MonadMonotonicTime (Lazy.RWST r w s m) where + getMonotonicTime = lift getMonotonicTime + +instance (Monoid w, MonadMonotonicTime m) => MonadMonotonicTime (Strict.RWST r w s m) where + getMonotonicTime = lift getMonotonicTime + +instance MonadMonotonicTime m => MonadMonotonicTime (ContT r m) where + getMonotonicTime = lift getMonotonicTime diff --git a/mtl/Control/Monad/Class/MonadTime/Trans.hs b/mtl/Control/Monad/Class/MonadTime/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/MonadTime/Trans.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Control.Monad.Class.MonadTime.Trans () where + +import Control.Monad.Cont (ContT) +import Control.Monad.Except (ExceptT) +import Control.Monad.RWS.Lazy qualified as Lazy +import Control.Monad.RWS.Strict qualified as Strict +import Control.Monad.State.Lazy qualified as Lazy +import Control.Monad.State.Strict qualified as Strict +import Control.Monad.Trans (lift) +import Control.Monad.Writer.Lazy qualified as Lazy +import Control.Monad.Writer.Strict qualified as Strict + +import Control.Monad.Class.MonadTime + +instance MonadMonotonicTimeNSec m => MonadMonotonicTimeNSec (ExceptT e m) where + getMonotonicTimeNSec = lift getMonotonicTimeNSec + +instance MonadMonotonicTimeNSec m => MonadMonotonicTimeNSec (Lazy.StateT s m) where + getMonotonicTimeNSec = lift getMonotonicTimeNSec + +instance MonadMonotonicTimeNSec m => MonadMonotonicTimeNSec (Strict.StateT s m) where + getMonotonicTimeNSec = lift getMonotonicTimeNSec + +instance (Monoid w, MonadMonotonicTimeNSec m) => MonadMonotonicTimeNSec (Lazy.WriterT w m) where + getMonotonicTimeNSec = lift getMonotonicTimeNSec + +instance (Monoid w, MonadMonotonicTimeNSec m) => MonadMonotonicTimeNSec (Strict.WriterT w m) where + getMonotonicTimeNSec = lift getMonotonicTimeNSec + +instance (Monoid w, MonadMonotonicTimeNSec m) => MonadMonotonicTimeNSec (Lazy.RWST r w s m) where + getMonotonicTimeNSec = lift getMonotonicTimeNSec + +instance (Monoid w, MonadMonotonicTimeNSec m) => MonadMonotonicTimeNSec (Strict.RWST r w s m) where + getMonotonicTimeNSec = lift getMonotonicTimeNSec + +instance MonadMonotonicTimeNSec m => MonadMonotonicTimeNSec (ContT r m) where + getMonotonicTimeNSec = lift getMonotonicTimeNSec + +instance MonadTime m => MonadTime (ExceptT e m) where + getCurrentTime = lift getCurrentTime + +instance MonadTime m => MonadTime (Lazy.StateT s m) where + getCurrentTime = lift getCurrentTime + +instance MonadTime m => MonadTime (Strict.StateT s m) where + getCurrentTime = lift getCurrentTime + +instance (Monoid w, MonadTime m) => MonadTime (Lazy.WriterT w m) where + getCurrentTime = lift getCurrentTime + +instance (Monoid w, MonadTime m) => MonadTime (Strict.WriterT w m) where + getCurrentTime = lift getCurrentTime + +instance (Monoid w, MonadTime m) => MonadTime (Lazy.RWST r w s m) where + getCurrentTime = lift getCurrentTime + +instance (Monoid w, MonadTime m) => MonadTime (Strict.RWST r w s m) where + getCurrentTime = lift getCurrentTime + +instance MonadTime m => MonadTime (ContT r m) where + getCurrentTime = lift getCurrentTime diff --git a/mtl/Control/Monad/Class/MonadTimer/SI/Trans.hs b/mtl/Control/Monad/Class/MonadTimer/SI/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/MonadTimer/SI/Trans.hs @@ -0,0 +1,66 @@ +-- undecidable instances needed for 'ContTSTM' instances of +-- 'MonadThrow' and 'MonadCatch' type classes. +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Control.Monad.Class.MonadTimer.SI.Trans () where + +import Control.Monad.Cont (ContT (..)) +import Control.Monad.Except (ExceptT (..)) +import Control.Monad.RWS (RWST (..)) +import Control.Monad.State (StateT (..)) +import Control.Monad.Trans (lift) +import Control.Monad.Writer (WriterT (..)) + +import Control.Monad.Class.MonadTimer.SI + +import Control.Monad.Class.MonadTime.SI.Trans () +import Control.Monad.Class.MonadTimer.Trans () + +import Data.Bifunctor (bimap) + + +instance MonadDelay m => MonadDelay (ContT r m) where + threadDelay = lift . threadDelay +instance (Monoid w, MonadDelay m) => MonadDelay (WriterT w m) where + threadDelay = lift . threadDelay +instance MonadDelay m => MonadDelay (StateT s m) where + threadDelay = lift . threadDelay +instance MonadDelay m => MonadDelay (ExceptT e m) where + threadDelay = lift . threadDelay +instance (Monoid w, MonadDelay m) => MonadDelay (RWST r w s m) where + threadDelay = lift . threadDelay + +instance (Monoid w, MonadTimer m) => MonadTimer (WriterT w m) where + registerDelay = lift . registerDelay + registerDelayCancellable = fmap (bimap lift lift) + . lift + . registerDelayCancellable + timeout d f = WriterT $ do + r <- timeout d (runWriterT f) + return $ case r of + Nothing -> (Nothing, mempty) + Just (a, w) -> (Just a, w) + +instance MonadTimer m => MonadTimer (StateT s m) where + registerDelay = lift . registerDelay + registerDelayCancellable = fmap (bimap lift lift) + . lift + . registerDelayCancellable + timeout d f = StateT $ \s -> do + r <- timeout d (runStateT f s) + return $ case r of + Nothing -> (Nothing, s) + Just (a, s') -> (Just a, s') + +instance (Monoid w, MonadTimer m) => MonadTimer (RWST r w s m) where + registerDelay = lift . registerDelay + registerDelayCancellable = fmap (bimap lift lift) + . lift + . registerDelayCancellable + timeout d (RWST f) = RWST $ \r s -> do + res <- timeout d (f r s) + return $ case res of + Nothing -> (Nothing, s, mempty) + Just (a, s', w) -> (Just a, s', w) + diff --git a/mtl/Control/Monad/Class/MonadTimer/Trans.hs b/mtl/Control/Monad/Class/MonadTimer/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/MonadTimer/Trans.hs @@ -0,0 +1,92 @@ +-- undecidable instances needed for 'ContTSTM' instances of +-- 'MonadThrow' and 'MonadCatch' type classes. +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Control.Monad.Class.MonadTimer.Trans () where + +import Control.Monad.Cont (ContT (..)) +import Control.Monad.Except (ExceptT (..)) +import Control.Monad.RWS.Lazy qualified as Lazy +import Control.Monad.RWS.Strict qualified as Strict +import Control.Monad.State.Lazy qualified as Lazy +import Control.Monad.State.Strict qualified as Strict +import Control.Monad.Trans (lift) +import Control.Monad.Writer.Lazy qualified as Lazy +import Control.Monad.Writer.Strict qualified as Strict + +import Control.Monad.Class.MonadTimer + +import Control.Monad.Class.MonadSTM.Trans () + +instance MonadDelay m => MonadDelay (ContT r m) where + threadDelay = lift . threadDelay + +instance (Monoid w, MonadDelay m) => MonadDelay (Lazy.WriterT w m) where + threadDelay = lift . threadDelay + +instance (Monoid w, MonadDelay m) => MonadDelay (Strict.WriterT w m) where + threadDelay = lift . threadDelay + +instance MonadDelay m => MonadDelay (Lazy.StateT s m) where + threadDelay = lift . threadDelay + +instance MonadDelay m => MonadDelay (Strict.StateT s m) where + threadDelay = lift . threadDelay + +instance MonadDelay m => MonadDelay (ExceptT e m) where + threadDelay = lift . threadDelay + +instance (Monoid w, MonadDelay m) => MonadDelay (Lazy.RWST r w s m) where + threadDelay = lift . threadDelay + +instance (Monoid w, MonadDelay m) => MonadDelay (Strict.RWST r w s m) where + threadDelay = lift . threadDelay + +instance (Monoid w, MonadTimer m) => MonadTimer (Lazy.WriterT w m) where + registerDelay = lift . registerDelay + timeout d f = Lazy.WriterT $ do + r <- timeout d (Lazy.runWriterT f) + return $ case r of + Nothing -> (Nothing, mempty) + Just (a, w) -> (Just a, w) + +instance (Monoid w, MonadTimer m) => MonadTimer (Strict.WriterT w m) where + registerDelay = lift . registerDelay + timeout d f = Strict.WriterT $ do + r <- timeout d (Strict.runWriterT f) + return $ case r of + Nothing -> (Nothing, mempty) + Just (a, w) -> (Just a, w) + +instance MonadTimer m => MonadTimer (Lazy.StateT s m) where + registerDelay = lift . registerDelay + timeout d f = Lazy.StateT $ \s -> do + r <- timeout d (Lazy.runStateT f s) + return $ case r of + Nothing -> (Nothing, s) + Just (a, s') -> (Just a, s') + +instance MonadTimer m => MonadTimer (Strict.StateT s m) where + registerDelay = lift . registerDelay + timeout d f = Strict.StateT $ \s -> do + r <- timeout d (Strict.runStateT f s) + return $ case r of + Nothing -> (Nothing, s) + Just (a, s') -> (Just a, s') + +instance (Monoid w, MonadTimer m) => MonadTimer (Lazy.RWST r w s m) where + registerDelay = lift . registerDelay + timeout d (Lazy.RWST f) = Lazy.RWST $ \r s -> do + res <- timeout d (f r s) + return $ case res of + Nothing -> (Nothing, s, mempty) + Just (a, s', w) -> (Just a, s', w) + +instance (Monoid w, MonadTimer m) => MonadTimer (Strict.RWST r w s m) where + registerDelay = lift . registerDelay + timeout d (Strict.RWST f) = Strict.RWST $ \r s -> do + res <- timeout d (f r s) + return $ case res of + Nothing -> (Nothing, s, mempty) + Just (a, s', w) -> (Just a, s', w) diff --git a/mtl/Control/Monad/Class/Trans.hs b/mtl/Control/Monad/Class/Trans.hs new file mode 100644 --- /dev/null +++ b/mtl/Control/Monad/Class/Trans.hs @@ -0,0 +1,13 @@ +-- | Export all orphaned instances. +-- +module Control.Monad.Class.Trans (module X) where + +import Control.Monad.Class.MonadEventlog.Trans as X () +import Control.Monad.Class.MonadSay.Trans as X () +import Control.Monad.Class.MonadST.Trans as X () +import Control.Monad.Class.MonadSTM.Trans as X +import Control.Monad.Class.MonadThrow.Trans as X () +import Control.Monad.Class.MonadTime.SI.Trans as X () +import Control.Monad.Class.MonadTime.Trans as X () +import Control.Monad.Class.MonadTimer.SI.Trans as X () +import Control.Monad.Class.MonadTimer.Trans as X () diff --git a/si-timers/src/Control/Monad/Class/MonadTime/SI.hs b/si-timers/src/Control/Monad/Class/MonadTime/SI.hs new file mode 100644 --- /dev/null +++ b/si-timers/src/Control/Monad/Class/MonadTime/SI.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NumericUnderscores #-} + +module Control.Monad.Class.MonadTime.SI + ( MonadTime (..) + , MonadMonotonicTime (..) + -- * 'DiffTime' and its action on 'Time' + , Time (..) + , diffTime + , addTime + , DiffTime + -- * 'NominalTime' and its action on 'UTCTime' + , UTCTime + , diffUTCTime + , addUTCTime + , NominalDiffTime + ) where + +import Control.DeepSeq (NFData (..)) +import Control.Monad.Reader + +import Control.Monad.Class.MonadTime (MonadMonotonicTimeNSec, MonadTime (..), + NominalDiffTime, UTCTime, addUTCTime, diffUTCTime) +import Control.Monad.Class.MonadTime qualified as MonadTime + +import NoThunks.Class (NoThunks (..)) + +import Data.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. +-- +-- 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 newtype NFData + deriving anyclass NoThunks + +-- | The time duration between two points in time (positive or negative). +diffTime :: Time -> Time -> DiffTime +diffTime (Time t) (Time t') = t - t' + +-- | Add a duration to a point in time, giving another time. +addTime :: DiffTime -> Time -> Time +addTime d (Time t) = Time (d + t) + +infixr 9 `addTime` + +class MonadMonotonicTimeNSec m => MonadMonotonicTime m where + getMonotonicTime :: m Time + + default getMonotonicTime :: m Time + getMonotonicTime = + conv <$> MonadTime.getMonotonicTimeNSec + where + conv :: Word64 -> Time + conv = Time . Time.picosecondsToDiffTime . (* 1_000) . toInteger + +instance MonadMonotonicTime IO where + +-- +-- MTL instances +-- + +instance MonadMonotonicTime m => MonadMonotonicTime (ReaderT r m) where + getMonotonicTime = lift getMonotonicTime diff --git a/si-timers/src/Control/Monad/Class/MonadTimer/NonStandard.hs b/si-timers/src/Control/Monad/Class/MonadTimer/NonStandard.hs new file mode 100644 --- /dev/null +++ b/si-timers/src/Control/Monad/Class/MonadTimer/NonStandard.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE TypeFamilies #-} + +#if defined(__GLASGOW_HASKELL__) && \ + !defined(mingw32_HOST_OS) && \ + !defined(__GHCJS__) && \ + !defined(js_HOST_ARCH) && \ + !defined(wasm32_HOST_ARCH) +#define GHC_TIMERS_API +#endif + +-- | A non-standard interface for timer api. +-- +-- This module also provides a polyfill which allows to use timer api also on +-- non-threaded RTS regardless of the architecture \/ OS. Currently we support +-- `*nix`, `macOS`, `Windows` (and, unofficially `GHCJS`). +-- +-- We use it to provide @'Control.Monad.Class.MonadTimer.MonadTimer' 'IO'@ +-- instance and to implement a cancellable timers, see +-- 'Control.Monad.Class.MonadTimer.SI.registerDelayCancellable'. +-- +-- You can expect we will deprecate it at some point (e.g. once GHC gets +-- a better support for timers especially across different execution +-- environments). +-- +module Control.Monad.Class.MonadTimer.NonStandard + ( TimeoutState (..) + , newTimeout + , readTimeout + , cancelTimeout + , awaitTimeout + , NewTimeout + , ReadTimeout + , CancelTimeout + , AwaitTimeout + ) where + +import Control.Concurrent.STM qualified as STM +#ifndef GHC_TIMERS_API +import Control.Monad (when) +#endif +import Control.Monad.Class.MonadSTM + +#ifdef GHC_TIMERS_API +import GHC.Event qualified as GHC (TimeoutKey, getSystemTimerManager, + registerTimeout, unregisterTimeout) +#else +import GHC.Conc.IO qualified as GHC (registerDelay) +#endif + + +-- | State of a timeout: pending, fired or cancelled. +-- +data TimeoutState = TimeoutPending | TimeoutFired | TimeoutCancelled + deriving (Eq, Ord, Show) + + +-- | The type of the timeout handle, used with 'newTimeout', 'readTimeout', and +-- 'cancelTimeout'. +-- +#ifdef GHC_TIMERS_API +data Timeout = TimeoutIO !(STM.TVar TimeoutState) !GHC.TimeoutKey +#else +data Timeout = TimeoutIO !(STM.TVar (STM.TVar Bool)) !(STM.TVar Bool) +#endif + +-- | Create a new timeout which will fire at the given time duration in +-- the future. +-- +-- The timeout will start in the 'TimeoutPending' state and either +-- fire at or after the given time leaving it in the 'TimeoutFired' state, +-- or it may be cancelled with 'cancelTimeout', leaving it in the +-- 'TimeoutCancelled' state. +-- +-- Timeouts /cannot/ be reset to the pending state once fired or cancelled +-- (as this would be very racy). You should create a new timeout if you need +-- this functionality. +-- +-- When native timer manager is supported (on `*nix` systems), it only holds +-- a `TVar` with `TimeoutState` and `GHC.TimeoutKey`. +-- +newTimeout :: NewTimeout IO Timeout +type NewTimeout m timeout = Int -> m timeout + + +-- | Read the current state of a timeout. This does not block, but returns +-- the current state. It is your responsibility to use 'retry' to wait. +-- +-- Alternatively you may wish to use the convenience utility 'awaitTimeout' +-- to wait for just the fired or cancelled outcomes. +-- +-- You should consider the cancelled state if you plan to use 'cancelTimeout'. +-- +readTimeout :: ReadTimeout IO Timeout +type ReadTimeout m timeout = timeout -> STM m TimeoutState + + +-- | Cancel a timeout (unless it has already fired), putting it into the +-- 'TimeoutCancelled' state. Code reading and acting on the timeout state +-- need to handle such cancellation appropriately. +-- +-- It is safe to race this concurrently against the timer firing. It will +-- have no effect if the timer fires first. +-- +cancelTimeout :: CancelTimeout IO Timeout +type CancelTimeout m timeout = timeout -> m () + +-- | Returns @True@ when the timeout is fired, or @False@ if it is cancelled. +awaitTimeout :: AwaitTimeout IO Timeout +type AwaitTimeout m timeout = timeout -> STM m Bool + + +#ifdef GHC_TIMERS_API + +readTimeout (TimeoutIO var _key) = STM.readTVar var + +newTimeout = \d -> do + var <- STM.newTVarIO TimeoutPending + mgr <- GHC.getSystemTimerManager + key <- GHC.registerTimeout mgr d (STM.atomically (timeoutAction var)) + return (TimeoutIO var key) + where + timeoutAction var = do + x <- STM.readTVar var + case x of + TimeoutPending -> STM.writeTVar var TimeoutFired + TimeoutFired -> error "MonadTimer(IO): invariant violation" + TimeoutCancelled -> return () + +cancelTimeout (TimeoutIO var key) = do + STM.atomically $ do + x <- STM.readTVar var + case x of + TimeoutPending -> STM.writeTVar var TimeoutCancelled + TimeoutFired -> return () + TimeoutCancelled -> return () + mgr <- GHC.getSystemTimerManager + GHC.unregisterTimeout mgr key + +#else + +readTimeout (TimeoutIO timeoutvarvar cancelvar) = do + canceled <- STM.readTVar cancelvar + fired <- STM.readTVar =<< STM.readTVar timeoutvarvar + case (canceled, fired) of + (True, _) -> return TimeoutCancelled + (_, False) -> return TimeoutPending + (_, True) -> return TimeoutFired + +newTimeout d = do + timeoutvar <- GHC.registerDelay d + timeoutvarvar <- STM.newTVarIO timeoutvar + cancelvar <- STM.newTVarIO False + return (TimeoutIO timeoutvarvar cancelvar) + +cancelTimeout (TimeoutIO timeoutvarvar cancelvar) = + STM.atomically $ do + fired <- STM.readTVar =<< STM.readTVar timeoutvarvar + when (not fired) $ STM.writeTVar cancelvar True + +#endif + +awaitTimeout t = do s <- readTimeout t + case s of + TimeoutPending -> retry + TimeoutFired -> return True + TimeoutCancelled -> return False diff --git a/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs b/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs new file mode 100644 --- /dev/null +++ b/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Control.Monad.Class.MonadTimer.SI + ( -- * Type classes + MonadDelay (..) + , MonadTimer (..) + -- * Auxiliary functions + , diffTimeToMicrosecondsAsInt + , microsecondsAsIntToDiffTime + -- * Re-exports + , DiffTime + , MonadFork + , MonadMonotonicTime + , MonadTime + , TimeoutState (..) + -- * Default implementations + , defaultRegisterDelay + , defaultRegisterDelayCancellable + ) where + +import Control.Concurrent.Class.MonadSTM +import Control.Exception (assert) +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer qualified as MonadTimer +import Control.Monad.Class.MonadTimer.NonStandard (TimeoutState (..)) +import Control.Monad.Class.MonadTimer.NonStandard qualified as NonStandard + +import Control.Monad.Reader + +import Data.Bifunctor (bimap) +import Data.Functor (($>)) +import Data.Time.Clock (diffTimeToPicoseconds) + + + +-- | Convert 'DiffTime' in seconds to microseconds represented by an 'Int'. +-- +-- Note that on 32bit systems it can only represent `2^31-1` seconds, which is +-- only ~35 minutes. +-- +-- It doesn't prevent under- or overflows; when assertions are on it will thrown +-- an assertion exception. +-- +diffTimeToMicrosecondsAsInt :: DiffTime -> Int +diffTimeToMicrosecondsAsInt d = + let usec :: Integer + usec = diffTimeToPicoseconds d `div` 1_000_000 in + assert (usec <= fromIntegral (maxBound :: Int) + && usec >= fromIntegral (minBound :: Int)) $ + fromIntegral usec + + +-- | Convert time in microseconds in 'DiffTime' (measured in seconds). +-- +microsecondsAsIntToDiffTime :: Int -> DiffTime +microsecondsAsIntToDiffTime = (/ 1_000_000) . fromIntegral + +class ( MonadTimer.MonadDelay m + , MonadMonotonicTime m + ) => MonadDelay m where + threadDelay :: DiffTime -> m () + +-- | Thread delay. This implementation will not over- or underflow. +-- +-- For delay larger than what `Int` can represent (see +-- `diffTimeToMicrosecondsAsInt`), it will recursively call +-- `Control.Monad.Class.MonadTimer.threadDelay`. +-- +-- For delays smaller than `minBound :: Int` seconds, `minBound :: Int` will be +-- used instead. +-- +instance MonadDelay IO where + threadDelay :: forall m. + MonadDelay m + => DiffTime -> m () + threadDelay d | d <= 0 = return () + + threadDelay d | d <= maxDelay = + MonadTimer.threadDelay (diffTimeToMicrosecondsAsInt d) + where + maxDelay :: DiffTime + maxDelay = microsecondsAsIntToDiffTime maxBound + + threadDelay d = do + c <- getMonotonicTime + let u = d `addTime` c + go c u + where + maxDelay :: DiffTime + maxDelay = microsecondsAsIntToDiffTime maxBound + + go :: Time -> Time -> m () + go c u = do + if d' >= maxDelay + then do + MonadTimer.threadDelay maxBound + c' <- getMonotonicTime + go c' u + else + MonadTimer.threadDelay (diffTimeToMicrosecondsAsInt d') + where + d' = u `diffTime` c + +instance MonadDelay m => MonadDelay (ReaderT r m) where + threadDelay = lift . threadDelay + +class ( MonadTimer.MonadTimer m + , MonadMonotonicTime m + ) => MonadTimer m where + + -- | A register delay function which safe on 32-bit systems. + registerDelay :: DiffTime -> m (TVar m Bool) + + -- | A cancellable register delay which is safe on 32-bit systems and efficient + -- for delays smaller than what `Int` can represent (especially on systems which + -- support native timer manager). + -- + registerDelayCancellable :: DiffTime -> m (STM m TimeoutState, m ()) + + -- | A timeout function. + -- + -- TODO: 'IO' instance is not safe on 32-bit systems. + timeout :: DiffTime -> m a -> m (Maybe a) + + +-- | A default implementation of `registerDelay` which supports delays longer +-- then `Int`; this is especially important on 32-bit systems where maximum +-- delay expressed in microseconds is around 35 minutes. +-- +defaultRegisterDelay :: forall m timeout. + ( MonadFork m + , MonadMonotonicTime m + , MonadSTM m + ) + => NonStandard.NewTimeout m timeout + -> NonStandard.AwaitTimeout m timeout + -> DiffTime + -> m (TVar m Bool) +defaultRegisterDelay newTimeout awaitTimeout d = do + c <- getMonotonicTime + v <- atomically $ newTVar False + tid <- forkIO $ go v c (d `addTime` c) + labelThread tid "delay-thread" + return v + where + maxDelay :: DiffTime + maxDelay = microsecondsAsIntToDiffTime maxBound + + go :: TVar m Bool -> Time -> Time -> m () + go v c u | u `diffTime` c >= maxDelay = do + _ <- newTimeout maxBound >>= atomically . awaitTimeout + c' <- getMonotonicTime + go v c' u + + go v c u = do + t <- newTimeout (diffTimeToMicrosecondsAsInt $ u `diffTime` c) + atomically $ do + _ <- awaitTimeout t + writeTVar v True + + +-- | A cancellable register delay which is safe on 32-bit systems and efficient +-- for delays smaller than what `Int` can represent (especially on systems which +-- support native timer manager). +-- +defaultRegisterDelayCancellable :: forall m timeout. + ( MonadFork m + , MonadMonotonicTime m + , MonadSTM m + ) + => NonStandard.NewTimeout m timeout + -> NonStandard.ReadTimeout m timeout + -> NonStandard.CancelTimeout m timeout + -> NonStandard.AwaitTimeout m timeout + -> DiffTime + -> m (STM m TimeoutState, m ()) + +defaultRegisterDelayCancellable newTimeout readTimeout cancelTimeout _awaitTimeout d | d <= maxDelay = do + t <- newTimeout (diffTimeToMicrosecondsAsInt d) + return (readTimeout t, cancelTimeout t) + where + maxDelay :: DiffTime + maxDelay = microsecondsAsIntToDiffTime maxBound + +defaultRegisterDelayCancellable newTimeout _readTimeout _cancelTimeout awaitTimeout d = do + -- current time + c <- getMonotonicTime + -- timeout state + v <- newTVarIO TimeoutPending + tid <- forkIO $ go v c (d `addTime` c) + labelThread tid "delay-thread" + let cancel = atomically $ readTVar v >>= \case + TimeoutCancelled -> return () + TimeoutFired -> return () + TimeoutPending -> writeTVar v TimeoutCancelled + return (readTVar v, cancel) + where + maxDelay :: DiffTime + maxDelay = microsecondsAsIntToDiffTime maxBound + + go :: TVar m TimeoutState + -> Time + -> Time + -> m () + go v c u | u `diffTime` c >= maxDelay = do + t <- newTimeout maxBound + ts <- atomically $ do + (readTVar v >>= \case + a@TimeoutCancelled -> return a + TimeoutFired -> error "registerDelayCancellable: invariant violation!" + TimeoutPending -> retry) + `orElse` + -- the overall timeout is still pending when 't' fires + (awaitTimeout t $> TimeoutPending) + case ts of + TimeoutPending -> do + c' <- getMonotonicTime + go v c' u + _ -> return () + + go v c u = do + t <- newTimeout (diffTimeToMicrosecondsAsInt $ u `diffTime` c) + atomically $ do + ts <- (readTVar v >>= \case + a@TimeoutCancelled -> return a + TimeoutFired -> error "registerDelayCancellable: invariant violation!" + TimeoutPending -> retry) + `orElse` + -- the overall timeout fires when 't' fires + (awaitTimeout t $> TimeoutFired) + case ts of + TimeoutFired -> writeTVar v TimeoutFired + _ -> return () + + +-- | Like 'GHC.Conc.registerDelay' but safe on 32-bit systems. When the delay +-- is larger than what `Int` can represent it will fork a thread which will +-- write to the returned 'TVar' once the delay has passed. When the delay is +-- small enough it will use the `MonadTimer`'s `registerDelay` (e.g. for `IO` +-- monad it will use the `GHC`'s `GHC.Conc.registerDelay`). +-- +-- TODO: 'timeout' not safe on 32-bit systems. +instance MonadTimer IO where + registerDelay d + | d <= maxDelay = + MonadTimer.registerDelay (diffTimeToMicrosecondsAsInt d) + | otherwise = + defaultRegisterDelay + NonStandard.newTimeout + NonStandard.awaitTimeout + d + where + maxDelay :: DiffTime + maxDelay = microsecondsAsIntToDiffTime maxBound + + registerDelayCancellable = + defaultRegisterDelayCancellable + NonStandard.newTimeout + NonStandard.readTimeout + NonStandard.cancelTimeout + NonStandard.awaitTimeout + + timeout = MonadTimer.timeout . diffTimeToMicrosecondsAsInt + +instance MonadTimer m => MonadTimer (ReaderT r m) where + registerDelay = lift . registerDelay + registerDelayCancellable = fmap (bimap lift lift) . lift . registerDelayCancellable + timeout d f = ReaderT $ \r -> timeout d (runReaderT f r) diff --git a/si-timers/test/Main.hs b/si-timers/test/Main.hs new file mode 100644 --- /dev/null +++ b/si-timers/test/Main.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import Test.Tasty + +import Test.MonadTimer qualified + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup "io-classes" + [ Test.MonadTimer.tests + ] + diff --git a/si-timers/test/Test/MonadTimer.hs b/si-timers/test/Test/MonadTimer.hs new file mode 100644 --- /dev/null +++ b/si-timers/test/Test/MonadTimer.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NumericUnderscores #-} + +module Test.MonadTimer (tests) where + +import Control.Monad.Class.MonadTimer.SI +import GHC.Real + +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck (testProperty) + +tests :: TestTree +tests = + testGroup "Control.Monad.Class.MonadTimer" + [ testProperty "diffTimeToMicroseconds left inverse" + prop_diffTimeToMicrosecondsAsIntLeftInverse + , testProperty "diffTimeToMicroseconds right inverse" + prop_diffTimeToMicrosecondsAsIntRightInverse + ] + +newtype IntDistr = IntDistr Int + deriving (Show, Eq) + +instance Arbitrary IntDistr where + arbitrary = oneof + [ IntDistr <$> arbitrary + , IntDistr . (maxBound - ) . getNonNegative <$> (arbitrary :: Gen (NonNegative Int)) + , IntDistr . (minBound + ) . getNonNegative <$> (arbitrary :: Gen (NonNegative Int)) + ] + + shrink (IntDistr a) = IntDistr `map` shrink a + +prop_diffTimeToMicrosecondsAsIntLeftInverse :: IntDistr -> Bool +prop_diffTimeToMicrosecondsAsIntLeftInverse (IntDistr usec) = + usec == diffTimeToMicrosecondsAsInt (microsecondsAsIntToDiffTime usec) + + +newtype DiffTimeDistr = DiffTimeDistr DiffTime + deriving (Show, Eq) + +instance Arbitrary DiffTimeDistr where + arbitrary = frequency + [ -- arbitrary DiffTime + (6, DiffTimeDistr . fromRational <$> arbitrary) + -- large positive DiffTimes, but smaller than `maxBound :: Int` microseconds + , (3, DiffTimeDistr + . (fromRational (toRational (maxBound :: Int) / 1_000_000) - ) + . fromRational + . getNonNegative + <$> resize 100 arbitrary + ) + -- large negative DiffTimes, but larger than `minBound :: Int` microseconds + , (3, DiffTimeDistr + . (fromRational (toRational (minBound :: Int) / 1_000_000) + ) + . fromRational + . getNonNegative + <$> arbitrary + ) + -- smaller than 1 :% 1_000_000 + , (1, DiffTimeDistr . fromRational . (/ 1_000_000) <$> resize 1 arbitrary) + ] + + shrink (DiffTimeDistr a) = (DiffTimeDistr . fromRational) `map` shrink (toRational a) + +prop_diffTimeToMicrosecondsAsIntRightInverse :: DiffTimeDistr -> Property +prop_diffTimeToMicrosecondsAsIntRightInverse (DiffTimeDistr a) = + label (labelRational (toRational a)) $ + abs (toRational a - a') < (1 :% 1_000_000) + .&&. + r === microsecondsAsIntToDiffTime (diffTimeToMicrosecondsAsInt r) + + + where + a' = toRational (microsecondsAsIntToDiffTime (diffTimeToMicrosecondsAsInt a)) + + -- 'a' rounded to microseconds + r :: DiffTime + r = fromRational (toRational x / 1_000_000) + where + x :: Integer + x = round $ (toRational a * 1_000_000) + + labelRational x = + if | abs x < 1 :% 1_000_000 + -> "small" + | abs x > toRational (maxBound :: Int) / 1_000_000 - 100 + -> "large" + | otherwise + -> "average" diff --git a/src/Control/Monad/Class/MonadThrow.hs b/src/Control/Monad/Class/MonadThrow.hs --- a/src/Control/Monad/Class/MonadThrow.hs +++ b/src/Control/Monad/Class/MonadThrow.hs @@ -57,6 +57,9 @@ 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 diff --git a/strict-mvar/README.md b/strict-mvar/README.md new file mode 100644 --- /dev/null +++ b/strict-mvar/README.md @@ -0,0 +1,7 @@ +# Strict Mutable Variables + +The `io-classes:strict-mvar` package provides a strict interface to mutable +variables (`MVar`). It builds on top of `io-classes:io-classes`, and thus it +provides the interface for `MVar`s implementations from both +[base](https://hackage.haskell.org/package/base-4.17.0.0/docs/Control-Concurrent-MVar.html) +and [io-sim](https://github.com/input-output-hk/io-sim). diff --git a/strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs b/strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs new file mode 100644 --- /dev/null +++ b/strict-mvar/src/Control/Concurrent/Class/MonadMVar/Strict.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to "Control.Concurrent.MVar" in the @base@ package. +module Control.Concurrent.Class.MonadMVar.Strict + ( -- * StrictMVar + StrictMVar + , LazyMVar + , castStrictMVar + , toLazyMVar + , fromLazyMVar + , newEmptyMVar + , newMVar + , takeMVar + , putMVar + , readMVar + , swapMVar + , tryTakeMVar + , tryPutMVar + , isEmptyMVar + , withMVar + , withMVarMasked + , modifyMVar_ + , modifyMVar + , modifyMVarMasked_ + , modifyMVarMasked + , tryReadMVar + -- * Re-exports + , MonadMVar + ) where + +import Control.Concurrent.Class.MonadMVar (MonadMVar) +import Control.Concurrent.Class.MonadMVar qualified as Lazy + +-- +-- StrictMVar +-- + +type LazyMVar m = Lazy.MVar m + +newtype StrictMVar m a = StrictMVar { + mvar :: LazyMVar m a + } + +castStrictMVar :: LazyMVar m ~ LazyMVar n + => StrictMVar m a -> StrictMVar n a +castStrictMVar v = StrictMVar (mvar v) + +-- | Get the underlying @MVar@ +-- +-- Since we obviously cannot guarantee that updates to this 'LazyMVar' will be +-- strict, this should be used with caution. +toLazyMVar :: StrictMVar m a -> LazyMVar m a +toLazyMVar = mvar + +-- | Create a 'StrictMVar' from a 'LazyMVar' +-- +-- It is not guaranteed that the 'LazyMVar' contains a value that is in WHNF, so +-- there is no guarantee that the resulting 'StrictMVar' contains a value that +-- is in WHNF. This should be used with caution. +fromLazyMVar :: Lazy.MVar m a -> StrictMVar m a +fromLazyMVar = StrictMVar + +newEmptyMVar :: MonadMVar m => m (StrictMVar m a) +newEmptyMVar = fromLazyMVar <$> Lazy.newEmptyMVar + +newMVar :: MonadMVar m => a -> m (StrictMVar m a) +newMVar !a = fromLazyMVar <$> Lazy.newMVar a + +takeMVar :: MonadMVar m => StrictMVar m a -> m a +takeMVar = Lazy.takeMVar . mvar + +putMVar :: MonadMVar m => StrictMVar m a -> a -> m () +putMVar v !a = Lazy.putMVar (mvar v) a + +readMVar :: MonadMVar m => StrictMVar m a -> m a +readMVar v = Lazy.readMVar (mvar v) + +swapMVar :: MonadMVar m => StrictMVar m a -> a -> m a +swapMVar v !a = Lazy.swapMVar (mvar v) a + +tryTakeMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a) +tryTakeMVar v = Lazy.tryTakeMVar (mvar v) + +tryPutMVar :: MonadMVar m => StrictMVar m a -> a -> m Bool +tryPutMVar v !a = Lazy.tryPutMVar (mvar v) a + +isEmptyMVar :: MonadMVar m => StrictMVar m a -> m Bool +isEmptyMVar v = Lazy.isEmptyMVar (mvar v) + +withMVar :: MonadMVar m => StrictMVar m a -> (a -> m b) -> m b +withMVar v = Lazy.withMVar (mvar v) + +withMVarMasked :: MonadMVar m => StrictMVar m a -> (a -> m b) -> m b +withMVarMasked v = Lazy.withMVarMasked (mvar v) + +modifyMVar_ :: MonadMVar m => StrictMVar m a -> (a -> m a) -> m () +modifyMVar_ v io = Lazy.modifyMVar_ (mvar v) io' + where + io' a = do + !a' <- io a + pure a' + +modifyMVar :: MonadMVar m => StrictMVar m a -> (a -> m (a, b)) -> m b +modifyMVar v io = Lazy.modifyMVar (mvar v) io' + where + io' a = do + (!a', b) <- io a + pure (a', b) + +modifyMVarMasked_ :: MonadMVar m => StrictMVar m a -> (a -> m a) -> m () +modifyMVarMasked_ v io = Lazy.modifyMVarMasked_ (mvar v) io' + where + io' a = do + !a' <- io a + pure a' + +modifyMVarMasked :: MonadMVar m => StrictMVar m a -> (a -> m (a,b)) -> m b +modifyMVarMasked v io = Lazy.modifyMVarMasked (mvar v) io' + where + io' a = do + (!a', b) <- io a + pure (a', b) + +tryReadMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a) +tryReadMVar v = Lazy.tryReadMVar (mvar v) diff --git a/strict-mvar/test/Main.hs b/strict-mvar/test/Main.hs new file mode 100644 --- /dev/null +++ b/strict-mvar/test/Main.hs @@ -0,0 +1,35 @@ +module Main where + +import Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF + +import Test.QuickCheck.Monadic (monadicIO) +import Test.Tasty +import Test.Tasty.QuickCheck + + +main :: IO () +main = defaultMain $ testGroup "strict-mvar" [tests] + +tests :: TestTree +tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict" + [ testGroup "WHNF" + [ testGroup "IO" + [ testProperty "prop_newMVar" $ + monadicIO .: prop_newMVar + , testProperty "prop_putMVar" $ + monadicIO .: prop_putMVar + , testProperty "prop_swapMVar" $ + monadicIO .: prop_swapMVar + , testProperty "prop_tryPutMVar" $ + monadicIO .: prop_tryPutMVar + , testProperty "prop_modifyMVar_" $ + monadicIO .: prop_modifyMVar_ + , testProperty "prop_modifyMVar" $ + monadicIO .: prop_modifyMVar + , testProperty "prop_modifyMVarMasked_" $ + monadicIO .: prop_modifyMVarMasked_ + , testProperty "prop_modifyMVarMasked" $ + monadicIO .: prop_modifyMVarMasked + ] + ] + ] diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict.hs new file mode 100644 --- /dev/null +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict.hs @@ -0,0 +1,15 @@ +-- | This module corresponds to `Control.Concurrent.STM` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict (module STM) where + +import Control.Concurrent.Class.MonadSTM.Strict.TArray as STM +import Control.Concurrent.Class.MonadSTM.Strict.TBQueue as STM +import Control.Concurrent.Class.MonadSTM.Strict.TChan as STM +import Control.Concurrent.Class.MonadSTM.Strict.TMVar as STM +import Control.Concurrent.Class.MonadSTM.Strict.TQueue as STM +import Control.Concurrent.Class.MonadSTM.Strict.TVar as STM +import Control.Monad.Class.MonadSTM as STM hiding (traceTBQueue, traceTBQueueIO, + traceTMVar, traceTMVarIO, traceTQueue, traceTQueueIO, traceTVar, + traceTVarIO) + + diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs new file mode 100644 --- /dev/null +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TArray.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module corresponds to `Control.Concurrent.STM.TArray` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TArray + ( StrictTArray + , LazyTArray + , toLazyTArray + , fromLazyTArray + ) where + + +import Control.Concurrent.Class.MonadSTM.TArray qualified as Lazy + +import Data.Array.Base (MArray (..)) + + +type LazyTArray m = Lazy.TArray m + +newtype StrictTArray m i e = StrictTArray { toLazyTArray :: LazyTArray m i e } + +fromLazyTArray :: LazyTArray m i e -> StrictTArray m i e +fromLazyTArray = StrictTArray + +instance ( MArray (Lazy.TArray m) e stm + , Monad stm + ) + => MArray (StrictTArray m) e stm where + getBounds (StrictTArray arr) = getBounds arr + newArray b !e = StrictTArray <$> newArray b e + newArray_ b = StrictTArray <$> newArray_ b + unsafeRead (StrictTArray arr) i = unsafeRead arr i + unsafeWrite (StrictTArray arr) i !e = unsafeWrite arr i e + getNumElements (StrictTArray arr) = getNumElements arr + diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs new file mode 100644 --- /dev/null +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TBQueue.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to `Control.Concurrent.STM.TBQueue` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TBQueue + ( -- * MonadSTM + StrictTBQueue + , LazyTBQueue + , toLazyTBQueue + , fromLazyTBQueue + , castStrictTBQueue + , newTBQueue + , newTBQueueIO + , readTBQueue + , tryReadTBQueue + , peekTBQueue + , tryPeekTBQueue + , flushTBQueue + , writeTBQueue + , lengthTBQueue + , isEmptyTBQueue + , isFullTBQueue + , unGetTBQueue + -- * MonadLabelledSTM + , labelTBQueue + , labelTBQueueIO + -- * MonadTraceSTM + , traceTBQueue + , traceTBQueueIO + ) where + + +import Control.Concurrent.Class.MonadSTM.TBQueue qualified as Lazy +import Control.Monad.Class.MonadSTM hiding (traceTBQueue, traceTBQueueIO) + +import Numeric.Natural (Natural) + + +type LazyTBQueue m = Lazy.TBQueue m + +newtype StrictTBQueue m a = StrictTBQueue { toLazyTBQueue :: LazyTBQueue m a } + +fromLazyTBQueue :: LazyTBQueue m a -> StrictTBQueue m a +fromLazyTBQueue = StrictTBQueue + +castStrictTBQueue :: LazyTBQueue m ~ LazyTBQueue n + => StrictTBQueue m a -> StrictTBQueue n a +castStrictTBQueue (StrictTBQueue var) = StrictTBQueue var + +labelTBQueue :: MonadLabelledSTM m => StrictTBQueue m a -> String -> STM m () +labelTBQueue (StrictTBQueue queue) = Lazy.labelTBQueue queue + +labelTBQueueIO :: MonadLabelledSTM m => StrictTBQueue m a -> String -> m () +labelTBQueueIO (StrictTBQueue queue) = Lazy.labelTBQueueIO queue + +traceTBQueue :: MonadTraceSTM m + => proxy m + -> StrictTBQueue m a + -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> STM m () +traceTBQueue p (StrictTBQueue queue) = Lazy.traceTBQueue p queue + +traceTBQueueIO :: MonadTraceSTM m + => StrictTBQueue m a + -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> m () +traceTBQueueIO (StrictTBQueue queue) = Lazy.traceTBQueueIO queue + +newTBQueue :: MonadSTM m => Natural -> STM m (StrictTBQueue m a) +newTBQueue n = StrictTBQueue <$> Lazy.newTBQueue n + +newTBQueueIO :: MonadSTM m => Natural -> m (StrictTBQueue m a) +newTBQueueIO = atomically . newTBQueue + +readTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m a +readTBQueue = Lazy.readTBQueue . toLazyTBQueue + +tryReadTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m (Maybe a) +tryReadTBQueue = Lazy.tryReadTBQueue . toLazyTBQueue + +peekTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m a +peekTBQueue = Lazy.peekTBQueue . toLazyTBQueue + +tryPeekTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m (Maybe a) +tryPeekTBQueue = Lazy.tryPeekTBQueue . toLazyTBQueue + +flushTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m [a] +flushTBQueue = Lazy.flushTBQueue . toLazyTBQueue + +writeTBQueue :: MonadSTM m => StrictTBQueue m a -> a -> STM m () +writeTBQueue (StrictTBQueue tqueue) !a = Lazy.writeTBQueue tqueue a + +lengthTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m Natural +lengthTBQueue = Lazy.lengthTBQueue . toLazyTBQueue + +isEmptyTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m Bool +isEmptyTBQueue = Lazy.isEmptyTBQueue . toLazyTBQueue + +isFullTBQueue :: MonadSTM m => StrictTBQueue m a -> STM m Bool +isFullTBQueue = Lazy.isFullTBQueue . toLazyTBQueue + +unGetTBQueue :: MonadSTM m => StrictTBQueue m a -> a -> STM m () +unGetTBQueue (StrictTBQueue queue) !a = Lazy.unGetTBQueue queue a diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs new file mode 100644 --- /dev/null +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TChan.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to `Control.Concurrent.STM.TChan` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TChan + ( StrictTChan + , LazyTChan + , toLazyTChan + , fromLazyTChan + , castStrictTChan + , newTChan + , newBroadcastTChan + , writeTChan + , readTChan + , tryReadTChan + , peekTChan + , tryPeekTChan + , dupTChan + , unGetTChan + , isEmptyTChan + , cloneTChan + ) where + + +import Control.Concurrent.Class.MonadSTM.TChan qualified as Lazy +import Control.Monad.Class.MonadSTM + + +type LazyTChan m = Lazy.TChan m + +newtype StrictTChan m a = StrictTChan { toLazyTChan :: LazyTChan m a } + +fromLazyTChan :: LazyTChan m a -> StrictTChan m a +fromLazyTChan = StrictTChan + +castStrictTChan :: LazyTChan m ~ LazyTChan n + => StrictTChan m a -> StrictTChan n a +castStrictTChan (StrictTChan var) = StrictTChan var + +newTChan :: MonadSTM m => STM m (StrictTChan m a) +newTChan = StrictTChan <$> Lazy.newTChan + +newBroadcastTChan :: MonadSTM m => STM m (StrictTChan m a) +newBroadcastTChan = StrictTChan <$> Lazy.newBroadcastTChan + +writeTChan :: MonadSTM m => StrictTChan m a -> a -> STM m () +writeTChan (StrictTChan chan) !a = Lazy.writeTChan chan a + +readTChan :: MonadSTM m => StrictTChan m a -> STM m a +readTChan = Lazy.readTChan . toLazyTChan + +tryReadTChan :: MonadSTM m => StrictTChan m a -> STM m (Maybe a) +tryReadTChan = Lazy.tryReadTChan . toLazyTChan + +peekTChan :: MonadSTM m => StrictTChan m a -> STM m a +peekTChan = Lazy.peekTChan . toLazyTChan + +tryPeekTChan :: MonadSTM m => StrictTChan m a -> STM m (Maybe a) +tryPeekTChan = Lazy.tryPeekTChan . toLazyTChan + +dupTChan :: MonadSTM m => StrictTChan m a -> STM m (StrictTChan m a) +dupTChan = fmap fromLazyTChan . Lazy.dupTChan . toLazyTChan + +unGetTChan :: MonadSTM m => StrictTChan m a -> a -> STM m () +unGetTChan (StrictTChan chan) !a = Lazy.unGetTChan chan a + +isEmptyTChan :: MonadSTM m => StrictTChan m a -> STM m Bool +isEmptyTChan = Lazy.isEmptyTChan . toLazyTChan + +cloneTChan :: MonadSTM m => StrictTChan m a -> STM m (StrictTChan m a) +cloneTChan = fmap fromLazyTChan . Lazy.cloneTChan . toLazyTChan diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs new file mode 100644 --- /dev/null +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TMVar.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to `Control.Concurrent.STM.TMVar` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TMVar + ( -- * StrictTMVar + StrictTMVar + , LazyTMVar + , toLazyTMVar + , fromLazyTMVar + , castStrictTMVar + , newTMVar + , newEmptyTMVar + , newTMVarIO + , newEmptyTMVarIO + , takeTMVar + , tryTakeTMVar + , putTMVar + , tryPutTMVar + , readTMVar + , tryReadTMVar + , swapTMVar + , writeTMVar + , isEmptyTMVar + -- * MonadLabelledSTM + , labelTMVar + , labelTMVarIO + -- * MonadTraceSTM + , traceTMVar + , traceTMVarIO + ) where + + +import Control.Concurrent.Class.MonadSTM.TMVar qualified as Lazy +import Control.Monad.Class.MonadSTM hiding (traceTMVar, traceTMVarIO) + + +type LazyTMVar m = Lazy.TMVar m + +-- | 'TMVar' that keeps its value in WHNF at all times +newtype StrictTMVar m a = StrictTMVar { toLazyTMVar :: LazyTMVar m a } + +fromLazyTMVar :: LazyTMVar m a -> StrictTMVar m a +fromLazyTMVar = StrictTMVar + +labelTMVar :: MonadLabelledSTM m => StrictTMVar m a -> String -> STM m () +labelTMVar (StrictTMVar tvar) = Lazy.labelTMVar tvar + +labelTMVarIO :: MonadLabelledSTM m => StrictTMVar m a -> String -> m () +labelTMVarIO v = atomically . labelTMVar v + +traceTMVar :: MonadTraceSTM m + => proxy m + -> StrictTMVar m a + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> STM m () +traceTMVar p (StrictTMVar var) = Lazy.traceTMVar p var + +traceTMVarIO :: MonadTraceSTM m + => StrictTMVar m a + -> (Maybe (Maybe a) -> (Maybe a) -> InspectMonad m TraceValue) + -> m () +traceTMVarIO (StrictTMVar var) = Lazy.traceTMVarIO var + +castStrictTMVar :: LazyTMVar m ~ LazyTMVar n + => StrictTMVar m a -> StrictTMVar n a +castStrictTMVar (StrictTMVar var) = StrictTMVar var + +newTMVar :: MonadSTM m => a -> STM m (StrictTMVar m a) +newTMVar !a = StrictTMVar <$> Lazy.newTMVar a + +newTMVarIO :: MonadSTM m => a -> m (StrictTMVar m a) +newTMVarIO !a = StrictTMVar <$> Lazy.newTMVarIO a + +newEmptyTMVar :: MonadSTM m => STM m (StrictTMVar m a) +newEmptyTMVar = StrictTMVar <$> Lazy.newEmptyTMVar + +newEmptyTMVarIO :: MonadSTM m => m (StrictTMVar m a) +newEmptyTMVarIO = StrictTMVar <$> Lazy.newEmptyTMVarIO + +takeTMVar :: MonadSTM m => StrictTMVar m a -> STM m a +takeTMVar (StrictTMVar tmvar) = Lazy.takeTMVar tmvar + +tryTakeTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a) +tryTakeTMVar (StrictTMVar tmvar) = Lazy.tryTakeTMVar tmvar + +putTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m () +putTMVar (StrictTMVar tmvar) !a = Lazy.putTMVar tmvar a + +tryPutTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m Bool +tryPutTMVar (StrictTMVar tmvar) !a = Lazy.tryPutTMVar tmvar a + +readTMVar :: MonadSTM m => StrictTMVar m a -> STM m a +readTMVar (StrictTMVar tmvar) = Lazy.readTMVar tmvar + +tryReadTMVar :: MonadSTM m => StrictTMVar m a -> STM m (Maybe a) +tryReadTMVar (StrictTMVar tmvar) = Lazy.tryReadTMVar tmvar + +swapTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m a +swapTMVar (StrictTMVar tmvar) !a = Lazy.swapTMVar tmvar a + +writeTMVar :: MonadSTM m => StrictTMVar m a -> a -> STM m () +writeTMVar (StrictTMVar tmvar) !a = Lazy.writeTMVar tmvar a + +isEmptyTMVar :: MonadSTM m => StrictTMVar m a -> STM m Bool +isEmptyTMVar (StrictTMVar tmvar) = Lazy.isEmptyTMVar tmvar diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs new file mode 100644 --- /dev/null +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TQueue.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to `Control.Concurrent.STM.TQueue` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TQueue + ( -- * MonadSTM + StrictTQueue + , LazyTQueue + , toLazyTQueue + , fromLazyTQueue + , castStrictTQueue + , newTQueue + , newTQueueIO + , readTQueue + , tryReadTQueue + , peekTQueue + , tryPeekTQueue + , flushTQueue + , writeTQueue + , unGetTQueue + , isEmptyTQueue + -- * MonadLabelledSTM + , labelTQueue + , labelTQueueIO + -- * MonadTraceSTM + , traceTQueue + , traceTQueueIO + ) where + + +import Control.Concurrent.Class.MonadSTM.TQueue qualified as Lazy +import Control.Monad.Class.MonadSTM hiding (traceTQueue, traceTQueueIO) + + +type LazyTQueue m = Lazy.TQueue m + +newtype StrictTQueue m a = StrictTQueue { toLazyTQueue :: LazyTQueue m a } + +fromLazyTQueue :: LazyTQueue m a -> StrictTQueue m a +fromLazyTQueue = StrictTQueue + +castStrictTQueue :: LazyTQueue m ~ LazyTQueue n + => StrictTQueue m a -> StrictTQueue n a +castStrictTQueue (StrictTQueue var) = StrictTQueue var + +labelTQueue :: MonadLabelledSTM m => StrictTQueue m a -> String -> STM m () +labelTQueue (StrictTQueue queue) = Lazy.labelTQueue queue + +labelTQueueIO :: MonadLabelledSTM m => StrictTQueue m a -> String -> m () +labelTQueueIO (StrictTQueue queue) = Lazy.labelTQueueIO queue + +traceTQueue :: MonadTraceSTM m + => proxy m + -> StrictTQueue m a + -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> STM m () +traceTQueue p (StrictTQueue queue) = Lazy.traceTQueue p queue + +traceTQueueIO :: MonadTraceSTM m + => StrictTQueue m a + -> ((Maybe [a]) -> [a] -> InspectMonad m TraceValue) + -> m () +traceTQueueIO (StrictTQueue queue) = Lazy.traceTQueueIO queue + +newTQueue :: MonadSTM m => STM m (StrictTQueue m a) +newTQueue = StrictTQueue <$> Lazy.newTQueue + +newTQueueIO :: MonadSTM m => m (StrictTQueue m a) +newTQueueIO = atomically newTQueue + +readTQueue :: MonadSTM m => StrictTQueue m a -> STM m a +readTQueue = Lazy.readTQueue . toLazyTQueue + +tryReadTQueue :: MonadSTM m => StrictTQueue m a -> STM m (Maybe a) +tryReadTQueue = Lazy.tryReadTQueue . toLazyTQueue + +peekTQueue :: MonadSTM m => StrictTQueue m a -> STM m a +peekTQueue = Lazy.peekTQueue . toLazyTQueue + +tryPeekTQueue :: MonadSTM m => StrictTQueue m a -> STM m (Maybe a) +tryPeekTQueue = Lazy.tryPeekTQueue . toLazyTQueue + +flushTQueue :: MonadSTM m => StrictTQueue m a -> STM m [a] +flushTQueue = Lazy.flushTQueue . toLazyTQueue + +writeTQueue :: MonadSTM m => StrictTQueue m a -> a -> STM m () +writeTQueue (StrictTQueue tqueue) !a = Lazy.writeTQueue tqueue a + +isEmptyTQueue :: MonadSTM m => StrictTQueue m a -> STM m Bool +isEmptyTQueue = Lazy.isEmptyTQueue . toLazyTQueue + +unGetTQueue :: MonadSTM m => StrictTQueue m a -> a -> STM m () +unGetTQueue (StrictTQueue queue) !a = Lazy.unGetTQueue queue a + diff --git a/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs new file mode 100644 --- /dev/null +++ b/strict-stm/Control/Concurrent/Class/MonadSTM/Strict/TVar.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to `Control.Concurrent.STM.TVar` in "stm" package +-- +module Control.Concurrent.Class.MonadSTM.Strict.TVar + ( -- * StrictTVar + StrictTVar + , LazyTVar + , toLazyTVar + , fromLazyTVar + , castStrictTVar + , newTVar + , newTVarIO + , readTVar + , readTVarIO + , writeTVar + , modifyTVar + , stateTVar + , swapTVar + , check + -- * MonadLabelSTM + , labelTVar + , labelTVarIO + -- * MonadTraceSTM + , traceTVar + , traceTVarIO + ) where + +import Control.Concurrent.Class.MonadSTM.TVar qualified as Lazy +import Control.Monad.Class.MonadSTM hiding (traceTVar, traceTVarIO) + +type LazyTVar m = Lazy.TVar m + +newtype StrictTVar m a = StrictTVar { + tvar :: LazyTVar m a + } + +labelTVar :: MonadLabelledSTM m => StrictTVar m a -> String -> STM m () +labelTVar StrictTVar { tvar } = Lazy.labelTVar tvar + +labelTVarIO :: MonadLabelledSTM m => StrictTVar m a -> String -> m () +labelTVarIO v = atomically . labelTVar v + +traceTVar :: MonadTraceSTM m + => proxy m + -> StrictTVar m a + -> (Maybe a -> a -> InspectMonad m TraceValue) + -> STM m () +traceTVar p StrictTVar {tvar} = Lazy.traceTVar p tvar + +traceTVarIO :: MonadTraceSTM m + => StrictTVar m a + -> (Maybe a -> a -> InspectMonad m TraceValue) + -> m () +traceTVarIO StrictTVar {tvar} = Lazy.traceTVarIO tvar + +-- | Cast the monad if both use the same representation of `TVar`s. +-- +-- This function is useful for monad transformers stacks if the `TVar` is used +-- in different monad stacks. +-- +castStrictTVar :: LazyTVar m ~ LazyTVar n + => StrictTVar m a -> StrictTVar n a +castStrictTVar StrictTVar {tvar} = StrictTVar {tvar} + +-- | Get the underlying @TVar@ +-- +-- Since we obviously cannot guarantee that updates to this 'LazyTVar' will be +-- strict, this should be used with caution. +toLazyTVar :: StrictTVar m a -> LazyTVar m a +toLazyTVar StrictTVar { tvar } = tvar + +fromLazyTVar :: LazyTVar m a -> StrictTVar m a +fromLazyTVar = StrictTVar + +newTVar :: MonadSTM m => a -> STM m (StrictTVar m a) +newTVar !a = StrictTVar <$> Lazy.newTVar a + +newTVarIO :: MonadSTM m => a -> m (StrictTVar m a) +newTVarIO !a = StrictTVar <$> Lazy.newTVarIO a + +readTVar :: MonadSTM m => StrictTVar m a -> STM m a +readTVar StrictTVar { tvar } = Lazy.readTVar tvar + +readTVarIO :: MonadSTM m => StrictTVar m a -> m a +readTVarIO StrictTVar { tvar } = Lazy.readTVarIO tvar + +writeTVar :: MonadSTM m => StrictTVar m a -> a -> STM m () +writeTVar v !a = Lazy.writeTVar (tvar v) a + +modifyTVar :: MonadSTM m => StrictTVar m a -> (a -> a) -> STM m () +modifyTVar v f = readTVar v >>= writeTVar v . f + +stateTVar :: MonadSTM m => StrictTVar m s -> (s -> (a, s)) -> STM m a +stateTVar v f = do + a <- readTVar v + let (b, a') = f a + writeTVar v a' + return b + +swapTVar :: MonadSTM m => StrictTVar m a -> a -> STM m a +swapTVar v a' = do + a <- readTVar v + writeTVar v a' + return a diff --git a/strict-stm/README.md b/strict-stm/README.md new file mode 100644 --- /dev/null +++ b/strict-stm/README.md @@ -0,0 +1,18 @@ +# Strict Software Transaction Memory + +The `io-classes:strict-stm` package provides a strict interface to software transaction +memory. It builds on top of [`io-classes:io-classes`] and thus it provides the interface +for both [`stm`] as well as [`io-sim`]. + +# Novel testing / space-leak elimination approach + +The strict interface provides a novel way of testing/eliminating space-leaks +which might lurk in `stm` shared mutable variables. Together with the +[`nothunks`] library it was successfully used to eliminate and keep a large +system ([`cardano-node`]) space leak free. + +[`cardano-node`]: https://www.github.com/input-output-hk/cardano-node +[`io-classes:io-classes`]: https://hackage.haskell.org/package/io-classes +[`io-sim`]: https://hackage.haskell.org/package/io-sim +[`nothunks`]: https://hackage.haskell.org/package/nothunks +[`stm`]: https://hackage.haskell.org/package/stm diff --git a/test/Test/Control/Concurrent/Class/MonadMVar/Strict/WHNF.hs b/test/Test/Control/Concurrent/Class/MonadMVar/Strict/WHNF.hs new file mode 100644 --- /dev/null +++ b/test/Test/Control/Concurrent/Class/MonadMVar/Strict/WHNF.hs @@ -0,0 +1,123 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | Test whether functions on 'StrictMVar's correctly force values to WHNF +-- before they are put inside the 'StrictMVar'. +module Test.Control.Concurrent.Class.MonadMVar.Strict.WHNF + ( prop_newMVar + , prop_putMVar + , prop_swapMVar + , prop_tryPutMVar + , prop_modifyMVar_ + , prop_modifyMVar + , prop_modifyMVarMasked_ + , prop_modifyMVarMasked + , (.:) + ) where + +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Monad (void) +import Data.Typeable (Typeable) +import NoThunks.Class (OnlyCheckWhnf (OnlyCheckWhnf), unsafeNoThunks) +import Test.QuickCheck +import Test.QuickCheck.Monadic (PropertyM, monitor, run) + +{------------------------------------------------------------------------------- + Utilities +-------------------------------------------------------------------------------} + +infixr 9 .: + +(.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z) +(.:) g f x0 x1 = g (f x0 x1) + +isInWHNF :: (MonadMVar m, Typeable a) => StrictMVar m a -> PropertyM m Bool +isInWHNF v = do + x <- run $ readMVar v + case unsafeNoThunks (OnlyCheckWhnf x) of + Nothing -> pure True + Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo) + >> pure False + +{------------------------------------------------------------------------------- + Properties +-------------------------------------------------------------------------------} + +prop_newMVar :: + MonadMVar m + => Int + -> Fun Int Int + -> PropertyM m Bool +prop_newMVar x f = do + v <- run $ newMVar (applyFun f x) + isInWHNF v + +prop_putMVar :: + MonadMVar m + => Int + -> Fun Int Int + -> PropertyM m Bool +prop_putMVar x f = do + v <- run newEmptyMVar + run $ putMVar v (applyFun f x) + isInWHNF v + +prop_swapMVar :: + MonadMVar m + => Int + -> Fun Int Int + -> PropertyM m Bool +prop_swapMVar x f = do + v <- run $ newMVar x + void $ run $ swapMVar v (applyFun f x) + isInWHNF v + +prop_tryPutMVar :: + MonadMVar m + => Int + -> Fun Int Int + -> PropertyM m Bool +prop_tryPutMVar x f = do + v <- run newEmptyMVar + b <- run $ tryPutMVar v (applyFun f x) + b' <- isInWHNF v + pure (b && b') + +prop_modifyMVar_ :: + MonadMVar m + => Int + -> Fun Int Int + -> PropertyM m Bool +prop_modifyMVar_ x f =do + v <- run $ newMVar x + run $ modifyMVar_ v (pure . applyFun f) + isInWHNF v + +prop_modifyMVar :: + MonadMVar m + => Int + -> Fun Int (Int, Char) + -> PropertyM m Bool +prop_modifyMVar x f =do + v <- run $ newMVar x + void $ run $ modifyMVar v (pure . applyFun f) + isInWHNF v + +prop_modifyMVarMasked_ :: + MonadMVar m + => Int + -> Fun Int Int + -> PropertyM m Bool +prop_modifyMVarMasked_ x f =do + v <- run $ newMVar x + void $ run $ modifyMVarMasked_ v (pure . applyFun f) + isInWHNF v + +prop_modifyMVarMasked :: + MonadMVar m + => Int + -> Fun Int (Int, Char) + -> PropertyM m Bool +prop_modifyMVarMasked x f =do + v <- run $ newMVar x + void $ run $ modifyMVarMasked v (pure . applyFun f) + isInWHNF v