diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/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 well tested, and some of it hasn't run +in a 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 +transformer 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.cabal b/io-classes-mtl.cabal new file mode 100644 --- /dev/null +++ b/io-classes-mtl.cabal @@ -0,0 +1,53 @@ +cabal-version: 3.0 +name: io-classes-mtl +version: 0.1.0.0 +synopsis: Experimental MTL instances for io-classes +description: + MTL instances for + [io-classes](https://hackage.hasekll.org/package/io-classes) package. + Some of the instances are novel and some are still experimental. +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 ^>= 1.0.0.0, + si-timers, + + + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Control/Monad/Class/MonadEventlog/Trans.hs b/src/Control/Monad/Class/MonadEventlog/Trans.hs new file mode 100644 --- /dev/null +++ b/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/src/Control/Monad/Class/MonadST/Trans.hs b/src/Control/Monad/Class/MonadST/Trans.hs new file mode 100644 --- /dev/null +++ b/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/src/Control/Monad/Class/MonadSTM/Trans.hs b/src/Control/Monad/Class/MonadSTM/Trans.hs new file mode 100644 --- /dev/null +++ b/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/src/Control/Monad/Class/MonadSay/Trans.hs b/src/Control/Monad/Class/MonadSay/Trans.hs new file mode 100644 --- /dev/null +++ b/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/src/Control/Monad/Class/MonadThrow/Trans.hs b/src/Control/Monad/Class/MonadThrow/Trans.hs new file mode 100644 --- /dev/null +++ b/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/src/Control/Monad/Class/MonadTime/SI/Trans.hs b/src/Control/Monad/Class/MonadTime/SI/Trans.hs new file mode 100644 --- /dev/null +++ b/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/src/Control/Monad/Class/MonadTime/Trans.hs b/src/Control/Monad/Class/MonadTime/Trans.hs new file mode 100644 --- /dev/null +++ b/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/src/Control/Monad/Class/MonadTimer/SI/Trans.hs b/src/Control/Monad/Class/MonadTimer/SI/Trans.hs new file mode 100644 --- /dev/null +++ b/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/src/Control/Monad/Class/MonadTimer/Trans.hs b/src/Control/Monad/Class/MonadTimer/Trans.hs new file mode 100644 --- /dev/null +++ b/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/src/Control/Monad/Class/Trans.hs b/src/Control/Monad/Class/Trans.hs new file mode 100644 --- /dev/null +++ b/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 ()