diff --git a/.github/workflows/cabal.project.local b/.github/workflows/cabal.project.local index f735c428..8319a8f4 100644 --- a/.github/workflows/cabal.project.local +++ b/.github/workflows/cabal.project.local @@ -17,3 +17,7 @@ package strict-stm package io-sim ghc-options: -Werror flags: +asserts + +package si-timers + ghc-options: -Werror + flags: +asserts diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index dd1f2d4e..4da4ca76 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -120,12 +120,12 @@ jobs: - name: Build projects [build] run: cabal build all - - name: io-classes [test] - run: cabal run io-classes:test - - name: io-sim [test] run: cabal run io-sim:test + - name: si-timers [test] + run: cabal run si-timers:test + stylish-haskell: runs-on: ubuntu-22.04 diff --git a/cabal.project b/cabal.project index b860b508..b04c0f5f 100644 --- a/cabal.project +++ b/cabal.project @@ -16,8 +16,10 @@ index-state: packages: ./io-sim ./io-classes + ./io-classes-mtl ./strict-mvar ./strict-stm + ./si-timers package io-sim flags: +asserts diff --git a/io-classes-mtl/CHANGELOG.md b/io-classes-mtl/CHANGELOG.md new file mode 100644 index 00000000..9baba1d3 --- /dev/null +++ b/io-classes-mtl/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for io-classes-mtl + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/io-classes-mtl/LICENSE b/io-classes-mtl/LICENSE new file mode 100644 index 00000000..d6456956 --- /dev/null +++ b/io-classes-mtl/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/io-classes-mtl/NOTICE b/io-classes-mtl/NOTICE new file mode 100644 index 00000000..031c8ce0 --- /dev/null +++ b/io-classes-mtl/NOTICE @@ -0,0 +1,14 @@ +Copyright 2023 Input Output Global Inc (IOG) + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/io-classes-mtl/README.md b/io-classes-mtl/README.md new file mode 100644 index 00000000..60b90e89 --- /dev/null +++ b/io-classes-mtl/README.md @@ -0,0 +1,19 @@ +# Experimental MTL Instance for io-classes + +`ReaderT` instances are included in `io-classes`, but all other instances are +included in this package. Some of them are rather novel and experimental +others might be less so. This code is not really tested, neither it has run +in production environment as we know (let us know if you do!). + +The `MonadSTM` instances for monad transformers are somewhat novel. The `STM` +monad is transformed together with the base monad. This means that the +transfomer primitive operations are available in `STM`. For example you an +`STM` transaction can lock updating the state of the current thread. + +We haven't included `MonadAsync` instances (although we have an experimental +branch how this could be done). It could work like the `lifted-async` +package. But we feel this can be controversial, so it's not included. + +The design goal is to follow `exception` package instances, but since we don't +have any tests we are not very confident of this either. Contributions are +welcomed! diff --git a/io-classes-mtl/io-classes-mtl.cabal b/io-classes-mtl/io-classes-mtl.cabal new file mode 100644 index 00000000..f999eb44 --- /dev/null +++ b/io-classes-mtl/io-classes-mtl.cabal @@ -0,0 +1,49 @@ +cabal-version: 3.0 +name: io-classes-mtl +version: 0.1.0.0 +synopsis: Experimental MTL instances for io-classes +license: Apache-2.0 +license-files: + LICENSE + NOTICE +author: Duncan Coutts, Marcin Szamotulski +maintainer: Marcin Szamotulski coot@coot.me +copyright: 2022-2023 Input Output Global Inc (IOG) +category: Control +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md + +common warnings + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wunused-packages + -Wno-redundant-constraints + -Wno-unticked-promoted-constructors + +library + import: warnings + 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.18, + array, + mtl, + + io-classes ^>= 0.6.0.0, + si-timers, + + + hs-source-dirs: src + default-language: Haskell2010 diff --git a/io-classes-mtl/src/Control/Monad/Class/MonadEventlog/Trans.hs b/io-classes-mtl/src/Control/Monad/Class/MonadEventlog/Trans.hs new file mode 100644 index 00000000..04fce2cf --- /dev/null +++ b/io-classes-mtl/src/Control/Monad/Class/MonadEventlog/Trans.hs @@ -0,0 +1,55 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Control.Monad.Class.MonadEventlog.Trans () where + +import Control.Monad.Cont +import Control.Monad.Except +import qualified Control.Monad.RWS.Lazy as Lazy +import qualified Control.Monad.RWS.Strict as Strict +import qualified Control.Monad.State.Lazy as Lazy +import qualified Control.Monad.State.Strict as Strict +import qualified Control.Monad.Writer.Lazy as Lazy +import qualified Control.Monad.Writer.Strict 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/io-classes-mtl/src/Control/Monad/Class/MonadST/Trans.hs b/io-classes-mtl/src/Control/Monad/Class/MonadST/Trans.hs new file mode 100644 index 00000000..bc107978 --- /dev/null +++ b/io-classes-mtl/src/Control/Monad/Class/MonadST/Trans.hs @@ -0,0 +1,38 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +module Control.Monad.Class.MonadST.Trans () where + +import Control.Monad.Cont +import Control.Monad.Except +import qualified Control.Monad.RWS.Lazy as Lazy +import qualified Control.Monad.RWS.Strict as Strict +import qualified Control.Monad.State.Lazy as Lazy +import qualified Control.Monad.State.Strict as Strict +import qualified Control.Monad.Writer.Lazy as Lazy +import qualified Control.Monad.Writer.Strict as Strict + +import Control.Monad.Class.MonadST + + +instance MonadST m => MonadST (ContT r m) where + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance MonadST m => MonadST (ExceptT e m) where + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance (Monoid w, MonadST m) => MonadST (Lazy.RWST r w s m) where + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance (Monoid w, MonadST m) => MonadST (Strict.RWST r w s m) where + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance MonadST m => MonadST (Lazy.StateT s m) where + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance MonadST m => MonadST (Strict.StateT s m) where + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance (Monoid w, MonadST m) => MonadST (Lazy.WriterT w m) where + withLiftST f = withLiftST $ \g -> f (lift . g) + +instance (Monoid w, MonadST m) => MonadST (Strict.WriterT w m) where + withLiftST f = withLiftST $ \g -> f (lift . g) diff --git a/io-classes-mtl/src/Control/Monad/Class/MonadSTM/Trans.hs b/io-classes-mtl/src/Control/Monad/Class/MonadSTM/Trans.hs new file mode 100644 index 00000000..3ef9419f --- /dev/null +++ b/io-classes-mtl/src/Control/Monad/Class/MonadSTM/Trans.hs @@ -0,0 +1,697 @@ +{-# 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.Trans (lift) +import qualified Control.Monad.RWS.Lazy as Lazy +import qualified Control.Monad.RWS.Strict as Strict +import qualified Control.Monad.State.Lazy as Lazy +import qualified Control.Monad.State.Strict as Strict +import qualified Control.Monad.Writer.Lazy as Lazy +import qualified Control.Monad.Writer.Strict as Strict + +import qualified Control.Monad.Class.MonadThrow as MonadThrow +import Control.Monad.Class.MonadSTM.Internal + +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 + + +-- 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 + +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 + 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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/io-classes-mtl/src/Control/Monad/Class/MonadSay/Trans.hs b/io-classes-mtl/src/Control/Monad/Class/MonadSay/Trans.hs new file mode 100644 index 00000000..10517ebf --- /dev/null +++ b/io-classes-mtl/src/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/io-classes-mtl/src/Control/Monad/Class/MonadThrow/Trans.hs b/io-classes-mtl/src/Control/Monad/Class/MonadThrow/Trans.hs new file mode 100644 index 00000000..6f03e473 --- /dev/null +++ b/io-classes-mtl/src/Control/Monad/Class/MonadThrow/Trans.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Control.Monad.Class.MonadThrow.Trans () where + +import Control.Monad.Except +import qualified Control.Monad.RWS.Lazy as Lazy +import qualified Control.Monad.RWS.Strict as Strict +import qualified Control.Monad.State.Lazy as Lazy +import qualified Control.Monad.State.Strict as Strict +import qualified Control.Monad.Writer.Lazy as Lazy +import qualified Control.Monad.Writer.Strict 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 + +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 + +-- | @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 + +-- | @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 + +-- | @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 + +-- | @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 + +-- | @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 + +-- | @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/io-classes-mtl/src/Control/Monad/Class/MonadTime/SI/Trans.hs b/io-classes-mtl/src/Control/Monad/Class/MonadTime/SI/Trans.hs new file mode 100644 index 00000000..6e145121 --- /dev/null +++ b/io-classes-mtl/src/Control/Monad/Class/MonadTime/SI/Trans.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Control.Monad.Class.MonadTime.SI.Trans () where + +import Control.Monad.Cont +import Control.Monad.Except +import qualified Control.Monad.RWS.Lazy as Lazy +import qualified Control.Monad.RWS.Strict as Strict +import qualified Control.Monad.State.Lazy as Lazy +import qualified Control.Monad.State.Strict as Strict +import qualified Control.Monad.Writer.Lazy as Lazy +import qualified Control.Monad.Writer.Strict as Strict + +import Control.Monad.Class.MonadTime.Trans () +import Control.Monad.Class.MonadTime.SI + +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/io-classes-mtl/src/Control/Monad/Class/MonadTime/Trans.hs b/io-classes-mtl/src/Control/Monad/Class/MonadTime/Trans.hs new file mode 100644 index 00000000..c7f60df5 --- /dev/null +++ b/io-classes-mtl/src/Control/Monad/Class/MonadTime/Trans.hs @@ -0,0 +1,62 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Control.Monad.Class.MonadTime.Trans () where + +import Control.Monad.Cont +import Control.Monad.Except +import qualified Control.Monad.RWS.Lazy as Lazy +import qualified Control.Monad.RWS.Strict as Strict +import qualified Control.Monad.State.Lazy as Lazy +import qualified Control.Monad.State.Strict as Strict +import qualified Control.Monad.Writer.Lazy as Lazy +import qualified Control.Monad.Writer.Strict 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/io-classes-mtl/src/Control/Monad/Class/MonadTimer/SI/Trans.hs b/io-classes-mtl/src/Control/Monad/Class/MonadTimer/SI/Trans.hs new file mode 100644 index 00000000..92894c22 --- /dev/null +++ b/io-classes-mtl/src/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/io-classes-mtl/src/Control/Monad/Class/MonadTimer/Trans.hs b/io-classes-mtl/src/Control/Monad/Class/MonadTimer/Trans.hs new file mode 100644 index 00000000..a255107d --- /dev/null +++ b/io-classes-mtl/src/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.Trans (lift) +import qualified Control.Monad.RWS.Lazy as Lazy +import qualified Control.Monad.RWS.Strict as Strict +import qualified Control.Monad.State.Lazy as Lazy +import qualified Control.Monad.State.Strict as Strict +import qualified Control.Monad.Writer.Lazy as Lazy +import qualified Control.Monad.Writer.Strict 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/io-classes-mtl/src/Control/Monad/Class/Trans.hs b/io-classes-mtl/src/Control/Monad/Class/Trans.hs new file mode 100644 index 00000000..266616fb --- /dev/null +++ b/io-classes-mtl/src/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.Trans as X () +import Control.Monad.Class.MonadTime.SI.Trans as X () +import Control.Monad.Class.MonadTimer.Trans as X () +import Control.Monad.Class.MonadTimer.SI.Trans as X () diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index 17b12f9f..9ca76861 100644 --- a/io-classes/CHANGELOG.md +++ b/io-classes/CHANGELOG.md @@ -2,6 +2,22 @@ ## next version +### Breaking changes + +* `MonadMonotonicTime` morphed into `MonadMonotonicTimeNSec` which supports + `getMonotonicTimeNSec` from "base". `MonadMonotonicTime` can be found in new + package `si-timers`. +* A simplified `MonadTimer` which is using time in microseconds encoded as + `Int` rather than `DiffTime`. The previous interface can be found in the + package `si-timers`. +* The non standard timer API is moved from `MonadTimer` to a `MonadTimerFancy` + type class which can be imported from + `Control.Monad.Class.MonadTimer.NonStandard` module. + +### Non breaking changes + +* Added `registerDelayCancellable` to `Control.Monad.Class.MonadTimer` module. + ## 0.6.0.0 ## 0.5.0.0 diff --git a/io-classes/io-classes.cabal b/io-classes/io-classes.cabal index 215ea43c..8adc5298 100644 --- a/io-classes/io-classes.cabal +++ b/io-classes/io-classes.cabal @@ -1,3 +1,4 @@ +cabal-version: 3.4 name: io-classes version: 0.6.0.0 synopsis: Type classes for concurrency with STM, ST and timing @@ -11,7 +12,6 @@ author: Alexander Vieth, Marcin Szamotulski, Duncan Coutts maintainer: category: Control build-type: Simple -cabal-version: >=1.10 tested-with: GHC == 8.10.7, GHC == 9.2.5, GHC == 9.4.4 source-repository head @@ -24,7 +24,19 @@ flag asserts manual: False default: False +common warnings + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wunused-packages + -Wno-redundant-constraints + -Wno-unticked-promoted-constructors + library + import: warnings hs-source-dirs: src -- At this experiment/prototype stage everything is exposed. @@ -63,30 +75,9 @@ library array, async >=2.1, bytestring, - deque, mtl >=2.2 && <2.4, stm >=2.5 && <2.6, time >=1.9.1 && <1.13 - 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 - -test-suite test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - other-modules: Test.MonadTimer - default-language: Haskell2010 - build-depends: base, - io-classes, - - QuickCheck, - tasty, - tasty-quickcheck diff --git a/io-classes/src/Control/Monad/Class/MonadAsync.hs b/io-classes/src/Control/Monad/Class/MonadAsync.hs index 0abb5507..e150d941 100644 --- a/io-classes/src/Control/Monad/Class/MonadAsync.hs +++ b/io-classes/src/Control/Monad/Class/MonadAsync.hs @@ -457,35 +457,35 @@ tryAll = try -- ReaderT instance -- -newtype WrappedAsync r (m :: Type -> Type) a = - WrappedAsync { unWrapAsync :: Async m a } +newtype AsyncReaderT r (m :: Type -> Type) a = + AsyncReaderT { getAsyncReaderT :: Async m a } instance ( MonadAsync m , MonadCatch (STM m) , MonadFork m , MonadMask m ) => MonadAsync (ReaderT r m) where - type Async (ReaderT r m) = WrappedAsync r m - asyncThreadId (WrappedAsync a) = asyncThreadId a + type Async (ReaderT r m) = AsyncReaderT r m + asyncThreadId (AsyncReaderT a) = asyncThreadId a - async (ReaderT ma) = ReaderT $ \r -> WrappedAsync <$> async (ma r) - asyncBound (ReaderT ma) = ReaderT $ \r -> WrappedAsync <$> asyncBound (ma r) - asyncOn n (ReaderT ma) = ReaderT $ \r -> WrappedAsync <$> asyncOn n (ma r) + async (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> async (ma r) + asyncBound (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncBound (ma r) + asyncOn n (ReaderT ma) = ReaderT $ \r -> AsyncReaderT <$> asyncOn n (ma r) withAsync (ReaderT ma) f = ReaderT $ \r -> withAsync (ma r) - $ \a -> runReaderT (f (WrappedAsync a)) r + $ \a -> runReaderT (f (AsyncReaderT a)) r withAsyncBound (ReaderT ma) f = ReaderT $ \r -> withAsyncBound (ma r) - $ \a -> runReaderT (f (WrappedAsync a)) r + $ \a -> runReaderT (f (AsyncReaderT a)) r withAsyncOn n (ReaderT ma) f = ReaderT $ \r -> withAsyncOn n (ma r) - $ \a -> runReaderT (f (WrappedAsync a)) r + $ \a -> runReaderT (f (AsyncReaderT a)) r - asyncWithUnmask f = ReaderT $ \r -> fmap WrappedAsync + asyncWithUnmask f = ReaderT $ \r -> fmap AsyncReaderT $ asyncWithUnmask $ \unmask -> runReaderT (f (liftF unmask)) r where liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a liftF g (ReaderT r) = ReaderT (g . r) - asyncOnWithUnmask n f = ReaderT $ \r -> fmap WrappedAsync + asyncOnWithUnmask n f = ReaderT $ \r -> fmap AsyncReaderT $ asyncOnWithUnmask n $ \unmask -> runReaderT (f (liftF unmask)) r where @@ -495,7 +495,7 @@ instance ( MonadAsync m withAsyncWithUnmask action f = ReaderT $ \r -> withAsyncWithUnmask (\unmask -> case action (liftF unmask) of ReaderT ma -> ma r) - $ \a -> runReaderT (f (WrappedAsync a)) r + $ \a -> runReaderT (f (AsyncReaderT a)) r where liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a liftF g (ReaderT r) = ReaderT (g . r) @@ -503,44 +503,44 @@ instance ( MonadAsync m withAsyncOnWithUnmask n action f = ReaderT $ \r -> withAsyncOnWithUnmask n (\unmask -> case action (liftF unmask) of ReaderT ma -> ma r) - $ \a -> runReaderT (f (WrappedAsync a)) r + $ \a -> runReaderT (f (AsyncReaderT a)) r where liftF :: (m a -> m a) -> ReaderT r m a -> ReaderT r m a liftF g (ReaderT r) = ReaderT (g . r) - waitCatchSTM = WrappedSTM . waitCatchSTM . unWrapAsync - pollSTM = WrappedSTM . pollSTM . unWrapAsync + waitCatchSTM = lift . waitCatchSTM . getAsyncReaderT + pollSTM = lift . pollSTM . getAsyncReaderT race (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race (ma r) (mb r) race_ (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> race_ (ma r) (mb r) concurrently (ReaderT ma) (ReaderT mb) = ReaderT $ \r -> concurrently (ma r) (mb r) - wait = lift . wait . unWrapAsync - poll = lift . poll . unWrapAsync - waitCatch = lift . waitCatch . unWrapAsync - cancel = lift . cancel . unWrapAsync + wait = lift . wait . getAsyncReaderT + poll = lift . poll . getAsyncReaderT + waitCatch = lift . waitCatch . getAsyncReaderT + cancel = lift . cancel . getAsyncReaderT uninterruptibleCancel = lift . uninterruptibleCancel - . unWrapAsync + . getAsyncReaderT cancelWith = (lift .: cancelWith) - . unWrapAsync - waitAny = fmap (first WrappedAsync) + . getAsyncReaderT + waitAny = fmap (first AsyncReaderT) . lift . waitAny - . map unWrapAsync - waitAnyCatch = fmap (first WrappedAsync) + . map getAsyncReaderT + waitAnyCatch = fmap (first AsyncReaderT) . lift . waitAnyCatch - . map unWrapAsync - waitAnyCancel = fmap (first WrappedAsync) + . map getAsyncReaderT + waitAnyCancel = fmap (first AsyncReaderT) . lift . waitAnyCancel - . map unWrapAsync - waitAnyCatchCancel = fmap (first WrappedAsync) + . map getAsyncReaderT + waitAnyCatchCancel = fmap (first AsyncReaderT) . lift . waitAnyCatchCancel - . map unWrapAsync - waitEither = on (lift .: waitEither) unWrapAsync - waitEitherCatch = on (lift .: waitEitherCatch) unWrapAsync - waitEitherCancel = on (lift .: waitEitherCancel) unWrapAsync - waitEitherCatchCancel = on (lift .: waitEitherCatchCancel) unWrapAsync - waitEither_ = on (lift .: waitEither_) unWrapAsync - waitBoth = on (lift .: waitBoth) unWrapAsync + . map getAsyncReaderT + waitEither = on (lift .: waitEither) getAsyncReaderT + waitEitherCatch = on (lift .: waitEitherCatch) getAsyncReaderT + waitEitherCancel = on (lift .: waitEitherCancel) getAsyncReaderT + waitEitherCatchCancel = on (lift .: waitEitherCatchCancel) getAsyncReaderT + waitEither_ = on (lift .: waitEither_) getAsyncReaderT + waitBoth = on (lift .: waitBoth) getAsyncReaderT -- diff --git a/io-classes/src/Control/Monad/Class/MonadEventlog.hs b/io-classes/src/Control/Monad/Class/MonadEventlog.hs index 2e3c34b2..d50a7b4a 100644 --- a/io-classes/src/Control/Monad/Class/MonadEventlog.hs +++ b/io-classes/src/Control/Monad/Class/MonadEventlog.hs @@ -6,6 +6,7 @@ module Control.Monad.Class.MonadEventlog ) where import Control.Monad.Reader + import qualified Debug.Trace as IO (traceEventIO, traceMarkerIO) class Monad m => MonadEventlog m where @@ -45,5 +46,5 @@ instance MonadEventlog IO where -- instance MonadEventlog m => MonadEventlog (ReaderT r m) where - traceEventIO = lift . traceEventIO + traceEventIO = lift . traceEventIO traceMarkerIO = lift . traceMarkerIO diff --git a/io-classes/src/Control/Monad/Class/MonadFork.hs b/io-classes/src/Control/Monad/Class/MonadFork.hs index 193bb6bd..1a41f979 100644 --- a/io-classes/src/Control/Monad/Class/MonadFork.hs +++ b/io-classes/src/Control/Monad/Class/MonadFork.hs @@ -54,8 +54,8 @@ forkWithUnmask = forkIOWithUnmask instance MonadThread IO where type ThreadId IO = IO.ThreadId - myThreadId = IO.myThreadId - labelThread = IO.labelThread + myThreadId = IO.myThreadId + labelThread = IO.labelThread threadStatus = IO.threadStatus instance MonadFork IO where @@ -68,17 +68,17 @@ instance MonadFork IO where instance MonadThread m => MonadThread (ReaderT r m) where type ThreadId (ReaderT r m) = ThreadId m - myThreadId = lift myThreadId + myThreadId = lift myThreadId labelThread t l = lift (labelThread t l) - threadStatus t = lift (threadStatus t) + threadStatus t = lift (threadStatus t) instance MonadFork m => MonadFork (ReaderT e m) where forkIO (ReaderT f) = ReaderT $ \e -> forkIO (f e) forkOn n (ReaderT f) = ReaderT $ \e -> forkOn n (f e) forkIOWithUnmask k = ReaderT $ \e -> forkIOWithUnmask $ \restore -> - let restore' :: ReaderT e m a -> ReaderT e m a - restore' (ReaderT f) = ReaderT $ restore . f - in runReaderT (k restore') e + let restore' :: ReaderT e m a -> ReaderT e m a + restore' (ReaderT f) = ReaderT $ restore . f + in runReaderT (k restore') e throwTo e t = lift (throwTo e t) yield = lift yield diff --git a/io-classes/src/Control/Monad/Class/MonadMVar.hs b/io-classes/src/Control/Monad/Class/MonadMVar.hs index 303cc686..5a35d18b 100644 --- a/io-classes/src/Control/Monad/Class/MonadMVar.hs +++ b/io-classes/src/Control/Monad/Class/MonadMVar.hs @@ -142,7 +142,6 @@ newtype WrappedMVar r (m :: Type -> Type) a = WrappedMVar { unwrapMVar :: MVar m instance ( MonadMask m , MonadMVar m - , MonadEvaluate m ) => MonadMVar (ReaderT r m) where type MVar (ReaderT r m) = WrappedMVar r m newEmptyMVar = WrappedMVar <$> lift newEmptyMVar diff --git a/io-classes/src/Control/Monad/Class/MonadST.hs b/io-classes/src/Control/Monad/Class/MonadST.hs index b753df5b..a422176a 100644 --- a/io-classes/src/Control/Monad/Class/MonadST.hs +++ b/io-classes/src/Control/Monad/Class/MonadST.hs @@ -2,6 +2,7 @@ module Control.Monad.Class.MonadST (MonadST (..)) where import Control.Monad.Reader + import Control.Monad.ST (ST, stToIO) diff --git a/io-classes/src/Control/Monad/Class/MonadSTM.hs b/io-classes/src/Control/Monad/Class/MonadSTM.hs index 6ab900a2..8a1e1139 100644 --- a/io-classes/src/Control/Monad/Class/MonadSTM.hs +++ b/io-classes/src/Control/Monad/Class/MonadSTM.hs @@ -18,8 +18,6 @@ module Control.Monad.Class.MonadSTM , MonadTraceSTM , MonadInspectSTM (..) , TraceValue (..) - -- * monad transformer 'STM' wrapper - , WrappedSTM (..) ) where import Control.Monad.Class.MonadSTM.Internal diff --git a/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs b/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs index 1dfffdd0..e9934cb5 100644 --- a/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs +++ b/io-classes/src/Control/Monad/Class/MonadSTM/Internal.hs @@ -14,8 +14,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} --- undecidable instances needed for 'WrappedSTM' instances of 'MonadThrow' and --- 'MonadCatch' type classes. + +-- needed for `ReaderT` instance {-# LANGUAGE UndecidableInstances #-} -- Internal module. It's only exposed as it provides various default types for @@ -51,8 +51,6 @@ module Control.Monad.Class.MonadSTM.Internal , newTMVarMDefault , newEmptyTMVarM , newEmptyTMVarMDefault - -- * Utils - , WrappedSTM (..) ) where import Prelude hiding (read) @@ -64,27 +62,20 @@ import qualified Control.Concurrent.STM.TMVar as STM import qualified Control.Concurrent.STM.TQueue as STM import qualified Control.Concurrent.STM.TSem as STM import qualified Control.Concurrent.STM.TVar as STM -import Control.Monad (MonadPlus (..), unless, when) +import Control.Monad (unless, when) import qualified Control.Monad.STM as STM -import Control.Monad.Cont (ContT (..)) -import Control.Monad.Except (ExceptT (..)) -import Control.Monad.RWS (RWST (..)) import Control.Monad.Reader (ReaderT (..)) -import Control.Monad.State (StateT (..)) import Control.Monad.Trans (lift) -import Control.Monad.Writer (WriterT (..)) import qualified Control.Monad.Class.MonadThrow as MonadThrow -import Control.Applicative (Alternative (..)) import Control.Exception import Data.Array (Array, bounds) import qualified Data.Array as Array import Data.Array.Base (IArray (numElements), MArray (..), arrEleBottom, listArray, unsafeAt) import Data.Foldable (traverse_) -import Data.Function (on) import Data.Ix (Ix, rangeSize) import Data.Kind (Type) import Data.Proxy (Proxy (..)) @@ -99,10 +90,7 @@ type LazyTVar m = TVar m type LazyTMVar m = TMVar m -- The STM primitives -class ( Monad m - , Alternative (STM m) - , MonadPlus (STM m) - ) => MonadSTM m where +class (Monad m, Monad (STM m)) => MonadSTM m where -- STM transactions type STM m = (stm :: Type -> Type) | stm -> m atomically :: HasCallStack => STM m a -> m a @@ -1297,511 +1285,85 @@ catchSTM :: (MonadSTM m, MonadThrow.MonadCatch (STM m), Exception e) catchSTM = MonadThrow.catch -- --- Monad Transformers +-- ReaderT instance -- -data Trans where - Cont :: Trans - Reader :: Trans - Writer :: Trans - State :: Trans - Except :: Trans - RWS :: Trans - --- | A newtype wrapper for an 'STM' monad for monad transformers. +-- | The underlying stm monad is also transformed. -- -newtype WrappedSTM (t :: Trans) r (m :: Type -> Type) a = WrappedSTM { runWrappedSTM :: STM m a } - -deriving instance MonadSTM m => Functor (WrappedSTM t r m) -deriving instance MonadSTM m => Applicative (WrappedSTM t r m) -deriving instance MonadSTM m => Monad (WrappedSTM t r m) -deriving instance MonadSTM m => Alternative (WrappedSTM t r m) -deriving instance MonadSTM m => MonadPlus (WrappedSTM t r m) - -instance ( Semigroup a, MonadSTM m ) => Semigroup (WrappedSTM t r m a) where - a <> b = (<>) <$> a <*> b -instance ( Monoid a, MonadSTM m ) => Monoid (WrappedSTM t r m a) where - mempty = pure mempty - -instance ( MonadSTM m, MArray e a (STM m) ) => MArray e a (WrappedSTM t r m) where - getBounds = WrappedSTM . getBounds - getNumElements = WrappedSTM . getNumElements - unsafeRead arr = WrappedSTM . unsafeRead arr - unsafeWrite arr i = WrappedSTM . unsafeWrite arr i - - --- 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 (WrappedSTM t r m) where - throwIO = WrappedSTM . MonadThrow.throwIO - -instance ( MonadSTM m - , MonadThrow.MonadThrow (STM m) - , MonadThrow.MonadCatch (STM m) - ) => MonadThrow.MonadCatch (WrappedSTM t r m) where - catch action handler = WrappedSTM - $ MonadThrow.catch (runWrappedSTM action) (runWrappedSTM . handler) - generalBracket acquire release use = WrappedSTM $ - MonadThrow.generalBracket (runWrappedSTM acquire) - (runWrappedSTM .: release) - (runWrappedSTM . use) - -instance MonadSTM m => MonadSTM (ContT r m) where - type STM (ContT r m) = WrappedSTM Cont r m - atomically = lift . atomically . runWrappedSTM - - type TVar (ContT r m) = TVar m - newTVar = WrappedSTM . newTVar - readTVar = WrappedSTM . readTVar - writeTVar = WrappedSTM .: writeTVar - retry = WrappedSTM retry - orElse = WrappedSTM .: on orElse runWrappedSTM - - modifyTVar = WrappedSTM .: modifyTVar - modifyTVar' = WrappedSTM .: modifyTVar' - stateTVar = WrappedSTM .: stateTVar - swapTVar = WrappedSTM .: swapTVar - check = WrappedSTM . check - - type TMVar (ContT r m) = TMVar m - newTMVar = WrappedSTM . newTMVar - newEmptyTMVar = WrappedSTM newEmptyTMVar - takeTMVar = WrappedSTM . takeTMVar - tryTakeTMVar = WrappedSTM . tryTakeTMVar - putTMVar = WrappedSTM .: putTMVar - tryPutTMVar = WrappedSTM .: tryPutTMVar - readTMVar = WrappedSTM . readTMVar - tryReadTMVar = WrappedSTM . tryReadTMVar - swapTMVar = WrappedSTM .: swapTMVar - isEmptyTMVar = WrappedSTM . isEmptyTMVar - - type TQueue (ContT r m) = TQueue m - newTQueue = WrappedSTM newTQueue - readTQueue = WrappedSTM . readTQueue - tryReadTQueue = WrappedSTM . tryReadTQueue - peekTQueue = WrappedSTM . peekTQueue - tryPeekTQueue = WrappedSTM . tryPeekTQueue - flushTQueue = WrappedSTM . flushTQueue - writeTQueue v = WrappedSTM . writeTQueue v - isEmptyTQueue = WrappedSTM . isEmptyTQueue - unGetTQueue = WrappedSTM .: unGetTQueue - - type TBQueue (ContT r m) = TBQueue m - newTBQueue = WrappedSTM . newTBQueue - readTBQueue = WrappedSTM . readTBQueue - tryReadTBQueue = WrappedSTM . tryReadTBQueue - peekTBQueue = WrappedSTM . peekTBQueue - tryPeekTBQueue = WrappedSTM . tryPeekTBQueue - flushTBQueue = WrappedSTM . flushTBQueue - writeTBQueue = WrappedSTM .: writeTBQueue - lengthTBQueue = WrappedSTM . lengthTBQueue - isEmptyTBQueue = WrappedSTM . isEmptyTBQueue - isFullTBQueue = WrappedSTM . isFullTBQueue - unGetTBQueue = WrappedSTM .: unGetTBQueue - - type TArray (ContT r m) = TArray m - - type TSem (ContT r m) = TSem m - newTSem = WrappedSTM . newTSem - waitTSem = WrappedSTM . waitTSem - signalTSem = WrappedSTM . signalTSem - signalTSemN = WrappedSTM .: signalTSemN - - type TChan (ContT r m) = TChan m - newTChan = WrappedSTM newTChan - newBroadcastTChan = WrappedSTM newBroadcastTChan - dupTChan = WrappedSTM . dupTChan - cloneTChan = WrappedSTM . cloneTChan - readTChan = WrappedSTM . readTChan - tryReadTChan = WrappedSTM . tryReadTChan - peekTChan = WrappedSTM . peekTChan - tryPeekTChan = WrappedSTM . tryPeekTChan - writeTChan = WrappedSTM .: writeTChan - unGetTChan = WrappedSTM .: unGetTChan - isEmptyTChan = WrappedSTM . isEmptyTChan - - instance MonadSTM m => MonadSTM (ReaderT r m) where - type STM (ReaderT r m) = WrappedSTM Reader r m - atomically = lift . atomically . runWrappedSTM + type STM (ReaderT r m) = ReaderT r (STM m) + atomically (ReaderT stm) = ReaderT $ \r -> atomically (stm r) type TVar (ReaderT r m) = TVar m - newTVar = WrappedSTM . newTVar - readTVar = WrappedSTM . readTVar - writeTVar = WrappedSTM .: writeTVar - retry = WrappedSTM retry - orElse = WrappedSTM .: on orElse runWrappedSTM - - modifyTVar = WrappedSTM .: modifyTVar - modifyTVar' = WrappedSTM .: modifyTVar' - stateTVar = WrappedSTM .: stateTVar - swapTVar = WrappedSTM .: swapTVar - check = WrappedSTM . check + newTVar = lift . newTVar + readTVar = lift . readTVar + writeTVar = lift .: writeTVar + retry = lift retry + orElse (ReaderT a) (ReaderT b) = ReaderT $ \r -> a r `orElse` b r + + modifyTVar = lift .: modifyTVar + modifyTVar' = lift .: modifyTVar' + stateTVar = lift .: stateTVar + swapTVar = lift .: swapTVar + check = lift . check type TMVar (ReaderT r m) = TMVar m - newTMVar = WrappedSTM . newTMVar - newEmptyTMVar = WrappedSTM newEmptyTMVar - takeTMVar = WrappedSTM . takeTMVar - tryTakeTMVar = WrappedSTM . tryTakeTMVar - putTMVar = WrappedSTM .: putTMVar - tryPutTMVar = WrappedSTM .: tryPutTMVar - readTMVar = WrappedSTM . readTMVar - tryReadTMVar = WrappedSTM . tryReadTMVar - swapTMVar = WrappedSTM .: swapTMVar - isEmptyTMVar = WrappedSTM . isEmptyTMVar + newTMVar = lift . newTMVar + newEmptyTMVar = lift newEmptyTMVar + takeTMVar = lift . takeTMVar + tryTakeTMVar = lift . tryTakeTMVar + putTMVar = lift .: putTMVar + tryPutTMVar = lift .: tryPutTMVar + readTMVar = lift . readTMVar + tryReadTMVar = lift . tryReadTMVar + swapTMVar = lift .: swapTMVar + isEmptyTMVar = lift . isEmptyTMVar type TQueue (ReaderT r m) = TQueue m - newTQueue = WrappedSTM newTQueue - readTQueue = WrappedSTM . readTQueue - tryReadTQueue = WrappedSTM . tryReadTQueue - peekTQueue = WrappedSTM . peekTQueue - tryPeekTQueue = WrappedSTM . tryPeekTQueue - flushTQueue = WrappedSTM . flushTQueue - writeTQueue v = WrappedSTM . writeTQueue v - isEmptyTQueue = WrappedSTM . isEmptyTQueue - unGetTQueue = WrappedSTM .: unGetTQueue + newTQueue = lift newTQueue + readTQueue = lift . readTQueue + tryReadTQueue = lift . tryReadTQueue + peekTQueue = lift . peekTQueue + tryPeekTQueue = lift . tryPeekTQueue + flushTQueue = lift . flushTQueue + writeTQueue v = lift . writeTQueue v + isEmptyTQueue = lift . isEmptyTQueue + unGetTQueue = lift .: unGetTQueue type TBQueue (ReaderT r m) = TBQueue m - newTBQueue = WrappedSTM . newTBQueue - readTBQueue = WrappedSTM . readTBQueue - tryReadTBQueue = WrappedSTM . tryReadTBQueue - peekTBQueue = WrappedSTM . peekTBQueue - tryPeekTBQueue = WrappedSTM . tryPeekTBQueue - flushTBQueue = WrappedSTM . flushTBQueue - writeTBQueue = WrappedSTM .: writeTBQueue - lengthTBQueue = WrappedSTM . lengthTBQueue - isEmptyTBQueue = WrappedSTM . isEmptyTBQueue - isFullTBQueue = WrappedSTM . isFullTBQueue - unGetTBQueue = WrappedSTM .: unGetTBQueue + newTBQueue = lift . newTBQueue + readTBQueue = lift . readTBQueue + tryReadTBQueue = lift . tryReadTBQueue + peekTBQueue = lift . peekTBQueue + tryPeekTBQueue = lift . tryPeekTBQueue + flushTBQueue = lift . flushTBQueue + writeTBQueue = lift .: writeTBQueue + lengthTBQueue = lift . lengthTBQueue + isEmptyTBQueue = lift . isEmptyTBQueue + isFullTBQueue = lift . isFullTBQueue + unGetTBQueue = lift .: unGetTBQueue type TArray (ReaderT r m) = TArray m type TSem (ReaderT r m) = TSem m - newTSem = WrappedSTM . newTSem - waitTSem = WrappedSTM . waitTSem - signalTSem = WrappedSTM . signalTSem - signalTSemN = WrappedSTM .: signalTSemN + newTSem = lift . newTSem + waitTSem = lift . waitTSem + signalTSem = lift . signalTSem + signalTSemN = lift .: signalTSemN type TChan (ReaderT r m) = TChan m - newTChan = WrappedSTM newTChan - newBroadcastTChan = WrappedSTM newBroadcastTChan - dupTChan = WrappedSTM . dupTChan - cloneTChan = WrappedSTM . cloneTChan - readTChan = WrappedSTM . readTChan - tryReadTChan = WrappedSTM . tryReadTChan - peekTChan = WrappedSTM . peekTChan - tryPeekTChan = WrappedSTM . tryPeekTChan - writeTChan = WrappedSTM .: writeTChan - unGetTChan = WrappedSTM .: unGetTChan - isEmptyTChan = WrappedSTM . isEmptyTChan - - -instance (Monoid w, MonadSTM m) => MonadSTM (WriterT w m) where - type STM (WriterT w m) = WrappedSTM Writer w m - atomically = lift . atomically . runWrappedSTM - - type TVar (WriterT w m) = TVar m - newTVar = WrappedSTM . newTVar - readTVar = WrappedSTM . readTVar - writeTVar = WrappedSTM .: writeTVar - retry = WrappedSTM retry - orElse = WrappedSTM .: on orElse runWrappedSTM - - modifyTVar = WrappedSTM .: modifyTVar - modifyTVar' = WrappedSTM .: modifyTVar' - stateTVar = WrappedSTM .: stateTVar - swapTVar = WrappedSTM .: swapTVar - check = WrappedSTM . check - - type TMVar (WriterT w m) = TMVar m - newTMVar = WrappedSTM . newTMVar - newEmptyTMVar = WrappedSTM newEmptyTMVar - takeTMVar = WrappedSTM . takeTMVar - tryTakeTMVar = WrappedSTM . tryTakeTMVar - putTMVar = WrappedSTM .: putTMVar - tryPutTMVar = WrappedSTM .: tryPutTMVar - readTMVar = WrappedSTM . readTMVar - tryReadTMVar = WrappedSTM . tryReadTMVar - swapTMVar = WrappedSTM .: swapTMVar - isEmptyTMVar = WrappedSTM . isEmptyTMVar - - type TQueue (WriterT w m) = TQueue m - newTQueue = WrappedSTM newTQueue - readTQueue = WrappedSTM . readTQueue - tryReadTQueue = WrappedSTM . tryReadTQueue - peekTQueue = WrappedSTM . peekTQueue - tryPeekTQueue = WrappedSTM . tryPeekTQueue - flushTQueue = WrappedSTM . flushTQueue - writeTQueue v = WrappedSTM . writeTQueue v - isEmptyTQueue = WrappedSTM . isEmptyTQueue - unGetTQueue = WrappedSTM .: unGetTQueue - - type TBQueue (WriterT w m) = TBQueue m - newTBQueue = WrappedSTM . newTBQueue - readTBQueue = WrappedSTM . readTBQueue - tryReadTBQueue = WrappedSTM . tryReadTBQueue - peekTBQueue = WrappedSTM . peekTBQueue - tryPeekTBQueue = WrappedSTM . tryPeekTBQueue - flushTBQueue = WrappedSTM . flushTBQueue - writeTBQueue = WrappedSTM .: writeTBQueue - lengthTBQueue = WrappedSTM . lengthTBQueue - isEmptyTBQueue = WrappedSTM . isEmptyTBQueue - isFullTBQueue = WrappedSTM . isFullTBQueue - unGetTBQueue = WrappedSTM .: unGetTBQueue - - type TArray (WriterT w m) = TArray m - - type TSem (WriterT w m) = TSem m - newTSem = WrappedSTM . newTSem - waitTSem = WrappedSTM . waitTSem - signalTSem = WrappedSTM . signalTSem - signalTSemN = WrappedSTM .: signalTSemN - - type TChan (WriterT w m) = TChan m - newTChan = WrappedSTM newTChan - newBroadcastTChan = WrappedSTM newBroadcastTChan - dupTChan = WrappedSTM . dupTChan - cloneTChan = WrappedSTM . cloneTChan - readTChan = WrappedSTM . readTChan - tryReadTChan = WrappedSTM . tryReadTChan - peekTChan = WrappedSTM . peekTChan - tryPeekTChan = WrappedSTM . tryPeekTChan - writeTChan = WrappedSTM .: writeTChan - unGetTChan = WrappedSTM .: unGetTChan - isEmptyTChan = WrappedSTM . isEmptyTChan - - -instance MonadSTM m => MonadSTM (StateT s m) where - type STM (StateT s m) = WrappedSTM State s m - atomically = lift . atomically . runWrappedSTM - - type TVar (StateT s m) = TVar m - newTVar = WrappedSTM . newTVar - readTVar = WrappedSTM . readTVar - writeTVar = WrappedSTM .: writeTVar - retry = WrappedSTM retry - orElse = WrappedSTM .: on orElse runWrappedSTM - - modifyTVar = WrappedSTM .: modifyTVar - modifyTVar' = WrappedSTM .: modifyTVar' - stateTVar = WrappedSTM .: stateTVar - swapTVar = WrappedSTM .: swapTVar - check = WrappedSTM . check - - type TMVar (StateT s m) = TMVar m - newTMVar = WrappedSTM . newTMVar - newEmptyTMVar = WrappedSTM newEmptyTMVar - takeTMVar = WrappedSTM . takeTMVar - tryTakeTMVar = WrappedSTM . tryTakeTMVar - putTMVar = WrappedSTM .: putTMVar - tryPutTMVar = WrappedSTM .: tryPutTMVar - readTMVar = WrappedSTM . readTMVar - tryReadTMVar = WrappedSTM . tryReadTMVar - swapTMVar = WrappedSTM .: swapTMVar - isEmptyTMVar = WrappedSTM . isEmptyTMVar - - type TQueue (StateT s m) = TQueue m - newTQueue = WrappedSTM newTQueue - readTQueue = WrappedSTM . readTQueue - tryReadTQueue = WrappedSTM . tryReadTQueue - peekTQueue = WrappedSTM . peekTQueue - tryPeekTQueue = WrappedSTM . tryPeekTQueue - flushTQueue = WrappedSTM . flushTQueue - writeTQueue v = WrappedSTM . writeTQueue v - isEmptyTQueue = WrappedSTM . isEmptyTQueue - unGetTQueue = WrappedSTM .: unGetTQueue - - type TBQueue (StateT s m) = TBQueue m - newTBQueue = WrappedSTM . newTBQueue - readTBQueue = WrappedSTM . readTBQueue - tryReadTBQueue = WrappedSTM . tryReadTBQueue - peekTBQueue = WrappedSTM . peekTBQueue - tryPeekTBQueue = WrappedSTM . tryPeekTBQueue - flushTBQueue = WrappedSTM . flushTBQueue - writeTBQueue = WrappedSTM .: writeTBQueue - lengthTBQueue = WrappedSTM . lengthTBQueue - isEmptyTBQueue = WrappedSTM . isEmptyTBQueue - isFullTBQueue = WrappedSTM . isFullTBQueue - unGetTBQueue = WrappedSTM .: unGetTBQueue - - type TArray (StateT s m) = TArray m - - type TSem (StateT s m) = TSem m - newTSem = WrappedSTM . newTSem - waitTSem = WrappedSTM . waitTSem - signalTSem = WrappedSTM . signalTSem - signalTSemN = WrappedSTM .: signalTSemN - - type TChan (StateT s m) = TChan m - newTChan = WrappedSTM newTChan - newBroadcastTChan = WrappedSTM newBroadcastTChan - dupTChan = WrappedSTM . dupTChan - cloneTChan = WrappedSTM . cloneTChan - readTChan = WrappedSTM . readTChan - tryReadTChan = WrappedSTM . tryReadTChan - peekTChan = WrappedSTM . peekTChan - tryPeekTChan = WrappedSTM . tryPeekTChan - writeTChan = WrappedSTM .: writeTChan - unGetTChan = WrappedSTM .: unGetTChan - isEmptyTChan = WrappedSTM . isEmptyTChan - - -instance MonadSTM m => MonadSTM (ExceptT e m) where - type STM (ExceptT e m) = WrappedSTM Except e m - atomically = lift . atomically . runWrappedSTM - - type TVar (ExceptT e m) = TVar m - newTVar = WrappedSTM . newTVar - readTVar = WrappedSTM . readTVar - writeTVar = WrappedSTM .: writeTVar - retry = WrappedSTM retry - orElse = WrappedSTM .: on orElse runWrappedSTM - - modifyTVar = WrappedSTM .: modifyTVar - modifyTVar' = WrappedSTM .: modifyTVar' - stateTVar = WrappedSTM .: stateTVar - swapTVar = WrappedSTM .: swapTVar - check = WrappedSTM . check - - type TMVar (ExceptT e m) = TMVar m - newTMVar = WrappedSTM . newTMVar - newEmptyTMVar = WrappedSTM newEmptyTMVar - takeTMVar = WrappedSTM . takeTMVar - tryTakeTMVar = WrappedSTM . tryTakeTMVar - putTMVar = WrappedSTM .: putTMVar - tryPutTMVar = WrappedSTM .: tryPutTMVar - readTMVar = WrappedSTM . readTMVar - tryReadTMVar = WrappedSTM . tryReadTMVar - swapTMVar = WrappedSTM .: swapTMVar - isEmptyTMVar = WrappedSTM . isEmptyTMVar - - type TQueue (ExceptT e m) = TQueue m - newTQueue = WrappedSTM newTQueue - readTQueue = WrappedSTM . readTQueue - tryReadTQueue = WrappedSTM . tryReadTQueue - peekTQueue = WrappedSTM . peekTQueue - tryPeekTQueue = WrappedSTM . tryPeekTQueue - flushTQueue = WrappedSTM . flushTQueue - writeTQueue v = WrappedSTM . writeTQueue v - isEmptyTQueue = WrappedSTM . isEmptyTQueue - unGetTQueue = WrappedSTM .: unGetTQueue - - type TBQueue (ExceptT e m) = TBQueue m - newTBQueue = WrappedSTM . newTBQueue - readTBQueue = WrappedSTM . readTBQueue - tryReadTBQueue = WrappedSTM . tryReadTBQueue - peekTBQueue = WrappedSTM . peekTBQueue - tryPeekTBQueue = WrappedSTM . tryPeekTBQueue - flushTBQueue = WrappedSTM . flushTBQueue - writeTBQueue = WrappedSTM .: writeTBQueue - lengthTBQueue = WrappedSTM . lengthTBQueue - isEmptyTBQueue = WrappedSTM . isEmptyTBQueue - isFullTBQueue = WrappedSTM . isFullTBQueue - unGetTBQueue = WrappedSTM .: unGetTBQueue - - type TArray (ExceptT e m) = TArray m - - type TSem (ExceptT e m) = TSem m - newTSem = WrappedSTM . newTSem - waitTSem = WrappedSTM . waitTSem - signalTSem = WrappedSTM . signalTSem - signalTSemN = WrappedSTM .: signalTSemN - - type TChan (ExceptT e m) = TChan m - newTChan = WrappedSTM newTChan - newBroadcastTChan = WrappedSTM newBroadcastTChan - dupTChan = WrappedSTM . dupTChan - cloneTChan = WrappedSTM . cloneTChan - readTChan = WrappedSTM . readTChan - tryReadTChan = WrappedSTM . tryReadTChan - peekTChan = WrappedSTM . peekTChan - tryPeekTChan = WrappedSTM . tryPeekTChan - writeTChan = WrappedSTM .: writeTChan - unGetTChan = WrappedSTM .: unGetTChan - isEmptyTChan = WrappedSTM . isEmptyTChan - - -instance (Monoid w, MonadSTM m) => MonadSTM (RWST r w s m) where - type STM (RWST r w s m) = WrappedSTM RWS (r, w, s) m - atomically = lift . atomically . runWrappedSTM - - type TVar (RWST r w s m) = TVar m - newTVar = WrappedSTM . newTVar - readTVar = WrappedSTM . readTVar - writeTVar = WrappedSTM .: writeTVar - retry = WrappedSTM retry - orElse = WrappedSTM .: on orElse runWrappedSTM - - modifyTVar = WrappedSTM .: modifyTVar - modifyTVar' = WrappedSTM .: modifyTVar' - stateTVar = WrappedSTM .: stateTVar - swapTVar = WrappedSTM .: swapTVar - check = WrappedSTM . check - - type TMVar (RWST r w s m) = TMVar m - newTMVar = WrappedSTM . newTMVar - newEmptyTMVar = WrappedSTM newEmptyTMVar - takeTMVar = WrappedSTM . takeTMVar - tryTakeTMVar = WrappedSTM . tryTakeTMVar - putTMVar = WrappedSTM .: putTMVar - tryPutTMVar = WrappedSTM .: tryPutTMVar - readTMVar = WrappedSTM . readTMVar - tryReadTMVar = WrappedSTM . tryReadTMVar - swapTMVar = WrappedSTM .: swapTMVar - isEmptyTMVar = WrappedSTM . isEmptyTMVar - - type TQueue (RWST r w s m) = TQueue m - newTQueue = WrappedSTM newTQueue - readTQueue = WrappedSTM . readTQueue - tryReadTQueue = WrappedSTM . tryReadTQueue - peekTQueue = WrappedSTM . peekTQueue - tryPeekTQueue = WrappedSTM . tryPeekTQueue - flushTQueue = WrappedSTM . flushTQueue - writeTQueue v = WrappedSTM . writeTQueue v - isEmptyTQueue = WrappedSTM . isEmptyTQueue - unGetTQueue = WrappedSTM .: unGetTQueue - - type TBQueue (RWST r w s m) = TBQueue m - newTBQueue = WrappedSTM . newTBQueue - readTBQueue = WrappedSTM . readTBQueue - tryReadTBQueue = WrappedSTM . tryReadTBQueue - peekTBQueue = WrappedSTM . peekTBQueue - tryPeekTBQueue = WrappedSTM . tryPeekTBQueue - flushTBQueue = WrappedSTM . flushTBQueue - writeTBQueue = WrappedSTM .: writeTBQueue - lengthTBQueue = WrappedSTM . lengthTBQueue - isEmptyTBQueue = WrappedSTM . isEmptyTBQueue - isFullTBQueue = WrappedSTM . isFullTBQueue - unGetTBQueue = WrappedSTM .: unGetTBQueue - - type TArray (RWST r w s m) = TArray m - - type TSem (RWST r w s m) = TSem m - newTSem = WrappedSTM . newTSem - waitTSem = WrappedSTM . waitTSem - signalTSem = WrappedSTM . signalTSem - signalTSemN = WrappedSTM .: signalTSemN - - type TChan (RWST r w s m) = TChan m - newTChan = WrappedSTM newTChan - newBroadcastTChan = WrappedSTM newBroadcastTChan - dupTChan = WrappedSTM . dupTChan - cloneTChan = WrappedSTM . cloneTChan - readTChan = WrappedSTM . readTChan - tryReadTChan = WrappedSTM . tryReadTChan - peekTChan = WrappedSTM . peekTChan - tryPeekTChan = WrappedSTM . tryPeekTChan - writeTChan = WrappedSTM .: writeTChan - unGetTChan = WrappedSTM .: unGetTChan - isEmptyTChan = WrappedSTM . isEmptyTChan + 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) diff --git a/io-classes/src/Control/Monad/Class/MonadSay.hs b/io-classes/src/Control/Monad/Class/MonadSay.hs index f9166a58..78def75f 100644 --- a/io-classes/src/Control/Monad/Class/MonadSay.hs +++ b/io-classes/src/Control/Monad/Class/MonadSay.hs @@ -1,6 +1,6 @@ module Control.Monad.Class.MonadSay where -import Control.Monad.State +import Control.Monad.Reader import qualified Data.ByteString.Char8 as BSC class Monad m => MonadSay m where @@ -9,5 +9,5 @@ class Monad m => MonadSay m where instance MonadSay IO where say = BSC.putStrLn . BSC.pack -instance MonadSay m => MonadSay (StateT s m) where +instance MonadSay m => MonadSay (ReaderT r m) where say = lift . say diff --git a/io-classes/src/Control/Monad/Class/MonadThrow.hs b/io-classes/src/Control/Monad/Class/MonadThrow.hs index 52174e13..5e4042d0 100644 --- a/io-classes/src/Control/Monad/Class/MonadThrow.hs +++ b/io-classes/src/Control/Monad/Class/MonadThrow.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Control.Monad.Class.MonadThrow @@ -25,8 +26,9 @@ module Control.Monad.Class.MonadThrow import Control.Exception (Exception (..), MaskingState, SomeException) import qualified Control.Exception as IO import Control.Monad (liftM) -import Control.Monad.Except (ExceptT (..), lift, runExceptT) -import Control.Monad.Reader (ReaderT (..), runReaderT) + +import Control.Monad.Reader (ReaderT (..), lift) + import Control.Monad.STM (STM) import qualified Control.Monad.STM as STM @@ -263,7 +265,7 @@ instance MonadCatch STM where -- --- Instances for ReaderT +-- ReaderT instances -- instance MonadThrow m => MonadThrow (ReaderT r m) where @@ -297,45 +299,3 @@ instance MonadMask m => MonadMask (ReaderT r m) where instance MonadEvaluate m => MonadEvaluate (ReaderT r m) where evaluate = lift . evaluate - --- --- Instances for ExceptT --- --- These all follow the @exceptions@ package to the letter --- - -instance MonadCatch m => MonadThrow (ExceptT e m) where - throwIO = lift . throwIO - -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) diff --git a/io-classes/src/Control/Monad/Class/MonadTime.hs b/io-classes/src/Control/Monad/Class/MonadTime.hs index 7768e3e0..3a7434dd 100644 --- a/io-classes/src/Control/Monad/Class/MonadTime.hs +++ b/io-classes/src/Control/Monad/Class/MonadTime.hs @@ -2,12 +2,7 @@ module Control.Monad.Class.MonadTime ( MonadTime (..) - , MonadMonotonicTime (..) - -- * 'DiffTime' and its action on 'Time' - , Time (..) - , diffTime - , addTime - , DiffTime + , MonadMonotonicTimeNSec (..) -- * 'NominalTime' and its action on 'UTCTime' , UTCTime , diffUTCTime @@ -16,64 +11,44 @@ module Control.Monad.Class.MonadTime ) where import Control.Monad.Reader -import Data.Time.Clock (DiffTime, NominalDiffTime, UTCTime, + +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime) import qualified Data.Time.Clock as Time import Data.Word (Word64) -import GHC.Clock (getMonotonicTimeNSec) -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 (Eq, Ord, Show, Generic) +import qualified GHC.Clock as IO (getMonotonicTimeNSec) --- | 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 Monad m => MonadMonotonicTime m where +class Monad m => MonadMonotonicTimeNSec m where -- | Time in a monotonic clock, with high precision. The epoch for this -- clock is arbitrary and does not correspond to any wall clock or calendar. -- - getMonotonicTime :: m Time + -- The time is measured in nano seconds as does `getMonotonicTimeNSec` from + -- "base". + -- + getMonotonicTimeNSec :: m Word64 -class MonadMonotonicTime m => MonadTime m where +class Monad m => MonadTime m where -- | Wall clock time. -- - getCurrentTime :: m UTCTime + getCurrentTime :: m UTCTime -- -- Instances for IO -- -instance MonadMonotonicTime IO where - getMonotonicTime = - fmap conv getMonotonicTimeNSec - where - conv :: Word64 -> Time - conv = Time . Time.picosecondsToDiffTime . (* 1000) . toInteger +instance MonadMonotonicTimeNSec IO where + getMonotonicTimeNSec = IO.getMonotonicTimeNSec instance MonadTime IO where getCurrentTime = Time.getCurrentTime -- --- Instance for ReaderT +-- MTL instances -- -instance MonadMonotonicTime m => MonadMonotonicTime (ReaderT r m) where - getMonotonicTime = lift getMonotonicTime +instance MonadMonotonicTimeNSec m => MonadMonotonicTimeNSec (ReaderT r m) where + getMonotonicTimeNSec = lift getMonotonicTimeNSec instance MonadTime m => MonadTime (ReaderT r m) where getCurrentTime = lift getCurrentTime diff --git a/io-classes/src/Control/Monad/Class/MonadTimer.hs b/io-classes/src/Control/Monad/Class/MonadTimer.hs index 2a9bca44..7b59be54 100644 --- a/io-classes/src/Control/Monad/Class/MonadTimer.hs +++ b/io-classes/src/Control/Monad/Class/MonadTimer.hs @@ -1,133 +1,31 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Control.Monad.Class.MonadTimer ( MonadDelay (..) , MonadTimer (..) - , TimeoutState (..) - , DiffTime - , diffTimeToMicrosecondsAsInt - , microsecondsAsIntToDiffTime ) where import qualified Control.Concurrent as IO -import Control.Concurrent.Class.MonadSTM.TVar +import Control.Concurrent.Class.MonadSTM import qualified Control.Concurrent.STM.TVar as STM -import Control.Exception (assert) -#if defined(mingw32_HOST_OS) -import Control.Monad (when) -#endif -import qualified Control.Monad.STM as STM -import Control.Monad.Cont (ContT (..)) -import Control.Monad.Except (ExceptT (..)) -import Control.Monad.RWS (RWST (..)) import Control.Monad.Reader (ReaderT (..)) -import Control.Monad.State (StateT (..)) import Control.Monad.Trans (lift) -import Control.Monad.Writer (WriterT (..)) - -import Data.Functor (void) -import Data.Kind (Type) -import Data.Time.Clock (DiffTime, diffTimeToPicoseconds) - -#if defined(__GLASGOW_HASKELL__) && !defined(mingw32_HOST_OS) && !defined(__GHCJS__) -import qualified GHC.Event as GHC (TimeoutKey, getSystemTimerManager, - registerTimeout, unregisterTimeout, updateTimeout) -#endif - -import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadSTM import qualified System.Timeout as IO -data TimeoutState = TimeoutPending | TimeoutFired | TimeoutCancelled - class Monad m => MonadDelay m where - threadDelay :: DiffTime -> m () - - default threadDelay :: MonadTimer m => DiffTime -> m () - threadDelay d = void . atomically . awaitTimeout =<< newTimeout d - -class (MonadSTM m, MonadDelay m) => MonadTimer m where - -- | The type of the timeout handle, used with 'newTimeout', 'readTimeout', - -- 'updateTimeout' and 'cancelTimeout'. - -- - data Timeout m :: Type - - -- | 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. - -- - newTimeout :: DiffTime -> m (Timeout m) - - -- | 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 :: Timeout m -> STM m TimeoutState - - -- Adjust when this timer will fire, to the given duration into the future. - -- - -- It is safe to race this concurrently against the timer firing. It will - -- have no effect if the timer fires first. - -- - -- The new time can be before or after the original expiry time, though - -- arguably it is an application design flaw to move timeouts sooner. - -- - updateTimeout :: Timeout m -> DiffTime -> m () - - -- | 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 :: Timeout m -> m () + threadDelay :: Int -> m () - -- | Returns @True@ when the timeout is fired, or @False@ if it is cancelled. - awaitTimeout :: Timeout m -> STM m Bool - awaitTimeout t = do s <- readTimeout t - case s of - TimeoutPending -> retry - TimeoutFired -> return True - TimeoutCancelled -> return False +class (MonadDelay m, MonadSTM m) => MonadTimer m where - registerDelay :: DiffTime -> m (TVar m Bool) + registerDelay :: Int -> m (TVar m Bool) - default registerDelay :: MonadFork m => DiffTime -> m (TVar m Bool) - registerDelay = defaultRegisterDelay - - timeout :: DiffTime -> m a -> m (Maybe a) - - -defaultRegisterDelay :: ( MonadTimer m - , MonadFork m - ) - => DiffTime - -> m (TVar m Bool) -defaultRegisterDelay d = do - v <- atomically $ newTVar False - t <- newTimeout d - _ <- forkIO $ atomically (awaitTimeout t >>= writeTVar v) - return v + timeout :: Int -> m a -> m (Maybe a) -- -- Instances for IO @@ -137,175 +35,21 @@ defaultRegisterDelay d = do -- advantage over 'IO.threadDelay'. -- instance MonadDelay IO where - threadDelay = go - where - go :: DiffTime -> IO () - go d | d > maxDelay = do - IO.threadDelay maxBound - go (d - maxDelay) - go d = do - IO.threadDelay (diffTimeToMicrosecondsAsInt d) - - maxDelay :: DiffTime - maxDelay = microsecondsAsIntToDiffTime maxBound - -#if defined(__GLASGOW_HASKELL__) && !defined(mingw32_HOST_OS) && !defined(__GHCJS__) -instance MonadTimer IO where - data Timeout IO = TimeoutIO !(STM.TVar TimeoutState) !GHC.TimeoutKey - - readTimeout (TimeoutIO var _key) = STM.readTVar var - - newTimeout = \d -> do - var <- STM.newTVarIO TimeoutPending - mgr <- GHC.getSystemTimerManager - key <- GHC.registerTimeout mgr (diffTimeToMicrosecondsAsInt 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 () + threadDelay = IO.threadDelay - -- In GHC's TimerManager this has no effect if the timer already fired. - -- It is safe to race against the timer firing. - updateTimeout (TimeoutIO _var key) d = do - mgr <- GHC.getSystemTimerManager - GHC.updateTimeout mgr key (diffTimeToMicrosecondsAsInt d) - 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 instance MonadTimer IO where - data Timeout IO = TimeoutIO !(STM.TVar (STM.TVar Bool)) !(STM.TVar Bool) - - 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 <- STM.registerDelay (diffTimeToMicrosecondsAsInt d) - timeoutvarvar <- STM.newTVarIO timeoutvar - cancelvar <- STM.newTVarIO False - return (TimeoutIO timeoutvarvar cancelvar) - updateTimeout (TimeoutIO timeoutvarvar _cancelvar) d = do - timeoutvar' <- STM.registerDelay (diffTimeToMicrosecondsAsInt d) - STM.atomically $ STM.writeTVar timeoutvarvar timeoutvar' - - cancelTimeout (TimeoutIO timeoutvarvar cancelvar) = - STM.atomically $ do - fired <- STM.readTVar =<< STM.readTVar timeoutvarvar - when (not fired) $ STM.writeTVar cancelvar True -#endif - - -- | For delays less (or equal) than @maxBound :: Int@ this is exactly the same as - -- 'STM.registerDaley'; for larger delays it will start a monitoring thread - -- whcih will update the 'TVar'. - -- - -- TODO: issue #2184 'registerDelay' relies on 'newTimeout', through - -- 'defaultRegisterDelay'. 'newTimeout' can overflow an 'Int' (this is - -- especially easy on 32-bit architectures). - registerDelay d - | d <= maxDelay = - STM.registerDelay (diffTimeToMicrosecondsAsInt d) - | otherwise = - defaultRegisterDelay d - where - maxDelay :: DiffTime - maxDelay = microsecondsAsIntToDiffTime maxBound - - timeout = IO.timeout . diffTimeToMicrosecondsAsInt - - -diffTimeToMicrosecondsAsInt :: DiffTime -> Int -diffTimeToMicrosecondsAsInt d = - let usec :: Integer - usec = diffTimeToPicoseconds d `div` 1_000_000 in - -- Can only represent usec times that fit within an Int, which on 32bit - -- systems means 2^31 usec, which is only ~35 minutes. - assert (usec <= fromIntegral (maxBound :: Int)) $ - fromIntegral usec - -microsecondsAsIntToDiffTime :: Int -> DiffTime -microsecondsAsIntToDiffTime = (/ 1_000_000) . fromIntegral + registerDelay = STM.registerDelay + timeout = IO.timeout -- --- Transfomer's instances +-- Transformer's instances -- -instance MonadDelay m => MonadDelay (ContT r m) where - threadDelay = lift . threadDelay instance MonadDelay m => MonadDelay (ReaderT 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 MonadTimer m => MonadTimer (ReaderT r m) where - newtype Timeout (ReaderT r m) = TimeoutR { unTimeoutR :: Timeout m } - newTimeout = lift . fmap TimeoutR . newTimeout - readTimeout = WrappedSTM . readTimeout . unTimeoutR - updateTimeout (TimeoutR t) d = lift $ updateTimeout t d - cancelTimeout = lift . cancelTimeout . unTimeoutR registerDelay = lift . registerDelay timeout d f = ReaderT $ \r -> timeout d (runReaderT f r) - -instance (Monoid w, MonadTimer m) => MonadTimer (WriterT w m) where - newtype Timeout (WriterT w m) = TimeoutW { unTimeoutW :: Timeout m } - newTimeout = lift . fmap TimeoutW . newTimeout - readTimeout = WrappedSTM . readTimeout . unTimeoutW - updateTimeout (TimeoutW t) d = lift $ updateTimeout t d - cancelTimeout = lift . cancelTimeout . unTimeoutW - registerDelay = lift . registerDelay - 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 - newtype Timeout (StateT s m) = TimeoutS { unTimeoutS :: Timeout m } - newTimeout = lift . fmap TimeoutS . newTimeout - readTimeout = WrappedSTM . readTimeout . unTimeoutS - updateTimeout (TimeoutS t) d = lift $ updateTimeout t d - cancelTimeout = lift . cancelTimeout . unTimeoutS - registerDelay = lift . registerDelay - 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 - newtype Timeout (RWST r w s m) = TimeoutRWS { unTimeoutRWS :: Timeout m } - newTimeout = lift . fmap TimeoutRWS . newTimeout - readTimeout = WrappedSTM . readTimeout . unTimeoutRWS - updateTimeout (TimeoutRWS t) d = lift $ updateTimeout t d - cancelTimeout = lift . cancelTimeout . unTimeoutRWS - registerDelay = lift . registerDelay - 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/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index ae6ff076..06aa4477 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -2,6 +2,11 @@ ## next version +### Breaking changes + +* Support refactored `MonadTimer`, and new `MonadTimerFancy`, `MonadTimeNSec` + monad classes. + ## 0.6.0.0 ### Breaking changes diff --git a/io-sim/io-sim.cabal b/io-sim/io-sim.cabal index d39e6287..ddb9e45e 100644 --- a/io-sim/io-sim.cabal +++ b/io-sim/io-sim.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.4 name: io-sim version: 0.6.0.0 synopsis: A pure simulator for monadic concurrency with STM @@ -24,7 +24,22 @@ source-repository head location: https://github.com/input-output-hk/io-sim subdir: io-sim +common test-warnings + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Widentities + -Wunused-packages + -Wredundant-constraints + -Wno-unticked-promoted-constructors + +common warnings + import: test-warnings + ghc-options: -Wincomplete-record-updates + -Wpartial-fields + library + import: warnings hs-source-dirs: src exposed-modules: Data.List.Trace, Control.Monad.IOSim, @@ -55,26 +70,18 @@ library containers, deque, parallel, - pretty-simple, psqueues >=0.2 && <0.3, - text, + si-timers ^>=0.6, time >=1.9.1 && <1.13, quiet, QuickCheck, - syb - ghc-options: -Wall - -Wcompat - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wpartial-fields - -Widentities - -Wredundant-constraints if flag(asserts) ghc-options: -fno-ignore-asserts test-suite test + import: test-warnings type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs @@ -91,16 +98,16 @@ test-suite test io-sim, parallel, QuickCheck, + si-timers, strict-stm, tasty, tasty-quickcheck, tasty-hunit, time - - ghc-options: -Wall - -fno-ignore-asserts + ghc-options: -fno-ignore-asserts benchmark bench + import: warnings type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: Main.hs @@ -108,7 +115,6 @@ benchmark bench build-depends: base, criterion, - contra-tracer, io-classes, io-sim, ghc-options: -Wall diff --git a/io-sim/src/Control/Monad/IOSim.hs b/io-sim/src/Control/Monad/IOSim.hs index 5f6354ca..a054128d 100644 --- a/io-sim/src/Control/Monad/IOSim.hs +++ b/io-sim/src/Control/Monad/IOSim.hs @@ -69,6 +69,10 @@ module Control.Monad.IOSim , EventlogMarker (..) -- * Low-level API , execReadTVar + , newTimeout + , readTimeout + , cancelTimeout + , awaitTimeout -- * Deprecated interfaces , SimM , SimSTM @@ -90,7 +94,6 @@ import Control.Exception (throw) import Control.Monad.ST.Lazy import Control.Monad.Class.MonadThrow as MonadThrow -import Control.Monad.Class.MonadTime import Control.Monad.IOSim.Internal import Control.Monad.IOSim.Types diff --git a/io-sim/src/Control/Monad/IOSim/Internal.hs b/io-sim/src/Control/Monad/IOSim/Internal.hs index 52145bbb..bcc3f31b 100644 --- a/io-sim/src/Control/Monad/IOSim/Internal.hs +++ b/io-sim/src/Control/Monad/IOSim/Internal.hs @@ -79,7 +79,7 @@ import Control.Monad.Class.MonadSTM hiding (STM) import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar)) import Control.Monad.Class.MonadThrow hiding (getMaskingState) import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI (TimeoutState (..)) import Control.Monad.IOSim.InternalTypes import Control.Monad.IOSim.Types hiding (SimEvent (SimPOREvent), @@ -480,33 +480,6 @@ schedule !thread@Thread{ , nextTmid = succ nextTmid } return (SimTrace time tid tlbl (EventTimerCreated nextTmid nextVid expiry) trace) - -- we do not follow `GHC.Event` behaviour here; updating a timer to the past - -- effectively cancels it. - UpdateTimeout (Timeout _tvar tmid) d k | d < 0 -> - {-# SCC "schedule.UpdateTimeout" #-} do - let !timers' = PSQ.delete tmid timers - !thread' = thread { threadControl = ThreadControl k ctl } - trace <- schedule thread' simstate { timers = timers' } - return (SimTrace time tid tlbl (EventTimerCancelled tmid) trace) - - UpdateTimeout (Timeout _tvar tmid) d k -> - {-# SCC "schedule.UpdateTimeout" #-} do - -- updating an expired timeout is a noop, so it is safe - -- to race using a timeout with updating or cancelling it - let updateTimeout_ Nothing = ((), Nothing) - updateTimeout_ (Just (_p, v)) = ((), Just (expiry, v)) - !expiry = d `addTime` time - !timers' = snd (PSQ.alter updateTimeout_ tmid timers) - !thread' = thread { threadControl = ThreadControl k ctl } - trace <- schedule thread' simstate { timers = timers' } - return (SimTrace time tid tlbl (EventTimerUpdated tmid expiry) trace) - - -- updating a negative timer is a no-op, unlike in `GHC.Event`. - UpdateTimeout (NegativeTimeout _tmid) _d k -> - {-# SCC "schedule.UpdateTimeout" #-} do - let thread' = thread { threadControl = ThreadControl k ctl } - schedule thread' simstate - CancelTimeout (Timeout tvar tmid) k -> {-# SCC "schedule.CancelTimeout" #-} do let !timers' = PSQ.delete tmid timers diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs index ac093802..dc2ebecb 100644 --- a/io-sim/src/Control/Monad/IOSim/Types.hs +++ b/io-sim/src/Control/Monad/IOSim/Types.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTSyntax #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-partial-fields #-} @@ -29,7 +30,6 @@ module Control.Monad.IOSim.Types , StmTxResult (..) , BranchStmA (..) , StmStack (..) - , Timeout (..) , TimeoutException (..) , setCurrentTime , unshareClock @@ -59,6 +59,15 @@ module Control.Monad.IOSim.Types , SimM , SimSTM , Thrower (..) + , Time (..) + , addTime + , diffTime + -- * Internal API + , Timeout (..) + , newTimeout + , readTimeout + , cancelTimeout + , awaitTimeout ) where import Control.Applicative @@ -77,7 +86,7 @@ import Control.Monad.Class.MonadST import Control.Monad.Class.MonadSTM.Internal (MonadInspectSTM (..), MonadLabelledSTM (..), MonadSTM, MonadTraceSTM (..), TArrayDefault, TChanDefault, TMVarDefault, TSemDefault, - TraceValue) + TraceValue, atomically, retry) import qualified Control.Monad.Class.MonadSTM.Internal as MonadSTM import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadTest @@ -85,7 +94,10 @@ import Control.Monad.Class.MonadThrow as MonadThrow hiding (getMaskingState) import qualified Control.Monad.Class.MonadThrow as MonadThrow import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI (TimeoutState (..)) +import qualified Control.Monad.Class.MonadTimer.SI as SI import Control.Monad.ST.Lazy import qualified Control.Monad.ST.Strict as StrictST @@ -101,7 +113,9 @@ import Data.Maybe (fromMaybe) import Data.Monoid (Endo (..)) import Data.STRef.Lazy import Data.Semigroup (Max (..)) +import Data.Time.Clock (diffTimeToPicoseconds) import Data.Typeable +import Data.Word (Word64) import qualified Debug.Trace as Debug import Text.Printf @@ -150,14 +164,11 @@ data SimA s a where StartTimeout :: DiffTime -> SimA s a -> (Maybe a -> SimA s b) -> SimA s b UnregisterTimeout :: TimeoutId -> SimA s a -> SimA s a + RegisterDelay :: DiffTime -> (TVar s Bool -> SimA s b) -> SimA s b + ThreadDelay :: DiffTime -> SimA s b -> SimA s b - RegisterDelay :: DiffTime -> (TVar s Bool -> SimA s b) -> SimA s b - - ThreadDelay :: DiffTime -> SimA s b -> SimA s b - - NewTimeout :: DiffTime -> (Timeout (IOSim s) -> SimA s b) -> SimA s b - UpdateTimeout :: Timeout (IOSim s) -> DiffTime -> SimA s b -> SimA s b - CancelTimeout :: Timeout (IOSim s) -> SimA s b -> SimA s b + NewTimeout :: DiffTime -> (Timeout s -> SimA s b) -> SimA s b + CancelTimeout :: Timeout s -> SimA s b -> SimA s b Throw :: Thrower -> SomeException -> SimA s a Catch :: Exception e => @@ -555,6 +566,13 @@ instance MonadST (IOSim s) where liftST :: StrictST.ST s a -> IOSim s a liftST action = IOSim $ oneShot $ \k -> LiftST action k +instance MonadMonotonicTimeNSec (IOSim s) where + getMonotonicTimeNSec = IOSim $ oneShot $ \k -> GetMonoTime (k . conv) + where + -- convert time in picoseconds to nanoseconds + conv :: Time -> Word64 + conv (Time d) = fromIntegral (diffTimeToPicoseconds d `div` 1_000) + instance MonadMonotonicTime (IOSim s) where getMonotonicTime = IOSim $ oneShot $ \k -> GetMonoTime k @@ -576,27 +594,58 @@ unshareClock = IOSim $ oneShot $ \k -> UnshareClock (k ()) instance MonadDelay (IOSim s) where -- Use optimized IOSim primitive - threadDelay d = IOSim $ oneShot $ \k -> ThreadDelay d (k ()) + threadDelay d = + IOSim $ oneShot $ \k -> ThreadDelay (SI.microsecondsAsIntToDiffTime d) + (k ()) -instance MonadTimer (IOSim s) where - data Timeout (IOSim s) = Timeout !(TVar s TimeoutState) !TimeoutId - -- ^ a timeout - | NegativeTimeout !TimeoutId - -- ^ a negative timeout +instance SI.MonadDelay (IOSim s) where + threadDelay d = + IOSim $ oneShot $ \k -> ThreadDelay d (k ()) + +data Timeout s = Timeout !(TVar s TimeoutState) !TimeoutId + -- ^ a timeout + | NegativeTimeout !TimeoutId + -- ^ a negative timeout + +newTimeout :: DiffTime -> IOSim s (Timeout s) +newTimeout d = IOSim $ oneShot $ \k -> NewTimeout d k - readTimeout (Timeout var _key) = MonadSTM.readTVar var - readTimeout (NegativeTimeout _key) = pure TimeoutCancelled +readTimeout :: Timeout s -> STM s TimeoutState +readTimeout (Timeout var _key) = MonadSTM.readTVar var +readTimeout (NegativeTimeout _key) = pure TimeoutCancelled - newTimeout d = IOSim $ oneShot $ \k -> NewTimeout d k - updateTimeout t d = IOSim $ oneShot $ \k -> UpdateTimeout t d (k ()) - cancelTimeout t = IOSim $ oneShot $ \k -> CancelTimeout t (k ()) +cancelTimeout :: Timeout s -> IOSim s () +cancelTimeout t = IOSim $ oneShot $ \k -> CancelTimeout t (k ()) + +awaitTimeout :: Timeout s -> STM s Bool +awaitTimeout t = do s <- readTimeout t + case s of + TimeoutPending -> retry + TimeoutFired -> return True + TimeoutCancelled -> return False + +instance MonadTimer (IOSim s) where + timeout d action + | d < 0 = Just <$> action + | d == 0 = return Nothing + | otherwise = IOSim $ oneShot $ \k -> StartTimeout d' (runIOSim action) k + where + d' = SI.microsecondsAsIntToDiffTime d + + registerDelay d = IOSim $ oneShot $ \k -> RegisterDelay d' k + where + d' = SI.microsecondsAsIntToDiffTime d +instance SI.MonadTimer (IOSim s) where timeout d action | d < 0 = Just <$> action | d == 0 = return Nothing | otherwise = IOSim $ oneShot $ \k -> StartTimeout d (runIOSim action) k registerDelay d = IOSim $ oneShot $ \k -> RegisterDelay d k + registerDelayCancellable d = do + t <- newTimeout d + return (readTimeout t, cancelTimeout t) newtype TimeoutException = TimeoutException TimeoutId deriving Eq diff --git a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs index 400e7641..2ebc4b64 100644 --- a/io-sim/src/Control/Monad/IOSimPOR/Internal.hs +++ b/io-sim/src/Control/Monad/IOSimPOR/Internal.hs @@ -77,7 +77,7 @@ import Control.Monad.Class.MonadSTM hiding (STM) import Control.Monad.Class.MonadSTM.Internal (TMVarDefault (TMVar)) import Control.Monad.Class.MonadThrow as MonadThrow import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI (TimeoutState (..)) import Control.Monad.IOSim.InternalTypes import Control.Monad.IOSim.Types hiding (SimEvent (SimEvent), @@ -582,30 +582,6 @@ schedule thread@Thread{ , nextTmid = succ nextTmid } return (SimPORTrace time tid tstep tlbl (EventTimerCreated nextTmid nextVid expiry) trace) - -- we do not follow `GHC.Event` behaviour here; updating a timer to the past - -- effectively cancels it. - UpdateTimeout (Timeout _tvar tmid) d k | d < 0 -> do - let timers' = PSQ.delete tmid timers - thread' = thread { threadControl = ThreadControl k ctl } - trace <- schedule thread' simstate { timers = timers' } - return (SimPORTrace time tid tstep tlbl (EventTimerCancelled tmid) trace) - - UpdateTimeout (Timeout _tvar tmid) d k -> do - -- updating an expired timeout is a noop, so it is safe - -- to race using a timeout with updating or cancelling it - let updateTimeout_ Nothing = ((), Nothing) - updateTimeout_ (Just (_p, v)) = ((), Just (expiry, v)) - expiry = d `addTime` time - timers' = snd (PSQ.alter updateTimeout_ tmid timers) - thread' = thread { threadControl = ThreadControl k ctl } - trace <- schedule thread' simstate { timers = timers' } - return (SimPORTrace time tid tstep tlbl (EventTimerUpdated tmid expiry) trace) - - -- updating a negative timer is a no-op, unlike in `GHC.Event`. - UpdateTimeout (NegativeTimeout _tmid) _d k -> do - let thread' = thread { threadControl = ThreadControl k ctl } - schedule thread' simstate - CancelTimeout (Timeout tvar tmid) k -> do let timers' = PSQ.delete tmid timers written <- execAtomically' (runSTM $ writeTVar tvar TimeoutCancelled) diff --git a/io-sim/test/Test/Control/Monad/Class/MonadMVar.hs b/io-sim/test/Test/Control/Monad/Class/MonadMVar.hs index 179133ac..708b2301 100644 --- a/io-sim/test/Test/Control/Monad/Class/MonadMVar.hs +++ b/io-sim/test/Test/Control/Monad/Class/MonadMVar.hs @@ -8,8 +8,8 @@ module Test.Control.Monad.Class.MonadMVar where import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadMVar -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Data.Bifoldable (bifoldMap) import Data.Foldable (traverse_) import Data.Functor (void, ($>)) @@ -105,7 +105,6 @@ unit_putMVar_blocks_on_full :: ( MonadFork m , MonadDelay m , MonadMVar m - , MonadMonotonicTime m ) => m Bool unit_putMVar_blocks_on_full = do @@ -162,7 +161,6 @@ unit_takeMVar_blocks_on_empty :: ( MonadFork m , MonadDelay m , MonadMVar m - , MonadMonotonicTime m ) => m Bool unit_takeMVar_blocks_on_empty = do diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index f6029f46..0a8a7308 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/io-sim/test/Test/Control/Monad/IOSim.hs @@ -39,8 +39,8 @@ import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim import Test.Control.Monad.Utils @@ -216,13 +216,25 @@ tests = , testProperty "thread status mask blocked (IO)" $ withMaxSuccess 1 $ ioProperty prop_thread_status_mask_blocked ] + , testGroup "MonadTimerCancellable" + [ testProperty "registerDelayCancellable (IOSim impl)" + (prop_registerDelayCancellable registerDelayCancellable) + , testProperty "registerDelayCancellable (IO impl)" + (prop_registerDelayCancellable $ + defaultRegisterDelayCancellable + (newTimeout . microsecondsAsIntToDiffTime) + readTimeout + cancelTimeout + awaitTimeout + ) + ] ] -- -- threadStatus -- -prop_two_threads_expect :: (MonadFork m, MonadThread m) +prop_two_threads_expect :: MonadFork m => m () -> (ThreadId m -> m ()) -> (ThreadStatus -> Property) @@ -233,7 +245,7 @@ prop_two_threads_expect target main prop = do status <- threadStatus tid return $ prop status -prop_two_threads_expect_ :: (MonadFork m, MonadThread m) +prop_two_threads_expect_ :: MonadFork m => m () -> (ThreadStatus -> Property) -> m Property @@ -242,21 +254,19 @@ prop_two_threads_expect_ target prop = (const $ yield) prop -prop_thread_status_finished :: (MonadFork m, MonadDelay m, MonadThread m) +prop_thread_status_finished :: MonadFork m => m Property prop_thread_status_finished = prop_two_threads_expect_ (pure ()) (ThreadFinished ===) -prop_thread_status_running :: (MonadFork m, MonadDelay m, MonadThread m) +prop_thread_status_running :: MonadFork m => m Property prop_thread_status_running = prop_two_threads_expect_ (forever yield) (ThreadRunning ===) prop_thread_status_blocked :: ( MonadFork m - , MonadDelay m - , MonadThread m , MonadSTM m ) => m Property @@ -270,7 +280,9 @@ prop_thread_status_blocked = do counterexample (show status ++ " /= ThreadBlocked _") False -prop_thread_status_blocked_delay :: (MonadFork m, MonadDelay m, MonadThread m) +prop_thread_status_blocked_delay :: ( MonadFork m + , MonadDelay m + ) => m Property prop_thread_status_blocked_delay = prop_two_threads_expect_ @@ -281,11 +293,7 @@ prop_thread_status_blocked_delay = counterexample (show status ++ " /= ThreadBlocked _") False -prop_thread_status_died :: ( MonadFork m - , MonadThrow m - , MonadDelay m - , MonadThread m - ) +prop_thread_status_died :: MonadFork m => m Property prop_thread_status_died = prop_two_threads_expect (forever yield) @@ -294,8 +302,6 @@ prop_thread_status_died = prop_thread_status_died_own :: ( MonadFork m , MonadThrow m - , MonadDelay m - , MonadThread m ) => m Property prop_thread_status_died_own = do @@ -303,9 +309,6 @@ prop_thread_status_died_own = do (ThreadFinished ===) prop_thread_status_yield :: ( MonadFork m - , MonadThrow m - , MonadDelay m - , MonadThread m , MonadSTM m ) => m Property @@ -317,9 +320,6 @@ prop_thread_status_yield = do (ThreadRunning ===) prop_thread_status_mask :: ( MonadFork m - , MonadThrow m - , MonadDelay m - , MonadThread m , MonadSTM m , MonadMask m ) @@ -334,8 +334,6 @@ prop_thread_status_mask = do (ThreadFinished ===) prop_thread_status_mask_blocked :: ( MonadFork m - , MonadThrow m - , MonadThread m , MonadMask m ) => m Property @@ -429,9 +427,7 @@ prop_mfix_purity_2 as = as' = getPositive `map` as -- recursive sum using 'threadDelay' - recDelay :: ( MonadMonotonicTime m - , MonadDelay m - ) + recDelay :: MonadDelay m => ([Int] -> m Time) -> [Int] -> m Time recDelay = \rec_ bs -> @@ -505,10 +501,8 @@ prop_mfix_lazy (NonEmpty env) = replicateHeadM :: ( #if MIN_VERSION_base(4,13,0) - MonadFail m, - MonadFail (STM m), + MonadFail m #endif - MonadSTM m ) => m Char -> [Char] -> m [Char] @@ -1038,6 +1032,7 @@ type TimeoutDuration = DiffTime type ActionDuration = DiffTime type TimeoutConstraints m = ( MonadAsync m + , MonadDelay m , MonadFork m , MonadTime m , MonadTimer m @@ -1423,6 +1418,84 @@ unit_catch_throwTo_masking_state_async_mayblock_ST :: MaskingState -> Property unit_catch_throwTo_masking_state_async_mayblock_ST ms = runSimOrThrow (prop_catch_throwTo_masking_state_async_mayblock ms) +-- +-- MonadTimerCancellable +-- + +data DelayWithCancel = DelayWithCancel DiffTime (Maybe DiffTime) + deriving Show + +instance Arbitrary DelayWithCancel where + arbitrary = + oneof + [ -- small delay + (\delay -> DelayWithCancel + (microsecondsAsIntToDiffTime delay) + Nothing) + <$> arbitrary + -- cancelled delay after small delay + , (\delay -> DelayWithCancel + (microsecondsAsIntToDiffTime delay + maxDelay) + Nothing) + <$> arbitrary + + , -- large delay + do delay <- arbitrary + cancel_ <- arbitrary `suchThat` (<= delay) + return (DelayWithCancel (microsecondsAsIntToDiffTime delay) + (Just (microsecondsAsIntToDiffTime cancel_))) + , -- cancelled delay after large delay + do delay <- arbitrary + cancel_ <- arbitrary `suchThat` (<= delay) + return (DelayWithCancel (microsecondsAsIntToDiffTime delay + maxDelay) + (Just (microsecondsAsIntToDiffTime cancel_ + maxDelay))) + ] + where + maxDelay :: DiffTime + maxDelay = microsecondsAsIntToDiffTime maxBound + +prop_registerDelayCancellable + :: (forall s. DiffTime -> IOSim s (STM (IOSim s) TimeoutState, IOSim s ())) + -- ^ implementation + -> DelayWithCancel + -> Property +prop_registerDelayCancellable registerDelayCancellableImpl + (DelayWithCancel delay mbCancel) = + -- 'within' covers the case where `registerDelayCancellable` would not + -- make progress awaiting for the timeout (a live lock). + within 1000 $ + let trace = runSimTrace sim + in case traceResult True trace of + Left err -> counterexample (ppTrace trace) + . counterexample (show err) + $ False + Right (_, r) -> counterexample (ppTrace trace) r + where + sim :: IOSim s (Maybe TimeoutState, Bool) + sim = do + (readTimeout_, cancelTimeout_) <- registerDelayCancellableImpl delay + case mbCancel of + + Nothing -> do + atomically $ do + tv <- readTimeout_ + case tv of + TimeoutFired -> return () + TimeoutPending -> retry + TimeoutCancelled -> return () + t <- getMonotonicTime + return (Nothing, t == Time (delay `max` 0)) + + Just cancelDelay -> do + threadDelay cancelDelay + cancelTimeout_ + tv <- atomically readTimeout_ + return $ case () of + _ | delay < cancelDelay -> (Just tv, tv == TimeoutFired) + | delay == cancelDelay -> (Just tv, tv == TimeoutFired + || tv == TimeoutCancelled) + | otherwise -> (Just tv, tv == TimeoutCancelled) + -- -- Utils -- diff --git a/io-sim/test/Test/Control/Monad/IOSimPOR.hs b/io-sim/test/Test/Control/Monad/IOSimPOR.hs index 50906bf0..22a1307b 100644 --- a/io-sim/test/Test/Control/Monad/IOSimPOR.hs +++ b/io-sim/test/Test/Control/Monad/IOSimPOR.hs @@ -11,9 +11,10 @@ module Test.Control.Monad.IOSimPOR (tests) where import Data.Fixed (Micro) +import Data.Foldable (foldl') import Data.Functor (($>)) import Data.IORef -import Data.List +import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map @@ -31,8 +32,8 @@ import Control.Concurrent.Class.MonadSTM import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadTest import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim import GHC.Generics @@ -137,7 +138,6 @@ data Step = data TimeoutStep = NewTimeout Int - | UpdateTimeout Int | CancelTimeout | AwaitTimeout deriving (Eq, Ord, Show, Generic) @@ -165,7 +165,6 @@ instance Arbitrary TimeoutStep where arbitrary = do Positive i <- arbitrary frequency $ map (fmap return) $ [(3,NewTimeout i), - (1,UpdateTimeout i), (1,CancelTimeout), (3,AwaitTimeout)] @@ -185,7 +184,7 @@ instance Arbitrary Task where normalize :: [Step] -> [Step] normalize steps = plug steps wsSteps 1000000 - where wsSteps = reverse $ sort [s | s@(WhenSet _ _) <- steps] + where wsSteps = reverse $ List.sort [s | s@(WhenSet _ _) <- steps] plug [] [] _ = [] plug (WhenSet _ _:s) (WhenSet a b:ws) m = WhenSet (min a m) (min b m):plug s ws (min b m) plug (step:s) ws m = step:plug s ws m @@ -217,7 +216,7 @@ shrinkDelays tasks | null times = [] | otherwise = [map (Task . removeTime d) [steps | Task steps <- tasks] | d <- times] - where times = foldr union [] [scanl1 (+) [d | Delay d <- t] | Task t <- tasks] + where times = foldr List.union [] [scanl1 (+) [d | Delay d <- t] | Task t <- tasks] removeTime 0 steps = steps removeTime _ [] = [] removeTime d (Delay d':steps) @@ -283,7 +282,6 @@ interpret r t (Task steps) = forkIO $ do case (timerVal,tstep) of (_,NewTimeout n) -> do tout <- newTimeout (fromIntegral n) atomically $ writeTVar timer (Just tout) - (Just tout,UpdateTimeout n) -> updateTimeout tout (fromIntegral n) (Just tout,CancelTimeout) -> cancelTimeout tout (Just tout,AwaitTimeout) -> atomically $ awaitTimeout tout >> return () (Nothing,_) -> return () @@ -461,9 +459,7 @@ prop_mfix_purity_2 as = as' = getPositive `map` as -- recursive sum using 'threadDelay' - recDelay :: ( MonadMonotonicTime m - , MonadDelay m - ) + recDelay :: MonadDelay m => ([Int] -> m Time) -> [Int] -> m Time recDelay = \rec_ bs -> @@ -515,14 +511,7 @@ prop_mfix_lazy (NonEmpty env) = samples :: Int samples = 10 - replicateHeadM :: - ( - - MonadFail m, - MonadFail (STM m), - - MonadSTM m - ) + replicateHeadM :: MonadFail m => m Char -> String -> m String replicateHeadM getChar_ as = do @@ -567,7 +556,7 @@ unit_catch_0, unit_catch_1, unit_catch_2, unit_catch_3, unit_catch_4, -- unhandled top level exception unit_catch_0 = exploreSimTrace id example $ \_ trace -> - counterexample (intercalate "\n" $ map show $ traceEvents trace) $ + counterexample (List.intercalate "\n" $ map show $ traceEvents trace) $ counterexample (show $ selectTraceSay trace) $ selectTraceSay trace === ["before"] .&&. diff --git a/io-sim/test/Test/Control/Monad/Utils.hs b/io-sim/test/Test/Control/Monad/Utils.hs index b92d9dac..7beabb10 100644 --- a/io-sim/test/Test/Control/Monad/Utils.hs +++ b/io-sim/test/Test/Control/Monad/Utils.hs @@ -16,8 +16,7 @@ import Control.Monad import Control.Monad.Class.MonadFork import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim import Test.Control.Monad.STM @@ -123,8 +122,8 @@ instance Arbitrary TestMicro where shrink (TestMicro rs) = [ TestMicro rs' | rs' <- shrinkList (const []) rs ] test_timers :: forall m. - ( MonadFork m - , MonadSTM m + ( MonadDelay m + , MonadFork m , MonadTimer m ) => [DiffTime] @@ -175,8 +174,7 @@ test_timers xs = -- test_fork_order :: forall m. - ( MonadFork m - , MonadSTM m + ( MonadFork m , MonadTimer m ) => Positive Int @@ -200,12 +198,11 @@ test_fork_order = \(Positive n) -> isValid n <$> withProbe (experiment n) isValid n tr = tr === [n,n-1..1] test_threadId_order :: forall m. - ( MonadFork m - , MonadSTM m - , MonadTimer m - ) - => Positive Int - -> m Property + ( MonadFork m + , MonadTimer m + ) + => Positive Int + -> m Property test_threadId_order = \(Positive n) -> do isValid n <$> (forM [1..n] (const experiment)) where @@ -229,8 +226,8 @@ test_threadId_order = \(Positive n) -> do --prop_wakeup_order_IO = ioProperty test_wakeup_order -test_wakeup_order :: ( MonadFork m - , MonadSTM m +test_wakeup_order :: ( MonadDelay m + , MonadFork m , MonadTimer m ) => m Property @@ -280,7 +277,10 @@ probeOutput probe x = atomically (modifyTVar probe (x:)) -- | Compare the behaviour of the STM reference operational semantics with -- the behaviour of any 'MonadSTM' STM implementation. -- -prop_stm_referenceM :: (MonadSTM m, MonadThrow (STM m), MonadCatch (STM m), MonadCatch m) +prop_stm_referenceM :: ( MonadSTM m + , MonadCatch (STM m) + , MonadCatch m + ) => SomeTerm -> m Property prop_stm_referenceM (SomeTerm _tyrep t) = do let (r1, _heap) = evalAtomically t @@ -290,7 +290,12 @@ prop_stm_referenceM (SomeTerm _tyrep t) = do -- | Check that 'timeout' does not deadlock when executed with asynchronous -- exceptions uninterruptibly masked. -- -prop_timeout_no_deadlockM :: forall m. ( MonadFork m, MonadSTM m, MonadTimer m, MonadMask m ) +prop_timeout_no_deadlockM :: forall m. + ( MonadDelay m + , MonadFork m + , MonadTimer m + , MonadMask m + ) => m Bool prop_timeout_no_deadlockM = do v <- registerDelay' 0.01 diff --git a/scripts/check-stylish.sh b/scripts/check-stylish.sh index 3e919497..b3739352 100755 --- a/scripts/check-stylish.sh +++ b/scripts/check-stylish.sh @@ -9,3 +9,4 @@ $FD -E Setup.hs -g '*.hsc?$' io-sim -X stylish-haskell -c .stylish-haskell.yaml $FD -E Setup.hs -E src/Control/Concurrent/Class/MonadSTM.hs -g '*.hsc?$' io-classes -X stylish-haskell -c .stylish-haskell.yaml -i $FD -E Setup.hs -g '*.hsc?$' strict-mvar -X stylish-haskell -c .stylish-haskell.yaml -i $FD -E Setup.hs -g '*.hsc?$' strict-stm -X stylish-haskell -c .stylish-haskell.yaml -i +$FD -E Setup.hs -g '*.hsc?$' si-timers -X stylish-haskell -c .stylish-haskell.yaml -i diff --git a/si-timers/CHANGELOG.md b/si-timers/CHANGELOG.md new file mode 100644 index 00000000..cefddb91 --- /dev/null +++ b/si-timers/CHANGELOG.md @@ -0,0 +1,6 @@ +# Changelog + +## 0.6.0.0 + +* initial version + diff --git a/si-timers/LICENSE b/si-timers/LICENSE new file mode 100644 index 00000000..f433b1a5 --- /dev/null +++ b/si-timers/LICENSE @@ -0,0 +1,177 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS diff --git a/si-timers/NOTICE b/si-timers/NOTICE new file mode 100644 index 00000000..3a29844a --- /dev/null +++ b/si-timers/NOTICE @@ -0,0 +1,14 @@ +Copyright 2019-2020 Input Output (Hong Kong) Ltd. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. + diff --git a/si-timers/si-timers.cabal b/si-timers/si-timers.cabal new file mode 100644 index 00000000..fe8091d8 --- /dev/null +++ b/si-timers/si-timers.cabal @@ -0,0 +1,83 @@ +cabal-version: 3.4 +name: si-timers +version: 0.6.0.0 +synopsis: Timers using SI units (seconds) which are safe on 32-bit + platforms. +-- description: +license: Apache-2.0 +license-files: + LICENSE + NOTICE +copyright: 2022-2023 Input Output Global Inc (IOG) +author: Duncan Coutts, Marcin Szamotulski, Neil Davis +maintainer: Marcin Szamotulski +category: Control +build-type: Simple +tested-with: GHC == 8.10.7, GHC == 9.2.5, GHC == 9.4.3 + +flag asserts + description: Enable assertions + manual: False + default: False + +source-repository head + type: git + location: https://github.com/input-output-hk/ouroboros-network + subdir: io-sim + +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wno-unticked-promoted-constructors + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + +library + import: warnings + hs-source-dirs: src + exposed-modules: Control.Monad.Class.MonadTime.SI + Control.Monad.Class.MonadTimer.SI + other-modules: Control.Monad.Class.MonadTimer.NonStandard + default-language: Haskell2010 + other-extensions: BangPatterns, + CPP, + ConstraintKinds, + ExistentialQuantification, + FlexibleInstances, + GADTSyntax, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + NamedFieldPuns, + RankNTypes, + ScopedTypeVariables, + TypeFamilies + build-depends: base >=4.9 && <4.18, + mtl, + stm, + time >=1.9.1 && <1.13, + + io-classes ^>=0.6 + if flag(asserts) + ghc-options: -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 + import: warnings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: Test.MonadTimer + default-language: Haskell2010 + build-depends: base, + + QuickCheck, + tasty, + tasty-quickcheck, + + si-timers 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 index 00000000..c2febc80 --- /dev/null +++ b/si-timers/src/Control/Monad/Class/MonadTime/SI.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# 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.Monad.Reader + +import Control.Monad.Class.MonadTime ( MonadMonotonicTimeNSec, + MonadTime (..), NominalDiffTime, UTCTime, diffUTCTime, + addUTCTime) +import qualified Control.Monad.Class.MonadTime as MonadTime + +import Data.Word (Word64) +import Data.Time.Clock (DiffTime) +import qualified Data.Time.Clock as Time +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 (Eq, Ord, Show, Generic) + +-- | 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 index 00000000..c3562d63 --- /dev/null +++ b/si-timers/src/Control/Monad/Class/MonadTimer/NonStandard.hs @@ -0,0 +1,162 @@ +{-# 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. +-- +-- We use it to provide 'MonadTimer IO' instance and to implement a cancellable +-- timer, see 'registerDelayCancellable' below. +-- +-- You can expect we will deprecate it at some point (e.g. once GHC gets +-- a better support for timers especially across different OSes). +-- +module Control.Monad.Class.MonadTimer.NonStandard + ( TimeoutState (..) + , newTimeout + , readTimeout + , cancelTimeout + , awaitTimeout + , NewTimeout + , ReadTimeout + , CancelTimeout + , AwaitTimeout + ) where + +import qualified Control.Concurrent.STM as STM +#ifndef GHC_TIMERS_API +import Control.Monad (when) +#endif +import Control.Monad.Class.MonadSTM + +#ifdef GHC_TIMERS_API +import qualified GHC.Event as GHC (TimeoutKey, getSystemTimerManager, + registerTimeout, unregisterTimeout) +#else +import qualified GHC.Conc.IO 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. +-- +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 index 00000000..1741255e --- /dev/null +++ b/si-timers/src/Control/Monad/Class/MonadTimer/SI.hs @@ -0,0 +1,262 @@ +{-# 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 qualified Control.Monad.Class.MonadTimer as MonadTimer +import Control.Monad.Class.MonadTimer.NonStandard (TimeoutState (..)) +import qualified Control.Monad.Class.MonadTimer.NonStandard 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. +diffTimeToMicrosecondsAsInt :: DiffTime -> Int +diffTimeToMicrosecondsAsInt d = + let usec :: Integer + usec = diffTimeToPicoseconds d `div` 1_000_000 in + assert (usec <= fromIntegral (maxBound :: 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. When the delay is smaller than what `Int` can represent it +-- will use the `Control.Monad.Class.MonadTimer.threadDelay` (e.g. for the `IO` +-- monad it will use `Control.Concurrent.threadDelay`); otherwise it will +-- recursively call `Control.Monad.Class.MonadTimer.threadDelay`. +-- +instance MonadDelay IO where + threadDelay :: forall m. + MonadDelay m + => DiffTime -> m () + 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/io-classes/test/Main.hs b/si-timers/test/Main.hs similarity index 100% rename from io-classes/test/Main.hs rename to si-timers/test/Main.hs diff --git a/io-classes/test/Test/MonadTimer.hs b/si-timers/test/Test/MonadTimer.hs similarity index 95% rename from io-classes/test/Test/MonadTimer.hs rename to si-timers/test/Test/MonadTimer.hs index f29dff5f..c65e3a27 100644 --- a/io-classes/test/Test/MonadTimer.hs +++ b/si-timers/test/Test/MonadTimer.hs @@ -3,12 +3,10 @@ module Test.MonadTimer (tests) where -import Control.Monad.Class.MonadTime (DiffTime) -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import GHC.Real import Test.QuickCheck -import Test.QuickCheck.Gen import Test.Tasty import Test.Tasty.QuickCheck (testProperty)