lifted-async 0.9.3.3 → 0.11.0
raw patch · 11 files changed
Files
- CHANGELOG.md +92/−0
- README.md +3/−9
- benchmarks/Benchmarks.hs +6/−6
- lifted-async.cabal +33/−35
- src/Control/Concurrent/Async/Lifted.hs +33/−37
- src/Control/Concurrent/Async/Lifted/Safe.hs +13/−32
- tests/Test/Async/Common.hs +1/−4
- tests/Test/Async/IO.hs +1/−5
- tests/Test/Async/Reader.hs +21/−17
- tests/Test/Async/State.hs +21/−13
- tests/TestSuite.hs +1/−1
CHANGELOG.md view
@@ -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
README.md view
@@ -2,20 +2,14 @@ ========== [](https://hackage.haskell.org/package/lifted-async) [](http://packdeps.haskellers.com/feed?needle=lifted-async)-[](http://stackage.org/lts/package/lifted-async)-[](https://travis-ci.org/maoe/lifted-async)+[](http://stackage.org/lts/package/lifted-async)+[](https://github.com/maoe/lifted-async/actions/workflows/haskell-ci.yml) [](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 <maoe@foldr.in>.+This library is written and maintained by Mitsutoshi Aoe <me@maoe.name>. [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).
benchmarks/Benchmarks.hs view
@@ -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
lifted-async.cabal view
@@ -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 <maoe@foldr.in>-copyright: Copyright (C) 2012-2018 Mitsutoshi Aoe+maintainer: Mitsutoshi Aoe <me@maoe.name>+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
src/Control/Concurrent/Async/Lifted.hs view
@@ -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 <maoe@foldr.in> 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)
src/Control/Concurrent/Async/Lifted/Safe.hs view
@@ -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 <maoe@foldr.in> 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
tests/Test/Async/Common.hs view
@@ -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
tests/Test/Async/IO.hs view
@@ -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
tests/Test/Async/Reader.hs view
@@ -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."+ ]
tests/Test/Async/State.hs view
@@ -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."+ ]
tests/TestSuite.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-} module Main where import Test.Tasty (defaultMain, testGroup)