├── .ghci ├── cabal.haskell-ci ├── Setup.hs ├── .gitignore ├── tests ├── TestSuite.hs ├── Test │ └── Async │ │ ├── Common.hs │ │ ├── IO.hs │ │ ├── Reader.hs │ │ └── State.hs └── RegressionTests.hs ├── hie.yaml ├── README.md ├── LICENSE ├── lifted-async.cabal ├── benchmarks └── Benchmarks.hs ├── CHANGELOG.md ├── .github └── workflows │ └── haskell-ci.yml └── src └── Control └── Concurrent └── Async ├── Lifted └── Safe.hs └── Lifted.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -i./src -i./tests 2 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: develop ghc* ci* 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .ghc.* 3 | .stack-work/ 4 | cabal.project.local 5 | dist-newstyle/ 6 | dist/ 7 | -------------------------------------------------------------------------------- /tests/TestSuite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Main where 3 | import Test.Tasty (defaultMain, testGroup) 4 | 5 | import Test.Async.IO 6 | import Test.Async.State 7 | import Test.Async.Reader 8 | 9 | main :: IO () 10 | main = defaultMain $ testGroup "lifted-async test suite" 11 | [ ioTestGroup 12 | , stateTestGroup 13 | , readerTestGroup 14 | ] 15 | -------------------------------------------------------------------------------- /tests/Test/Async/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module Test.Async.Common 3 | ( value 4 | , TestException(..) 5 | , module X 6 | ) where 7 | 8 | import Control.Exception.Lifted 9 | import Test.Tasty as X 10 | import Test.Tasty.HUnit as X 11 | import Test.Tasty.TH as X 12 | 13 | value :: Int 14 | value = 42 15 | 16 | data TestException = TestException 17 | deriving (Eq, Show) 18 | 19 | instance Exception TestException 20 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "src" 4 | component: "lib:lifted-async" 5 | 6 | - path: "tests" 7 | component: "lifted-async:test:test-lifted-async" 8 | 9 | - path: "tests" 10 | component: "lifted-async:test:regression-tests" 11 | 12 | - path: "benchmarks/Benchmarks.hs" 13 | component: "lifted-async:bench:benchmark-lifted-async" 14 | 15 | - path: "benchmarks/Benchmarks.hs" 16 | component: "lifted-async:bench:benchmark-lifted-async-threaded" 17 | -------------------------------------------------------------------------------- /tests/RegressionTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | import Control.Monad (when, void) 4 | import Data.Function (fix) 5 | import Data.IORef 6 | import Foreign.C.Types (CUInt(..)) 7 | 8 | import Control.Concurrent.Async.Lifted 9 | 10 | import Test.Tasty.TH 11 | import Test.Tasty.HUnit 12 | 13 | main :: IO () 14 | main = $defaultMainGenerator 15 | 16 | -- https://github.com/maoe/lifted-async/issues/1 17 | case_issue1 :: Assertion 18 | case_issue1 = do 19 | ref <- newIORef (5 :: Int) 20 | withAsync (zombie ref) $ \_ -> return () 21 | n <- readIORef ref 22 | n @?= 5 23 | where 24 | zombie ref = fix $ \loop -> do 25 | n <- readIORef ref 26 | when (n > 0) $ do 27 | void $ c_sleep 1 28 | writeIORef ref $! n - 1 29 | loop 30 | 31 | foreign import ccall safe "sleep" c_sleep :: CUInt -> IO CUInt 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | lifted-async 2 | ========== 3 | [![Hackage](https://img.shields.io/hackage/v/lifted-async.svg)](https://hackage.haskell.org/package/lifted-async) 4 | [![Hackage-Deps](https://img.shields.io/hackage-deps/v/lifted-async.svg)](http://packdeps.haskellers.com/feed?needle=lifted-async) 5 | [![lifted-async on Stackage LTS](https://stackage.org/package/lifted-async/badge/lts)](http://stackage.org/lts/package/lifted-async) 6 | [![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) 7 | [![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) 8 | 9 | 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. 10 | 11 | Contact information 12 | ========== 13 | 14 | This library is written and maintained by Mitsutoshi Aoe . 15 | [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). 16 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-2017, Mitsutoshi Aoe 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Mitsutoshi Aoe nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /tests/Test/Async/IO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Test.Async.IO 4 | ( ioTestGroup 5 | ) where 6 | import Control.Monad (when, void) 7 | import Data.Maybe (isJust, isNothing) 8 | 9 | import Control.Concurrent.Lifted 10 | import Control.Exception.Lifted as E 11 | 12 | import Control.Concurrent.Async.Lifted.Safe 13 | import Test.Async.Common 14 | 15 | ioTestGroup :: TestTree 16 | ioTestGroup = $(testGroupGenerator) 17 | 18 | case_async_waitCatch :: Assertion 19 | case_async_waitCatch = do 20 | a <- async (return value) 21 | r <- waitCatch a 22 | case r of 23 | Left _ -> assertFailure "" 24 | Right e -> e @?= value 25 | 26 | case_async_wait :: Assertion 27 | case_async_wait = do 28 | a <- async (return value) 29 | r <- wait a 30 | assertEqual "async_wait" r value 31 | 32 | case_async_exwaitCatch :: Assertion 33 | case_async_exwaitCatch = do 34 | a <- async (throwIO TestException) 35 | r <- waitCatch a 36 | case r of 37 | Left e -> fromException e @?= Just TestException 38 | Right _ -> assertFailure "" 39 | 40 | case_async_exwait :: Assertion 41 | case_async_exwait = do 42 | a <- async (throwIO TestException) 43 | (wait a >> assertFailure "") `E.catch` \e -> e @?= TestException 44 | 45 | case_withAsync_waitCatch :: Assertion 46 | case_withAsync_waitCatch = do 47 | withAsync (return value) $ \a -> do 48 | r <- waitCatch a 49 | case r of 50 | Left _ -> assertFailure "" 51 | Right e -> e @?= value 52 | 53 | case_withAsync_wait2 :: Assertion 54 | case_withAsync_wait2 = do 55 | a <- withAsync (threadDelay 1000000) $ return 56 | r <- waitCatch a 57 | case r of 58 | Left e -> fromException e @?= Just AsyncCancelled 59 | Right _ -> assertFailure "" 60 | 61 | case_async_cancel :: Assertion 62 | case_async_cancel = sequence_ $ replicate 1000 run 63 | where 64 | run = do 65 | a <- async (return value) 66 | cancelWith a TestException 67 | r <- waitCatch a 68 | case r of 69 | Left e -> fromException e @?= Just TestException 70 | Right r' -> r' @?= value 71 | 72 | case_async_poll :: Assertion 73 | case_async_poll = do 74 | a <- async (threadDelay 1000000) 75 | r <- poll a 76 | when (isJust r) $ assertFailure "" 77 | r' <- poll a -- poll twice, just to check we don't deadlock 78 | when (isJust r') $ assertFailure "" 79 | 80 | case_async_poll2 :: Assertion 81 | case_async_poll2 = do 82 | a <- async (return value) 83 | void $ wait a 84 | r <- poll a 85 | when (isNothing r) $ assertFailure "" 86 | r' <- poll a -- poll twice, just to check we don't deadlock 87 | when (isNothing r') $ assertFailure "" 88 | -------------------------------------------------------------------------------- /lifted-async.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.24 2 | name: lifted-async 3 | version: 0.10.2.7 4 | synopsis: Run lifted IO operations asynchronously and wait for their results 5 | homepage: https://github.com/maoe/lifted-async 6 | bug-reports: https://github.com/maoe/lifted-async/issues 7 | license: BSD3 8 | license-file: LICENSE 9 | author: Mitsutoshi Aoe 10 | maintainer: Mitsutoshi Aoe 11 | copyright: Copyright (C) 2012-2024 Mitsutoshi Aoe 12 | category: Concurrency 13 | build-type: Simple 14 | tested-with: 15 | GHC == 9.14.1 16 | GHC == 9.12.2 17 | GHC == 9.10.2 18 | GHC == 9.8.4 19 | GHC == 9.6.7 20 | GHC == 9.4.8 21 | GHC == 9.2.8 22 | GHC == 9.0.2 23 | GHC == 8.10.7 24 | GHC == 8.8.4 25 | GHC == 8.6.5 26 | GHC == 8.4.4 27 | GHC == 8.2.2 28 | GHC == 8.0.2 29 | 30 | extra-doc-files: 31 | README.md 32 | CHANGELOG.md 33 | 34 | description: 35 | This package provides IO operations from @async@ package lifted to any 36 | instance of 'MonadBase' or 'MonadBaseControl'. 37 | 38 | library 39 | hs-source-dirs: src 40 | exposed-modules: 41 | Control.Concurrent.Async.Lifted 42 | Control.Concurrent.Async.Lifted.Safe 43 | build-depends: 44 | base >= 4.9 && < 4.23 45 | , async >= 2.2 && < 2.3 46 | , lifted-base >= 0.2 && < 0.3 47 | , transformers-base >= 0.4 && < 0.5 48 | , monad-control == 1.0.* 49 | , constraints >= 0.2 && < 0.15 50 | ghc-options: -Wall 51 | default-language: Haskell2010 52 | 53 | test-suite test-lifted-async 54 | type: exitcode-stdio-1.0 55 | hs-source-dirs: tests 56 | main-is: TestSuite.hs 57 | other-modules: 58 | Test.Async.Common 59 | Test.Async.IO 60 | Test.Async.State 61 | Test.Async.Reader 62 | ghc-options: -Wall -threaded 63 | build-depends: 64 | base 65 | , lifted-async 66 | , lifted-base 67 | , mtl 68 | , tasty 69 | , tasty-expected-failure < 0.13 70 | , tasty-hunit >= 0.9 && < 0.11 71 | , tasty-th 72 | default-language: Haskell2010 73 | 74 | test-suite regression-tests 75 | type: exitcode-stdio-1.0 76 | hs-source-dirs: tests 77 | main-is: RegressionTests.hs 78 | ghc-options: -Wall -threaded 79 | build-depends: 80 | base 81 | , lifted-async 82 | , tasty-hunit >= 0.9 && < 0.11 83 | , tasty-th 84 | default-language: Haskell2010 85 | 86 | benchmark benchmark-lifted-async 87 | type: exitcode-stdio-1.0 88 | hs-source-dirs: benchmarks 89 | main-is: Benchmarks.hs 90 | ghc-options: -Wall 91 | build-depends: 92 | base 93 | , async 94 | , tasty-bench < 0.5 95 | , lifted-async 96 | default-language: Haskell2010 97 | 98 | benchmark benchmark-lifted-async-threaded 99 | type: exitcode-stdio-1.0 100 | hs-source-dirs: benchmarks 101 | main-is: Benchmarks.hs 102 | ghc-options: -Wall -threaded 103 | build-depends: 104 | base 105 | , async 106 | , tasty-bench < 0.5 107 | , lifted-async 108 | default-language: Haskell2010 109 | 110 | source-repository head 111 | type: git 112 | branch: develop 113 | location: https://github.com/maoe/lifted-async.git 114 | -------------------------------------------------------------------------------- /tests/Test/Async/Reader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Test.Async.Reader 4 | ( readerTestGroup 5 | ) where 6 | import Control.Monad (void, when) 7 | import Control.Monad.Reader (runReaderT, liftIO) 8 | import Data.Maybe (isJust, isNothing) 9 | 10 | import Control.Concurrent.Lifted 11 | import Control.Exception.Lifted as E 12 | import Test.Tasty.ExpectedFailure 13 | 14 | import Control.Concurrent.Async.Lifted.Safe 15 | import Test.Async.Common 16 | 17 | readerTestGroup :: TestTree 18 | readerTestGroup = $(testGroupGenerator) 19 | 20 | case_async_waitCatch :: Assertion 21 | case_async_waitCatch = do 22 | r <- flip runReaderT value $ do 23 | a <- async $ return value 24 | waitCatch a 25 | case r of 26 | Left _ -> assertFailure "An exception must not be raised." 27 | Right e -> do 28 | e @?= value 29 | 30 | case_async_wait :: Assertion 31 | case_async_wait = do 32 | r <- flip runReaderT value $ do 33 | a <- async $ return value 34 | wait a 35 | r @?= value 36 | 37 | case_async_exwaitCatch :: Assertion 38 | case_async_exwaitCatch = do 39 | r <- flip runReaderT value $ do 40 | a <- async $ throwIO TestException 41 | waitCatch a 42 | case r of 43 | Left e -> 44 | fromException e @?= Just TestException 45 | Right _ -> assertFailure "An exception must be raised." 46 | 47 | case_async_exwait :: Assertion 48 | case_async_exwait = 49 | void $ flip runReaderT value $ do 50 | a <- async $ throwIO TestException 51 | (wait a >> liftIO (assertFailure "An exception must be raised")) 52 | `E.catch` \e -> 53 | liftIO $ e @?= TestException 54 | 55 | case_withAsync_waitCatch :: Assertion 56 | case_withAsync_waitCatch = 57 | void $ flip runReaderT value $ do 58 | withAsync (return value) $ \a -> do 59 | r <- waitCatch a 60 | case r of 61 | Left _ -> liftIO $ assertFailure "An exception must not be raised." 62 | Right e -> do 63 | liftIO $ e @?= value 64 | 65 | case_withAsync_wait2 :: Assertion 66 | case_withAsync_wait2 = do 67 | r <- flip runReaderT value $ do 68 | a <- withAsync (threadDelay 1000000) $ return 69 | waitCatch a 70 | case r of 71 | Left e -> do 72 | fromException e @?= Just AsyncCancelled 73 | Right _ -> assertFailure "An exception must be raised." 74 | 75 | case_async_cancel :: Assertion 76 | case_async_cancel = sequence_ $ replicate 1000 run 77 | where 78 | run = do 79 | r <- flip runReaderT value $ do 80 | a <- async $ return value 81 | cancelWith a TestException 82 | waitCatch a 83 | case r of 84 | Left e -> 85 | fromException e @?= Just TestException 86 | Right r' -> 87 | r' @?= value 88 | 89 | case_async_poll :: Assertion 90 | case_async_poll = 91 | void $ flip runReaderT value $ do 92 | a <- async (threadDelay 1000000) 93 | r <- poll a 94 | when (isJust r) $ 95 | liftIO $ assertFailure "The result must be nothing." 96 | r' <- poll a -- poll twice, just to check we don't deadlock 97 | when (isJust r') $ 98 | liftIO $ assertFailure "The result must be Nothing." 99 | 100 | case_async_poll2 :: Assertion 101 | case_async_poll2 = 102 | void $ flip runReaderT value $ do 103 | a <- async (return value) 104 | void $ wait a 105 | r <- poll a 106 | when (isNothing r) $ 107 | liftIO $ assertFailure "The result must not be Nothing." 108 | r' <- poll a -- poll twice, just to check we don't deadlock 109 | when (isNothing r') $ 110 | liftIO $ assertFailure "The result must not be Nothing." 111 | 112 | test_ignored :: [TestTree] 113 | test_ignored = 114 | [ ignoreTestBecause "see #26" $ testCase "link" $ do 115 | r <- try $ flip runReaderT value $ do 116 | a <- async $ threadDelay 1000000 >> return value 117 | link a 118 | cancelWith a TestException 119 | wait a 120 | case r of 121 | Left e -> case fromException e of 122 | Just (ExceptionInLinkedThread _ e') -> 123 | fromException e' @?= Just TestException 124 | Nothing -> assertFailure $ 125 | "expected ExceptionInLinkedThread _ TestException" 126 | ++ " but got " ++ show e 127 | Right _ -> assertFailure "An exception must be raised." 128 | ] 129 | -------------------------------------------------------------------------------- /benchmarks/Benchmarks.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Control.Exception (SomeException(..)) 3 | 4 | import Test.Tasty.Bench (bench, bgroup, defaultMain, nfIO, whnfIO) 5 | import qualified Control.Concurrent.Async as A 6 | import qualified Control.Concurrent.Async.Lifted as L 7 | import qualified Control.Concurrent.Async.Lifted.Safe as LS 8 | 9 | main :: IO () 10 | main = defaultMain 11 | [ bgroup "async-wait" 12 | [ bench "async" $ whnfIO asyncWait_async 13 | , bench "lifted-async" $ whnfIO asyncWait_liftedAsync 14 | , bench "lifted-async-safe" $ whnfIO asyncWait_liftedAsyncSafe 15 | ] 16 | -- , bgroup "async-cancel-waitCatch" 17 | -- [ bench "async" $ whnfIO asyncCancelWaitCatch_async 18 | -- , bench "lifted-async" $ whnfIO asyncCancelWaitCatch_liftedAsync 19 | -- , bench "lifted-async-safe" $ whnfIO asyncCancelWaitCatch_liftedAsyncSafe 20 | -- ] 21 | , bgroup "waitAny" 22 | [ bench "async" $ whnfIO waitAny_async 23 | , bench "lifted-async" $ whnfIO waitAny_liftedAsync 24 | , bench "lifted-async-safe" $ whnfIO waitAny_liftedAsyncSafe 25 | ] 26 | , bgroup "race" 27 | [ bench "async" $ nfIO race_async 28 | , bench "lifted-async" $ nfIO race_liftedAsync 29 | , bench "lifted-async-safe" $ nfIO race_liftedAsyncSafe 30 | , bench "async (inlined)" $ nfIO race_async_inlined 31 | , bench "lifted-async (inlined)" $ nfIO race_liftedAsync_inlined 32 | ] 33 | , bgroup "concurrently" 34 | [ bench "async" $ nfIO concurrently_async 35 | , bench "lifted-async" $ nfIO concurrently_liftedAsync 36 | , bench "lifted-async-safe" $ nfIO concurrently_liftedAsyncSafe 37 | , bench "async (inlined)" $ nfIO concurrently_async_inlined 38 | , bench "lifted-async (inlined)" $ nfIO concurrently_liftedAsync_inlined 39 | ] 40 | , bgroup "mapConcurrently" 41 | [ bench "async" $ nfIO mapConcurrently_async 42 | , bench "lifted-async" $ nfIO mapConcurrently_liftedAsync 43 | , bench "lifted-async-safe" $ nfIO mapConcurrently_liftedAsyncSafe 44 | ] 45 | ] 46 | 47 | asyncWait_async :: IO Int 48 | asyncWait_async = do 49 | a <- A.async (return 1) 50 | A.wait a 51 | 52 | asyncWait_liftedAsync :: IO Int 53 | asyncWait_liftedAsync = do 54 | a <- L.async (return 1) 55 | L.wait a 56 | 57 | asyncWait_liftedAsyncSafe :: IO Int 58 | asyncWait_liftedAsyncSafe = do 59 | a <- LS.async (return 1) 60 | LS.wait a 61 | 62 | asyncCancelWaitCatch_async :: IO (Either SomeException Int) 63 | asyncCancelWaitCatch_async = do 64 | a <- A.async (return 1) 65 | A.cancel a 66 | A.waitCatch a 67 | 68 | asyncCancelWaitCatch_liftedAsync :: IO (Either SomeException Int) 69 | asyncCancelWaitCatch_liftedAsync = do 70 | a <- L.async (return 1) 71 | L.cancel a 72 | L.waitCatch a 73 | 74 | asyncCancelWaitCatch_liftedAsyncSafe :: IO (Either SomeException Int) 75 | asyncCancelWaitCatch_liftedAsyncSafe = do 76 | a <- LS.async (return 1) 77 | LS.cancel a 78 | LS.waitCatch a 79 | 80 | waitAny_async :: IO Int 81 | waitAny_async = do 82 | as <- mapM (A.async . return) [1..10] 83 | (_, n) <- A.waitAny as 84 | return n 85 | 86 | waitAny_liftedAsync :: IO Int 87 | waitAny_liftedAsync = do 88 | as <- mapM (L.async . return) [1..10] 89 | (_, n) <- L.waitAny as 90 | return n 91 | 92 | waitAny_liftedAsyncSafe :: IO Int 93 | waitAny_liftedAsyncSafe = do 94 | as <- mapM (LS.async . return) [1..10] 95 | (_, n) <- LS.waitAny as 96 | return n 97 | 98 | race_async :: IO (Either Int Int) 99 | race_async = 100 | A.race (return 1) (return 2) 101 | 102 | race_liftedAsync :: IO (Either Int Int) 103 | race_liftedAsync = 104 | L.race (return 1) (return 2) 105 | 106 | race_liftedAsyncSafe :: IO (Either Int Int) 107 | race_liftedAsyncSafe = 108 | LS.race (return 1) (return 2) 109 | 110 | race_async_inlined :: IO (Either Int Int) 111 | race_async_inlined = 112 | A.withAsync (return 1) $ \a -> 113 | A.withAsync (return 2) $ \b -> 114 | A.waitEither a b 115 | 116 | race_liftedAsync_inlined :: IO (Either Int Int) 117 | race_liftedAsync_inlined = 118 | L.withAsync (return 1) $ \a -> 119 | L.withAsync (return 2) $ \b -> 120 | L.waitEither a b 121 | 122 | concurrently_async :: IO (Int, Int) 123 | concurrently_async = 124 | A.concurrently (return 1) (return 2) 125 | 126 | concurrently_liftedAsync :: IO (Int, Int) 127 | concurrently_liftedAsync = 128 | L.concurrently (return 1) (return 2) 129 | 130 | concurrently_liftedAsyncSafe :: IO (Int, Int) 131 | concurrently_liftedAsyncSafe = 132 | LS.concurrently (return 1) (return 2) 133 | 134 | concurrently_async_inlined :: IO (Int, Int) 135 | concurrently_async_inlined = 136 | A.withAsync (return 1) $ \a -> 137 | A.withAsync (return 2) $ \b -> 138 | A.waitBoth a b 139 | 140 | concurrently_liftedAsync_inlined :: IO (Int, Int) 141 | concurrently_liftedAsync_inlined = 142 | L.withAsync (return 1) $ \a -> 143 | L.withAsync (return 2) $ \b -> 144 | L.waitBoth a b 145 | 146 | mapConcurrently_async :: IO [Int] 147 | mapConcurrently_async = 148 | A.mapConcurrently return [1..10] 149 | 150 | mapConcurrently_liftedAsync :: IO [Int] 151 | mapConcurrently_liftedAsync = 152 | L.mapConcurrently return [1..10] 153 | 154 | mapConcurrently_liftedAsyncSafe :: IO [Int] 155 | mapConcurrently_liftedAsyncSafe = 156 | LS.mapConcurrently return [1..10] 157 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for lifted-async 2 | 3 | ## Unreleased 4 | 5 | * Drop support for GHC 7 6 | * Allow base-4.22 7 | 8 | ## v0.10.2.7 - 2024-11-03 9 | 10 | * 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)) 11 | 12 | ## v0.10.2.6 - 2024-10-05 13 | 14 | * Allow base-4.20, bump CI to GHC 9.10.1 (([#44](https://github.com/maoe/lifted-async/issues/44))) 15 | 16 | ## v0.10.2.5 - 2023-11-11 17 | 18 | * Support GHC 9.8 ([#42](https://github.com/maoe/lifted-async/issues/42)) 19 | * Allow base-4.19, bump CI to GHC 9.8.1 ([#43](https://github.com/maoe/lifted-async/pull/43)) 20 | 21 | ## v0.10.2.4 - 2022-03-19 22 | 23 | * Support mtl-2.3.1, allow base-4.18 (GHC 9.6) ([#41](https://github.com/maoe/lifted-async/pull/41)) 24 | 25 | ## v0.10.2.3 - 2022-08-13 26 | 27 | * Allow base-4.17 (GHC 9.4) and bump CI to latest GHC versions ([#39](https://github.com/maoe/lifted-async/pull/39)) 28 | 29 | ## v0.10.2.2 - 2021-11-02 30 | 31 | * Allow base-4.17 for GHC 9.2.1 ([#37](https://github.com/maoe/lifted-async/pull/37)) 32 | 33 | ## v0.10.2.1 - 2021-07-23 34 | 35 | * Relax upper version bound for tasty-bench 36 | 37 | ## v0.10.2 - 2021-04-02 38 | 39 | * Define withAsync in terms of corresponding function from async ([#36](https://github.com/maoe/lifted-async/pull/36)) 40 | * Fixes [#34](https://github.com/maoe/lifted-async/issues/34) 41 | 42 | ## v0.10.1.3 - 2021-02-26 43 | 44 | * Support GHC 9.0.1 ([#33](https://github.com/maoe/lifted-async/pull/33)) 45 | * Switch from Travis CI to GitHub Actions 46 | * Switch from criterion to tasty-bench 47 | 48 | ## v0.10.1.2 - 2020-07-23 49 | 50 | * Relax upper version bound for tasty-expected-failure 51 | 52 | ## v0.10.1.1 - 2020-06-29 53 | 54 | * Bump up cabal-version to 1.24 55 | 56 | ## v0.10.1 - 2020-06-29 57 | 58 | * Fix typechecking errors with GHC HEAD 8.11 ([#31](https://github.com/maoe/lifted-async/pull/31)) 59 | 60 | ## v0.10.0.6 - 2020-03-31 61 | 62 | * Relax upper version bound for base to suppose GHC 8.10 ([#30](https://github.com/maoe/lifted-async/pull/30)) 63 | 64 | ## v0.10.0.5 - 2020-02-08 65 | 66 | * Relax upper version bounds for constraints 67 | 68 | ## v0.10.0.4 - 2019-05-03 69 | 70 | * Relax upper version bounds for base and constraints 71 | 72 | ## v0.10.0.3 - 2018-09-25 73 | 74 | * Relax upper version bound for base to support GHC 8.6.1 75 | 76 | ## v0.10.0.2 - 2018-05-13 77 | 78 | * Allow test_link to fail because it's non-deterministic (#26) 79 | 80 | ## v0.10.0.1 - 2018-03-10 81 | 82 | * Relax upper version bound for base in GHC 8.4.1 (#25) 83 | 84 | ## v0.10.0 - 2018-02-08 85 | 86 | * Support only async >= 2.2 87 | * Drop support for monad-control == 0.* 88 | * Drop support for GHC < 7.10 89 | 90 | ## v0.9.3.3 - 2018-01-22 91 | 92 | * Relax upper version bound for constraints 93 | 94 | ## v0.9.3.2 - 2017-12-12 95 | 96 | * Minor improvements in the cabal file 97 | 98 | ## v0.9.3.1 - 2017-12-12 99 | 100 | * Relax upper version bound for tasty-hunit 101 | 102 | ## v0.9.3 - 2017-06-26 103 | 104 | * Add Haddock comments for concurrently_ (#23) 105 | * Add replicateConcurrently and replicateConcurrently_ 106 | * Test with GHC 8.2.1 on Travis 107 | 108 | ## v0.9.2 - 2017-06-24 109 | 110 | * Add concurrently_ (#22) 111 | 112 | ## v0.9.1.1 - 2017-01-26 113 | 114 | * Relax upper version bound for constraints 115 | 116 | ## v0.9.1 - 2017-01-13 117 | 118 | * Add (for|map)Concurrently_ (#21) 119 | 120 | ## v0.9.0 - 2016-05-22 121 | 122 | * Leverage `StM m a ~ a` in the `Safe` module for faster `wait`/`poll`/`race`/`concurrently` 123 | 124 | ## v0.8.0.1 - 2015-01-17 125 | 126 | * Relax upper bound for constraints 127 | 128 | ## v0.8.0 - 2016-01-10 129 | 130 | * Drop Monad instance for Concurrently 131 | * Expose STM operations 132 | * Relax upper bound for base and async 133 | * Add Monoid and Semigroup instances for Concurrently 134 | 135 | ## v0.7.0.2 - 2015-11-26 136 | 137 | * Relax upper bound for the constraints package 138 | * Upper bound remains < 0.6 for GHC < 7.8 as constraints-0.6 requires the closed type families extension. 139 | * Drop support for GHC 7.4.2 140 | 141 | ## v0.7.0.1 - 2015-05-18 142 | 143 | * Fix typecheck error with GHC HEAD (#17) 144 | 145 | ## v0.7.0 - 2015-03-30 146 | 147 | * Fix the unnecessarily constrained type of link2 (#16) 148 | * Turn the caveat in the Safe module into a WARNING pragma (#15) 149 | 150 | ## v0.6.0.1 - 2015-01-14 151 | 152 | * Increase the lower bound for base to >= 4.5 153 | 154 | ## v0.6.0 - 2015-01-13 155 | 156 | * Replace `StM m a ~ a` in the type signatures with `Forall (Pure m)` (#12) 157 | 158 | ## v0.5.0.1 - 2014-12-29 159 | 160 | * Fix build issues in the test suite (#11 and others) 161 | 162 | ## v0.5.0 - 2014-12-29 163 | 164 | * Simplify the type of `Concurrently` (#10) 165 | 166 | ## v0.4.0 - 2014-12-29 167 | 168 | * Accept `constraints > 0.4` as well even when built with ghc < 7.8. 169 | * Support for GHC 7.10.1 170 | 171 | ## v0.3.0 - 2014-12-28 172 | 173 | * Support for `monad-control == 1.0.*` 174 | * `waitEither_` and `race_` now discard monadic effects besides `IO`. This is a breaking change. 175 | * `Control.Concurrent.Async.Lifted.Safe` is added. 176 | * Add `Monad` instance for `Concurrently` 177 | * Relax upper bound for base 178 | 179 | ## v0.2.0.2 - 2014-08-20 180 | 181 | * Fix build failure in the test suite (#6) 182 | 183 | ## v0.2.0.1 - 2014-07-26 184 | 185 | * Fix a typo in a haddock comment (#5 by @supki) 186 | * Fix Travis CI failure 187 | 188 | ## v0.2.0 - 2014-05-01 189 | 190 | * Generalize `Concurrently` (#4) 191 | -------------------------------------------------------------------------------- /tests/Test/Async/State.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Test.Async.State 3 | ( stateTestGroup 4 | ) where 5 | import Control.Monad (void, when) 6 | import Control.Monad.State (runStateT, get, modify, liftIO) 7 | import Data.Maybe (isJust, isNothing) 8 | 9 | import Control.Concurrent.Lifted 10 | import Control.Exception.Lifted as E 11 | import Test.Tasty.ExpectedFailure 12 | 13 | import Control.Concurrent.Async.Lifted 14 | import Test.Async.Common 15 | 16 | stateTestGroup :: TestTree 17 | stateTestGroup = $(testGroupGenerator) 18 | 19 | case_async_waitCatch :: Assertion 20 | case_async_waitCatch = do 21 | (r, s) <- flip runStateT value $ do 22 | a <- async $ modify (+1) >> return value 23 | waitCatch a 24 | case r of 25 | Left _ -> assertFailure "An exception must not be raised." 26 | Right e -> do 27 | e @?= value 28 | s @?= value + 1 29 | 30 | case_async_wait :: Assertion 31 | case_async_wait = do 32 | (r, s) <- flip runStateT value $ do 33 | a <- async $ modify (+1) >> return value 34 | wait a 35 | r @?= value 36 | s @?= value + 1 37 | 38 | case_async_exwaitCatch :: Assertion 39 | case_async_exwaitCatch = do 40 | (r, s) <- flip runStateT value $ do 41 | a <- async $ modify (+1) >> throwIO TestException 42 | waitCatch a 43 | case r of 44 | Left e -> do 45 | fromException e @?= Just TestException 46 | s @?= value 47 | Right _ -> assertFailure "An exception must be raised." 48 | 49 | case_async_exwait :: Assertion 50 | case_async_exwait = 51 | void $ flip runStateT value $ do 52 | a <- async $ modify (+1) >> throwIO TestException 53 | (wait a >> liftIO (assertFailure "An exception must be raised")) 54 | `E.catch` \e -> do 55 | liftIO $ e @?= TestException 56 | s <- get 57 | liftIO $ s @?= value 58 | 59 | case_withAsync_waitCatch :: Assertion 60 | case_withAsync_waitCatch = 61 | void $ flip runStateT value $ do 62 | withAsync (modify (+1) >> return value) $ \a -> do 63 | r <- waitCatch a 64 | case r of 65 | Left _ -> liftIO $ assertFailure "An exception must not be raised." 66 | Right e -> do 67 | liftIO $ e @?= value 68 | s <- get 69 | liftIO $ s @?= value + 1 70 | 71 | case_withAsync_wait2 :: Assertion 72 | case_withAsync_wait2 = do 73 | (r, s) <- flip runStateT value $ do 74 | a <- withAsync (modify (+1) >> threadDelay 1000000) $ return 75 | waitCatch a 76 | case r of 77 | Left e -> do 78 | fromException e @?= Just AsyncCancelled 79 | s @?= value 80 | Right _ -> assertFailure "An exception must be raised." 81 | 82 | case_async_cancel :: Assertion 83 | case_async_cancel = sequence_ $ replicate 1000 run 84 | where 85 | run = do 86 | (r, s) <- flip runStateT value $ do 87 | a <- async $ modify (+1) >> return value 88 | cancelWith a TestException 89 | waitCatch a 90 | case r of 91 | Left e -> do 92 | fromException e @?= Just TestException 93 | s @?= value 94 | Right r' -> do 95 | r' @?= value 96 | s @?= value + 1 97 | 98 | case_async_poll :: Assertion 99 | case_async_poll = 100 | void $ flip runStateT value $ do 101 | a <- async (threadDelay 1000000) 102 | r <- poll a 103 | when (isJust r) $ 104 | liftIO $ assertFailure "The result must be nothing." 105 | r' <- poll a -- poll twice, just to check we don't deadlock 106 | when (isJust r') $ 107 | liftIO $ assertFailure "The result must be Nothing." 108 | 109 | case_async_poll2 :: Assertion 110 | case_async_poll2 = 111 | void $ flip runStateT value $ do 112 | a <- async (return value) 113 | void $ wait a 114 | r <- poll a 115 | when (isNothing r) $ 116 | liftIO $ assertFailure "The result must not be Nothing." 117 | r' <- poll a -- poll twice, just to check we don't deadlock 118 | when (isNothing r') $ 119 | liftIO $ assertFailure "The result must not be Nothing." 120 | 121 | case_withAsync_waitEither :: Assertion 122 | case_withAsync_waitEither = do 123 | (_, s) <- flip runStateT value $ do 124 | withAsync (modify (+1)) $ \a -> 125 | waitEither a a 126 | liftIO $ s @?= value + 1 127 | 128 | case_withAsync_waitEither_ :: Assertion 129 | case_withAsync_waitEither_ = do 130 | ((), s) <- flip runStateT value $ do 131 | withAsync (modify (+1)) $ \a -> 132 | waitEither_ a a 133 | liftIO $ s @?= value 134 | 135 | case_withAsync_waitBoth1 :: Assertion 136 | case_withAsync_waitBoth1 = do 137 | (_, s) <- flip runStateT value $ do 138 | withAsync (return value) $ \a -> 139 | withAsync (modify (+1)) $ \b -> 140 | waitBoth a b 141 | liftIO $ s @?= value + 1 142 | 143 | case_withAsync_waitBoth2 :: Assertion 144 | case_withAsync_waitBoth2 = do 145 | (_, s) <- flip runStateT value $ do 146 | withAsync (modify (+1)) $ \a -> 147 | withAsync (return value) $ \b -> 148 | waitBoth a b 149 | liftIO $ s @?= value 150 | 151 | test_ignored :: [TestTree] 152 | test_ignored = 153 | [ ignoreTestBecause "see #26" $ testCase "link" $ do 154 | r <- try $ flip runStateT value $ do 155 | a <- async $ threadDelay 1000000 >> return value 156 | link a 157 | cancelWith a TestException 158 | wait a 159 | case r of 160 | Left e -> case fromException e of 161 | Just (ExceptionInLinkedThread _ e') -> 162 | fromException e' @?= Just TestException 163 | Nothing -> assertFailure $ 164 | "expected ExceptionInLinkedThread _ TestException" 165 | ++ " but got " ++ show e 166 | Right _ -> assertFailure "An exception must be raised." 167 | ] 168 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'lifted-async.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250821 12 | # 13 | # REGENDATA ("0.19.20250821",["github","lifted-async.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - develop 20 | - ghc* 21 | - ci* 22 | pull_request: 23 | branches: 24 | - develop 25 | - ghc* 26 | - ci* 27 | jobs: 28 | linux: 29 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 30 | runs-on: ubuntu-24.04 31 | timeout-minutes: 32 | 60 33 | container: 34 | image: buildpack-deps:jammy 35 | continue-on-error: ${{ matrix.allow-failure }} 36 | strategy: 37 | matrix: 38 | include: 39 | - compiler: ghc-9.14.0.20250819 40 | compilerKind: ghc 41 | compilerVersion: 9.14.0.20250819 42 | setup-method: ghcup-prerelease 43 | allow-failure: false 44 | - compiler: ghc-9.12.2 45 | compilerKind: ghc 46 | compilerVersion: 9.12.2 47 | setup-method: ghcup 48 | allow-failure: false 49 | - compiler: ghc-9.10.2 50 | compilerKind: ghc 51 | compilerVersion: 9.10.2 52 | setup-method: ghcup 53 | allow-failure: false 54 | - compiler: ghc-9.8.4 55 | compilerKind: ghc 56 | compilerVersion: 9.8.4 57 | setup-method: ghcup 58 | allow-failure: false 59 | - compiler: ghc-9.6.7 60 | compilerKind: ghc 61 | compilerVersion: 9.6.7 62 | setup-method: ghcup 63 | allow-failure: false 64 | - compiler: ghc-9.4.8 65 | compilerKind: ghc 66 | compilerVersion: 9.4.8 67 | setup-method: ghcup 68 | allow-failure: false 69 | - compiler: ghc-9.2.8 70 | compilerKind: ghc 71 | compilerVersion: 9.2.8 72 | setup-method: ghcup 73 | allow-failure: false 74 | - compiler: ghc-9.0.2 75 | compilerKind: ghc 76 | compilerVersion: 9.0.2 77 | setup-method: ghcup 78 | allow-failure: false 79 | - compiler: ghc-8.10.7 80 | compilerKind: ghc 81 | compilerVersion: 8.10.7 82 | setup-method: ghcup 83 | allow-failure: false 84 | - compiler: ghc-8.8.4 85 | compilerKind: ghc 86 | compilerVersion: 8.8.4 87 | setup-method: ghcup 88 | allow-failure: false 89 | - compiler: ghc-8.6.5 90 | compilerKind: ghc 91 | compilerVersion: 8.6.5 92 | setup-method: ghcup 93 | allow-failure: false 94 | - compiler: ghc-8.4.4 95 | compilerKind: ghc 96 | compilerVersion: 8.4.4 97 | setup-method: ghcup 98 | allow-failure: false 99 | - compiler: ghc-8.2.2 100 | compilerKind: ghc 101 | compilerVersion: 8.2.2 102 | setup-method: ghcup 103 | allow-failure: false 104 | - compiler: ghc-8.0.2 105 | compilerKind: ghc 106 | compilerVersion: 8.0.2 107 | setup-method: ghcup 108 | allow-failure: false 109 | fail-fast: false 110 | steps: 111 | - name: apt-get install 112 | run: | 113 | apt-get update 114 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 115 | - name: Install GHCup 116 | run: | 117 | mkdir -p "$HOME/.ghcup/bin" 118 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 119 | chmod a+x "$HOME/.ghcup/bin/ghcup" 120 | - name: Install cabal-install 121 | run: | 122 | "$HOME/.ghcup/bin/ghcup" install cabal 3.16.0.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 123 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.16.0.0 -vnormal+nowrap" >> "$GITHUB_ENV" 124 | - name: Install GHC (GHCup) 125 | if: matrix.setup-method == 'ghcup' 126 | run: | 127 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 128 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 129 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 130 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 131 | echo "HC=$HC" >> "$GITHUB_ENV" 132 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 133 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 134 | env: 135 | HCKIND: ${{ matrix.compilerKind }} 136 | HCNAME: ${{ matrix.compiler }} 137 | HCVER: ${{ matrix.compilerVersion }} 138 | - name: Install GHC (GHCup prerelease) 139 | if: matrix.setup-method == 'ghcup-prerelease' 140 | run: | 141 | "$HOME/.ghcup/bin/ghcup" config add-release-channel prereleases 142 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 143 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 144 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 145 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 146 | echo "HC=$HC" >> "$GITHUB_ENV" 147 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 148 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 149 | env: 150 | HCKIND: ${{ matrix.compilerKind }} 151 | HCNAME: ${{ matrix.compiler }} 152 | HCVER: ${{ matrix.compilerVersion }} 153 | - name: Set PATH and environment variables 154 | run: | 155 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 156 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 157 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 158 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 159 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 160 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 161 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 162 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 163 | if [ $((HCNUMVER >= 91400)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi 164 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 165 | env: 166 | HCKIND: ${{ matrix.compilerKind }} 167 | HCNAME: ${{ matrix.compiler }} 168 | HCVER: ${{ matrix.compilerVersion }} 169 | - name: env 170 | run: | 171 | env 172 | - name: write cabal config 173 | run: | 174 | mkdir -p $CABAL_DIR 175 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 220 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 221 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 222 | rm -f cabal-plan.xz 223 | chmod a+x $HOME/.cabal/bin/cabal-plan 224 | cabal-plan --version 225 | - name: checkout 226 | uses: actions/checkout@v4 227 | with: 228 | path: source 229 | - name: initial cabal.project for sdist 230 | run: | 231 | touch cabal.project 232 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 233 | cat cabal.project 234 | - name: sdist 235 | run: | 236 | mkdir -p sdist 237 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 238 | - name: unpack 239 | run: | 240 | mkdir -p unpacked 241 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 242 | - name: generate cabal.project 243 | run: | 244 | PKGDIR_lifted_async="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/lifted-async-[0-9.]*')" 245 | echo "PKGDIR_lifted_async=${PKGDIR_lifted_async}" >> "$GITHUB_ENV" 246 | rm -f cabal.project cabal.project.local 247 | touch cabal.project 248 | touch cabal.project.local 249 | echo "packages: ${PKGDIR_lifted_async}" >> cabal.project 250 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package lifted-async" >> cabal.project ; fi 251 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods -Werror=missing-fields" >> cabal.project ; fi 252 | if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo "package lifted-async" >> cabal.project ; fi 253 | if [ $((HCNUMVER >= 90400)) -ne 0 ] ; then echo " ghc-options: -Werror=unused-packages" >> cabal.project ; fi 254 | if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo "package lifted-async" >> cabal.project ; fi 255 | if [ $((HCNUMVER >= 90000)) -ne 0 ] ; then echo " ghc-options: -Werror=incomplete-patterns -Werror=incomplete-uni-patterns" >> cabal.project ; fi 256 | cat >> cabal.project <> cabal.project 260 | fi 261 | $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(lifted-async)$/; }' >> cabal.project.local 262 | cat cabal.project 263 | cat cabal.project.local 264 | - name: dump install plan 265 | run: | 266 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 267 | cabal-plan 268 | - name: restore cache 269 | uses: actions/cache/restore@v4 270 | with: 271 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 272 | path: ~/.cabal/store 273 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 274 | - name: install dependencies 275 | run: | 276 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 277 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 278 | - name: build w/o tests 279 | run: | 280 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 281 | - name: build 282 | run: | 283 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 284 | - name: tests 285 | run: | 286 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 287 | - name: cabal check 288 | run: | 289 | cd ${PKGDIR_lifted_async} || false 290 | ${CABAL} -vnormal check 291 | - name: haddock 292 | run: | 293 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 294 | - name: unconstrained build 295 | run: | 296 | rm -f cabal.project.local 297 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 298 | - name: save cache 299 | if: always() 300 | uses: actions/cache/save@v4 301 | with: 302 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 303 | path: ~/.cabal/store 304 | -------------------------------------------------------------------------------- /src/Control/Concurrent/Async/Lifted/Safe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | {- | 13 | Module : Control.Concurrent.Async.Lifted.Safe 14 | Copyright : Copyright (C) 2012-2018 Mitsutoshi Aoe 15 | License : BSD-style (see the file LICENSE) 16 | Maintainer : Mitsutoshi Aoe 17 | Stability : experimental 18 | 19 | This is a safe variant of @Control.Concurrent.Async.Lifted@. 20 | 21 | This module assumes your monad stack to satisfy @'StM' m a ~ a@ so you can't 22 | mess up monadic effects. If your monad stack is stateful, use 23 | @Control.Concurrent.Async.Lifted@ with special care. 24 | -} 25 | 26 | module Control.Concurrent.Async.Lifted.Safe 27 | ( 28 | -- * Asynchronous actions 29 | A.Async 30 | 31 | , Pure 32 | , Forall 33 | -- ** Spawning 34 | , async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask 35 | 36 | -- ** Spawning with automatic 'cancel'ation 37 | , withAsync, withAsyncBound, withAsyncOn 38 | , withAsyncWithUnmask, withAsyncOnWithUnmask 39 | 40 | -- ** Quering 'Async's 41 | , wait, poll, waitCatch 42 | , cancel 43 | , uninterruptibleCancel 44 | , cancelWith 45 | , A.asyncThreadId 46 | , A.AsyncCancelled(..) 47 | 48 | -- ** STM operations 49 | , A.waitSTM, A.pollSTM, A.waitCatchSTM 50 | 51 | -- ** Waiting for multiple 'Async's 52 | , waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel 53 | , waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel 54 | , waitEither_ 55 | , waitBoth 56 | 57 | -- ** Waiting for multiple 'Async's in STM 58 | , A.waitAnySTM 59 | , A.waitAnyCatchSTM 60 | , A.waitEitherSTM 61 | , A.waitEitherCatchSTM 62 | , A.waitEitherSTM_ 63 | , A.waitBothSTM 64 | 65 | -- ** Linking 66 | , Unsafe.link, Unsafe.link2 67 | , A.ExceptionInLinkedThread(..) 68 | 69 | -- * Convenient utilities 70 | , race, race_, concurrently, concurrently_ 71 | , mapConcurrently, mapConcurrently_ 72 | , forConcurrently, forConcurrently_ 73 | , replicateConcurrently, replicateConcurrently_ 74 | , Concurrently(..) 75 | 76 | , A.compareAsyncs 77 | ) 78 | where 79 | 80 | import Control.Applicative 81 | import Control.Concurrent (threadDelay) 82 | import Control.Monad 83 | import Data.Foldable (fold) 84 | 85 | import Control.Concurrent.Async (Async) 86 | import Control.Exception.Lifted (SomeException, Exception) 87 | import Control.Monad.Base (MonadBase(..)) 88 | import Control.Monad.Trans.Control hiding (restoreM) 89 | import Data.Constraint ((\\), (:-)) 90 | import Data.Constraint.Forall (Forall, inst) 91 | import qualified Control.Concurrent.Async as A 92 | 93 | import qualified Control.Concurrent.Async.Lifted as Unsafe 94 | 95 | #if !MIN_VERSION_base(4, 11, 0) 96 | import Data.Semigroup (Semigroup((<>))) 97 | #endif 98 | 99 | -- | Generalized version of 'A.async'. 100 | async 101 | :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) 102 | => m a -> m (Async a) 103 | async = Unsafe.async 104 | \\ (inst :: Forall (Pure m) :- Pure m a) 105 | 106 | -- | Generalized version of 'A.asyncBound'. 107 | asyncBound 108 | :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) 109 | => m a -> m (Async a) 110 | asyncBound = Unsafe.asyncBound 111 | \\ (inst :: Forall (Pure m) :- Pure m a) 112 | 113 | -- | Generalized version of 'A.asyncOn'. 114 | asyncOn 115 | :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) 116 | => Int -> m a -> m (Async a) 117 | asyncOn cpu m = Unsafe.asyncOn cpu m 118 | \\ (inst :: Forall (Pure m) :- Pure m a) 119 | 120 | -- | Generalized version of 'A.asyncWithUnmask'. 121 | asyncWithUnmask 122 | :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) 123 | => ((forall b. m b -> m b) -> m a) 124 | -> m (Async a) 125 | asyncWithUnmask restore = Unsafe.asyncWithUnmask restore 126 | \\ (inst :: Forall (Pure m) :- Pure m a) 127 | 128 | -- | Generalized version of 'A.asyncOnWithUnmask'. 129 | asyncOnWithUnmask 130 | :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) 131 | => Int 132 | -> ((forall b. m b -> m b) -> m a) 133 | -> m (Async a) 134 | asyncOnWithUnmask cpu restore = Unsafe.asyncOnWithUnmask cpu restore 135 | \\ (inst :: Forall (Pure m) :- Pure m a) 136 | 137 | -- | Generalized version of 'A.withAsync'. 138 | withAsync 139 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 140 | => m a 141 | -> (Async a -> m b) 142 | -> m b 143 | withAsync = Unsafe.withAsync 144 | \\ (inst :: Forall (Pure m) :- Pure m a) 145 | 146 | -- | Generalized version of 'A.withAsyncBound'. 147 | withAsyncBound 148 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 149 | => m a 150 | -> (Async a -> m b) 151 | -> m b 152 | withAsyncBound = Unsafe.withAsyncBound 153 | \\ (inst :: Forall (Pure m) :- Pure m a) 154 | 155 | -- | Generalized version of 'A.withAsyncOn'. 156 | withAsyncOn 157 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 158 | => Int 159 | -> m a 160 | -> (Async a -> m b) 161 | -> m b 162 | withAsyncOn = Unsafe.withAsyncOn 163 | \\ (inst :: Forall (Pure m) :- Pure m a) 164 | 165 | -- | Generalized version of 'A.withAsyncWithUnmask'. 166 | withAsyncWithUnmask 167 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 168 | => ((forall c. m c -> m c) -> m a) 169 | -> (Async a -> m b) 170 | -> m b 171 | withAsyncWithUnmask restore = Unsafe.withAsyncWithUnmask restore 172 | \\ (inst :: Forall (Pure m) :- Pure m a) 173 | 174 | -- | Generalized version of 'A.withAsyncOnWithUnmask'. 175 | withAsyncOnWithUnmask 176 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 177 | => Int 178 | -> ((forall c. m c -> m c) -> m a) 179 | -> (Async a -> m b) 180 | -> m b 181 | withAsyncOnWithUnmask cpu restore = Unsafe.withAsyncOnWithUnmask cpu restore 182 | \\ (inst :: Forall (Pure m) :- Pure m a) 183 | 184 | -- | Generalized version of 'A.wait'. 185 | wait 186 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 187 | => Async a -> m a 188 | wait = liftBase . A.wait 189 | \\ (inst :: Forall (Pure m) :- Pure m a) 190 | 191 | -- | Generalized version of 'A.poll'. 192 | poll 193 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 194 | => Async a 195 | -> m (Maybe (Either SomeException a)) 196 | poll = liftBase . A.poll 197 | \\ (inst :: Forall (Pure m) :- Pure m a) 198 | 199 | -- | Generalized version of 'A.waitCatch'. 200 | waitCatch 201 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 202 | => Async a 203 | -> m (Either SomeException a) 204 | waitCatch = liftBase . A.waitCatch 205 | \\ (inst :: Forall (Pure m) :- Pure m a) 206 | 207 | -- | Generalized version of 'A.cancel'. 208 | cancel :: MonadBase IO m => Async a -> m () 209 | cancel = Unsafe.cancel 210 | 211 | -- | Generalized version of 'A.cancelWith'. 212 | cancelWith :: (MonadBase IO m, Exception e) => Async a -> e -> m () 213 | cancelWith = Unsafe.cancelWith 214 | 215 | -- | Generalized version of 'A.uninterruptibleCancel'. 216 | uninterruptibleCancel :: MonadBase IO m => Async a -> m () 217 | uninterruptibleCancel = Unsafe.uninterruptibleCancel 218 | 219 | -- | Generalized version of 'A.waitAny'. 220 | waitAny 221 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 222 | => [Async a] -> m (Async a, a) 223 | waitAny = liftBase . A.waitAny 224 | \\ (inst :: Forall (Pure m) :- Pure m a) 225 | 226 | -- | Generalized version of 'A.waitAnyCatch'. 227 | waitAnyCatch 228 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 229 | => [Async a] 230 | -> m (Async a, Either SomeException a) 231 | waitAnyCatch = liftBase . A.waitAnyCatch 232 | \\ (inst :: Forall (Pure m) :- Pure m a) 233 | 234 | -- | Generalized version of 'A.waitAnyCancel'. 235 | waitAnyCancel 236 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 237 | => [Async a] 238 | -> m (Async a, a) 239 | waitAnyCancel = liftBase . A.waitAnyCancel 240 | \\ (inst :: Forall (Pure m) :- Pure m a) 241 | 242 | -- | Generalized version of 'A.waitAnyCatchCancel'. 243 | waitAnyCatchCancel 244 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 245 | => [Async a] 246 | -> m (Async a, Either SomeException a) 247 | waitAnyCatchCancel = liftBase . A.waitAnyCatchCancel 248 | \\ (inst :: Forall (Pure m) :- Pure m a) 249 | 250 | -- | Generalized version of 'A.waitEither'. 251 | waitEither 252 | :: forall m a b. (MonadBase IO m, Forall (Pure m)) 253 | => Async a 254 | -> Async b 255 | -> m (Either a b) 256 | waitEither = (liftBase .) . A.waitEither 257 | \\ (inst :: Forall (Pure m) :- Pure m a) 258 | \\ (inst :: Forall (Pure m) :- Pure m b) 259 | 260 | -- | Generalized version of 'A.waitEitherCatch'. 261 | waitEitherCatch 262 | :: forall m a b. (MonadBase IO m, Forall (Pure m)) 263 | => Async a 264 | -> Async b 265 | -> m (Either (Either SomeException a) (Either SomeException b)) 266 | waitEitherCatch = (liftBase .) . A.waitEitherCatch 267 | \\ (inst :: Forall (Pure m) :- Pure m a) 268 | \\ (inst :: Forall (Pure m) :- Pure m b) 269 | 270 | -- | Generalized version of 'A.waitEitherCancel'. 271 | waitEitherCancel 272 | :: forall m a b. (MonadBase IO m, Forall (Pure m)) 273 | => Async a 274 | -> Async b 275 | -> m (Either a b) 276 | waitEitherCancel = (liftBase .) . A.waitEitherCancel 277 | \\ (inst :: Forall (Pure m) :- Pure m a) 278 | \\ (inst :: Forall (Pure m) :- Pure m b) 279 | 280 | -- | Generalized version of 'A.waitEitherCatchCancel'. 281 | waitEitherCatchCancel 282 | :: forall m a b. (MonadBase IO m, Forall (Pure m)) 283 | => Async a 284 | -> Async b 285 | -> m (Either (Either SomeException a) (Either SomeException b)) 286 | waitEitherCatchCancel = (liftBase .) . A.waitEitherCatchCancel 287 | \\ (inst :: Forall (Pure m) :- Pure m a) 288 | \\ (inst :: Forall (Pure m) :- Pure m b) 289 | 290 | -- | Generalized version of 'A.waitEither_' 291 | waitEither_ :: MonadBase IO m => Async a -> Async b -> m () 292 | waitEither_ = Unsafe.waitEither_ 293 | 294 | -- | Generalized version of 'A.waitBoth'. 295 | waitBoth 296 | :: forall m a b. (MonadBase IO m, Forall (Pure m)) 297 | => Async a 298 | -> Async b 299 | -> m (a, b) 300 | waitBoth = (liftBase .) . A.waitBoth 301 | \\ (inst :: Forall (Pure m) :- Pure m a) 302 | \\ (inst :: Forall (Pure m) :- Pure m b) 303 | 304 | -- | Generalized version of 'A.race'. 305 | race 306 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 307 | => m a -> m b -> m (Either a b) 308 | race = liftBaseOp2_ A.race 309 | 310 | -- | Generalized version of 'A.race_'. 311 | race_ 312 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 313 | => m a -> m b -> m () 314 | race_ = liftBaseOp2_ A.race_ 315 | 316 | -- | Generalized version of 'A.concurrently'. 317 | concurrently 318 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 319 | => m a -> m b -> m (a, b) 320 | concurrently = liftBaseOp2_ A.concurrently 321 | 322 | -- | Generalized version of 'A.concurrently_'. 323 | concurrently_ 324 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 325 | => m a -> m b -> m () 326 | concurrently_ = liftBaseOp2_ A.concurrently_ 327 | 328 | -- | Similar to 'A.liftBaseOp_' but takes a binary function 329 | -- and leverages @'StM' m a ~ a@. 330 | liftBaseOp2_ 331 | :: forall base m a b c. (MonadBaseControl base m, Forall (Pure m)) 332 | => (base a -> base b -> base c) 333 | -> m a -> m b -> m c 334 | liftBaseOp2_ f left right = liftBaseWith $ \run -> f 335 | (run left \\ (inst :: Forall (Pure m) :- Pure m a)) 336 | (run right \\ (inst :: Forall (Pure m) :- Pure m b)) 337 | 338 | -- | Generalized version of 'A.mapConcurrently'. 339 | mapConcurrently 340 | :: (Traversable t, MonadBaseControl IO m, Forall (Pure m)) 341 | => (a -> m b) 342 | -> t a 343 | -> m (t b) 344 | mapConcurrently f = runConcurrently . traverse (Concurrently . f) 345 | 346 | -- | Generalized version of 'A.mapConcurrently_'. 347 | mapConcurrently_ 348 | :: (Foldable t, MonadBaseControl IO m, Forall (Pure m)) 349 | => (a -> m b) 350 | -> t a 351 | -> m () 352 | mapConcurrently_ f = runConcurrently . foldMap (Concurrently . void . f) 353 | 354 | -- | Generalized version of 'A.forConcurrently'. 355 | forConcurrently 356 | :: (Traversable t, MonadBaseControl IO m, Forall (Pure m)) 357 | => t a 358 | -> (a -> m b) 359 | -> m (t b) 360 | forConcurrently = flip mapConcurrently 361 | 362 | -- | Generalized version of 'A.forConcurrently_'. 363 | forConcurrently_ 364 | :: (Foldable t, MonadBaseControl IO m, Forall (Pure m)) 365 | => t a 366 | -> (a -> m b) 367 | -> m () 368 | forConcurrently_ = flip mapConcurrently_ 369 | 370 | -- | Generalized version of 'A.replicateConcurrently'. 371 | replicateConcurrently 372 | :: (MonadBaseControl IO m, Forall (Pure m)) 373 | => Int 374 | -> m a 375 | -> m [a] 376 | replicateConcurrently n = 377 | runConcurrently . sequenceA . replicate n . Concurrently 378 | 379 | -- | Generalized version of 'A.replicateConcurrently_'. 380 | replicateConcurrently_ 381 | :: (MonadBaseControl IO m, Forall (Pure m)) 382 | => Int 383 | -> m a 384 | -> m () 385 | replicateConcurrently_ n = 386 | runConcurrently . fold . replicate n . Concurrently . void 387 | 388 | -- | Generalized version of 'A.Concurrently'. 389 | -- 390 | -- A value of type @'Concurrently' m a@ is an IO-based operation that can be 391 | -- composed with other 'Concurrently' values, using the 'Applicative' and 392 | -- 'Alternative' instances. 393 | -- 394 | -- Calling 'runConcurrently' on a value of type @'Concurrently' m a@ will 395 | -- execute the IO-based lifted operations it contains concurrently, before 396 | -- delivering the result of type 'a'. 397 | -- 398 | -- For example 399 | -- 400 | -- @ 401 | -- (page1, page2, page3) <- 'runConcurrently' $ (,,) 402 | -- '<$>' 'Concurrently' (getURL "url1") 403 | -- '<*>' 'Concurrently' (getURL "url2") 404 | -- '<*>' 'Concurrently' (getURL "url3") 405 | -- @ 406 | data Concurrently m a where 407 | Concurrently 408 | :: Forall (Pure m) => { runConcurrently :: m a } -> Concurrently m a 409 | 410 | -- | Most of the functions in this module have @'Forall' ('Pure' m)@ in their 411 | -- constraints, which means they require the monad 'm' satisfies 412 | -- @'StM' m a ~ a@ for all 'a'. 413 | class StM m a ~ a => Pure m a 414 | instance StM m a ~ a => Pure m a 415 | 416 | instance Functor m => Functor (Concurrently m) where 417 | fmap f (Concurrently a) = Concurrently $ f <$> a 418 | 419 | instance (MonadBaseControl IO m, Forall (Pure m)) => 420 | Applicative (Concurrently m) where 421 | pure = Concurrently . pure 422 | Concurrently (fs :: m (a -> b)) <*> Concurrently as = 423 | Concurrently (uncurry ($) <$> concurrently fs as) 424 | \\ (inst :: Forall (Pure m) :- Pure m a) 425 | \\ (inst :: Forall (Pure m) :- Pure m (a -> b)) 426 | 427 | instance (MonadBaseControl IO m, Forall (Pure m)) => 428 | Alternative (Concurrently m) where 429 | empty = Concurrently $ liftBaseWith $ \_ -> forever $ threadDelay maxBound 430 | Concurrently (as :: m a) <|> Concurrently bs = 431 | Concurrently (either id id <$> race as bs) 432 | \\ (inst :: Forall (Pure m) :- Pure m a) 433 | \\ (inst :: Forall (Pure m) :- Pure m b) 434 | 435 | instance (MonadBaseControl IO m, Semigroup a, Forall (Pure m)) => 436 | Semigroup (Concurrently m a) where 437 | (<>) = liftA2 (<>) 438 | 439 | instance (MonadBaseControl IO m, Semigroup a, Monoid a, Forall (Pure m)) => 440 | Monoid (Concurrently m a) where 441 | mempty = pure mempty 442 | mappend = (<>) 443 | -------------------------------------------------------------------------------- /src/Control/Concurrent/Async/Lifted.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | {- | 8 | Module : Control.Concurrent.Async.Lifted 9 | Copyright : Copyright (C) 2012-2018 Mitsutoshi Aoe 10 | License : BSD-style (see the file LICENSE) 11 | Maintainer : Mitsutoshi Aoe 12 | Stability : experimental 13 | 14 | This is a wrapped version of @Control.Concurrent.Async@ with types generalized 15 | from 'IO' to all monads in either 'MonadBase' or 'MonadBaseControl'. 16 | 17 | All the functions restore the monadic effects in the forked computation 18 | unless specified otherwise. 19 | 20 | If your monad stack satisfies @'StM' m a ~ a@ (e.g. the reader monad), consider 21 | using @Control.Concurrent.Async.Lifted.Safe@ module, which prevents you from 22 | messing up monadic effects. 23 | -} 24 | 25 | module Control.Concurrent.Async.Lifted 26 | ( -- * Asynchronous actions 27 | A.Async 28 | -- ** Spawning 29 | , async, asyncBound, asyncOn 30 | , asyncWithUnmask, asyncOnWithUnmask 31 | 32 | -- ** Spawning with automatic 'cancel'ation 33 | , withAsync, withAsyncBound, withAsyncOn 34 | , withAsyncWithUnmask, withAsyncOnWithUnmask 35 | 36 | -- ** Quering 'Async's 37 | , wait, poll, waitCatch 38 | , cancel 39 | , uninterruptibleCancel 40 | , cancelWith 41 | , A.asyncThreadId 42 | , A.AsyncCancelled(..) 43 | 44 | -- ** STM operations 45 | , A.waitSTM, A.pollSTM, A.waitCatchSTM 46 | 47 | -- ** Waiting for multiple 'Async's 48 | , waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel 49 | , waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel 50 | , waitEither_ 51 | , waitBoth 52 | 53 | -- ** Waiting for multiple 'Async's in STM 54 | , A.waitAnySTM 55 | , A.waitAnyCatchSTM 56 | , A.waitEitherSTM 57 | , A.waitEitherCatchSTM 58 | , A.waitEitherSTM_ 59 | , A.waitBothSTM 60 | 61 | -- ** Linking 62 | , link, link2 63 | , A.ExceptionInLinkedThread(..) 64 | 65 | -- * Convenient utilities 66 | , race, race_, concurrently, concurrently_ 67 | , mapConcurrently, mapConcurrently_ 68 | , forConcurrently, forConcurrently_ 69 | , replicateConcurrently, replicateConcurrently_ 70 | , Concurrently(..) 71 | 72 | , A.compareAsyncs 73 | ) where 74 | 75 | import Control.Applicative 76 | import Control.Concurrent (threadDelay) 77 | import Control.Monad ((>=>), forever, void) 78 | import Data.Foldable (fold) 79 | import GHC.IO (unsafeUnmask) 80 | import Prelude 81 | 82 | import Control.Concurrent.Async (Async) 83 | import Control.Exception.Lifted (SomeException, Exception) 84 | import Control.Monad.Base (MonadBase(..)) 85 | import Control.Monad.Trans.Control 86 | import qualified Control.Concurrent.Async as A 87 | import qualified Control.Exception.Lifted as E 88 | 89 | #if !MIN_VERSION_base(4, 11, 0) 90 | import Data.Semigroup (Semigroup((<>))) 91 | #endif 92 | 93 | -- | Generalized version of 'A.async'. 94 | async :: MonadBaseControl IO m => m a -> m (Async (StM m a)) 95 | async = asyncUsing A.async 96 | 97 | -- | Generalized version of 'A.asyncBound'. 98 | asyncBound :: MonadBaseControl IO m => m a -> m (Async (StM m a)) 99 | asyncBound = asyncUsing A.asyncBound 100 | 101 | -- | Generalized version of 'A.asyncOn'. 102 | asyncOn :: MonadBaseControl IO m => Int -> m a -> m (Async (StM m a)) 103 | asyncOn cpu = asyncUsing (A.asyncOn cpu) 104 | 105 | -- | Generalized version of 'A.asyncWithUnmask'. 106 | asyncWithUnmask 107 | :: MonadBaseControl IO m 108 | => ((forall b. m b -> m b) -> m a) 109 | -> m (Async (StM m a)) 110 | asyncWithUnmask actionWith = 111 | asyncUsing A.async (actionWith (liftBaseOp_ unsafeUnmask)) 112 | 113 | -- | Generalized version of 'A.asyncOnWithUnmask'. 114 | asyncOnWithUnmask 115 | :: MonadBaseControl IO m 116 | => Int 117 | -> ((forall b. m b -> m b) -> m a) 118 | -> m (Async (StM m a)) 119 | asyncOnWithUnmask cpu actionWith = 120 | asyncUsing (A.asyncOn cpu) (actionWith (liftBaseOp_ unsafeUnmask)) 121 | 122 | asyncUsing 123 | :: MonadBaseControl IO m 124 | => (IO (StM m a) -> IO (Async (StM m a))) 125 | -> m a 126 | -> m (Async (StM m a)) 127 | asyncUsing fork m = 128 | liftBaseWith $ \runInIO -> fork (runInIO m) 129 | 130 | -- | Generalized version of 'A.withAsync'. 131 | withAsync 132 | :: MonadBaseControl IO m 133 | => m a 134 | -> (Async (StM m a) -> m b) 135 | -> m b 136 | withAsync = liftWithAsync A.withAsync 137 | {-# INLINABLE withAsync #-} 138 | 139 | -- | Generalized version of 'A.withAsyncBound'. 140 | withAsyncBound 141 | :: MonadBaseControl IO m 142 | => m a 143 | -> (Async (StM m a) -> m b) 144 | -> m b 145 | withAsyncBound = liftWithAsync A.withAsyncBound 146 | {-# INLINABLE withAsyncBound #-} 147 | 148 | liftWithAsync 149 | :: MonadBaseControl IO m 150 | => (IO (StM m a) -> (Async (StM m a) -> IO (StM m b)) -> IO (StM m b)) 151 | -> (m a -> (Async (StM m a) -> m b) -> m b) 152 | liftWithAsync withA action cont = restoreM =<< do 153 | liftBaseWith $ \runInIO -> do 154 | withA (runInIO action) (runInIO . cont) 155 | 156 | -- | Generalized version of 'A.withAsyncOn'. 157 | withAsyncOn 158 | :: MonadBaseControl IO m 159 | => Int 160 | -> m a 161 | -> (Async (StM m a) -> m b) 162 | -> m b 163 | withAsyncOn = withAsyncUsing . asyncOn 164 | {-# INLINABLE withAsyncOn #-} 165 | 166 | -- | Generalized version of 'A.withAsyncWithUnmask'. 167 | withAsyncWithUnmask 168 | :: MonadBaseControl IO m 169 | => ((forall c. m c -> m c) -> m a) 170 | -> (Async (StM m a) -> m b) 171 | -> m b 172 | withAsyncWithUnmask actionWith = 173 | withAsyncUsing async (actionWith (liftBaseOp_ unsafeUnmask)) 174 | {-# INLINABLE withAsyncWithUnmask #-} 175 | 176 | -- | Generalized version of 'A.withAsyncOnWithUnmask'. 177 | withAsyncOnWithUnmask 178 | :: MonadBaseControl IO m 179 | => Int 180 | -> ((forall c. m c -> m c) -> m a) 181 | -> (Async (StM m a) -> m b) 182 | -> m b 183 | withAsyncOnWithUnmask cpu actionWith = 184 | withAsyncUsing (asyncOn cpu) (actionWith (liftBaseOp_ unsafeUnmask)) 185 | {-# INLINABLE withAsyncOnWithUnmask #-} 186 | 187 | withAsyncUsing 188 | :: MonadBaseControl IO m 189 | => (m a -> m (Async (StM m a))) 190 | -> m a 191 | -> (Async (StM m a) -> m b) 192 | -> m b 193 | withAsyncUsing fork action inner = E.mask $ \restore -> do 194 | a <- fork $ restore action 195 | r <- restore (inner a) `E.catch` \e -> do 196 | cancel a 197 | E.throwIO (e :: SomeException) 198 | cancel a 199 | return r 200 | 201 | -- | Generalized version of 'A.wait'. 202 | wait :: MonadBaseControl IO m => Async (StM m a) -> m a 203 | wait = liftBase . A.wait >=> restoreM 204 | 205 | -- | Generalized version of 'A.poll'. 206 | poll 207 | :: MonadBaseControl IO m 208 | => Async (StM m a) 209 | -> m (Maybe (Either SomeException a)) 210 | poll a = 211 | liftBase (A.poll a) >>= 212 | maybe (return Nothing) (fmap Just . sequenceEither) 213 | 214 | -- | Generalized version of 'A.cancel'. 215 | cancel :: MonadBase IO m => Async a -> m () 216 | cancel = liftBase . A.cancel 217 | 218 | -- | Generalized version of 'A.cancelWith'. 219 | cancelWith :: (MonadBase IO m, Exception e) => Async a -> e -> m () 220 | cancelWith = (liftBase .) . A.cancelWith 221 | 222 | -- | Generalized version of 'A.uninterruptibleCancel'. 223 | uninterruptibleCancel :: MonadBase IO m => Async a -> m () 224 | uninterruptibleCancel = liftBase . A.uninterruptibleCancel 225 | 226 | -- | Generalized version of 'A.waitCatch'. 227 | waitCatch 228 | :: MonadBaseControl IO m 229 | => Async (StM m a) 230 | -> m (Either SomeException a) 231 | waitCatch a = liftBase (A.waitCatch a) >>= sequenceEither 232 | 233 | -- | Generalized version of 'A.waitAny'. 234 | waitAny :: MonadBaseControl IO m => [Async (StM m a)] -> m (Async (StM m a), a) 235 | waitAny as = do 236 | (a, s) <- liftBase $ A.waitAny as 237 | r <- restoreM s 238 | return (a, r) 239 | 240 | -- | Generalized version of 'A.waitAnyCatch'. 241 | waitAnyCatch 242 | :: MonadBaseControl IO m 243 | => [Async (StM m a)] 244 | -> m (Async (StM m a), Either SomeException a) 245 | waitAnyCatch as = do 246 | (a, s) <- liftBase $ A.waitAnyCatch as 247 | r <- sequenceEither s 248 | return (a, r) 249 | 250 | -- | Generalized version of 'A.waitAnyCancel'. 251 | waitAnyCancel 252 | :: MonadBaseControl IO m 253 | => [Async (StM m a)] 254 | -> m (Async (StM m a), a) 255 | waitAnyCancel as = do 256 | (a, s) <- liftBase $ A.waitAnyCancel as 257 | r <- restoreM s 258 | return (a, r) 259 | 260 | -- | Generalized version of 'A.waitAnyCatchCancel'. 261 | waitAnyCatchCancel 262 | :: MonadBaseControl IO m 263 | => [Async (StM m a)] 264 | -> m (Async (StM m a), Either SomeException a) 265 | waitAnyCatchCancel as = do 266 | (a, s) <- liftBase $ A.waitAnyCatchCancel as 267 | r <- sequenceEither s 268 | return (a, r) 269 | 270 | -- | Generalized version of 'A.waitEither'. 271 | waitEither 272 | :: MonadBaseControl IO m 273 | => Async (StM m a) 274 | -> Async (StM m b) 275 | -> m (Either a b) 276 | waitEither a b = 277 | liftBase (A.waitEither a b) >>= 278 | either (fmap Left . restoreM) (fmap Right . restoreM) 279 | 280 | -- | Generalized version of 'A.waitEitherCatch'. 281 | waitEitherCatch 282 | :: MonadBaseControl IO m 283 | => Async (StM m a) 284 | -> Async (StM m b) 285 | -> m (Either (Either SomeException a) (Either SomeException b)) 286 | waitEitherCatch a b = 287 | liftBase (A.waitEitherCatch a b) >>= 288 | either (fmap Left . sequenceEither) (fmap Right . sequenceEither) 289 | 290 | -- | Generalized version of 'A.waitEitherCancel'. 291 | waitEitherCancel 292 | :: MonadBaseControl IO m 293 | => Async (StM m a) 294 | -> Async (StM m b) 295 | -> m (Either a b) 296 | waitEitherCancel a b = 297 | liftBase (A.waitEitherCancel a b) >>= 298 | either (fmap Left . restoreM) (fmap Right . restoreM) 299 | 300 | -- | Generalized version of 'A.waitEitherCatchCancel'. 301 | waitEitherCatchCancel 302 | :: MonadBaseControl IO m 303 | => Async (StM m a) 304 | -> Async (StM m b) 305 | -> m (Either (Either SomeException a) (Either SomeException b)) 306 | waitEitherCatchCancel a b = 307 | liftBase (A.waitEitherCatch a b) >>= 308 | either (fmap Left . sequenceEither) (fmap Right . sequenceEither) 309 | 310 | -- | Generalized version of 'A.waitEither_'. 311 | -- 312 | -- NOTE: This function discards the monadic effects besides IO in the forked 313 | -- computation. 314 | waitEither_ 315 | :: MonadBase IO m 316 | => Async a 317 | -> Async b 318 | -> m () 319 | waitEither_ a b = liftBase (A.waitEither_ a b) 320 | 321 | -- | Generalized version of 'A.waitBoth'. 322 | waitBoth 323 | :: MonadBaseControl IO m 324 | => Async (StM m a) 325 | -> Async (StM m b) 326 | -> m (a, b) 327 | waitBoth a b = do 328 | (sa, sb) <- liftBase (A.waitBoth a b) 329 | ra <- restoreM sa 330 | rb <- restoreM sb 331 | return (ra, rb) 332 | {-# INLINABLE waitBoth #-} 333 | 334 | -- | Generalized version of 'A.link'. 335 | link :: MonadBase IO m => Async a -> m () 336 | link = liftBase . A.link 337 | 338 | -- | Generalized version of 'A.link2'. 339 | link2 :: MonadBase IO m => Async a -> Async b -> m () 340 | link2 = (liftBase .) . A.link2 341 | 342 | -- | Generalized version of 'A.race'. 343 | race :: MonadBaseControl IO m => m a -> m b -> m (Either a b) 344 | race left right = 345 | withAsync left $ \a -> 346 | withAsync right $ \b -> 347 | waitEither a b 348 | {-# INLINABLE race #-} 349 | 350 | -- | Generalized version of 'A.race_'. 351 | -- 352 | -- NOTE: This function discards the monadic effects besides IO in the forked 353 | -- computation. 354 | race_ :: MonadBaseControl IO m => m a -> m b -> m () 355 | race_ left right = 356 | withAsync left $ \a -> 357 | withAsync right $ \b -> 358 | waitEither_ a b 359 | {-# INLINABLE race_ #-} 360 | 361 | -- | Generalized version of 'A.concurrently'. 362 | concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b) 363 | concurrently left right = 364 | withAsync left $ \a -> 365 | withAsync right $ \b -> 366 | waitBoth a b 367 | {-# INLINABLE concurrently #-} 368 | 369 | -- | Generalized version of 'A.concurrently_'. 370 | concurrently_ :: MonadBaseControl IO m => m a -> m b -> m () 371 | concurrently_ left right = void $ concurrently left right 372 | {-# INLINABLE concurrently_ #-} 373 | 374 | -- | Generalized version of 'A.mapConcurrently'. 375 | mapConcurrently 376 | :: (Traversable t, MonadBaseControl IO m) 377 | => (a -> m b) 378 | -> t a 379 | -> m (t b) 380 | mapConcurrently f = runConcurrently . traverse (Concurrently . f) 381 | 382 | -- | Generalized version of 'A.mapConcurrently_'. 383 | mapConcurrently_ 384 | :: (Foldable t, MonadBaseControl IO m) 385 | => (a -> m b) 386 | -> t a 387 | -> m () 388 | mapConcurrently_ f = runConcurrently . foldMap (Concurrently . void . f) 389 | 390 | -- | Generalized version of 'A.forConcurrently'. 391 | forConcurrently 392 | :: (Traversable t, MonadBaseControl IO m) 393 | => t a 394 | -> (a -> m b) 395 | -> m (t b) 396 | forConcurrently = flip mapConcurrently 397 | 398 | -- | Generalized version of 'A.forConcurrently_'. 399 | forConcurrently_ 400 | :: (Foldable t, MonadBaseControl IO m) 401 | => t a 402 | -> (a -> m b) 403 | -> m () 404 | forConcurrently_ = flip mapConcurrently_ 405 | 406 | -- | Generalized version of 'A.replicateConcurrently'. 407 | replicateConcurrently 408 | :: MonadBaseControl IO m 409 | => Int 410 | -> m a 411 | -> m [a] 412 | replicateConcurrently n = 413 | runConcurrently . sequenceA . replicate n . Concurrently 414 | 415 | -- | Generalized version of 'A.replicateConcurrently_'. 416 | replicateConcurrently_ 417 | :: MonadBaseControl IO m 418 | => Int 419 | -> m a 420 | -> m () 421 | replicateConcurrently_ n = 422 | runConcurrently . fold . replicate n . Concurrently . void 423 | 424 | -- | Generalized version of 'A.Concurrently'. 425 | -- 426 | -- A value of type @'Concurrently' m a@ is an IO-based operation that can be 427 | -- composed with other 'Concurrently' values, using the 'Applicative' and 428 | -- 'Alternative' instances. 429 | -- 430 | -- Calling 'runConcurrently' on a value of type @'Concurrently' m a@ will 431 | -- execute the IO-based lifted operations it contains concurrently, before 432 | -- delivering the result of type 'a'. 433 | -- 434 | -- For example 435 | -- 436 | -- @ 437 | -- (page1, page2, page3) <- 'runConcurrently' $ (,,) 438 | -- '<$>' 'Concurrently' (getURL "url1") 439 | -- '<*>' 'Concurrently' (getURL "url2") 440 | -- '<*>' 'Concurrently' (getURL "url3") 441 | -- @ 442 | newtype Concurrently m a = Concurrently { runConcurrently :: m a } 443 | 444 | instance Functor m => Functor (Concurrently m) where 445 | fmap f (Concurrently a) = Concurrently $ f <$> a 446 | 447 | instance MonadBaseControl IO m => Applicative (Concurrently m) where 448 | pure = Concurrently . pure 449 | Concurrently fs <*> Concurrently as = 450 | Concurrently $ uncurry ($) <$> concurrently fs as 451 | 452 | instance MonadBaseControl IO m => Alternative (Concurrently m) where 453 | empty = Concurrently $ liftBaseWith $ \_ -> forever $ threadDelay maxBound 454 | Concurrently as <|> Concurrently bs = 455 | Concurrently $ either id id <$> race as bs 456 | 457 | instance (MonadBaseControl IO m, Semigroup a) => 458 | Semigroup (Concurrently m a) where 459 | (<>) = liftA2 (<>) 460 | 461 | instance (MonadBaseControl IO m, Semigroup a, Monoid a) => 462 | Monoid (Concurrently m a) where 463 | mempty = pure mempty 464 | mappend = (<>) 465 | 466 | sequenceEither :: MonadBaseControl IO m => Either e (StM m a) -> m (Either e a) 467 | sequenceEither = either (return . Left) (fmap Right . restoreM) 468 | --------------------------------------------------------------------------------