diff --git a/.gitignore b/.gitignore --- a/.gitignore +++ b/.gitignore @@ -32,6 +32,7 @@ .ghc.environment.* # GHC +dist-boot dist-install GNUmakefile ghc.mk diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,204 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci '--output=.travis.yml' '--config=cabal.haskell-ci' 'cabal.project' -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.9.20191213 -# -version: ~> 1.0 -language: c -os: linux -dist: xenial -git: - # whether to recursively clone submodules - submodules: false -notifications: - irc: - channels: - - irc.freenode.org#haskell-lens - skip_join: true - template: - - "\"\\x0313exceptions\\x03/\\x0306%{branch}\\x03 \\x0314%{commit}\\x03 %{build_url} %{message}\"" -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - - $HOME/.hlint -before_cache: - - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - - rm -rfv $CABALHOME/packages/head.hackage -jobs: - include: - - compiler: ghc-8.10.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.0"]}} - os: linux - - compiler: ghc-8.8.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.0"]}} - os: linux - - compiler: ghc-8.6.5 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}} - os: linux - - compiler: ghc-8.4.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.0"]}} - os: linux - - compiler: ghc-8.2.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.0"]}} - os: linux - - compiler: ghc-8.0.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.0"]}} - os: linux - - compiler: ghc-7.10.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.3","cabal-install-3.0"]}} - os: linux - - compiler: ghc-7.8.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.4","cabal-install-3.0"]}} - os: linux - - compiler: ghc-7.6.3 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.6.3","cabal-install-3.0"]}} - os: linux - - compiler: ghc-7.4.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.4.2","cabal-install-3.0"]}} - os: linux - - compiler: ghc-7.2.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.2.2","cabal-install-3.0"]}} - os: linux - - compiler: ghc-7.0.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.0.4","cabal-install-3.0"]}} - os: linux - allow_failures: - - compiler: ghc-7.0.4 - - compiler: ghc-7.2.2 - - compiler: ghc-8.10.1 -before_install: - - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - - WITHCOMPILER="-w $HC" - - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - TOP=$(pwd) - - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap+markoutput" - - set -o pipefail - - | - echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk - echo 'BEGIN { state = "output"; }' >> .colorful.awk - echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk - echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk - echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk - echo ' if (state == "cabal") {' >> .colorful.awk - echo ' print blue($0)' >> .colorful.awk - echo ' } else {' >> .colorful.awk - echo ' print $0' >> .colorful.awk - echo ' }' >> .colorful.awk - echo '}' >> .colorful.awk - - cat .colorful.awk - - | - color_cabal_output () { - awk -f $TOP/.colorful.awk - } - - echo text | color_cabal_output -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - HEADHACKAGE=false - - if [ $HCNUMVER -ge 81000 ] ; then HEADHACKAGE=true ; fi - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "write-ghc-environment-files: always" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - echo " secure: True" >> $CABALHOME/config - echo " key-threshold: 3" >> $CABALHOME/config - echo " root-keys:" >> $CABALHOME/config - echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config - echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config - echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config - echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config - echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config - - | - if $HEADHACKAGE; then - echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1/g')" >> $CABALHOME/config - echo "repository head.hackage.ghc.haskell.org" >> $CABALHOME/config - echo " url: https://ghc.gitlab.haskell.org/head.hackage/" >> $CABALHOME/config - echo " secure: True" >> $CABALHOME/config - echo " root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d" >> $CABALHOME/config - echo " 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329" >> $CABALHOME/config - echo " f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89" >> $CABALHOME/config - echo " key-threshold: 3" >> $CABALHOME/config - fi - - | - echo "program-default-options" >> $CABALHOME/config - echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config - - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze - - travis_retry ${CABAL} v2-update -v - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ." >> cabal.project - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(exceptions)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output - - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output -script: - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - # Packaging... - - ${CABAL} v2-sdist all | color_cabal_output - # Unpacking... - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - - PKGDIR_exceptions="$(find . -maxdepth 1 -type d -regex '.*/exceptions-[0-9.]*')" - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ${PKGDIR_exceptions}" >> cabal.project - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(exceptions)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - # Building with tests and benchmarks... - # build & run tests, build benchmarks - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output - # Testing... - - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output - # cabal check... - - (cd ${PKGDIR_exceptions} && ${CABAL} -vnormal check) - # haddock... - - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output - -# REGENDATA ("0.9.20191213",["--output=.travis.yml","--config=cabal.haskell-ci","cabal.project"]) -# EOF diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,7 @@ +0.10.5 [2022.05.07] +------------------- +* 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/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ exceptions ========== -[![Hackage](https://img.shields.io/hackage/v/exceptions.svg)](https://hackage.haskell.org/package/exceptions) [![Build Status](https://secure.travis-ci.org/ekmett/exceptions.png?branch=master)](http://travis-ci.org/ekmett/exceptions) +[![Hackage](https://img.shields.io/hackage/v/exceptions.svg)](https://hackage.haskell.org/package/exceptions) [![Build Status](https://github.com/ekmett/exceptions/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/exceptions/actions?query=workflow%3AHaskell-CI) This package provides (optionally pure) extensible exceptions that are compatible with the monad transformer library. diff --git a/exceptions.cabal b/exceptions.cabal --- a/exceptions.cabal +++ b/exceptions.cabal @@ -1,7 +1,7 @@ name: exceptions category: Control, Exceptions, Monad -version: 0.10.4 -cabal-version: >= 1.8 +version: 0.10.5 +cabal-version: >= 1.10 license: BSD3 license-file: LICENSE author: Edward A. Kmett @@ -22,18 +22,16 @@ , GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 - , GHC == 8.8.1 - , GHC == 8.10.1 + , GHC == 8.8.4 + , GHC == 8.10.4 + , GHC == 9.0.1 synopsis: Extensible optionally-pure exceptions description: Extensible optionally-pure exceptions. extra-source-files: - .travis.yml .ghci .gitignore .vim.custom - travis/cabal-apt-install - travis/config AUTHORS.markdown README.markdown CHANGELOG.markdown @@ -50,19 +48,19 @@ build-depends: base >= 4.3 && < 5, stm >= 2.2 && < 3, - template-haskell >= 2.2 && < 2.17, - mtl >= 2.0 && < 2.3 + template-haskell >= 2.2 && < 2.19, + 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, - transformers-compat >= 0.3 && < 0.7 + transformers-compat >= 0.3 && < 0.8 exposed-modules: Control.Monad.Catch @@ -70,12 +68,14 @@ ghc-options: -Wall -fwarn-tabs -O2 hs-source-dirs: src + default-language: Haskell2010 test-suite exceptions-tests main-is: Tests.hs other-modules: Control.Monad.Catch.Tests hs-source-dirs: tests ghc-options: -Wall -fwarn-tabs + default-language: Haskell2010 type: exitcode-stdio-1.0 build-depends: base, @@ -86,12 +86,12 @@ test-framework >= 0.8 && < 0.9, test-framework-hunit >= 0.3 && < 0.4, test-framework-quickcheck2 >= 0.3 && < 0.4, - QuickCheck >= 2.5 && < 2.14 + QuickCheck >= 2.5 && < 2.15 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, - transformers-compat >= 0.3 && < 0.7 + transformers-compat >= 0.3 && < 0.8 diff --git a/src/Control/Monad/Catch.hs b/src/Control/Monad/Catch.hs --- a/src/Control/Monad/Catch.hs +++ b/src/Control/Monad/Catch.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} @@ -15,11 +16,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 +78,7 @@ 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 +88,12 @@ 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 +117,11 @@ 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 @@ -183,7 +187,7 @@ -- error from the same layer, instances should ensure that the error from @g@ -- wins. -- --- Effects other than throwing an error are also overriden by the deeper layers. +-- Effects other than throwing an error are also overridden by the deeper layers. -- For example, @StateT s Maybe a@ represents a value of type @s -> Maybe (a, -- s)@, so if an error thrown from @f@ causes this function to return @Nothing@, -- any changes to the state which @f@ also performed will be erased. As a @@ -597,12 +601,6 @@ 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 @@ -639,42 +637,6 @@ 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 -- | Catches exceptions from the base monad. @@ -718,6 +680,50 @@ throwM = lift . throwM -- 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 diff --git a/src/Control/Monad/Catch/Pure.hs b/src/Control/Monad/Catch/Pure.hs --- a/src/Control/Monad/Catch/Pure.hs +++ b/src/Control/Monad/Catch/Pure.hs @@ -55,10 +55,17 @@ 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 +import Data.Monoid (Monoid(..)) #endif import Data.Functor.Identity import Data.Traversable as Traversable diff --git a/tests/Control/Monad/Catch/Tests.hs b/tests/Control/Monad/Catch/Tests.hs --- a/tests/Control/Monad/Catch/Tests.hs +++ b/tests/Control/Monad/Catch/Tests.hs @@ -4,13 +4,19 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE CPP #-} +#if !(MIN_VERSION_transformers(0,6,0)) +{-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif + module Control.Monad.Catch.Tests (tests) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706) import Prelude hiding (catch) #endif +#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ((<*>)) +#endif import Control.Monad (unless) import Data.Data (Data, Typeable) import Data.IORef (newIORef, writeIORef, readIORef) @@ -18,24 +24,25 @@ 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(..)) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck (Property, once) +import Test.QuickCheck (Property, ioProperty, once) import Test.QuickCheck.Monadic (monadic, run, assert) -import Test.QuickCheck.Property (morallyDubiousIOProperty) import qualified Control.Monad.State.Lazy as LazyState import qualified Control.Monad.State.Strict as StrictState 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 @@ -85,7 +92,7 @@ monadic (mspecRunner mspec) $ do effectWasPerformed <- run $ do (effect, detector) <- effectDetector - runExceptT $ ExceptT (return $ Left ()) `finally` lift effect + _ <- runExceptT $ ExceptT (return $ Left ()) `finally` lift effect detector assert effectWasPerformed @@ -111,9 +118,11 @@ , SomeMSpec mspecLazyRWSTIO , SomeMSpec mspecStrictRWSTIO - , SomeMSpec mspecListTIO , SomeMSpec mspecMaybeTIO +#if !(MIN_VERSION_transformers(0,6,0)) , SomeMSpec mspecErrorTIO + , SomeMSpec mspecListTIO +#endif , SomeMSpec mspecSTM --, SomeMSpec mspecContTIO @@ -148,15 +157,17 @@ 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 (\[x] -> x) (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 @@ -172,7 +183,7 @@ tfst :: (Property, ()) -> Property = fst fromRight (Left _) = error "fromRight" fromRight (Right a) = a - io = morallyDubiousIOProperty + io = ioProperty detectableEffects = [ SomeDetectableEffect $ detectableEffectIO @@ -183,29 +194,44 @@ ] detectableEffectIO :: DetectableEffect IO - detectableEffectIO = DetectableEffect mspecIO $ do - ref <- newIORef False - return (writeIORef ref True, readIORef ref) + detectableEffectIO = DetectableEffect + { detectableEffectMSpec = mspecIO + , detectableEffectEffectDetector = do + ref <- newIORef False + return (writeIORef ref True, readIORef ref) + } detectableEffectLazyStateTIO :: DetectableEffect (LazyState.StateT Bool IO) - detectableEffectLazyStateTIO = DetectableEffect mspecLazyStateTIO $ do - LazyState.put False - return (LazyState.put True, LazyState.get) + detectableEffectLazyStateTIO = DetectableEffect + { detectableEffectMSpec = mspecLazyStateTIO + , detectableEffectEffectDetector = do + LazyState.put False + return (LazyState.put True, LazyState.get) + } detectableEffectStrictStateTIO :: DetectableEffect (StrictState.StateT Bool IO) - detectableEffectStrictStateTIO = DetectableEffect mspecStrictStateTIO $ do - StrictState.put False - return (StrictState.put True, StrictState.get) + detectableEffectStrictStateTIO = DetectableEffect + { detectableEffectMSpec = mspecStrictStateTIO + , detectableEffectEffectDetector = do + StrictState.put False + return (StrictState.put True, StrictState.get) + } detectableEffectLazyRWSTIO :: DetectableEffect (LazyRWS.RWST () () Bool IO) - detectableEffectLazyRWSTIO = DetectableEffect mspecLazyRWSTIO $ do - LazyRWS.put False - return (LazyRWS.put True, LazyRWS.get) + detectableEffectLazyRWSTIO = DetectableEffect + { detectableEffectMSpec = mspecLazyRWSTIO + , detectableEffectEffectDetector = do + LazyRWS.put False + return (LazyRWS.put True, LazyRWS.get) + } detectableEffectStrictRWSTIO :: DetectableEffect (StrictRWS.RWST () () Bool IO) - detectableEffectStrictRWSTIO = DetectableEffect mspecStrictRWSTIO $ do - StrictRWS.put False - return (StrictRWS.put True, StrictRWS.get) + detectableEffectStrictRWSTIO = DetectableEffect + { detectableEffectMSpec = mspecStrictRWSTIO + , detectableEffectEffectDetector = do + StrictRWS.put False + return (StrictRWS.put True, StrictRWS.get) + } mkMonadCatch = mkMSpecTest "MonadCatch" testMonadCatch mkCatchJust = mkMSpecTest "catchJust" testCatchJust diff --git a/travis/cabal-apt-install b/travis/cabal-apt-install deleted file mode 100644 --- a/travis/cabal-apt-install +++ /dev/null @@ -1,27 +0,0 @@ -#! /bin/bash -set -eu - -APT="sudo apt-get -q -y" -CABAL_INSTALL_DEPS="cabal install --only-dependencies --force-reinstall" - -$APT update -$APT install dctrl-tools - -# Find potential system packages to satisfy cabal dependencies -deps() -{ - local M='^\([^ ]\+\)-[0-9.]\+ (.*$' - local G=' -o ( -FPackage -X libghc-\L\1\E-dev )' - local E="$($CABAL_INSTALL_DEPS "$@" --dry-run -v 2> /dev/null \ - | sed -ne "s/$M/$G/p" | sort -u)" - grep-aptavail -n -sPackage \( -FNone -X None \) $E | sort -u -} - -$APT install $(deps "$@") libghc-quickcheck2-dev # QuickCheck is special -$CABAL_INSTALL_DEPS "$@" # Install the rest via Hackage - -if ! $APT install hlint ; then - $APT install $(deps hlint) - cabal install hlint -fi - diff --git a/travis/config b/travis/config deleted file mode 100644 --- a/travis/config +++ /dev/null @@ -1,16 +0,0 @@ --- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix --- --- This is particularly useful for travis-ci to get it to stop complaining --- about a broken build when everything is still correct on our end. --- --- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead --- --- To enable this, uncomment the before_script in .travis.yml - -remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive -remote-repo-cache: ~/.cabal/packages -world-file: ~/.cabal/world -build-summary: ~/.cabal/logs/build.log -remote-build-reporting: anonymous -install-dirs user -install-dirs global