diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown index c99a153966a455fc28bc05530dc4d8d6383d83a3..1fd3dcf9a7b86bfc82a28eeb278dc1db829f00ee 100644 --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,7 @@ +next [????.??.??] +----------------- +* Allow building with `transformers-0.6.*` and `mtl-2.3.*`. + 0.10.4 [2019.12.26] ------------------- * Allow building with `template-haskell-2.16.*`. diff --git a/exceptions.cabal b/exceptions.cabal index c8028f2d302b7f267370e8bf5bb61786cf1ba8b2..6af81ceaff0949753f2b61632f5d0fb339164247 100644 --- a/exceptions.cabal +++ b/exceptions.cabal @@ -49,14 +49,14 @@ library base >= 4.3 && < 5, stm >= 2.2 && < 3, template-haskell >= 2.2 && < 2.19, - mtl >= 2.0 && < 2.3 + mtl >= 2.0 && < 2.4 if !impl(ghc >= 8.0) build-depends: fail == 4.9.* if flag(transformers-0-4) build-depends: - transformers >= 0.4 && < 0.6 + transformers >= 0.4 && < 0.7 else build-depends: transformers >= 0.2 && < 0.4, @@ -90,7 +90,7 @@ test-suite exceptions-tests if flag(transformers-0-4) build-depends: - transformers >= 0.4 && < 0.6 + transformers >= 0.4 && < 0.7 else build-depends: transformers >= 0.2 && < 0.4, diff --git a/src/Control/Monad/Catch.hs b/src/Control/Monad/Catch.hs index 148b3416cac73ce35101003f98055629473ce6d1..ab19a0b4c9805e51ba3c9c95594299c137cbc948 100644 --- a/src/Control/Monad/Catch.hs +++ b/src/Control/Monad/Catch.hs @@ -15,11 +15,9 @@ #define MIN_VERSION_transformers(x,y,z) 1 #endif -#ifndef MIN_VERSION_mtl -#define MIN_VERSION_mtl(x,y,z) 1 -#endif - +#if !(MIN_VERSION_transformers(0,6,0)) {-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif -------------------------------------------------------------------- -- | -- Copyright : (C) Edward Kmett 2013-2015, (c) Google Inc. 2012 @@ -79,6 +77,7 @@ module Control.Monad.Catch ( import Control.Exception (Exception(..), SomeException(..)) import qualified Control.Exception as ControlException +import Control.Monad (liftM) import qualified Control.Monad.STM as STM import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS import qualified Control.Monad.Trans.RWS.Strict as StrictRWS @@ -88,13 +87,12 @@ import qualified Control.Monad.Trans.Writer.Lazy as LazyW import qualified Control.Monad.Trans.Writer.Strict as StrictW import Control.Monad.ST (ST) import Control.Monad.STM (STM) -import Control.Monad.Trans.List (ListT(..), runListT) +import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) -import Control.Monad.Trans.Error (ErrorT(..), Error, runErrorT) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.Trans.Cont (ContT) import Control.Monad.Trans.Identity -import Control.Monad.Reader as Reader +import Control.Monad.Trans.Reader (ReaderT(..), runReaderT) import Language.Haskell.TH.Syntax (Q) @@ -118,6 +116,11 @@ import Data.Monoid import Control.Applicative #endif +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Trans.Error (ErrorT(..), Error, runErrorT) +import Control.Monad.Trans.List (ListT(..), runListT) +#endif + ------------------------------------------------------------------------------ -- $mtl -- The mtl style typeclass @@ -597,12 +600,6 @@ instance (MonadMask m, Monoid w) => MonadMask (StrictRWS.RWST r w s m) where return (a, s2, mappend w1 w2)) return ((b, c), s3, w123) --- Transformers which are only instances of MonadThrow and MonadCatch, not MonadMask -instance MonadThrow m => MonadThrow (ListT m) where - throwM = lift . throwM -instance MonadCatch m => MonadCatch (ListT m) where - catch (ListT m) f = ListT $ catch m (runListT . f) - -- | Throws exceptions into the base monad. instance MonadThrow m => MonadThrow (MaybeT m) where throwM = lift . throwM @@ -638,42 +635,6 @@ instance MonadMask m => MonadMask (MaybeT m) where -- since the error message is the same regardless. return ((,) <$> eb <*> ec) --- | Throws exceptions into the base monad. -instance (Error e, MonadThrow m) => MonadThrow (ErrorT e m) where - throwM = lift . throwM --- | Catches exceptions from the base monad. -instance (Error e, MonadCatch m) => MonadCatch (ErrorT e m) where - catch (ErrorT m) f = ErrorT $ catch m (runErrorT . f) -instance (Error e, MonadMask m) => MonadMask (ErrorT e m) where - mask f = ErrorT $ mask $ \u -> runErrorT $ f (q u) - where - q :: (m (Either e a) -> m (Either e a)) - -> ErrorT e m a -> ErrorT e m a - q u (ErrorT b) = ErrorT (u b) - uninterruptibleMask f = ErrorT $ uninterruptibleMask $ \u -> runErrorT $ f (q u) - where - q :: (m (Either e a) -> m (Either e a)) - -> ErrorT e m a -> ErrorT e m a - q u (ErrorT b) = ErrorT (u b) - - generalBracket acquire release use = ErrorT $ do - (eb, ec) <- generalBracket - (runErrorT 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) -> runErrorT (release resource (ExitCaseSuccess b)) - ExitCaseException e -> runErrorT (release resource (ExitCaseException e)) - _ -> runErrorT (release resource ExitCaseAbort)) - (either (return . Left) (runErrorT . 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) - -- | Throws exceptions into the base monad. instance MonadThrow m => MonadThrow (ExceptT e m) where throwM = lift . throwM @@ -719,6 +680,50 @@ instance MonadThrow m => MonadThrow (ContT r m) where -- I don't believe any valid of MonadCatch exists for ContT. -- instance MonadCatch m => MonadCatch (ContT r m) where +#if !(MIN_VERSION_transformers(0,6,0)) +-- | Throws exceptions into the base monad. +instance (Error e, MonadThrow m) => MonadThrow (ErrorT e m) where + throwM = lift . throwM +-- | Catches exceptions from the base monad. +instance (Error e, MonadCatch m) => MonadCatch (ErrorT e m) where + catch (ErrorT m) f = ErrorT $ catch m (runErrorT . f) +instance (Error e, MonadMask m) => MonadMask (ErrorT e m) where + mask f = ErrorT $ mask $ \u -> runErrorT $ f (q u) + where + q :: (m (Either e a) -> m (Either e a)) + -> ErrorT e m a -> ErrorT e m a + q u (ErrorT b) = ErrorT (u b) + uninterruptibleMask f = ErrorT $ uninterruptibleMask $ \u -> runErrorT $ f (q u) + where + q :: (m (Either e a) -> m (Either e a)) + -> ErrorT e m a -> ErrorT e m a + q u (ErrorT b) = ErrorT (u b) + + generalBracket acquire release use = ErrorT $ do + (eb, ec) <- generalBracket + (runErrorT 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) -> runErrorT (release resource (ExitCaseSuccess b)) + ExitCaseException e -> runErrorT (release resource (ExitCaseException e)) + _ -> runErrorT (release resource ExitCaseAbort)) + (either (return . Left) (runErrorT . 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) + +-- Transformers which are only instances of MonadThrow and MonadCatch, not MonadMask +instance MonadThrow m => MonadThrow (ListT m) where + throwM = lift . throwM +instance MonadCatch m => MonadCatch (ListT m) where + catch (ListT m) f = ListT $ catch m (runListT . f) +#endif + ------------------------------------------------------------------------------ -- $utilities -- These functions follow those from "Control.Exception", except that they are diff --git a/src/Control/Monad/Catch/Pure.hs b/src/Control/Monad/Catch/Pure.hs index 4e433b5e52f409413eae77a0b11a5afb8c7cf94d..d9af7462ef539d884251e9ca83e0bc3b43a16f1b 100644 --- a/src/Control/Monad/Catch/Pure.hs +++ b/src/Control/Monad/Catch/Pure.hs @@ -55,8 +55,14 @@ import Prelude hiding (catch, foldr) import Control.Applicative import Control.Monad.Catch import qualified Control.Monad.Fail as Fail -import Control.Monad.Reader as Reader -import Control.Monad.RWS +import Control.Monad.Fix (MonadFix(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad (MonadPlus(..), ap, liftM) +import Control.Monad.Reader (MonadReader(..)) +import Control.Monad.RWS (MonadRWS) +import Control.Monad.State (MonadState(..)) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Writer (MonadWriter(..)) #if __GLASGOW_HASKELL__ < 710 import Data.Foldable #endif diff --git a/tests/Control/Monad/Catch/Tests.hs b/tests/Control/Monad/Catch/Tests.hs index d58bd05c6dfb68da7f1b5e7af660fbdf0ab7eef6..9f5e7a7efbd18771a7f7e33a11ae6f5120ed8d8d 100644 --- a/tests/Control/Monad/Catch/Tests.hs +++ b/tests/Control/Monad/Catch/Tests.hs @@ -3,7 +3,10 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE CPP #-} + +#if !(MIN_VERSION_transformers(0,6,0)) {-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif module Control.Monad.Catch.Tests (tests) where @@ -21,9 +24,7 @@ import Data.IORef (newIORef, writeIORef, readIORef) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Reader (ReaderT(..)) -import Control.Monad.List (ListT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) -import Control.Monad.Error (ErrorT(..)) import Control.Monad.Trans.Except (ExceptT(..), runExceptT) import Control.Monad.STM (STM, atomically) --import Control.Monad.Cont (ContT(..)) @@ -38,6 +39,10 @@ import qualified Control.Monad.Writer.Lazy as LazyWriter import qualified Control.Monad.Writer.Strict as StrictWriter import qualified Control.Monad.RWS.Lazy as LazyRWS import qualified Control.Monad.RWS.Strict as StrictRWS +#if !(MIN_VERSION_transformers(0,6,0)) +import Control.Monad.Error (ErrorT(..)) +import Control.Monad.List (ListT(..)) +#endif import Control.Monad.Catch import Control.Monad.Catch.Pure @@ -113,9 +118,11 @@ tests = testGroup "Control.Monad.Catch.Tests" $ , SomeMSpec mspecLazyRWSTIO , SomeMSpec mspecStrictRWSTIO - , SomeMSpec mspecListTIO , SomeMSpec mspecMaybeTIO +#if !(MIN_VERSION_transformers(0,6,0)) , SomeMSpec mspecErrorTIO + , SomeMSpec mspecListTIO +#endif , SomeMSpec mspecSTM --, SomeMSpec mspecContTIO @@ -150,15 +157,17 @@ tests = testGroup "Control.Monad.Catch.Tests" $ mspecStrictRWSTIO :: MSpec (StrictRWS.RWST () () Bool IO) mspecStrictRWSTIO = MSpec "StrictRWS.RWST IO" $ \m -> io $ fmap tfst $ StrictRWS.evalRWST m () False - mspecListTIO :: MSpec (ListT IO) - mspecListTIO = MSpec "ListT IO" $ \m -> io $ fmap (foldr const undefined) (runListT m) - mspecMaybeTIO :: MSpec (MaybeT IO) mspecMaybeTIO = MSpec "MaybeT IO" $ \m -> io $ fmap (maybe undefined id) (runMaybeT m) +#if !(MIN_VERSION_transformers(0,6,0)) mspecErrorTIO :: MSpec (ErrorT String IO) mspecErrorTIO = MSpec "ErrorT IO" $ \m -> io $ fmap (either error id) (runErrorT m) + mspecListTIO :: MSpec (ListT IO) + mspecListTIO = MSpec "ListT IO" $ \m -> io $ fmap (foldr const undefined) (runListT m) +#endif + mspecSTM :: MSpec STM mspecSTM = MSpec "STM" $ io . atomically