packages feed

lifted-async 0.2.0.2 → 0.11.0

raw patch · 12 files changed

Files

CHANGELOG.md view
@@ -1,3 +1,180 @@+# 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++## 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)
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2012, Mitsutoshi Aoe+Copyright (c) 2012-2017, Mitsutoshi Aoe  All rights reserved.
README.md view
@@ -1,18 +1,15 @@ lifted-async ==========-[![Build Status](https://secure.travis-ci.org/maoe/lifted-async.png)](http://travis-ci.org/maoe/lifted-async)-[![Coverage Status](https://coveralls.io/repos/maoe/lifted-async/badge.png)](https://coveralls.io/r/maoe/lifted-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](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 <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,40 +1,46 @@-{-# LANGUAGE BangPatterns #-} 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  main :: IO () main = defaultMain   [ bgroup "async-wait"       [ bench "async" $ whnfIO asyncWait_async       , bench "lifted-async" $ whnfIO asyncWait_liftedAsync-      ]-  , bgroup "async-cancel-waitCatch"-      [ bench "async" $ whnfIO asyncCancelWaitCatch_async-      , bench "lifted-async" $ whnfIO asyncCancelWaitCatch_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       ]   ] @@ -48,6 +54,11 @@   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)@@ -60,6 +71,12 @@   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]@@ -72,6 +89,12 @@   (_, 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)@@ -80,6 +103,10 @@ 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 ->@@ -100,6 +127,10 @@ 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 ->@@ -119,3 +150,7 @@ mapConcurrently_liftedAsync :: IO [Int] mapConcurrently_liftedAsync =   L.mapConcurrently return [1..10]++mapConcurrently_liftedAsyncSafe :: IO [Int]+mapConcurrently_liftedAsyncSafe =+  LS.mapConcurrently return [1..10]
lifted-async.cabal view
@@ -1,18 +1,33 @@+cabal-version:       1.24 name:                lifted-async-version:             0.2.0.2+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-2014 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 == 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 @@ -21,16 +36,19 @@   instance of 'MonadBase' or 'MonadBaseControl'.  library+  hs-source-dirs: src   exposed-modules:     Control.Concurrent.Async.Lifted+    Control.Concurrent.Async.Lifted.Safe   build-depends:-      base >= 4.3 && < 4.8-    , async >= 2.0.1-    , lifted-base >= 0.2-    , monad-control >= 0.3.1-    , transformers-base >= 0.4+      base >= 4.9 && < 4.23+    , async >= 2.2 && < 2.3+    , lifted-base >= 0.2 && < 0.3+    , transformers-base >= 0.4 && < 0.5+    , 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@@ -40,60 +58,56 @@     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-hunit == 0.9.*+    , 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   hs-source-dirs: tests   main-is: RegressionTests.hs-  ghc-options: -Wall -O -threaded+  ghc-options: -Wall -threaded   build-depends:       base-    , async     , lifted-async-    , mtl-    , tasty-hunit == 0.9.*+    , tasty-hunit >= 0.9 && < 0.11     , tasty-th+  default-language: Haskell2010  benchmark benchmark-lifted-async   type: exitcode-stdio-1.0   hs-source-dirs: benchmarks   main-is: Benchmarks.hs-  ghc-options: -Wall -O+  ghc-options: -Wall   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   hs-source-dirs: benchmarks   main-is: Benchmarks.hs-  ghc-options: -Wall -O -threaded+  ghc-options: -Wall -threaded   build-depends:       base     , async-    , criterion-    , deepseq+    , tasty-bench < 0.5     , lifted-async+  default-language: Haskell2010  source-repository head   type: git   branch: develop-  location: https://github.com/maoe/lifted-async.git--source-repository this-  type: git-  tag: v0.2.0.2   location: https://github.com/maoe/lifted-async.git
src/Control/Concurrent/Async/Lifted.hs view
@@ -1,32 +1,45 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  {- | Module      : Control.Concurrent.Async.Lifted-Copyright   : Copyright (C) 2012-2014 Mitsutoshi Aoe+Copyright   : Copyright (C) 2012-2018 Mitsutoshi Aoe License     : BSD-style (see the file LICENSE) Maintainer  : Mitsutoshi Aoe <maoe@foldr.in> Stability   : experimental -This is a wrapped version of "Control.Concurrent.Async" with types generalized+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+  , async, asyncBound, asyncOn+  , asyncWithUnmask, asyncOnWithUnmask      -- ** Spawning with automatic 'cancel'ation   , withAsync, withAsyncBound, withAsyncOn   , 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@@ -37,20 +50,34 @@   , 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, mapConcurrently+  , 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, liftM, void)-import Data.Traversable (Traversable(..))+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)@@ -59,6 +86,10 @@ import qualified Control.Concurrent.Async as A import qualified Control.Exception.Lifted as E +#if !MIN_VERSION_base(4, 11, 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@@ -102,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'.@@ -111,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@@ -170,8 +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'.+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@@ -179,14 +230,6 @@   -> m (Either SomeException a) waitCatch a = liftBase (A.waitCatch a) >>= sequenceEither --- | Generalized version of 'A.cancel'.-cancel :: MonadBase IO m => Async (StM m a) -> m ()-cancel = liftBase . A.cancel---- | Generalized version of 'A.cancelWith'.-cancelWith :: (MonadBase IO m, Exception e) => Async (StM m a) -> e -> m ()-cancelWith = (liftBase .) . A.cancelWith- -- | Generalized version of 'A.waitAny'. waitAny :: MonadBaseControl IO m => [Async (StM m a)] -> m (Async (StM m a), a) waitAny as = do@@ -205,8 +248,14 @@   return (a, r)  -- | Generalized version of 'A.waitAnyCancel'.-waitAnyCancel :: MonadBase IO m => [Async a] -> m (Async a, a)-waitAnyCancel = liftBase . 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@@ -226,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@@ -236,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@@ -246,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@@ -256,15 +305,18 @@   -> 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_'.+--+-- NOTE: This function discards the monadic effects besides IO in the forked+-- computation. waitEither_-  :: MonadBaseControl IO m-  => Async (StM m a)-  -> Async (StM m b)+  :: MonadBase IO m+  => Async a+  -> Async b   -> m ()-waitEither_ = (void .) . waitEither+waitEither_ a b = liftBase (A.waitEither_ a b)  -- | Generalized version of 'A.waitBoth'. waitBoth@@ -280,11 +332,11 @@ {-# INLINABLE waitBoth #-}  -- | Generalized version of 'A.link'.-link :: MonadBase IO m => Async (StM m a) -> m ()+link :: MonadBase IO m => Async a -> m () link = liftBase . A.link  -- | Generalized version of 'A.link2'.-link2 :: MonadBase IO m => Async (StM m a) -> Async (StM m b) -> m ()+link2 :: MonadBase IO m => Async a -> Async b -> m () link2 = (liftBase .) . A.link2  -- | Generalized version of 'A.race'.@@ -296,6 +348,9 @@ {-# 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 ->@@ -311,6 +366,11 @@   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)@@ -319,41 +379,89 @@   -> 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 b m a@ is an IO-based operation that can be+-- 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 b m a@ will+-- 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 (b :: * -> *) m a = Concurrently { runConcurrently :: m a }---- NOTE: The phantom type variable @b :: * -> *@ in 'Concurrently' is needed to--- avoid @UndecidableInstances@ in the following instance declarations.--- See https://github.com/maoe/lifted-async/issues/4 for alternative--- implementaions.+-- @+--   (page1, page2, page3) <- 'runConcurrently' $ (,,)+--     '<$>' 'Concurrently' (getURL "url1")+--     '<*>' 'Concurrently' (getURL "url2")+--     '<*>' 'Concurrently' (getURL "url3")+-- @+newtype Concurrently m a = Concurrently { runConcurrently :: m a } -instance (b ~ IO, Functor m) => Functor (Concurrently b m) where+instance Functor m => Functor (Concurrently m) where   fmap f (Concurrently a) = Concurrently $ f <$> a -instance (b ~ IO, MonadBaseControl b m) => Applicative (Concurrently b m) where+instance MonadBaseControl IO m => Applicative (Concurrently m) where   pure = Concurrently . pure   Concurrently fs <*> Concurrently as =     Concurrently $ uncurry ($) <$> concurrently fs as -instance (b ~ IO, MonadBaseControl b m) => Alternative (Concurrently b m) where-  empty = Concurrently . liftBaseWith . const $ forever (threadDelay maxBound)+instance MonadBaseControl IO m => Alternative (Concurrently m) where+  empty = Concurrently $ liftBaseWith $ \_ -> forever $ threadDelay maxBound   Concurrently as <|> Concurrently bs =     Concurrently $ either id id <$> race as bs +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 = (<>)+ 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
@@ -0,0 +1,442 @@+{-# 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 <maoe@foldr.in>+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 !MIN_VERSION_base(4, 11, 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 $ \_ -> 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)++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 = (<>)
tests/Test/Async/Common.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} module Test.Async.Common   ( value@@ -6,19 +5,15 @@   , 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 -import Control.Concurrent.Async.Lifted as X- value :: Int value = 42  data TestException = TestException-  deriving (Eq, Show, Typeable)+  deriving (Eq, Show)  instance Exception TestException
tests/Test/Async/IO.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Test.Async.IO   ( ioTestGroup@@ -8,6 +9,7 @@ import Control.Concurrent.Lifted import Control.Exception.Lifted as E +import Control.Concurrent.Async.Lifted.Safe import Test.Async.Common  ioTestGroup :: TestTree@@ -53,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
@@ -0,0 +1,128 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+module Test.Async.Reader+  ( readerTestGroup+  ) where+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++import Control.Concurrent.Async.Lifted.Safe+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."+  ]
tests/Test/Async/State.hs view
@@ -2,12 +2,15 @@ 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  stateTestGroup :: TestTree@@ -72,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." @@ -115,12 +118,19 @@     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 + 1+  liftIO $ s @?= value  case_withAsync_waitBoth1 :: Assertion case_withAsync_waitBoth1 = do@@ -138,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,12 +1,14 @@-{-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-} 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   ]