lifted-async-0.10.0.4/0000755000000000000000000000000007346545000012505 5ustar0000000000000000lifted-async-0.10.0.4/CHANGELOG.md0000755000000000000000000000536507346545000014332 0ustar0000000000000000# Revision history for lifted-async ## 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 ## v0.9.3.1 - 2017-12-12 * Relax upper version bound for tasty-hunit ## v0.9.3 - 2017-06-26 * Add Haddock comments for concurrently_ (#23) * Add replicateConcurrently and replicateConcurrently_ * Test with GHC 8.2.1 on Travis ## v0.9.2 - 2017-06-24 * Add concurrently_ (#22) ## v0.9.1.1 - 2017-01-26 * Relax upper version bound for constraints ## v0.9.1 - 2017-01-13 * Add (for|map)Concurrently_ (#21) ## v0.9.0 - 2016-05-22 * Leverage `StM m a ~ a` in the `Safe` module for faster `wait`/`poll`/`race`/`concurrently` ## v0.8.0.1 - 2015-01-17 * Relax upper bound for constraints ## v0.8.0 - 2016-01-10 * Drop Monad instance for Concurrently * Expose STM operations * Relax upper bound for base and async * Add Monoid and Semigroup instances for Concurrently ## v0.7.0.2 - 2015-11-26 * Relax upper bound for the constraints package * Upper bound remains < 0.6 for GHC < 7.8 as constraints-0.6 requires the closed type families extension. * Drop support for GHC 7.4.2 ## v0.7.0.1 - 2015-05-18 * Fix typecheck error with GHC HEAD (#17) ## v0.7.0 - 2015-03-30 * Fix the unnecessarily constrained type of link2 (#16) * Turn the caveat in the Safe module into a WARNING pragma (#15) ## v0.6.0.1 - 2015-01-14 * Increase the lower bound for base to >= 4.5 ## v0.6.0 - 2015-01-13 * Replace `StM m a ~ a` in the type signatures with `Forall (Pure m)` (#12) ## v0.5.0.1 - 2014-12-29 * Fix build issues in the test suite (#11 and others) ## v0.5.0 - 2014-12-29 * Simplify the type of `Concurrently` (#10) ## v0.4.0 - 2014-12-29 * Accept `constraints > 0.4` as well even when built with ghc < 7.8. * Support for GHC 7.10.1 ## v0.3.0 - 2014-12-28 * Support for `monad-control == 1.0.*` * `waitEither_` and `race_` now discard monadic effects besides `IO`. This is a breaking change. * `Control.Concurrent.Async.Lifted.Safe` is added. * Add `Monad` instance for `Concurrently` * Relax upper bound for base ## v0.2.0.2 - 2014-08-20 * Fix build failure in the test suite (#6) ## v0.2.0.1 - 2014-07-26 * Fix a typo in a haddock comment (#5 by @supki) * Fix Travis CI failure ## v0.2.0 - 2014-05-01 * Generalize `Concurrently` (#4) lifted-async-0.10.0.4/LICENSE0000644000000000000000000000277307346545000013523 0ustar0000000000000000Copyright (c) 2012-2017, Mitsutoshi Aoe All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Mitsutoshi Aoe nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. lifted-async-0.10.0.4/README.md0000755000000000000000000000244007346545000013767 0ustar0000000000000000lifted-async ========== [![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) [![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 . [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). lifted-async-0.10.0.4/Setup.hs0000644000000000000000000000005607346545000014142 0ustar0000000000000000import Distribution.Simple main = defaultMain lifted-async-0.10.0.4/benchmarks/0000755000000000000000000000000007346545000014622 5ustar0000000000000000lifted-async-0.10.0.4/benchmarks/Benchmarks.hs0000644000000000000000000001073107346545000017235 0ustar0000000000000000module Main where import Control.Exception (SomeException(..)) import Criterion.Main import qualified Control.Concurrent.Async as A import qualified Control.Concurrent.Async.Lifted as L import qualified Control.Concurrent.Async.Lifted.Safe as LS main :: IO () main = defaultMain [ bgroup "async-wait" [ bench "async" $ whnfIO asyncWait_async , 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 "waitAny" [ bench "async" $ whnfIO waitAny_async , bench "lifted-async" $ whnfIO waitAny_liftedAsync , bench "lifted-async-safe" $ whnfIO waitAny_liftedAsyncSafe ] , bgroup "race" [ bench "async" $ nfIO race_async , bench "lifted-async" $ nfIO race_liftedAsync , bench "lifted-async-safe" $ nfIO race_liftedAsyncSafe , bench "async (inlined)" $ nfIO race_async_inlined , bench "lifted-async (inlined)" $ nfIO race_liftedAsync_inlined ] , bgroup "concurrently" [ bench "async" $ nfIO concurrently_async , bench "lifted-async" $ nfIO concurrently_liftedAsync , bench "lifted-async-safe" $ nfIO concurrently_liftedAsyncSafe , bench "async (inlined)" $ nfIO concurrently_async_inlined , bench "lifted-async (inlined)" $ nfIO concurrently_liftedAsync_inlined ] , bgroup "mapConcurrently" [ bench "async" $ nfIO mapConcurrently_async , bench "lifted-async" $ nfIO mapConcurrently_liftedAsync , bench "lifted-async-safe" $ nfIO mapConcurrently_liftedAsyncSafe ] ] asyncWait_async :: IO Int asyncWait_async = do a <- A.async (return 1) A.wait a asyncWait_liftedAsync :: IO Int asyncWait_liftedAsync = do a <- L.async (return 1) L.wait a asyncWait_liftedAsyncSafe :: IO Int asyncWait_liftedAsyncSafe = do a <- LS.async (return 1) LS.wait a asyncCancelWaitCatch_async :: IO (Either SomeException Int) asyncCancelWaitCatch_async = do a <- A.async (return 1) A.cancel a A.waitCatch a asyncCancelWaitCatch_liftedAsync :: IO (Either SomeException Int) asyncCancelWaitCatch_liftedAsync = do a <- L.async (return 1) L.cancel a L.waitCatch a asyncCancelWaitCatch_liftedAsyncSafe :: IO (Either SomeException Int) asyncCancelWaitCatch_liftedAsyncSafe = do a <- LS.async (return 1) LS.cancel a LS.waitCatch a waitAny_async :: IO Int waitAny_async = do as <- mapM (A.async . return) [1..10] (_, n) <- A.waitAny as return n waitAny_liftedAsync :: IO Int waitAny_liftedAsync = do as <- mapM (L.async . return) [1..10] (_, n) <- L.waitAny as return n waitAny_liftedAsyncSafe :: IO Int waitAny_liftedAsyncSafe = do as <- mapM (LS.async . return) [1..10] (_, n) <- LS.waitAny as return n race_async :: IO (Either Int Int) race_async = A.race (return 1) (return 2) race_liftedAsync :: IO (Either Int Int) race_liftedAsync = L.race (return 1) (return 2) race_liftedAsyncSafe :: IO (Either Int Int) race_liftedAsyncSafe = LS.race (return 1) (return 2) race_async_inlined :: IO (Either Int Int) race_async_inlined = A.withAsync (return 1) $ \a -> A.withAsync (return 2) $ \b -> A.waitEither a b race_liftedAsync_inlined :: IO (Either Int Int) race_liftedAsync_inlined = L.withAsync (return 1) $ \a -> L.withAsync (return 2) $ \b -> L.waitEither a b concurrently_async :: IO (Int, Int) concurrently_async = A.concurrently (return 1) (return 2) concurrently_liftedAsync :: IO (Int, Int) concurrently_liftedAsync = L.concurrently (return 1) (return 2) concurrently_liftedAsyncSafe :: IO (Int, Int) concurrently_liftedAsyncSafe = LS.concurrently (return 1) (return 2) concurrently_async_inlined :: IO (Int, Int) concurrently_async_inlined = A.withAsync (return 1) $ \a -> A.withAsync (return 2) $ \b -> A.waitBoth a b concurrently_liftedAsync_inlined :: IO (Int, Int) concurrently_liftedAsync_inlined = L.withAsync (return 1) $ \a -> L.withAsync (return 2) $ \b -> L.waitBoth a b mapConcurrently_async :: IO [Int] mapConcurrently_async = A.mapConcurrently return [1..10] mapConcurrently_liftedAsync :: IO [Int] mapConcurrently_liftedAsync = L.mapConcurrently return [1..10] mapConcurrently_liftedAsyncSafe :: IO [Int] mapConcurrently_liftedAsyncSafe = LS.mapConcurrently return [1..10] lifted-async-0.10.0.4/lifted-async.cabal0000644000000000000000000000502307346545000016053 0ustar0000000000000000name: lifted-async version: 0.10.0.4 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-2019 Mitsutoshi Aoe category: Concurrency build-type: Simple cabal-version: >= 1.8 tested-with: GHC == 8.8.1 GHC == 8.6.5 GHC == 8.4.4 GHC == 8.2.2 GHC == 8.0.2 GHC == 7.10.3 extra-source-files: README.md CHANGELOG.md description: This package provides IO operations from @async@ package lifted to any instance of 'MonadBase' or 'MonadBaseControl'. library exposed-modules: Control.Concurrent.Async.Lifted Control.Concurrent.Async.Lifted.Safe build-depends: base >= 4.5 && < 4.14 , async >= 2.2 && < 2.3 , lifted-base >= 0.2 && < 0.3 , transformers-base >= 0.4 && < 0.5 , monad-control == 1.0.* if impl(ghc >= 7.8) build-depends: constraints >= 0.2 && < 0.12 else build-depends: constraints >= 0.2 && < 0.6 ghc-options: -Wall hs-source-dirs: src test-suite test-lifted-async type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: TestSuite.hs other-modules: Test.Async.Common 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.12 , tasty-hunit >= 0.9 && < 0.11 , tasty-th test-suite regression-tests type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: RegressionTests.hs ghc-options: -Wall -threaded build-depends: base , async , lifted-async , mtl , tasty-hunit >= 0.9 && < 0.11 , tasty-th benchmark benchmark-lifted-async type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: Benchmarks.hs ghc-options: -Wall build-depends: base , async , criterion , deepseq , lifted-async benchmark benchmark-lifted-async-threaded type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: Benchmarks.hs ghc-options: -Wall -threaded build-depends: base , async , criterion , deepseq , lifted-async source-repository head type: git branch: develop location: https://github.com/maoe/lifted-async.git lifted-async-0.10.0.4/src/Control/Concurrent/Async/0000755000000000000000000000000007346545000020113 5ustar0000000000000000lifted-async-0.10.0.4/src/Control/Concurrent/Async/Lifted.hs0000644000000000000000000003216707346545000021667 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {- | Module : Control.Concurrent.Async.Lifted Copyright : Copyright (C) 2012-2018 Mitsutoshi Aoe License : BSD-style (see the file LICENSE) Maintainer : Mitsutoshi Aoe Stability : experimental This is a wrapped version of @Control.Concurrent.Async@ with types generalized from 'IO' to all monads in either 'MonadBase' or 'MonadBaseControl'. All the functions restore the monadic effects in the forked computation unless specified otherwise. 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. -} module Control.Concurrent.Async.Lifted ( -- * Asynchronous actions A.Async -- ** Spawning , async, asyncBound, asyncOn , asyncWithUnmask, asyncOnWithUnmask -- ** Spawning with automatic 'cancel'ation , withAsync, withAsyncBound, withAsyncOn , withAsyncWithUnmask, withAsyncOnWithUnmask -- ** Quering 'Async's , wait, poll, waitCatch , cancel , uninterruptibleCancel , cancelWith , A.asyncThreadId , A.AsyncCancelled(..) -- ** STM operations , A.waitSTM, A.pollSTM, A.waitCatchSTM -- ** Waiting for multiple 'Async's , waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel , waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel , waitEither_ , waitBoth -- ** Waiting for multiple 'Async's in STM , A.waitAnySTM , A.waitAnyCatchSTM , A.waitEitherSTM , A.waitEitherCatchSTM , A.waitEitherSTM_ , A.waitBothSTM -- ** Linking , link, link2 , A.ExceptionInLinkedThread(..) -- * Convenient utilities , race, race_, concurrently, concurrently_ , mapConcurrently, mapConcurrently_ , forConcurrently, forConcurrently_ , replicateConcurrently, replicateConcurrently_ , Concurrently(..) , A.compareAsyncs ) where import Control.Applicative import Control.Concurrent (threadDelay) import Control.Monad ((>=>), forever, void) import Data.Foldable (fold) import GHC.IO (unsafeUnmask) import Prelude import Control.Concurrent.Async (Async) import Control.Exception.Lifted (SomeException, Exception) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Trans.Control 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) import Data.Semigroup (Semigroup((<>))) #endif -- | Generalized version of 'A.async'. async :: MonadBaseControl IO m => m a -> m (Async (StM m a)) async = asyncUsing A.async -- | Generalized version of 'A.asyncBound'. asyncBound :: MonadBaseControl IO m => m a -> m (Async (StM m a)) asyncBound = asyncUsing A.asyncBound -- | Generalized version of 'A.asyncOn'. asyncOn :: MonadBaseControl IO m => Int -> m a -> m (Async (StM m a)) asyncOn cpu = asyncUsing (A.asyncOn cpu) -- | Generalized version of 'A.asyncWithUnmask'. asyncWithUnmask :: MonadBaseControl IO m => ((forall b. m b -> m b) -> m a) -> m (Async (StM m a)) asyncWithUnmask actionWith = asyncUsing A.async (actionWith (liftBaseOp_ unsafeUnmask)) -- | Generalized version of 'A.asyncOnWithUnmask'. asyncOnWithUnmask :: MonadBaseControl IO m => Int -> ((forall b. m b -> m b) -> m a) -> m (Async (StM m a)) asyncOnWithUnmask cpu actionWith = asyncUsing (A.asyncOn cpu) (actionWith (liftBaseOp_ unsafeUnmask)) asyncUsing :: MonadBaseControl IO m => (IO (StM m a) -> IO (Async (StM m a))) -> m a -> m (Async (StM m a)) asyncUsing fork m = liftBaseWith $ \runInIO -> fork (runInIO m) -- | Generalized version of 'A.withAsync'. withAsync :: MonadBaseControl IO m => m a -> (Async (StM m a) -> m b) -> m b withAsync = withAsyncUsing async {-# INLINABLE withAsync #-} -- | Generalized version of 'A.withAsyncBound'. withAsyncBound :: MonadBaseControl IO m => m a -> (Async (StM m a) -> m b) -> m b withAsyncBound = withAsyncUsing asyncBound {-# INLINABLE withAsyncBound #-} -- | Generalized version of 'A.withAsyncOn'. withAsyncOn :: MonadBaseControl IO m => Int -> m a -> (Async (StM m a) -> m b) -> m b withAsyncOn = withAsyncUsing . asyncOn {-# INLINABLE withAsyncOn #-} -- | Generalized version of 'A.withAsyncWithUnmask'. withAsyncWithUnmask :: MonadBaseControl IO m => ((forall c. m c -> m c) -> m a) -> (Async (StM m a) -> m b) -> m b withAsyncWithUnmask actionWith = withAsyncUsing async (actionWith (liftBaseOp_ unsafeUnmask)) {-# INLINABLE withAsyncWithUnmask #-} -- | Generalized version of 'A.withAsyncOnWithUnmask'. withAsyncOnWithUnmask :: MonadBaseControl IO m => Int -> ((forall c. m c -> m c) -> m a) -> (Async (StM m a) -> m b) -> m b withAsyncOnWithUnmask cpu actionWith = withAsyncUsing (asyncOn cpu) (actionWith (liftBaseOp_ unsafeUnmask)) {-# INLINABLE withAsyncOnWithUnmask #-} withAsyncUsing :: MonadBaseControl IO m => (m a -> m (Async (StM m a))) -> m a -> (Async (StM m a) -> m b) -> m b withAsyncUsing fork action inner = E.mask $ \restore -> do a <- fork $ restore action r <- restore (inner a) `E.catch` \e -> do cancel a E.throwIO (e :: SomeException) cancel a return r -- | Generalized version of 'A.wait'. wait :: MonadBaseControl IO m => Async (StM m a) -> m a wait = liftBase . A.wait >=> restoreM -- | Generalized version of 'A.poll'. poll :: MonadBaseControl IO m => Async (StM m a) -> m (Maybe (Either SomeException a)) poll a = liftBase (A.poll a) >>= maybe (return Nothing) (fmap Just . sequenceEither) -- | Generalized version of 'A.cancel'. cancel :: MonadBase IO m => Async a -> m () cancel = liftBase . A.cancel -- | Generalized version of 'A.cancelWith'. 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 => Async (StM m a) -> m (Either SomeException a) waitCatch a = liftBase (A.waitCatch a) >>= sequenceEither -- | Generalized version of 'A.waitAny'. waitAny :: MonadBaseControl IO m => [Async (StM m a)] -> m (Async (StM m a), a) waitAny as = do (a, s) <- liftBase $ A.waitAny as r <- restoreM s return (a, r) -- | Generalized version of 'A.waitAnyCatch'. waitAnyCatch :: MonadBaseControl IO m => [Async (StM m a)] -> m (Async (StM m a), Either SomeException a) waitAnyCatch as = do (a, s) <- liftBase $ A.waitAnyCatch as r <- sequenceEither s return (a, r) -- | Generalized version of 'A.waitAnyCancel'. waitAnyCancel :: MonadBaseControl IO m => [Async (StM m a)] -> m (Async (StM m a), a) waitAnyCancel as = do (a, s) <- liftBase $ A.waitAnyCancel as r <- restoreM s return (a, r) -- | Generalized version of 'A.waitAnyCatchCancel'. waitAnyCatchCancel :: MonadBaseControl IO m => [Async (StM m a)] -> m (Async (StM m a), Either SomeException a) waitAnyCatchCancel as = do (a, s) <- liftBase $ A.waitAnyCatchCancel as r <- sequenceEither s return (a, r) -- | Generalized version of 'A.waitEither'. waitEither :: MonadBaseControl IO m => Async (StM m a) -> Async (StM m b) -> m (Either a b) waitEither a b = liftBase (A.waitEither a b) >>= either (fmap Left . restoreM) (fmap Right . restoreM) -- | Generalized version of 'A.waitEitherCatch'. waitEitherCatch :: MonadBaseControl IO m => Async (StM m a) -> Async (StM m b) -> m (Either (Either SomeException a) (Either SomeException b)) waitEitherCatch a b = liftBase (A.waitEitherCatch a b) >>= either (fmap Left . sequenceEither) (fmap Right . sequenceEither) -- | Generalized version of 'A.waitEitherCancel'. waitEitherCancel :: MonadBaseControl IO m => Async (StM m a) -> Async (StM m b) -> m (Either a b) waitEitherCancel a b = liftBase (A.waitEitherCancel a b) >>= either (fmap Left . restoreM) (fmap Right . restoreM) -- | Generalized version of 'A.waitEitherCatchCancel'. waitEitherCatchCancel :: MonadBaseControl IO m => Async (StM m a) -> Async (StM m b) -> m (Either (Either SomeException a) (Either SomeException b)) waitEitherCatchCancel a b = liftBase (A.waitEitherCatch a b) >>= either (fmap Left . sequenceEither) (fmap Right . sequenceEither) -- | Generalized version of 'A.waitEither_'. -- -- NOTE: This function discards the monadic effects besides IO in the forked -- computation. waitEither_ :: MonadBase IO m => Async a -> Async b -> m () waitEither_ a b = liftBase (A.waitEither_ a b) -- | Generalized version of 'A.waitBoth'. waitBoth :: MonadBaseControl IO m => Async (StM m a) -> Async (StM m b) -> m (a, b) waitBoth a b = do (sa, sb) <- liftBase (A.waitBoth a b) ra <- restoreM sa rb <- restoreM sb return (ra, rb) {-# INLINABLE waitBoth #-} -- | Generalized version of 'A.link'. link :: MonadBase IO m => Async a -> m () link = liftBase . A.link -- | Generalized version of 'A.link2'. link2 :: MonadBase IO m => Async a -> Async b -> m () link2 = (liftBase .) . A.link2 -- | Generalized version of 'A.race'. race :: MonadBaseControl IO m => m a -> m b -> m (Either a b) race left right = withAsync left $ \a -> withAsync right $ \b -> waitEither a b {-# INLINABLE race #-} -- | Generalized version of 'A.race_'. -- -- NOTE: This function discards the monadic effects besides IO in the forked -- computation. race_ :: MonadBaseControl IO m => m a -> m b -> m () race_ left right = withAsync left $ \a -> withAsync right $ \b -> waitEither_ a b {-# INLINABLE race_ #-} -- | Generalized version of 'A.concurrently'. concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b) concurrently left right = withAsync left $ \a -> withAsync right $ \b -> waitBoth a b {-# INLINABLE concurrently #-} -- | Generalized version of 'A.concurrently_'. concurrently_ :: MonadBaseControl IO m => m a -> m b -> m () concurrently_ left right = void $ concurrently left right {-# INLINABLE concurrently_ #-} -- | Generalized version of 'A.mapConcurrently'. mapConcurrently :: (Traversable t, MonadBaseControl IO m) => (a -> m b) -> t a -> m (t b) mapConcurrently f = runConcurrently . traverse (Concurrently . f) -- | Generalized version of 'A.mapConcurrently_'. mapConcurrently_ :: (Foldable t, MonadBaseControl IO m) => (a -> m b) -> t a -> m () mapConcurrently_ f = runConcurrently . foldMap (Concurrently . void . f) -- | Generalized version of 'A.forConcurrently'. forConcurrently :: (Traversable t, MonadBaseControl IO m) => t a -> (a -> m b) -> m (t b) forConcurrently = flip mapConcurrently -- | Generalized version of 'A.forConcurrently_'. forConcurrently_ :: (Foldable t, MonadBaseControl IO m) => t a -> (a -> m b) -> m () forConcurrently_ = flip mapConcurrently_ -- | Generalized version of 'A.replicateConcurrently'. replicateConcurrently :: MonadBaseControl IO m => Int -> m a -> m [a] replicateConcurrently n = runConcurrently . sequenceA . replicate n . Concurrently -- | Generalized version of 'A.replicateConcurrently_'. replicateConcurrently_ :: MonadBaseControl IO m => Int -> m a -> m () replicateConcurrently_ n = runConcurrently . fold . replicate n . Concurrently . void -- | Generalized version of 'A.Concurrently'. -- -- A value of type @'Concurrently' m a@ is an IO-based operation that can be -- composed with other 'Concurrently' values, using the 'Applicative' and -- 'Alternative' instances. -- -- Calling 'runConcurrently' on a value of type @'Concurrently' m a@ will -- execute the IO-based lifted operations it contains concurrently, before -- delivering the result of type 'a'. -- -- For example -- -- @ -- (page1, page2, page3) <- 'runConcurrently' $ (,,) -- '<$>' 'Concurrently' (getURL "url1") -- '<*>' 'Concurrently' (getURL "url2") -- '<*>' 'Concurrently' (getURL "url3") -- @ newtype Concurrently m a = Concurrently { runConcurrently :: m a } instance Functor m => Functor (Concurrently m) where fmap f (Concurrently a) = Concurrently $ f <$> a instance MonadBaseControl IO m => Applicative (Concurrently m) where pure = Concurrently . pure Concurrently fs <*> Concurrently as = Concurrently $ uncurry ($) <$> concurrently fs as instance MonadBaseControl IO m => Alternative (Concurrently m) where empty = Concurrently $ liftBaseWith $ const (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 (<>) instance (MonadBaseControl IO m, Semigroup a, Monoid a) => 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) (fmap Right . restoreM) lifted-async-0.10.0.4/src/Control/Concurrent/Async/Lifted/0000755000000000000000000000000007346545000021322 5ustar0000000000000000lifted-async-0.10.0.4/src/Control/Concurrent/Async/Lifted/Safe.hs0000644000000000000000000003306307346545000022541 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {- | Module : Control.Concurrent.Async.Lifted.Safe Copyright : Copyright (C) 2012-2018 Mitsutoshi Aoe License : BSD-style (see the file LICENSE) Maintainer : Mitsutoshi Aoe Stability : experimental This is a safe variant of @Control.Concurrent.Async.Lifted@. This module assumes your monad stack to satisfy @'StM' m a ~ a@ so you can't mess up monadic effects. If your monad stack is stateful, use @Control.Concurrent.Async.Lifted@ with special care. -} module Control.Concurrent.Async.Lifted.Safe ( -- * Asynchronous actions A.Async , Pure , Forall -- ** Spawning , async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask -- ** Spawning with automatic 'cancel'ation , withAsync, withAsyncBound, withAsyncOn , withAsyncWithUnmask, withAsyncOnWithUnmask -- ** Quering 'Async's , wait, poll, waitCatch , cancel , uninterruptibleCancel , cancelWith , A.asyncThreadId , A.AsyncCancelled(..) -- ** STM operations , A.waitSTM, A.pollSTM, A.waitCatchSTM -- ** Waiting for multiple 'Async's , waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel , waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel , waitEither_ , waitBoth -- ** Waiting for multiple 'Async's in STM , A.waitAnySTM , A.waitAnyCatchSTM , A.waitEitherSTM , A.waitEitherCatchSTM , A.waitEitherSTM_ , A.waitBothSTM -- ** Linking , Unsafe.link, Unsafe.link2 , A.ExceptionInLinkedThread(..) -- * Convenient utilities , race, race_, concurrently, concurrently_ , mapConcurrently, mapConcurrently_ , forConcurrently, forConcurrently_ , replicateConcurrently, replicateConcurrently_ , Concurrently(..) , A.compareAsyncs ) where import Control.Applicative import Control.Concurrent (threadDelay) import Control.Monad import Data.Foldable (fold) import Control.Concurrent.Async (Async) import Control.Exception.Lifted (SomeException, Exception) import Control.Monad.Base (MonadBase(..)) import Control.Monad.Trans.Control hiding (restoreM) import Data.Constraint ((\\), (:-)) import Data.Constraint.Forall (Forall, inst) import qualified Control.Concurrent.Async as A 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) import Data.Semigroup (Semigroup((<>))) #endif -- | Generalized version of 'A.async'. async :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) => m a -> m (Async a) async = Unsafe.async \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.asyncBound'. asyncBound :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) => m a -> m (Async a) asyncBound = Unsafe.asyncBound \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.asyncOn'. asyncOn :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) => Int -> m a -> m (Async a) asyncOn cpu m = Unsafe.asyncOn cpu m \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.asyncWithUnmask'. asyncWithUnmask :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) => ((forall b. m b -> m b) -> m a) -> m (Async a) asyncWithUnmask restore = Unsafe.asyncWithUnmask restore \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.asyncOnWithUnmask'. asyncOnWithUnmask :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) => Int -> ((forall b. m b -> m b) -> m a) -> m (Async a) asyncOnWithUnmask cpu restore = Unsafe.asyncOnWithUnmask cpu restore \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.withAsync'. withAsync :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) => m a -> (Async a -> m b) -> m b withAsync = Unsafe.withAsync \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.withAsyncBound'. withAsyncBound :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) => m a -> (Async a -> m b) -> m b withAsyncBound = Unsafe.withAsyncBound \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.withAsyncOn'. withAsyncOn :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) => Int -> m a -> (Async a -> m b) -> m b withAsyncOn = Unsafe.withAsyncOn \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.withAsyncWithUnmask'. withAsyncWithUnmask :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) => ((forall c. m c -> m c) -> m a) -> (Async a -> m b) -> m b withAsyncWithUnmask restore = Unsafe.withAsyncWithUnmask restore \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.withAsyncOnWithUnmask'. withAsyncOnWithUnmask :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) => Int -> ((forall c. m c -> m c) -> m a) -> (Async a -> m b) -> m b withAsyncOnWithUnmask cpu restore = Unsafe.withAsyncOnWithUnmask cpu restore \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.wait'. wait :: forall m a. (MonadBase IO m, Forall (Pure m)) => Async a -> m a wait = liftBase . A.wait \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.poll'. poll :: forall m a. (MonadBase IO m, Forall (Pure m)) => Async a -> m (Maybe (Either SomeException a)) poll = liftBase . A.poll \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.waitCatch'. waitCatch :: forall m a. (MonadBase IO m, Forall (Pure m)) => Async a -> m (Either SomeException a) waitCatch = liftBase . A.waitCatch \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.cancel'. cancel :: MonadBase IO m => Async a -> m () cancel = Unsafe.cancel -- | Generalized version of 'A.cancelWith'. 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)) => [Async a] -> m (Async a, a) waitAny = liftBase . A.waitAny \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.waitAnyCatch'. waitAnyCatch :: forall m a. (MonadBase IO m, Forall (Pure m)) => [Async a] -> m (Async a, Either SomeException a) waitAnyCatch = liftBase . A.waitAnyCatch \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.waitAnyCancel'. waitAnyCancel :: forall m a. (MonadBase IO m, Forall (Pure m)) => [Async a] -> m (Async a, a) waitAnyCancel = liftBase . A.waitAnyCancel \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.waitAnyCatchCancel'. waitAnyCatchCancel :: forall m a. (MonadBase IO m, Forall (Pure m)) => [Async a] -> m (Async a, Either SomeException a) waitAnyCatchCancel = liftBase . A.waitAnyCatchCancel \\ (inst :: Forall (Pure m) :- Pure m a) -- | Generalized version of 'A.waitEither'. waitEither :: forall m a b. (MonadBase IO m, Forall (Pure m)) => Async a -> Async b -> m (Either a b) waitEither = (liftBase .) . A.waitEither \\ (inst :: Forall (Pure m) :- Pure m a) \\ (inst :: Forall (Pure m) :- Pure m b) -- | Generalized version of 'A.waitEitherCatch'. waitEitherCatch :: forall m a b. (MonadBase IO m, Forall (Pure m)) => Async a -> Async b -> m (Either (Either SomeException a) (Either SomeException b)) waitEitherCatch = (liftBase .) . A.waitEitherCatch \\ (inst :: Forall (Pure m) :- Pure m a) \\ (inst :: Forall (Pure m) :- Pure m b) -- | Generalized version of 'A.waitEitherCancel'. waitEitherCancel :: forall m a b. (MonadBase IO m, Forall (Pure m)) => Async a -> Async b -> m (Either a b) waitEitherCancel = (liftBase .) . A.waitEitherCancel \\ (inst :: Forall (Pure m) :- Pure m a) \\ (inst :: Forall (Pure m) :- Pure m b) -- | Generalized version of 'A.waitEitherCatchCancel'. waitEitherCatchCancel :: forall m a b. (MonadBase IO m, Forall (Pure m)) => Async a -> Async b -> m (Either (Either SomeException a) (Either SomeException b)) waitEitherCatchCancel = (liftBase .) . A.waitEitherCatchCancel \\ (inst :: Forall (Pure m) :- Pure m a) \\ (inst :: Forall (Pure m) :- Pure m b) -- | Generalized version of 'A.waitEither_' waitEither_ :: MonadBase IO m => Async a -> Async b -> m () waitEither_ = Unsafe.waitEither_ -- | Generalized version of 'A.waitBoth'. waitBoth :: forall m a b. (MonadBase IO m, Forall (Pure m)) => Async a -> Async b -> m (a, b) waitBoth = (liftBase .) . A.waitBoth \\ (inst :: Forall (Pure m) :- Pure m a) \\ (inst :: Forall (Pure m) :- Pure m b) -- | Generalized version of 'A.race'. race :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) => m a -> m b -> m (Either a b) race = liftBaseOp2_ A.race -- | Generalized version of 'A.race_'. race_ :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) => m a -> m b -> m () race_ = liftBaseOp2_ A.race_ -- | Generalized version of 'A.concurrently'. concurrently :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) => m a -> m b -> m (a, b) concurrently = liftBaseOp2_ A.concurrently -- | Generalized version of 'A.concurrently_'. concurrently_ :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) => m a -> m b -> m () concurrently_ = liftBaseOp2_ A.concurrently_ -- | Similar to 'A.liftBaseOp_' but takes a binary function -- and leverages @'StM' m a ~ a@. liftBaseOp2_ :: forall base m a b c. (MonadBaseControl base m, Forall (Pure m)) => (base a -> base b -> base c) -> m a -> m b -> m c liftBaseOp2_ f left right = liftBaseWith $ \run -> f (run left \\ (inst :: Forall (Pure m) :- Pure m a)) (run right \\ (inst :: Forall (Pure m) :- Pure m b)) -- | Generalized version of 'A.mapConcurrently'. mapConcurrently :: (Traversable t, MonadBaseControl IO m, Forall (Pure m)) => (a -> m b) -> t a -> m (t b) mapConcurrently f = runConcurrently . traverse (Concurrently . f) -- | Generalized version of 'A.mapConcurrently_'. mapConcurrently_ :: (Foldable t, MonadBaseControl IO m, Forall (Pure m)) => (a -> m b) -> t a -> m () mapConcurrently_ f = runConcurrently . foldMap (Concurrently . void . f) -- | Generalized version of 'A.forConcurrently'. forConcurrently :: (Traversable t, MonadBaseControl IO m, Forall (Pure m)) => t a -> (a -> m b) -> m (t b) forConcurrently = flip mapConcurrently -- | Generalized version of 'A.forConcurrently_'. forConcurrently_ :: (Foldable t, MonadBaseControl IO m, Forall (Pure m)) => t a -> (a -> m b) -> m () forConcurrently_ = flip mapConcurrently_ -- | Generalized version of 'A.replicateConcurrently'. replicateConcurrently :: (MonadBaseControl IO m, Forall (Pure m)) => Int -> m a -> m [a] replicateConcurrently n = runConcurrently . sequenceA . replicate n . Concurrently -- | Generalized version of 'A.replicateConcurrently_'. replicateConcurrently_ :: (MonadBaseControl IO m, Forall (Pure m)) => Int -> m a -> m () replicateConcurrently_ n = runConcurrently . fold . replicate n . Concurrently . void -- | Generalized version of 'A.Concurrently'. -- -- A value of type @'Concurrently' m a@ is an IO-based operation that can be -- composed with other 'Concurrently' values, using the 'Applicative' and -- 'Alternative' instances. -- -- Calling 'runConcurrently' on a value of type @'Concurrently' m a@ will -- execute the IO-based lifted operations it contains concurrently, before -- delivering the result of type 'a'. -- -- For example -- -- @ -- (page1, page2, page3) <- 'runConcurrently' $ (,,) -- '<$>' 'Concurrently' (getURL "url1") -- '<*>' 'Concurrently' (getURL "url2") -- '<*>' 'Concurrently' (getURL "url3") -- @ data Concurrently m a where Concurrently :: Forall (Pure m) => { runConcurrently :: m a } -> Concurrently m a -- | Most of the functions in this module have @'Forall' ('Pure' m)@ in their -- constraints, which means they require the monad 'm' satisfies -- @'StM' m a ~ a@ for all 'a'. class StM m a ~ a => Pure m a instance StM m a ~ a => Pure m a instance Functor m => Functor (Concurrently m) where fmap f (Concurrently a) = Concurrently $ f <$> a instance (MonadBaseControl IO m, Forall (Pure m)) => Applicative (Concurrently m) where pure = Concurrently . pure Concurrently (fs :: m (a -> b)) <*> Concurrently as = Concurrently (uncurry ($) <$> concurrently fs as) \\ (inst :: Forall (Pure m) :- Pure m a) \\ (inst :: Forall (Pure m) :- Pure m (a -> b)) instance (MonadBaseControl IO m, Forall (Pure m)) => Alternative (Concurrently m) where empty = Concurrently $ liftBaseWith $ const (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 (<>) instance (MonadBaseControl IO m, Semigroup a, Monoid a, Forall (Pure m)) => 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 lifted-async-0.10.0.4/tests/0000755000000000000000000000000007346545000013647 5ustar0000000000000000lifted-async-0.10.0.4/tests/RegressionTests.hs0000644000000000000000000000134407346545000017350 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE TemplateHaskell #-} import Control.Monad (when, void) import Data.Function (fix) import Data.IORef import Foreign.C.Types (CUInt(..)) import Control.Concurrent.Async.Lifted import Test.Tasty.TH import Test.Tasty.HUnit main :: IO () main = $defaultMainGenerator -- https://github.com/maoe/lifted-async/issues/1 case_issue1 :: Assertion case_issue1 = do ref <- newIORef (5 :: Int) withAsync (zombie ref) $ \_ -> return () n <- readIORef ref n @?= 5 where zombie ref = fix $ \loop -> do n <- readIORef ref when (n > 0) $ do void $ c_sleep 1 writeIORef ref $! n - 1 loop foreign import ccall safe "sleep" c_sleep :: CUInt -> IO CUInt lifted-async-0.10.0.4/tests/Test/Async/0000755000000000000000000000000007346545000015643 5ustar0000000000000000lifted-async-0.10.0.4/tests/Test/Async/Common.hs0000644000000000000000000000063207346545000017430 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} module Test.Async.Common ( value , TestException(..) , module X ) where import Data.Typeable import Control.Exception.Lifted import Test.Tasty as X import Test.Tasty.HUnit as X import Test.Tasty.TH as X value :: Int value = 42 data TestException = TestException deriving (Eq, Show, Typeable) instance Exception TestException lifted-async-0.10.0.4/tests/Test/Async/IO.hs0000644000000000000000000000451007346545000016506 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Test.Async.IO ( ioTestGroup ) where import Control.Monad (when, void) import Data.Maybe (isJust, isNothing) 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 ioTestGroup = $(testGroupGenerator) case_async_waitCatch :: Assertion case_async_waitCatch = do a <- async (return value) r <- waitCatch a case r of Left _ -> assertFailure "" Right e -> e @?= value case_async_wait :: Assertion case_async_wait = do a <- async (return value) r <- wait a assertEqual "async_wait" r value case_async_exwaitCatch :: Assertion case_async_exwaitCatch = do a <- async (throwIO TestException) r <- waitCatch a case r of Left e -> fromException e @?= Just TestException Right _ -> assertFailure "" case_async_exwait :: Assertion case_async_exwait = do a <- async (throwIO TestException) (wait a >> assertFailure "") `E.catch` \e -> e @?= TestException case_withAsync_waitCatch :: Assertion case_withAsync_waitCatch = do withAsync (return value) $ \a -> do r <- waitCatch a case r of Left _ -> assertFailure "" Right e -> e @?= value case_withAsync_wait2 :: Assertion case_withAsync_wait2 = do a <- withAsync (threadDelay 1000000) $ return r <- waitCatch a case r of Left e -> fromException e @?= Just AsyncCancelled Right _ -> assertFailure "" case_async_cancel :: Assertion case_async_cancel = sequence_ $ replicate 1000 run where run = do a <- async (return value) cancelWith a TestException r <- waitCatch a case r of Left e -> fromException e @?= Just TestException Right r' -> r' @?= value case_async_poll :: Assertion case_async_poll = do a <- async (threadDelay 1000000) r <- poll a when (isJust r) $ assertFailure "" r' <- poll a -- poll twice, just to check we don't deadlock when (isJust r') $ assertFailure "" case_async_poll2 :: Assertion case_async_poll2 = do a <- async (return value) void $ wait a r <- poll a when (isNothing r) $ assertFailure "" r' <- poll a -- poll twice, just to check we don't deadlock when (isNothing r') $ assertFailure "" lifted-async-0.10.0.4/tests/Test/Async/Reader.hs0000644000000000000000000000727307346545000017412 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Test.Async.Reader ( readerTestGroup ) where import Control.Monad.Reader 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 readerTestGroup = $(testGroupGenerator) case_async_waitCatch :: Assertion case_async_waitCatch = do r <- flip runReaderT value $ do a <- async $ return value waitCatch a case r of Left _ -> assertFailure "An exception must not be raised." Right e -> do e @?= value case_async_wait :: Assertion case_async_wait = do r <- flip runReaderT value $ do a <- async $ return value wait a r @?= value case_async_exwaitCatch :: Assertion case_async_exwaitCatch = do r <- flip runReaderT value $ do a <- async $ throwIO TestException waitCatch a case r of Left e -> fromException e @?= Just TestException Right _ -> assertFailure "An exception must be raised." case_async_exwait :: Assertion case_async_exwait = void $ flip runReaderT value $ do a <- async $ throwIO TestException (wait a >> liftIO (assertFailure "An exception must be raised")) `E.catch` \e -> liftIO $ e @?= TestException case_withAsync_waitCatch :: Assertion case_withAsync_waitCatch = void $ flip runReaderT value $ do withAsync (return value) $ \a -> do r <- waitCatch a case r of Left _ -> liftIO $ assertFailure "An exception must not be raised." Right e -> do liftIO $ e @?= value case_withAsync_wait2 :: Assertion case_withAsync_wait2 = do r <- flip runReaderT value $ do a <- withAsync (threadDelay 1000000) $ return waitCatch a case r of Left e -> do fromException e @?= Just AsyncCancelled Right _ -> assertFailure "An exception must be raised." case_async_cancel :: Assertion case_async_cancel = sequence_ $ replicate 1000 run where run = do r <- flip runReaderT value $ do a <- async $ return value cancelWith a TestException waitCatch a case r of Left e -> fromException e @?= Just TestException Right r' -> r' @?= value case_async_poll :: Assertion case_async_poll = void $ flip runReaderT value $ do a <- async (threadDelay 1000000) r <- poll a when (isJust r) $ liftIO $ assertFailure "The result must be nothing." r' <- poll a -- poll twice, just to check we don't deadlock when (isJust r') $ liftIO $ assertFailure "The result must be Nothing." case_async_poll2 :: Assertion case_async_poll2 = void $ flip runReaderT value $ do a <- async (return value) void $ wait a r <- poll a when (isNothing r) $ liftIO $ assertFailure "The result must not be Nothing." r' <- poll a -- poll twice, just to check we don't deadlock when (isNothing r') $ liftIO $ assertFailure "The result must not be Nothing." 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." ] lifted-async-0.10.0.4/tests/Test/Async/State.hs0000644000000000000000000001136007346545000017260 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Test.Async.State ( stateTestGroup ) where import Control.Monad.State 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 stateTestGroup :: TestTree stateTestGroup = $(testGroupGenerator) case_async_waitCatch :: Assertion case_async_waitCatch = do (r, s) <- flip runStateT value $ do a <- async $ modify (+1) >> return value waitCatch a case r of Left _ -> assertFailure "An exception must not be raised." Right e -> do e @?= value s @?= value + 1 case_async_wait :: Assertion case_async_wait = do (r, s) <- flip runStateT value $ do a <- async $ modify (+1) >> return value wait a r @?= value s @?= value + 1 case_async_exwaitCatch :: Assertion case_async_exwaitCatch = do (r, s) <- flip runStateT value $ do a <- async $ modify (+1) >> throwIO TestException waitCatch a case r of Left e -> do fromException e @?= Just TestException s @?= value Right _ -> assertFailure "An exception must be raised." case_async_exwait :: Assertion case_async_exwait = void $ flip runStateT value $ do a <- async $ modify (+1) >> throwIO TestException (wait a >> liftIO (assertFailure "An exception must be raised")) `E.catch` \e -> do liftIO $ e @?= TestException s <- get liftIO $ s @?= value case_withAsync_waitCatch :: Assertion case_withAsync_waitCatch = void $ flip runStateT value $ do withAsync (modify (+1) >> return value) $ \a -> do r <- waitCatch a case r of Left _ -> liftIO $ assertFailure "An exception must not be raised." Right e -> do liftIO $ e @?= value s <- get liftIO $ s @?= value + 1 case_withAsync_wait2 :: Assertion case_withAsync_wait2 = do (r, s) <- flip runStateT value $ do a <- withAsync (modify (+1) >> threadDelay 1000000) $ return waitCatch a case r of Left e -> do fromException e @?= Just AsyncCancelled s @?= value Right _ -> assertFailure "An exception must be raised." case_async_cancel :: Assertion case_async_cancel = sequence_ $ replicate 1000 run where run = do (r, s) <- flip runStateT value $ do a <- async $ modify (+1) >> return value cancelWith a TestException waitCatch a case r of Left e -> do fromException e @?= Just TestException s @?= value Right r' -> do r' @?= value s @?= value + 1 case_async_poll :: Assertion case_async_poll = void $ flip runStateT value $ do a <- async (threadDelay 1000000) r <- poll a when (isJust r) $ liftIO $ assertFailure "The result must be nothing." r' <- poll a -- poll twice, just to check we don't deadlock when (isJust r') $ liftIO $ assertFailure "The result must be Nothing." case_async_poll2 :: Assertion case_async_poll2 = void $ flip runStateT value $ do a <- async (return value) void $ wait a r <- poll a when (isNothing r) $ liftIO $ assertFailure "The result must not be Nothing." r' <- poll a -- poll twice, just to check we don't deadlock when (isNothing r') $ liftIO $ assertFailure "The result must not be Nothing." case_withAsync_waitEither :: Assertion case_withAsync_waitEither = do (_, s) <- flip runStateT value $ do withAsync (modify (+1)) $ \a -> waitEither a a liftIO $ s @?= value + 1 case_withAsync_waitEither_ :: Assertion case_withAsync_waitEither_ = do ((), s) <- flip runStateT value $ do withAsync (modify (+1)) $ \a -> waitEither_ a a liftIO $ s @?= value case_withAsync_waitBoth1 :: Assertion case_withAsync_waitBoth1 = do (_, s) <- flip runStateT value $ do withAsync (return value) $ \a -> withAsync (modify (+1)) $ \b -> waitBoth a b liftIO $ s @?= value + 1 case_withAsync_waitBoth2 :: Assertion case_withAsync_waitBoth2 = do (_, s) <- flip runStateT value $ do withAsync (modify (+1)) $ \a -> withAsync (return value) $ \b -> waitBoth a b liftIO $ s @?= value 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." ] lifted-async-0.10.0.4/tests/TestSuite.hs0000644000000000000000000000047707346545000016144 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-} module Main where import Test.Tasty (defaultMain, testGroup) import Test.Async.IO import Test.Async.State import Test.Async.Reader main :: IO () main = defaultMain $ testGroup "lifted-async test suite" [ ioTestGroup , stateTestGroup , readerTestGroup ]