diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,95 @@ +# Revision history for lifted-async + +## v0.11.0 - 2025-09-06 + +* Drop support for GHC 7 and allow base-4.22 ([#47](https://github.com/maoe/lifted-async/pull/47)) + +## v0.10.2.7 - 2024-11-03 + +* Allow base-4.21, tasty-bench-0.4, bump Haskell CI to GHC 9.12.0 ([#46](https://github.com/maoe/lifted-async/pull/46)) + +## v0.10.2.6 - 2024-10-05 + +* Allow base-4.20, bump CI to GHC 9.10.1 (([#44](https://github.com/maoe/lifted-async/issues/44))) + +## v0.10.2.5 - 2023-11-11 + +* Support GHC 9.8 ([#42](https://github.com/maoe/lifted-async/issues/42)) +* Allow base-4.19, bump CI to GHC 9.8.1 ([#43](https://github.com/maoe/lifted-async/pull/43)) + +## v0.10.2.4 - 2022-03-19 + +* Support mtl-2.3.1, allow base-4.18 (GHC 9.6) ([#41](https://github.com/maoe/lifted-async/pull/41)) + +## v0.10.2.3 - 2022-08-13 + +* Allow base-4.17 (GHC 9.4) and bump CI to latest GHC versions ([#39](https://github.com/maoe/lifted-async/pull/39)) + +## v0.10.2.2 - 2021-11-02 + +* Allow base-4.17 for GHC 9.2.1 ([#37](https://github.com/maoe/lifted-async/pull/37)) + +## v0.10.2.1 - 2021-07-23 + +* Relax upper version bound for tasty-bench + +## v0.10.2 - 2021-04-02 + +* Define withAsync in terms of corresponding function from async ([#36](https://github.com/maoe/lifted-async/pull/36)) + * Fixes [#34](https://github.com/maoe/lifted-async/issues/34) + +## v0.10.1.3 - 2021-02-26 + +* Support GHC 9.0.1 ([#33](https://github.com/maoe/lifted-async/pull/33)) +* Switch from Travis CI to GitHub Actions +* Switch from criterion to tasty-bench + +## v0.10.1.2 - 2020-07-23 + +* Relax upper version bound for tasty-expected-failure + +## v0.10.1.1 - 2020-06-29 + +* Bump up cabal-version to 1.24 + +## v0.10.1 - 2020-06-29 + +* Fix typechecking errors with GHC HEAD 8.11 ([#31](https://github.com/maoe/lifted-async/pull/31)) + +## v0.10.0.6 - 2020-03-31 + +* Relax upper version bound for base to suppose GHC 8.10 ([#30](https://github.com/maoe/lifted-async/pull/30)) + +## v0.10.0.5 - 2020-02-08 + +* Relax upper version bounds for constraints + +## v0.10.0.4 - 2019-05-03 + +* Relax upper version bounds for base and constraints + +## v0.10.0.3 - 2018-09-25 + +* Relax upper version bound for base to support GHC 8.6.1 + +## v0.10.0.2 - 2018-05-13 + +* Allow test_link to fail because it's non-deterministic (#26) + +## v0.10.0.1 - 2018-03-10 + +* Relax upper version bound for base in GHC 8.4.1 (#25) + +## v0.10.0 - 2018-02-08 + +* Support only async >= 2.2 +* Drop support for monad-control == 0.* +* Drop support for GHC < 7.10 + +## v0.9.3.3 - 2018-01-22 + +* Relax upper version bound for constraints + ## v0.9.3.2 - 2017-12-12 * Minor improvements in the cabal file diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,20 +2,14 @@ ========== [![Hackage](https://img.shields.io/hackage/v/lifted-async.svg)](https://hackage.haskell.org/package/lifted-async) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/lifted-async.svg)](http://packdeps.haskellers.com/feed?needle=lifted-async) -[![lifted-async on Stackage LTS 3](http://stackage.org/package/lifted-async/badge/lts)](http://stackage.org/lts/package/lifted-async) -[![Build Status](https://travis-ci.org/maoe/lifted-async.svg?branch=develop)](https://travis-ci.org/maoe/lifted-async) +[![lifted-async on Stackage LTS](https://stackage.org/package/lifted-async/badge/lts)](http://stackage.org/lts/package/lifted-async) +[![Haskell-CI](https://github.com/maoe/lifted-async/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/maoe/lifted-async/actions/workflows/haskell-ci.yml) [![Gitter](https://badges.gitter.im/maoe/lifted-async.svg)](https://gitter.im/maoe/lifted-async?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge) This package provides IO operations from [async](http://hackage.haskell.org/package/async) package lifted to any instance of `MonadBase` or `MonadBaseControl` from [monad-control](http://hackage.haskell.org/package/monad-control) package. -You can install this library using cabal: - -``` -cabal install lifted-async -``` - Contact information ========== -This library is written and maintained by Mitsutoshi Aoe . +This library is written and maintained by Mitsutoshi Aoe . [Pull requests](https://github.com/maoe/lifted-async/pulls) and [bug reports](https://github.com/maoe/lifted-async/issues) are welcome. A chat room is available on [Gitter](https://gitter.im/maoe/lifted-async). diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs --- a/benchmarks/Benchmarks.hs +++ b/benchmarks/Benchmarks.hs @@ -1,7 +1,7 @@ module Main where import Control.Exception (SomeException(..)) -import Criterion.Main +import Test.Tasty.Bench (bench, bgroup, defaultMain, nfIO, whnfIO) import qualified Control.Concurrent.Async as A import qualified Control.Concurrent.Async.Lifted as L import qualified Control.Concurrent.Async.Lifted.Safe as LS @@ -13,11 +13,11 @@ , bench "lifted-async" $ whnfIO asyncWait_liftedAsync , bench "lifted-async-safe" $ whnfIO asyncWait_liftedAsyncSafe ] - , bgroup "async-cancel-waitCatch" - [ bench "async" $ whnfIO asyncCancelWaitCatch_async - , bench "lifted-async" $ whnfIO asyncCancelWaitCatch_liftedAsync - , bench "lifted-async-safe" $ whnfIO asyncCancelWaitCatch_liftedAsyncSafe - ] + -- , bgroup "async-cancel-waitCatch" + -- [ bench "async" $ whnfIO asyncCancelWaitCatch_async + -- , bench "lifted-async" $ whnfIO asyncCancelWaitCatch_liftedAsync + -- , bench "lifted-async-safe" $ whnfIO asyncCancelWaitCatch_liftedAsyncSafe + -- ] , bgroup "waitAny" [ bench "async" $ whnfIO waitAny_async , bench "lifted-async" $ whnfIO waitAny_liftedAsync diff --git a/lifted-async.cabal b/lifted-async.cabal --- a/lifted-async.cabal +++ b/lifted-async.cabal @@ -1,24 +1,33 @@ +cabal-version: 1.24 name: lifted-async -version: 0.9.3.3 +version: 0.11.0 synopsis: Run lifted IO operations asynchronously and wait for their results homepage: https://github.com/maoe/lifted-async bug-reports: https://github.com/maoe/lifted-async/issues license: BSD3 license-file: LICENSE author: Mitsutoshi Aoe -maintainer: Mitsutoshi Aoe -copyright: Copyright (C) 2012-2018 Mitsutoshi Aoe +maintainer: Mitsutoshi Aoe +copyright: Copyright (C) 2012-2025 Mitsutoshi Aoe category: Concurrency build-type: Simple -cabal-version: >= 1.8 tested-with: - GHC == 8.2.1 - , GHC == 8.0.2 - , GHC == 7.10.2 - , GHC == 7.8.4 - , GHC == 7.6.3 + GHC == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.2 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 -extra-source-files: +extra-doc-files: README.md CHANGELOG.md @@ -26,31 +35,20 @@ This package provides IO operations from @async@ package lifted to any instance of 'MonadBase' or 'MonadBaseControl'. -flag monad-control-1 - description: User moand-control == 1.* - default: True - manual: False - library + hs-source-dirs: src exposed-modules: Control.Concurrent.Async.Lifted Control.Concurrent.Async.Lifted.Safe build-depends: - base >= 4.5 && < 4.11 - , async >= 2.1.1 && < 2.2 + base >= 4.9 && < 4.23 + , async >= 2.2 && < 2.3 , lifted-base >= 0.2 && < 0.3 , transformers-base >= 0.4 && < 0.5 - if flag(monad-control-1) - build-depends: monad-control == 1.0.* - if impl(ghc >= 7.8) - build-depends: constraints >= 0.2 && < 0.11 - else - build-depends: constraints >= 0.2 && < 0.6 - else - build-depends: - monad-control == 0.* + , monad-control == 1.0.* + , constraints >= 0.2 && < 0.15 ghc-options: -Wall - hs-source-dirs: src + default-language: Haskell2010 test-suite test-lifted-async type: exitcode-stdio-1.0 @@ -61,16 +59,17 @@ Test.Async.IO Test.Async.State Test.Async.Reader + ghc-options: -Wall -threaded build-depends: base - , HUnit , lifted-async , lifted-base - , monad-control , mtl , tasty + , tasty-expected-failure < 0.13 , tasty-hunit >= 0.9 && < 0.11 , tasty-th + default-language: Haskell2010 test-suite regression-tests type: exitcode-stdio-1.0 @@ -79,11 +78,10 @@ ghc-options: -Wall -threaded build-depends: base - , async , lifted-async - , mtl , tasty-hunit >= 0.9 && < 0.11 , tasty-th + default-language: Haskell2010 benchmark benchmark-lifted-async type: exitcode-stdio-1.0 @@ -93,9 +91,9 @@ build-depends: base , async - , criterion - , deepseq + , tasty-bench < 0.5 , lifted-async + default-language: Haskell2010 benchmark benchmark-lifted-async-threaded type: exitcode-stdio-1.0 @@ -105,9 +103,9 @@ build-depends: base , async - , criterion - , deepseq + , tasty-bench < 0.5 , lifted-async + default-language: Haskell2010 source-repository head type: git diff --git a/src/Control/Concurrent/Async/Lifted.hs b/src/Control/Concurrent/Async/Lifted.hs --- a/src/Control/Concurrent/Async/Lifted.hs +++ b/src/Control/Concurrent/Async/Lifted.hs @@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {- | Module : Control.Concurrent.Async.Lifted -Copyright : Copyright (C) 2012-2017 Mitsutoshi Aoe +Copyright : Copyright (C) 2012-2018 Mitsutoshi Aoe License : BSD-style (see the file LICENSE) Maintainer : Mitsutoshi Aoe Stability : experimental @@ -18,11 +17,9 @@ All the functions restore the monadic effects in the forked computation unless specified otherwise. -#if MIN_VERSION_monad_control(1, 0, 0) If your monad stack satisfies @'StM' m a ~ a@ (e.g. the reader monad), consider using @Control.Concurrent.Async.Lifted.Safe@ module, which prevents you from messing up monadic effects. -#endif -} module Control.Concurrent.Async.Lifted @@ -37,8 +34,12 @@ , withAsyncWithUnmask, withAsyncOnWithUnmask -- ** Quering 'Async's - , wait, poll, waitCatch, cancel, cancelWith + , wait, poll, waitCatch + , cancel + , uninterruptibleCancel + , cancelWith , A.asyncThreadId + , A.AsyncCancelled(..) -- ** STM operations , A.waitSTM, A.pollSTM, A.waitCatchSTM @@ -49,7 +50,6 @@ , waitEither_ , waitBoth -#if MIN_VERSION_async(2, 1, 0) -- ** Waiting for multiple 'Async's in STM , A.waitAnySTM , A.waitAnyCatchSTM @@ -57,10 +57,10 @@ , A.waitEitherCatchSTM , A.waitEitherSTM_ , A.waitBothSTM -#endif -- ** Linking , link, link2 + , A.ExceptionInLinkedThread(..) -- * Convenient utilities , race, race_, concurrently, concurrently_ @@ -68,14 +68,16 @@ , forConcurrently, forConcurrently_ , replicateConcurrently, replicateConcurrently_ , Concurrently(..) + + , A.compareAsyncs ) where import Control.Applicative import Control.Concurrent (threadDelay) -import Control.Monad ((>=>), forever, liftM, void) +import Control.Monad ((>=>), forever, void) import Data.Foldable (fold) import GHC.IO (unsafeUnmask) -import Prelude hiding (mapM) +import Prelude import Control.Concurrent.Async (Async) import Control.Exception.Lifted (SomeException, Exception) @@ -84,13 +86,7 @@ import qualified Control.Concurrent.Async as A import qualified Control.Exception.Lifted as E -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Traversable -#endif -#if !MIN_VERSION_base(4, 8, 0) -import Data.Monoid (Monoid(mappend, mempty)) -#elif MIN_VERSION_base(4, 9, 0) +#if !MIN_VERSION_base(4, 11, 0) import Data.Semigroup (Semigroup((<>))) #endif @@ -137,7 +133,7 @@ => m a -> (Async (StM m a) -> m b) -> m b -withAsync = withAsyncUsing async +withAsync = liftWithAsync A.withAsync {-# INLINABLE withAsync #-} -- | Generalized version of 'A.withAsyncBound'. @@ -146,9 +142,17 @@ => m a -> (Async (StM m a) -> m b) -> m b -withAsyncBound = withAsyncUsing asyncBound +withAsyncBound = liftWithAsync A.withAsyncBound {-# INLINABLE withAsyncBound #-} +liftWithAsync + :: MonadBaseControl IO m + => (IO (StM m a) -> (Async (StM m a) -> IO (StM m b)) -> IO (StM m b)) + -> (m a -> (Async (StM m a) -> m b) -> m b) +liftWithAsync withA action cont = restoreM =<< do + liftBaseWith $ \runInIO -> do + withA (runInIO action) (runInIO . cont) + -- | Generalized version of 'A.withAsyncOn'. withAsyncOn :: MonadBaseControl IO m @@ -205,22 +209,20 @@ -> m (Maybe (Either SomeException a)) poll a = liftBase (A.poll a) >>= - maybe (return Nothing) (liftM Just . sequenceEither) + maybe (return Nothing) (fmap Just . sequenceEither) -- | Generalized version of 'A.cancel'. --- --- NOTE: This function discards the monadic effects besides IO in the forked --- computation. cancel :: MonadBase IO m => Async a -> m () cancel = liftBase . A.cancel -- | Generalized version of 'A.cancelWith'. --- --- NOTE: This function discards the monadic effects besides IO in the forked --- computation. cancelWith :: (MonadBase IO m, Exception e) => Async a -> e -> m () cancelWith = (liftBase .) . A.cancelWith +-- | Generalized version of 'A.uninterruptibleCancel'. +uninterruptibleCancel :: MonadBase IO m => Async a -> m () +uninterruptibleCancel = liftBase . A.uninterruptibleCancel + -- | Generalized version of 'A.waitCatch'. waitCatch :: MonadBaseControl IO m @@ -273,7 +275,7 @@ -> m (Either a b) waitEither a b = liftBase (A.waitEither a b) >>= - either (liftM Left . restoreM) (liftM Right . restoreM) + either (fmap Left . restoreM) (fmap Right . restoreM) -- | Generalized version of 'A.waitEitherCatch'. waitEitherCatch @@ -283,7 +285,7 @@ -> m (Either (Either SomeException a) (Either SomeException b)) waitEitherCatch a b = liftBase (A.waitEitherCatch a b) >>= - either (liftM Left . sequenceEither) (liftM Right . sequenceEither) + either (fmap Left . sequenceEither) (fmap Right . sequenceEither) -- | Generalized version of 'A.waitEitherCancel'. waitEitherCancel @@ -293,7 +295,7 @@ -> m (Either a b) waitEitherCancel a b = liftBase (A.waitEitherCancel a b) >>= - either (liftM Left . restoreM) (liftM Right . restoreM) + either (fmap Left . restoreM) (fmap Right . restoreM) -- | Generalized version of 'A.waitEitherCatchCancel'. waitEitherCatchCancel @@ -303,7 +305,7 @@ -> m (Either (Either SomeException a) (Either SomeException b)) waitEitherCatchCancel a b = liftBase (A.waitEitherCatch a b) >>= - either (liftM Left . sequenceEither) (liftM Right . sequenceEither) + either (fmap Left . sequenceEither) (fmap Right . sequenceEither) -- | Generalized version of 'A.waitEither_'. -- @@ -448,11 +450,10 @@ Concurrently $ uncurry ($) <$> concurrently fs as instance MonadBaseControl IO m => Alternative (Concurrently m) where - empty = Concurrently $ liftBaseWith $ const (forever $ threadDelay maxBound) + empty = Concurrently $ liftBaseWith $ \_ -> forever $ threadDelay maxBound Concurrently as <|> Concurrently bs = Concurrently $ either id id <$> race as bs -#if MIN_VERSION_base(4, 9, 0) instance (MonadBaseControl IO m, Semigroup a) => Semigroup (Concurrently m a) where (<>) = liftA2 (<>) @@ -461,11 +462,6 @@ Monoid (Concurrently m a) where mempty = pure mempty mappend = (<>) -#else -instance (MonadBaseControl IO m, Monoid a) => Monoid (Concurrently m a) where - mempty = pure mempty - mappend = liftA2 mappend -#endif sequenceEither :: MonadBaseControl IO m => Either e (StM m a) -> m (Either e a) -sequenceEither = either (return . Left) (liftM Right . restoreM) +sequenceEither = either (return . Left) (fmap Right . restoreM) diff --git a/src/Control/Concurrent/Async/Lifted/Safe.hs b/src/Control/Concurrent/Async/Lifted/Safe.hs --- a/src/Control/Concurrent/Async/Lifted/Safe.hs +++ b/src/Control/Concurrent/Async/Lifted/Safe.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,7 +11,7 @@ {- | Module : Control.Concurrent.Async.Lifted.Safe -Copyright : Copyright (C) 2012-2017 Mitsutoshi Aoe +Copyright : Copyright (C) 2012-2018 Mitsutoshi Aoe License : BSD-style (see the file LICENSE) Maintainer : Mitsutoshi Aoe Stability : experimental @@ -25,7 +24,6 @@ -} module Control.Concurrent.Async.Lifted.Safe -#if MIN_VERSION_monad_control(1, 0, 0) ( -- * Asynchronous actions A.Async @@ -41,8 +39,11 @@ -- ** Quering 'Async's , wait, poll, waitCatch - , cancel, cancelWith + , cancel + , uninterruptibleCancel + , cancelWith , A.asyncThreadId + , A.AsyncCancelled(..) -- ** STM operations , A.waitSTM, A.pollSTM, A.waitCatchSTM @@ -53,7 +54,6 @@ , waitEither_ , waitBoth -#if MIN_VERSION_async(2, 1, 0) -- ** Waiting for multiple 'Async's in STM , A.waitAnySTM , A.waitAnyCatchSTM @@ -61,10 +61,10 @@ , A.waitEitherCatchSTM , A.waitEitherSTM_ , A.waitBothSTM -#endif -- ** Linking , Unsafe.link, Unsafe.link2 + , A.ExceptionInLinkedThread(..) -- * Convenient utilities , race, race_, concurrently, concurrently_ @@ -73,18 +73,10 @@ , replicateConcurrently, replicateConcurrently_ , Concurrently(..) - + , A.compareAsyncs ) -#else -{-# WARNING - "This module is available only if built with @monad-control >= 1.0.0@.\ - If you have an older version of @monad-control@, use\ - @Control.Concurrent.Async.Lifted@ instead." - #-} -#endif where -#if MIN_VERSION_monad_control(1, 0, 0) import Control.Applicative import Control.Concurrent (threadDelay) import Control.Monad @@ -100,13 +92,7 @@ import qualified Control.Concurrent.Async.Lifted as Unsafe -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 -import Data.Foldable -import Data.Traversable -#endif -#if !MIN_VERSION_base(4, 8, 0) -import Data.Monoid (Monoid(mappend, mempty)) -#elif MIN_VERSION_base(4, 9, 0) +#if !MIN_VERSION_base(4, 11, 0) import Data.Semigroup (Semigroup((<>))) #endif @@ -226,6 +212,10 @@ cancelWith :: (MonadBase IO m, Exception e) => Async a -> e -> m () cancelWith = Unsafe.cancelWith +-- | Generalized version of 'A.uninterruptibleCancel'. +uninterruptibleCancel :: MonadBase IO m => Async a -> m () +uninterruptibleCancel = Unsafe.uninterruptibleCancel + -- | Generalized version of 'A.waitAny'. waitAny :: forall m a. (MonadBase IO m, Forall (Pure m)) @@ -436,13 +426,12 @@ instance (MonadBaseControl IO m, Forall (Pure m)) => Alternative (Concurrently m) where - empty = Concurrently $ liftBaseWith $ const (forever $ threadDelay maxBound) + empty = Concurrently $ liftBaseWith $ \_ -> forever $ threadDelay maxBound Concurrently (as :: m a) <|> Concurrently bs = Concurrently (either id id <$> race as bs) \\ (inst :: Forall (Pure m) :- Pure m a) \\ (inst :: Forall (Pure m) :- Pure m b) -#if MIN_VERSION_base(4, 9, 0) instance (MonadBaseControl IO m, Semigroup a, Forall (Pure m)) => Semigroup (Concurrently m a) where (<>) = liftA2 (<>) @@ -451,11 +440,3 @@ Monoid (Concurrently m a) where mempty = pure mempty mappend = (<>) -#else -instance (MonadBaseControl IO m, Monoid a, Forall (Pure m)) => - Monoid (Concurrently m a) where - mempty = pure mempty - mappend = liftA2 mappend -#endif - -#endif diff --git a/tests/Test/Async/Common.hs b/tests/Test/Async/Common.hs --- a/tests/Test/Async/Common.hs +++ b/tests/Test/Async/Common.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} module Test.Async.Common ( value @@ -6,8 +5,6 @@ , module X ) where -import Data.Typeable - import Control.Exception.Lifted import Test.Tasty as X import Test.Tasty.HUnit as X @@ -17,6 +14,6 @@ value = 42 data TestException = TestException - deriving (Eq, Show, Typeable) + deriving (Eq, Show) instance Exception TestException diff --git a/tests/Test/Async/IO.hs b/tests/Test/Async/IO.hs --- a/tests/Test/Async/IO.hs +++ b/tests/Test/Async/IO.hs @@ -9,11 +9,7 @@ import Control.Concurrent.Lifted import Control.Exception.Lifted as E -#if MIN_VERSION_monad_control(1, 0, 0) import Control.Concurrent.Async.Lifted.Safe -#else -import Control.Concurrent.Async.Lifted -#endif import Test.Async.Common ioTestGroup :: TestTree @@ -59,7 +55,7 @@ a <- withAsync (threadDelay 1000000) $ return r <- waitCatch a case r of - Left e -> fromException e @?= Just ThreadKilled + Left e -> fromException e @?= Just AsyncCancelled Right _ -> assertFailure "" case_async_cancel :: Assertion diff --git a/tests/Test/Async/Reader.hs b/tests/Test/Async/Reader.hs --- a/tests/Test/Async/Reader.hs +++ b/tests/Test/Async/Reader.hs @@ -3,17 +3,15 @@ module Test.Async.Reader ( readerTestGroup ) where -import Control.Monad.Reader +import Control.Monad (void, when) +import Control.Monad.Reader (runReaderT, liftIO) import Data.Maybe (isJust, isNothing) import Control.Concurrent.Lifted import Control.Exception.Lifted as E +import Test.Tasty.ExpectedFailure -#if MIN_VERSION_monad_control(1, 0, 0) import Control.Concurrent.Async.Lifted.Safe -#else -import Control.Concurrent.Async.Lifted -#endif import Test.Async.Common readerTestGroup :: TestTree @@ -71,7 +69,7 @@ waitCatch a case r of Left e -> do - fromException e @?= Just ThreadKilled + fromException e @?= Just AsyncCancelled Right _ -> assertFailure "An exception must be raised." case_async_cancel :: Assertion @@ -111,14 +109,20 @@ when (isNothing r') $ liftIO $ assertFailure "The result must not be Nothing." -case_link :: Assertion -case_link = do - r <- try $ flip runReaderT value $ do - a <- async $ threadDelay 1000000 >> return value - link a - cancelWith a TestException - wait a - case r of - Left e -> do - fromException e @?= Just TestException - Right _ -> assertFailure "An exception must be raised." +test_ignored :: [TestTree] +test_ignored = + [ ignoreTestBecause "see #26" $ testCase "link" $ do + r <- try $ flip runReaderT value $ do + a <- async $ threadDelay 1000000 >> return value + link a + cancelWith a TestException + wait a + case r of + Left e -> case fromException e of + Just (ExceptionInLinkedThread _ e') -> + fromException e' @?= Just TestException + Nothing -> assertFailure $ + "expected ExceptionInLinkedThread _ TestException" + ++ " but got " ++ show e + Right _ -> assertFailure "An exception must be raised." + ] diff --git a/tests/Test/Async/State.hs b/tests/Test/Async/State.hs --- a/tests/Test/Async/State.hs +++ b/tests/Test/Async/State.hs @@ -2,11 +2,13 @@ module Test.Async.State ( stateTestGroup ) where -import Control.Monad.State +import Control.Monad (void, when) +import Control.Monad.State (runStateT, get, modify, liftIO) import Data.Maybe (isJust, isNothing) import Control.Concurrent.Lifted import Control.Exception.Lifted as E +import Test.Tasty.ExpectedFailure import Control.Concurrent.Async.Lifted import Test.Async.Common @@ -73,7 +75,7 @@ waitCatch a case r of Left e -> do - fromException e @?= Just ThreadKilled + fromException e @?= Just AsyncCancelled s @?= value Right _ -> assertFailure "An exception must be raised." @@ -146,14 +148,20 @@ waitBoth a b liftIO $ s @?= value -case_link :: Assertion -case_link = do - r <- try $ flip runStateT value $ do - a <- async $ threadDelay 1000000 >> return value - link a - cancelWith a TestException - wait a - case r of - Left e -> do - fromException e @?= Just TestException - Right _ -> assertFailure "An exception must be raised." +test_ignored :: [TestTree] +test_ignored = + [ ignoreTestBecause "see #26" $ testCase "link" $ do + r <- try $ flip runStateT value $ do + a <- async $ threadDelay 1000000 >> return value + link a + cancelWith a TestException + wait a + case r of + Left e -> case fromException e of + Just (ExceptionInLinkedThread _ e') -> + fromException e' @?= Just TestException + Nothing -> assertFailure $ + "expected ExceptionInLinkedThread _ TestException" + ++ " but got " ++ show e + Right _ -> assertFailure "An exception must be raised." + ] diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where import Test.Tasty (defaultMain, testGroup)