├── .ghci ├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── benchmarks └── Benchmarks.hs ├── cabal.haskell-ci ├── hie.yaml ├── lifted-async.cabal ├── src └── Control │ └── Concurrent │ └── Async │ ├── Lifted.hs │ └── Lifted │ └── Safe.hs └── tests ├── RegressionTests.hs ├── Test └── Async │ ├── Common.hs │ ├── IO.hs │ ├── Reader.hs │ └── State.hs └── TestSuite.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -i./src -i./tests 2 | -------------------------------------------------------------------------------- /.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/andreasabel/haskell-ci 10 | # 11 | # version: 0.19.20241021 12 | # 13 | # REGENDATA ("0.19.20241021",["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-20.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.12.20241014 40 | compilerKind: ghc 41 | compilerVersion: 9.12.20241014 42 | setup-method: ghcup 43 | allow-failure: false 44 | - compiler: ghc-9.10.1 45 | compilerKind: ghc 46 | compilerVersion: 9.10.1 47 | setup-method: ghcup 48 | allow-failure: false 49 | - compiler: ghc-9.8.2 50 | compilerKind: ghc 51 | compilerVersion: 9.8.2 52 | setup-method: ghcup 53 | allow-failure: false 54 | - compiler: ghc-9.6.6 55 | compilerKind: ghc 56 | compilerVersion: 9.6.6 57 | setup-method: ghcup 58 | allow-failure: false 59 | - compiler: ghc-9.4.8 60 | compilerKind: ghc 61 | compilerVersion: 9.4.8 62 | setup-method: ghcup 63 | allow-failure: false 64 | - compiler: ghc-9.2.8 65 | compilerKind: ghc 66 | compilerVersion: 9.2.8 67 | setup-method: ghcup 68 | allow-failure: false 69 | - compiler: ghc-9.0.2 70 | compilerKind: ghc 71 | compilerVersion: 9.0.2 72 | setup-method: ghcup 73 | allow-failure: false 74 | - compiler: ghc-8.10.7 75 | compilerKind: ghc 76 | compilerVersion: 8.10.7 77 | setup-method: ghcup 78 | allow-failure: false 79 | - compiler: ghc-8.8.4 80 | compilerKind: ghc 81 | compilerVersion: 8.8.4 82 | setup-method: ghcup 83 | allow-failure: false 84 | - compiler: ghc-8.6.5 85 | compilerKind: ghc 86 | compilerVersion: 8.6.5 87 | setup-method: ghcup 88 | allow-failure: false 89 | - compiler: ghc-8.4.4 90 | compilerKind: ghc 91 | compilerVersion: 8.4.4 92 | setup-method: ghcup 93 | allow-failure: false 94 | - compiler: ghc-8.2.2 95 | compilerKind: ghc 96 | compilerVersion: 8.2.2 97 | setup-method: ghcup 98 | allow-failure: false 99 | - compiler: ghc-8.0.2 100 | compilerKind: ghc 101 | compilerVersion: 8.0.2 102 | setup-method: ghcup 103 | allow-failure: false 104 | fail-fast: false 105 | steps: 106 | - name: apt 107 | run: | 108 | apt-get update 109 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 110 | mkdir -p "$HOME/.ghcup/bin" 111 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 112 | chmod a+x "$HOME/.ghcup/bin/ghcup" 113 | "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; 114 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 115 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 116 | env: 117 | HCKIND: ${{ matrix.compilerKind }} 118 | HCNAME: ${{ matrix.compiler }} 119 | HCVER: ${{ matrix.compilerVersion }} 120 | - name: Set PATH and environment variables 121 | run: | 122 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 123 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 124 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 125 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 126 | HCDIR=/opt/$HCKIND/$HCVER 127 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 128 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 129 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 130 | echo "HC=$HC" >> "$GITHUB_ENV" 131 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 132 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 133 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 134 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 135 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 136 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 137 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 138 | if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi 139 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 140 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 141 | env: 142 | HCKIND: ${{ matrix.compilerKind }} 143 | HCNAME: ${{ matrix.compiler }} 144 | HCVER: ${{ matrix.compilerVersion }} 145 | - name: env 146 | run: | 147 | env 148 | - name: write cabal config 149 | run: | 150 | mkdir -p $CABAL_DIR 151 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 196 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 197 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 198 | rm -f cabal-plan.xz 199 | chmod a+x $HOME/.cabal/bin/cabal-plan 200 | cabal-plan --version 201 | - name: checkout 202 | uses: actions/checkout@v4 203 | with: 204 | path: source 205 | - name: initial cabal.project for sdist 206 | run: | 207 | touch cabal.project 208 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 209 | cat cabal.project 210 | - name: sdist 211 | run: | 212 | mkdir -p sdist 213 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 214 | - name: unpack 215 | run: | 216 | mkdir -p unpacked 217 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 218 | - name: generate cabal.project 219 | run: | 220 | PKGDIR_lifted_async="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/lifted-async-[0-9.]*')" 221 | echo "PKGDIR_lifted_async=${PKGDIR_lifted_async}" >> "$GITHUB_ENV" 222 | rm -f cabal.project cabal.project.local 223 | touch cabal.project 224 | touch cabal.project.local 225 | echo "packages: ${PKGDIR_lifted_async}" >> cabal.project 226 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package lifted-async" >> cabal.project ; fi 227 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 228 | cat >> cabal.project <> cabal.project 232 | fi 233 | $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(lifted-async)$/; }' >> cabal.project.local 234 | cat cabal.project 235 | cat cabal.project.local 236 | - name: dump install plan 237 | run: | 238 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 239 | cabal-plan 240 | - name: restore cache 241 | uses: actions/cache/restore@v4 242 | with: 243 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 244 | path: ~/.cabal/store 245 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 246 | - name: install dependencies 247 | run: | 248 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 249 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 250 | - name: build w/o tests 251 | run: | 252 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 253 | - name: build 254 | run: | 255 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 256 | - name: tests 257 | run: | 258 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 259 | - name: cabal check 260 | run: | 261 | cd ${PKGDIR_lifted_async} || false 262 | ${CABAL} -vnormal check 263 | - name: haddock 264 | run: | 265 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 266 | - name: unconstrained build 267 | run: | 268 | rm -f cabal.project.local 269 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 270 | - name: save cache 271 | uses: actions/cache/save@v4 272 | if: always() 273 | with: 274 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 275 | path: ~/.cabal/store 276 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | .ghc.* 3 | .stack-work/ 4 | cabal.project.local 5 | dist-newstyle/ 6 | dist/ 7 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for lifted-async 2 | 3 | ## v0.10.2.7 - 2024-11-03 4 | 5 | * 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)) 6 | 7 | ## v0.10.2.6 - 2024-10-05 8 | 9 | * Allow base-4.20, bump CI to GHC 9.10.1 (([#44](https://github.com/maoe/lifted-async/issues/44))) 10 | 11 | ## v0.10.2.5 - 2023-11-11 12 | 13 | * Support GHC 9.8 ([#42](https://github.com/maoe/lifted-async/issues/42)) 14 | * Allow base-4.19, bump CI to GHC 9.8.1 ([#43](https://github.com/maoe/lifted-async/pull/43)) 15 | 16 | ## v0.10.2.4 - 2022-03-19 17 | 18 | * Support mtl-2.3.1, allow base-4.18 (GHC 9.6) ([#41](https://github.com/maoe/lifted-async/pull/41)) 19 | 20 | ## v0.10.2.3 - 2022-08-13 21 | 22 | * Allow base-4.17 (GHC 9.4) and bump CI to latest GHC versions ([#39](https://github.com/maoe/lifted-async/pull/39)) 23 | 24 | ## v0.10.2.2 - 2021-11-02 25 | 26 | * Allow base-4.17 for GHC 9.2.1 ([#37](https://github.com/maoe/lifted-async/pull/37)) 27 | 28 | ## v0.10.2.1 - 2021-07-23 29 | 30 | * Relax upper version bound for tasty-bench 31 | 32 | ## v0.10.2 - 2021-04-02 33 | 34 | * Define withAsync in terms of corresponding function from async ([#36](https://github.com/maoe/lifted-async/pull/36)) 35 | * Fixes [#34](https://github.com/maoe/lifted-async/issues/34) 36 | 37 | ## v0.10.1.3 - 2021-02-26 38 | 39 | * Support GHC 9.0.1 ([#33](https://github.com/maoe/lifted-async/pull/33)) 40 | * Switch from Travis CI to GitHub Actions 41 | * Switch from criterion to tasty-bench 42 | 43 | ## v0.10.1.2 - 2020-07-23 44 | 45 | * Relax upper version bound for tasty-expected-failure 46 | 47 | ## v0.10.1.1 - 2020-06-29 48 | 49 | * Bump up cabal-version to 1.24 50 | 51 | ## v0.10.1 - 2020-06-29 52 | 53 | * Fix typechecking errors with GHC HEAD 8.11 ([#31](https://github.com/maoe/lifted-async/pull/31)) 54 | 55 | ## v0.10.0.6 - 2020-03-31 56 | 57 | * Relax upper version bound for base to suppose GHC 8.10 ([#30](https://github.com/maoe/lifted-async/pull/30)) 58 | 59 | ## v0.10.0.5 - 2020-02-08 60 | 61 | * Relax upper version bounds for constraints 62 | 63 | ## v0.10.0.4 - 2019-05-03 64 | 65 | * Relax upper version bounds for base and constraints 66 | 67 | ## v0.10.0.3 - 2018-09-25 68 | 69 | * Relax upper version bound for base to support GHC 8.6.1 70 | 71 | ## v0.10.0.2 - 2018-05-13 72 | 73 | * Allow test_link to fail because it's non-deterministic (#26) 74 | 75 | ## v0.10.0.1 - 2018-03-10 76 | 77 | * Relax upper version bound for base in GHC 8.4.1 (#25) 78 | 79 | ## v0.10.0 - 2018-02-08 80 | 81 | * Support only async >= 2.2 82 | * Drop support for monad-control == 0.* 83 | * Drop support for GHC < 7.10 84 | 85 | ## v0.9.3.3 - 2018-01-22 86 | 87 | * Relax upper version bound for constraints 88 | 89 | ## v0.9.3.2 - 2017-12-12 90 | 91 | * Minor improvements in the cabal file 92 | 93 | ## v0.9.3.1 - 2017-12-12 94 | 95 | * Relax upper version bound for tasty-hunit 96 | 97 | ## v0.9.3 - 2017-06-26 98 | 99 | * Add Haddock comments for concurrently_ (#23) 100 | * Add replicateConcurrently and replicateConcurrently_ 101 | * Test with GHC 8.2.1 on Travis 102 | 103 | ## v0.9.2 - 2017-06-24 104 | 105 | * Add concurrently_ (#22) 106 | 107 | ## v0.9.1.1 - 2017-01-26 108 | 109 | * Relax upper version bound for constraints 110 | 111 | ## v0.9.1 - 2017-01-13 112 | 113 | * Add (for|map)Concurrently_ (#21) 114 | 115 | ## v0.9.0 - 2016-05-22 116 | 117 | * Leverage `StM m a ~ a` in the `Safe` module for faster `wait`/`poll`/`race`/`concurrently` 118 | 119 | ## v0.8.0.1 - 2015-01-17 120 | 121 | * Relax upper bound for constraints 122 | 123 | ## v0.8.0 - 2016-01-10 124 | 125 | * Drop Monad instance for Concurrently 126 | * Expose STM operations 127 | * Relax upper bound for base and async 128 | * Add Monoid and Semigroup instances for Concurrently 129 | 130 | ## v0.7.0.2 - 2015-11-26 131 | 132 | * Relax upper bound for the constraints package 133 | * Upper bound remains < 0.6 for GHC < 7.8 as constraints-0.6 requires the closed type families extension. 134 | * Drop support for GHC 7.4.2 135 | 136 | ## v0.7.0.1 - 2015-05-18 137 | 138 | * Fix typecheck error with GHC HEAD (#17) 139 | 140 | ## v0.7.0 - 2015-03-30 141 | 142 | * Fix the unnecessarily constrained type of link2 (#16) 143 | * Turn the caveat in the Safe module into a WARNING pragma (#15) 144 | 145 | ## v0.6.0.1 - 2015-01-14 146 | 147 | * Increase the lower bound for base to >= 4.5 148 | 149 | ## v0.6.0 - 2015-01-13 150 | 151 | * Replace `StM m a ~ a` in the type signatures with `Forall (Pure m)` (#12) 152 | 153 | ## v0.5.0.1 - 2014-12-29 154 | 155 | * Fix build issues in the test suite (#11 and others) 156 | 157 | ## v0.5.0 - 2014-12-29 158 | 159 | * Simplify the type of `Concurrently` (#10) 160 | 161 | ## v0.4.0 - 2014-12-29 162 | 163 | * Accept `constraints > 0.4` as well even when built with ghc < 7.8. 164 | * Support for GHC 7.10.1 165 | 166 | ## v0.3.0 - 2014-12-28 167 | 168 | * Support for `monad-control == 1.0.*` 169 | * `waitEither_` and `race_` now discard monadic effects besides `IO`. This is a breaking change. 170 | * `Control.Concurrent.Async.Lifted.Safe` is added. 171 | * Add `Monad` instance for `Concurrently` 172 | * Relax upper bound for base 173 | 174 | ## v0.2.0.2 - 2014-08-20 175 | 176 | * Fix build failure in the test suite (#6) 177 | 178 | ## v0.2.0.1 - 2014-07-26 179 | 180 | * Fix a typo in a haddock comment (#5 by @supki) 181 | * Fix Travis CI failure 182 | 183 | ## v0.2.0 - 2014-05-01 184 | 185 | * Generalize `Concurrently` (#4) 186 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: develop ghc* ci* 2 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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.12.0 16 | GHC == 9.10.1 17 | GHC == 9.8.2 18 | GHC == 9.6.6 19 | GHC == 9.4.8 20 | GHC == 9.2.8 21 | GHC == 9.0.2 22 | GHC == 8.10.7 23 | GHC == 8.8.4 24 | GHC == 8.6.5 25 | GHC == 8.4.4 26 | GHC == 8.2.2 27 | GHC == 8.0.2 28 | 29 | extra-doc-files: 30 | README.md 31 | CHANGELOG.md 32 | 33 | description: 34 | This package provides IO operations from @async@ package lifted to any 35 | instance of 'MonadBase' or 'MonadBaseControl'. 36 | 37 | library 38 | exposed-modules: 39 | Control.Concurrent.Async.Lifted 40 | Control.Concurrent.Async.Lifted.Safe 41 | build-depends: 42 | base >= 4.5 && < 4.22 43 | , async >= 2.2 && < 2.3 44 | , lifted-base >= 0.2 && < 0.3 45 | , transformers-base >= 0.4 && < 0.5 46 | , monad-control == 1.0.* 47 | if impl(ghc >= 7.8) 48 | build-depends: constraints >= 0.2 && < 0.15 49 | else 50 | build-depends: constraints >= 0.2 && < 0.6 51 | ghc-options: -Wall 52 | hs-source-dirs: src 53 | default-language: Haskell2010 54 | 55 | test-suite test-lifted-async 56 | type: exitcode-stdio-1.0 57 | hs-source-dirs: tests 58 | main-is: TestSuite.hs 59 | other-modules: 60 | Test.Async.Common 61 | Test.Async.IO 62 | Test.Async.State 63 | Test.Async.Reader 64 | ghc-options: -Wall -threaded 65 | build-depends: 66 | base 67 | , HUnit 68 | , lifted-async 69 | , lifted-base 70 | , monad-control 71 | , mtl 72 | , tasty 73 | , tasty-expected-failure < 0.13 74 | , tasty-hunit >= 0.9 && < 0.11 75 | , tasty-th 76 | default-language: Haskell2010 77 | 78 | test-suite regression-tests 79 | type: exitcode-stdio-1.0 80 | hs-source-dirs: tests 81 | main-is: RegressionTests.hs 82 | ghc-options: -Wall -threaded 83 | build-depends: 84 | base 85 | , async 86 | , lifted-async 87 | , mtl 88 | , tasty-hunit >= 0.9 && < 0.11 89 | , tasty-th 90 | default-language: Haskell2010 91 | 92 | benchmark benchmark-lifted-async 93 | type: exitcode-stdio-1.0 94 | hs-source-dirs: benchmarks 95 | main-is: Benchmarks.hs 96 | ghc-options: -Wall 97 | build-depends: 98 | base 99 | , async 100 | , tasty-bench < 0.5 101 | , deepseq 102 | , lifted-async 103 | default-language: Haskell2010 104 | 105 | benchmark benchmark-lifted-async-threaded 106 | type: exitcode-stdio-1.0 107 | hs-source-dirs: benchmarks 108 | main-is: Benchmarks.hs 109 | ghc-options: -Wall -threaded 110 | build-depends: 111 | base 112 | , async 113 | , tasty-bench < 0.5 114 | , deepseq 115 | , lifted-async 116 | default-language: Haskell2010 117 | 118 | source-repository head 119 | type: git 120 | branch: develop 121 | location: https://github.com/maoe/lifted-async.git 122 | -------------------------------------------------------------------------------- /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 defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 90 | import Data.Foldable 91 | import Data.Traversable 92 | #endif 93 | #if !MIN_VERSION_base(4, 8, 0) 94 | import Data.Monoid (Monoid(mappend, mempty)) 95 | #elif MIN_VERSION_base(4, 9, 0) && !MIN_VERSION_base(4, 13, 0) 96 | import Data.Semigroup (Semigroup((<>))) 97 | #endif 98 | 99 | -- | Generalized version of 'A.async'. 100 | async :: MonadBaseControl IO m => m a -> m (Async (StM m a)) 101 | async = asyncUsing A.async 102 | 103 | -- | Generalized version of 'A.asyncBound'. 104 | asyncBound :: MonadBaseControl IO m => m a -> m (Async (StM m a)) 105 | asyncBound = asyncUsing A.asyncBound 106 | 107 | -- | Generalized version of 'A.asyncOn'. 108 | asyncOn :: MonadBaseControl IO m => Int -> m a -> m (Async (StM m a)) 109 | asyncOn cpu = asyncUsing (A.asyncOn cpu) 110 | 111 | -- | Generalized version of 'A.asyncWithUnmask'. 112 | asyncWithUnmask 113 | :: MonadBaseControl IO m 114 | => ((forall b. m b -> m b) -> m a) 115 | -> m (Async (StM m a)) 116 | asyncWithUnmask actionWith = 117 | asyncUsing A.async (actionWith (liftBaseOp_ unsafeUnmask)) 118 | 119 | -- | Generalized version of 'A.asyncOnWithUnmask'. 120 | asyncOnWithUnmask 121 | :: MonadBaseControl IO m 122 | => Int 123 | -> ((forall b. m b -> m b) -> m a) 124 | -> m (Async (StM m a)) 125 | asyncOnWithUnmask cpu actionWith = 126 | asyncUsing (A.asyncOn cpu) (actionWith (liftBaseOp_ unsafeUnmask)) 127 | 128 | asyncUsing 129 | :: MonadBaseControl IO m 130 | => (IO (StM m a) -> IO (Async (StM m a))) 131 | -> m a 132 | -> m (Async (StM m a)) 133 | asyncUsing fork m = 134 | liftBaseWith $ \runInIO -> fork (runInIO m) 135 | 136 | -- | Generalized version of 'A.withAsync'. 137 | withAsync 138 | :: MonadBaseControl IO m 139 | => m a 140 | -> (Async (StM m a) -> m b) 141 | -> m b 142 | withAsync = liftWithAsync A.withAsync 143 | {-# INLINABLE withAsync #-} 144 | 145 | -- | Generalized version of 'A.withAsyncBound'. 146 | withAsyncBound 147 | :: MonadBaseControl IO m 148 | => m a 149 | -> (Async (StM m a) -> m b) 150 | -> m b 151 | withAsyncBound = liftWithAsync A.withAsyncBound 152 | {-# INLINABLE withAsyncBound #-} 153 | 154 | liftWithAsync 155 | :: MonadBaseControl IO m 156 | => (IO (StM m a) -> (Async (StM m a) -> IO (StM m b)) -> IO (StM m b)) 157 | -> (m a -> (Async (StM m a) -> m b) -> m b) 158 | liftWithAsync withA action cont = restoreM =<< do 159 | liftBaseWith $ \runInIO -> do 160 | withA (runInIO action) (runInIO . cont) 161 | 162 | -- | Generalized version of 'A.withAsyncOn'. 163 | withAsyncOn 164 | :: MonadBaseControl IO m 165 | => Int 166 | -> m a 167 | -> (Async (StM m a) -> m b) 168 | -> m b 169 | withAsyncOn = withAsyncUsing . asyncOn 170 | {-# INLINABLE withAsyncOn #-} 171 | 172 | -- | Generalized version of 'A.withAsyncWithUnmask'. 173 | withAsyncWithUnmask 174 | :: MonadBaseControl IO m 175 | => ((forall c. m c -> m c) -> m a) 176 | -> (Async (StM m a) -> m b) 177 | -> m b 178 | withAsyncWithUnmask actionWith = 179 | withAsyncUsing async (actionWith (liftBaseOp_ unsafeUnmask)) 180 | {-# INLINABLE withAsyncWithUnmask #-} 181 | 182 | -- | Generalized version of 'A.withAsyncOnWithUnmask'. 183 | withAsyncOnWithUnmask 184 | :: MonadBaseControl IO m 185 | => Int 186 | -> ((forall c. m c -> m c) -> m a) 187 | -> (Async (StM m a) -> m b) 188 | -> m b 189 | withAsyncOnWithUnmask cpu actionWith = 190 | withAsyncUsing (asyncOn cpu) (actionWith (liftBaseOp_ unsafeUnmask)) 191 | {-# INLINABLE withAsyncOnWithUnmask #-} 192 | 193 | withAsyncUsing 194 | :: MonadBaseControl IO m 195 | => (m a -> m (Async (StM m a))) 196 | -> m a 197 | -> (Async (StM m a) -> m b) 198 | -> m b 199 | withAsyncUsing fork action inner = E.mask $ \restore -> do 200 | a <- fork $ restore action 201 | r <- restore (inner a) `E.catch` \e -> do 202 | cancel a 203 | E.throwIO (e :: SomeException) 204 | cancel a 205 | return r 206 | 207 | -- | Generalized version of 'A.wait'. 208 | wait :: MonadBaseControl IO m => Async (StM m a) -> m a 209 | wait = liftBase . A.wait >=> restoreM 210 | 211 | -- | Generalized version of 'A.poll'. 212 | poll 213 | :: MonadBaseControl IO m 214 | => Async (StM m a) 215 | -> m (Maybe (Either SomeException a)) 216 | poll a = 217 | liftBase (A.poll a) >>= 218 | maybe (return Nothing) (fmap Just . sequenceEither) 219 | 220 | -- | Generalized version of 'A.cancel'. 221 | cancel :: MonadBase IO m => Async a -> m () 222 | cancel = liftBase . A.cancel 223 | 224 | -- | Generalized version of 'A.cancelWith'. 225 | cancelWith :: (MonadBase IO m, Exception e) => Async a -> e -> m () 226 | cancelWith = (liftBase .) . A.cancelWith 227 | 228 | -- | Generalized version of 'A.uninterruptibleCancel'. 229 | uninterruptibleCancel :: MonadBase IO m => Async a -> m () 230 | uninterruptibleCancel = liftBase . A.uninterruptibleCancel 231 | 232 | -- | Generalized version of 'A.waitCatch'. 233 | waitCatch 234 | :: MonadBaseControl IO m 235 | => Async (StM m a) 236 | -> m (Either SomeException a) 237 | waitCatch a = liftBase (A.waitCatch a) >>= sequenceEither 238 | 239 | -- | Generalized version of 'A.waitAny'. 240 | waitAny :: MonadBaseControl IO m => [Async (StM m a)] -> m (Async (StM m a), a) 241 | waitAny as = do 242 | (a, s) <- liftBase $ A.waitAny as 243 | r <- restoreM s 244 | return (a, r) 245 | 246 | -- | Generalized version of 'A.waitAnyCatch'. 247 | waitAnyCatch 248 | :: MonadBaseControl IO m 249 | => [Async (StM m a)] 250 | -> m (Async (StM m a), Either SomeException a) 251 | waitAnyCatch as = do 252 | (a, s) <- liftBase $ A.waitAnyCatch as 253 | r <- sequenceEither s 254 | return (a, r) 255 | 256 | -- | Generalized version of 'A.waitAnyCancel'. 257 | waitAnyCancel 258 | :: MonadBaseControl IO m 259 | => [Async (StM m a)] 260 | -> m (Async (StM m a), a) 261 | waitAnyCancel as = do 262 | (a, s) <- liftBase $ A.waitAnyCancel as 263 | r <- restoreM s 264 | return (a, r) 265 | 266 | -- | Generalized version of 'A.waitAnyCatchCancel'. 267 | waitAnyCatchCancel 268 | :: MonadBaseControl IO m 269 | => [Async (StM m a)] 270 | -> m (Async (StM m a), Either SomeException a) 271 | waitAnyCatchCancel as = do 272 | (a, s) <- liftBase $ A.waitAnyCatchCancel as 273 | r <- sequenceEither s 274 | return (a, r) 275 | 276 | -- | Generalized version of 'A.waitEither'. 277 | waitEither 278 | :: MonadBaseControl IO m 279 | => Async (StM m a) 280 | -> Async (StM m b) 281 | -> m (Either a b) 282 | waitEither a b = 283 | liftBase (A.waitEither a b) >>= 284 | either (fmap Left . restoreM) (fmap Right . restoreM) 285 | 286 | -- | Generalized version of 'A.waitEitherCatch'. 287 | waitEitherCatch 288 | :: MonadBaseControl IO m 289 | => Async (StM m a) 290 | -> Async (StM m b) 291 | -> m (Either (Either SomeException a) (Either SomeException b)) 292 | waitEitherCatch a b = 293 | liftBase (A.waitEitherCatch a b) >>= 294 | either (fmap Left . sequenceEither) (fmap Right . sequenceEither) 295 | 296 | -- | Generalized version of 'A.waitEitherCancel'. 297 | waitEitherCancel 298 | :: MonadBaseControl IO m 299 | => Async (StM m a) 300 | -> Async (StM m b) 301 | -> m (Either a b) 302 | waitEitherCancel a b = 303 | liftBase (A.waitEitherCancel a b) >>= 304 | either (fmap Left . restoreM) (fmap Right . restoreM) 305 | 306 | -- | Generalized version of 'A.waitEitherCatchCancel'. 307 | waitEitherCatchCancel 308 | :: MonadBaseControl IO m 309 | => Async (StM m a) 310 | -> Async (StM m b) 311 | -> m (Either (Either SomeException a) (Either SomeException b)) 312 | waitEitherCatchCancel a b = 313 | liftBase (A.waitEitherCatch a b) >>= 314 | either (fmap Left . sequenceEither) (fmap Right . sequenceEither) 315 | 316 | -- | Generalized version of 'A.waitEither_'. 317 | -- 318 | -- NOTE: This function discards the monadic effects besides IO in the forked 319 | -- computation. 320 | waitEither_ 321 | :: MonadBase IO m 322 | => Async a 323 | -> Async b 324 | -> m () 325 | waitEither_ a b = liftBase (A.waitEither_ a b) 326 | 327 | -- | Generalized version of 'A.waitBoth'. 328 | waitBoth 329 | :: MonadBaseControl IO m 330 | => Async (StM m a) 331 | -> Async (StM m b) 332 | -> m (a, b) 333 | waitBoth a b = do 334 | (sa, sb) <- liftBase (A.waitBoth a b) 335 | ra <- restoreM sa 336 | rb <- restoreM sb 337 | return (ra, rb) 338 | {-# INLINABLE waitBoth #-} 339 | 340 | -- | Generalized version of 'A.link'. 341 | link :: MonadBase IO m => Async a -> m () 342 | link = liftBase . A.link 343 | 344 | -- | Generalized version of 'A.link2'. 345 | link2 :: MonadBase IO m => Async a -> Async b -> m () 346 | link2 = (liftBase .) . A.link2 347 | 348 | -- | Generalized version of 'A.race'. 349 | race :: MonadBaseControl IO m => m a -> m b -> m (Either a b) 350 | race left right = 351 | withAsync left $ \a -> 352 | withAsync right $ \b -> 353 | waitEither a b 354 | {-# INLINABLE race #-} 355 | 356 | -- | Generalized version of 'A.race_'. 357 | -- 358 | -- NOTE: This function discards the monadic effects besides IO in the forked 359 | -- computation. 360 | race_ :: MonadBaseControl IO m => m a -> m b -> m () 361 | race_ left right = 362 | withAsync left $ \a -> 363 | withAsync right $ \b -> 364 | waitEither_ a b 365 | {-# INLINABLE race_ #-} 366 | 367 | -- | Generalized version of 'A.concurrently'. 368 | concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b) 369 | concurrently left right = 370 | withAsync left $ \a -> 371 | withAsync right $ \b -> 372 | waitBoth a b 373 | {-# INLINABLE concurrently #-} 374 | 375 | -- | Generalized version of 'A.concurrently_'. 376 | concurrently_ :: MonadBaseControl IO m => m a -> m b -> m () 377 | concurrently_ left right = void $ concurrently left right 378 | {-# INLINABLE concurrently_ #-} 379 | 380 | -- | Generalized version of 'A.mapConcurrently'. 381 | mapConcurrently 382 | :: (Traversable t, MonadBaseControl IO m) 383 | => (a -> m b) 384 | -> t a 385 | -> m (t b) 386 | mapConcurrently f = runConcurrently . traverse (Concurrently . f) 387 | 388 | -- | Generalized version of 'A.mapConcurrently_'. 389 | mapConcurrently_ 390 | :: (Foldable t, MonadBaseControl IO m) 391 | => (a -> m b) 392 | -> t a 393 | -> m () 394 | mapConcurrently_ f = runConcurrently . foldMap (Concurrently . void . f) 395 | 396 | -- | Generalized version of 'A.forConcurrently'. 397 | forConcurrently 398 | :: (Traversable t, MonadBaseControl IO m) 399 | => t a 400 | -> (a -> m b) 401 | -> m (t b) 402 | forConcurrently = flip mapConcurrently 403 | 404 | -- | Generalized version of 'A.forConcurrently_'. 405 | forConcurrently_ 406 | :: (Foldable t, MonadBaseControl IO m) 407 | => t a 408 | -> (a -> m b) 409 | -> m () 410 | forConcurrently_ = flip mapConcurrently_ 411 | 412 | -- | Generalized version of 'A.replicateConcurrently'. 413 | replicateConcurrently 414 | :: MonadBaseControl IO m 415 | => Int 416 | -> m a 417 | -> m [a] 418 | replicateConcurrently n = 419 | runConcurrently . sequenceA . replicate n . Concurrently 420 | 421 | -- | Generalized version of 'A.replicateConcurrently_'. 422 | replicateConcurrently_ 423 | :: MonadBaseControl IO m 424 | => Int 425 | -> m a 426 | -> m () 427 | replicateConcurrently_ n = 428 | runConcurrently . fold . replicate n . Concurrently . void 429 | 430 | -- | Generalized version of 'A.Concurrently'. 431 | -- 432 | -- A value of type @'Concurrently' m a@ is an IO-based operation that can be 433 | -- composed with other 'Concurrently' values, using the 'Applicative' and 434 | -- 'Alternative' instances. 435 | -- 436 | -- Calling 'runConcurrently' on a value of type @'Concurrently' m a@ will 437 | -- execute the IO-based lifted operations it contains concurrently, before 438 | -- delivering the result of type 'a'. 439 | -- 440 | -- For example 441 | -- 442 | -- @ 443 | -- (page1, page2, page3) <- 'runConcurrently' $ (,,) 444 | -- '<$>' 'Concurrently' (getURL "url1") 445 | -- '<*>' 'Concurrently' (getURL "url2") 446 | -- '<*>' 'Concurrently' (getURL "url3") 447 | -- @ 448 | newtype Concurrently m a = Concurrently { runConcurrently :: m a } 449 | 450 | instance Functor m => Functor (Concurrently m) where 451 | fmap f (Concurrently a) = Concurrently $ f <$> a 452 | 453 | instance MonadBaseControl IO m => Applicative (Concurrently m) where 454 | pure = Concurrently . pure 455 | Concurrently fs <*> Concurrently as = 456 | Concurrently $ uncurry ($) <$> concurrently fs as 457 | 458 | instance MonadBaseControl IO m => Alternative (Concurrently m) where 459 | empty = Concurrently $ liftBaseWith $ \_ -> forever $ threadDelay maxBound 460 | Concurrently as <|> Concurrently bs = 461 | Concurrently $ either id id <$> race as bs 462 | 463 | #if MIN_VERSION_base(4, 9, 0) 464 | instance (MonadBaseControl IO m, Semigroup a) => 465 | Semigroup (Concurrently m a) where 466 | (<>) = liftA2 (<>) 467 | 468 | instance (MonadBaseControl IO m, Semigroup a, Monoid a) => 469 | Monoid (Concurrently m a) where 470 | mempty = pure mempty 471 | mappend = (<>) 472 | #else 473 | instance (MonadBaseControl IO m, Monoid a) => Monoid (Concurrently m a) where 474 | mempty = pure mempty 475 | mappend = liftA2 mappend 476 | #endif 477 | 478 | sequenceEither :: MonadBaseControl IO m => Either e (StM m a) -> m (Either e a) 479 | sequenceEither = either (return . Left) (fmap Right . restoreM) 480 | -------------------------------------------------------------------------------- /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 defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 710 96 | import Data.Foldable 97 | import Data.Traversable 98 | #endif 99 | #if !MIN_VERSION_base(4, 8, 0) 100 | import Data.Monoid (Monoid(mappend, mempty)) 101 | #elif MIN_VERSION_base(4, 9, 0) && !MIN_VERSION_base(4, 13, 0) 102 | import Data.Semigroup (Semigroup((<>))) 103 | #endif 104 | 105 | -- | Generalized version of 'A.async'. 106 | async 107 | :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) 108 | => m a -> m (Async a) 109 | async = Unsafe.async 110 | \\ (inst :: Forall (Pure m) :- Pure m a) 111 | 112 | -- | Generalized version of 'A.asyncBound'. 113 | asyncBound 114 | :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) 115 | => m a -> m (Async a) 116 | asyncBound = Unsafe.asyncBound 117 | \\ (inst :: Forall (Pure m) :- Pure m a) 118 | 119 | -- | Generalized version of 'A.asyncOn'. 120 | asyncOn 121 | :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) 122 | => Int -> m a -> m (Async a) 123 | asyncOn cpu m = Unsafe.asyncOn cpu m 124 | \\ (inst :: Forall (Pure m) :- Pure m a) 125 | 126 | -- | Generalized version of 'A.asyncWithUnmask'. 127 | asyncWithUnmask 128 | :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) 129 | => ((forall b. m b -> m b) -> m a) 130 | -> m (Async a) 131 | asyncWithUnmask restore = Unsafe.asyncWithUnmask restore 132 | \\ (inst :: Forall (Pure m) :- Pure m a) 133 | 134 | -- | Generalized version of 'A.asyncOnWithUnmask'. 135 | asyncOnWithUnmask 136 | :: forall m a. (MonadBaseControl IO m, Forall (Pure m)) 137 | => Int 138 | -> ((forall b. m b -> m b) -> m a) 139 | -> m (Async a) 140 | asyncOnWithUnmask cpu restore = Unsafe.asyncOnWithUnmask cpu restore 141 | \\ (inst :: Forall (Pure m) :- Pure m a) 142 | 143 | -- | Generalized version of 'A.withAsync'. 144 | withAsync 145 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 146 | => m a 147 | -> (Async a -> m b) 148 | -> m b 149 | withAsync = Unsafe.withAsync 150 | \\ (inst :: Forall (Pure m) :- Pure m a) 151 | 152 | -- | Generalized version of 'A.withAsyncBound'. 153 | withAsyncBound 154 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 155 | => m a 156 | -> (Async a -> m b) 157 | -> m b 158 | withAsyncBound = Unsafe.withAsyncBound 159 | \\ (inst :: Forall (Pure m) :- Pure m a) 160 | 161 | -- | Generalized version of 'A.withAsyncOn'. 162 | withAsyncOn 163 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 164 | => Int 165 | -> m a 166 | -> (Async a -> m b) 167 | -> m b 168 | withAsyncOn = Unsafe.withAsyncOn 169 | \\ (inst :: Forall (Pure m) :- Pure m a) 170 | 171 | -- | Generalized version of 'A.withAsyncWithUnmask'. 172 | withAsyncWithUnmask 173 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 174 | => ((forall c. m c -> m c) -> m a) 175 | -> (Async a -> m b) 176 | -> m b 177 | withAsyncWithUnmask restore = Unsafe.withAsyncWithUnmask restore 178 | \\ (inst :: Forall (Pure m) :- Pure m a) 179 | 180 | -- | Generalized version of 'A.withAsyncOnWithUnmask'. 181 | withAsyncOnWithUnmask 182 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 183 | => Int 184 | -> ((forall c. m c -> m c) -> m a) 185 | -> (Async a -> m b) 186 | -> m b 187 | withAsyncOnWithUnmask cpu restore = Unsafe.withAsyncOnWithUnmask cpu restore 188 | \\ (inst :: Forall (Pure m) :- Pure m a) 189 | 190 | -- | Generalized version of 'A.wait'. 191 | wait 192 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 193 | => Async a -> m a 194 | wait = liftBase . A.wait 195 | \\ (inst :: Forall (Pure m) :- Pure m a) 196 | 197 | -- | Generalized version of 'A.poll'. 198 | poll 199 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 200 | => Async a 201 | -> m (Maybe (Either SomeException a)) 202 | poll = liftBase . A.poll 203 | \\ (inst :: Forall (Pure m) :- Pure m a) 204 | 205 | -- | Generalized version of 'A.waitCatch'. 206 | waitCatch 207 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 208 | => Async a 209 | -> m (Either SomeException a) 210 | waitCatch = liftBase . A.waitCatch 211 | \\ (inst :: Forall (Pure m) :- Pure m a) 212 | 213 | -- | Generalized version of 'A.cancel'. 214 | cancel :: MonadBase IO m => Async a -> m () 215 | cancel = Unsafe.cancel 216 | 217 | -- | Generalized version of 'A.cancelWith'. 218 | cancelWith :: (MonadBase IO m, Exception e) => Async a -> e -> m () 219 | cancelWith = Unsafe.cancelWith 220 | 221 | -- | Generalized version of 'A.uninterruptibleCancel'. 222 | uninterruptibleCancel :: MonadBase IO m => Async a -> m () 223 | uninterruptibleCancel = Unsafe.uninterruptibleCancel 224 | 225 | -- | Generalized version of 'A.waitAny'. 226 | waitAny 227 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 228 | => [Async a] -> m (Async a, a) 229 | waitAny = liftBase . A.waitAny 230 | \\ (inst :: Forall (Pure m) :- Pure m a) 231 | 232 | -- | Generalized version of 'A.waitAnyCatch'. 233 | waitAnyCatch 234 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 235 | => [Async a] 236 | -> m (Async a, Either SomeException a) 237 | waitAnyCatch = liftBase . A.waitAnyCatch 238 | \\ (inst :: Forall (Pure m) :- Pure m a) 239 | 240 | -- | Generalized version of 'A.waitAnyCancel'. 241 | waitAnyCancel 242 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 243 | => [Async a] 244 | -> m (Async a, a) 245 | waitAnyCancel = liftBase . A.waitAnyCancel 246 | \\ (inst :: Forall (Pure m) :- Pure m a) 247 | 248 | -- | Generalized version of 'A.waitAnyCatchCancel'. 249 | waitAnyCatchCancel 250 | :: forall m a. (MonadBase IO m, Forall (Pure m)) 251 | => [Async a] 252 | -> m (Async a, Either SomeException a) 253 | waitAnyCatchCancel = liftBase . A.waitAnyCatchCancel 254 | \\ (inst :: Forall (Pure m) :- Pure m a) 255 | 256 | -- | Generalized version of 'A.waitEither'. 257 | waitEither 258 | :: forall m a b. (MonadBase IO m, Forall (Pure m)) 259 | => Async a 260 | -> Async b 261 | -> m (Either a b) 262 | waitEither = (liftBase .) . A.waitEither 263 | \\ (inst :: Forall (Pure m) :- Pure m a) 264 | \\ (inst :: Forall (Pure m) :- Pure m b) 265 | 266 | -- | Generalized version of 'A.waitEitherCatch'. 267 | waitEitherCatch 268 | :: forall m a b. (MonadBase IO m, Forall (Pure m)) 269 | => Async a 270 | -> Async b 271 | -> m (Either (Either SomeException a) (Either SomeException b)) 272 | waitEitherCatch = (liftBase .) . A.waitEitherCatch 273 | \\ (inst :: Forall (Pure m) :- Pure m a) 274 | \\ (inst :: Forall (Pure m) :- Pure m b) 275 | 276 | -- | Generalized version of 'A.waitEitherCancel'. 277 | waitEitherCancel 278 | :: forall m a b. (MonadBase IO m, Forall (Pure m)) 279 | => Async a 280 | -> Async b 281 | -> m (Either a b) 282 | waitEitherCancel = (liftBase .) . A.waitEitherCancel 283 | \\ (inst :: Forall (Pure m) :- Pure m a) 284 | \\ (inst :: Forall (Pure m) :- Pure m b) 285 | 286 | -- | Generalized version of 'A.waitEitherCatchCancel'. 287 | waitEitherCatchCancel 288 | :: forall m a b. (MonadBase IO m, Forall (Pure m)) 289 | => Async a 290 | -> Async b 291 | -> m (Either (Either SomeException a) (Either SomeException b)) 292 | waitEitherCatchCancel = (liftBase .) . A.waitEitherCatchCancel 293 | \\ (inst :: Forall (Pure m) :- Pure m a) 294 | \\ (inst :: Forall (Pure m) :- Pure m b) 295 | 296 | -- | Generalized version of 'A.waitEither_' 297 | waitEither_ :: MonadBase IO m => Async a -> Async b -> m () 298 | waitEither_ = Unsafe.waitEither_ 299 | 300 | -- | Generalized version of 'A.waitBoth'. 301 | waitBoth 302 | :: forall m a b. (MonadBase IO m, Forall (Pure m)) 303 | => Async a 304 | -> Async b 305 | -> m (a, b) 306 | waitBoth = (liftBase .) . A.waitBoth 307 | \\ (inst :: Forall (Pure m) :- Pure m a) 308 | \\ (inst :: Forall (Pure m) :- Pure m b) 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 (Either a b) 314 | race = liftBaseOp2_ A.race 315 | 316 | -- | Generalized version of 'A.race_'. 317 | race_ 318 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 319 | => m a -> m b -> m () 320 | race_ = liftBaseOp2_ A.race_ 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 (a, b) 326 | concurrently = liftBaseOp2_ A.concurrently 327 | 328 | -- | Generalized version of 'A.concurrently_'. 329 | concurrently_ 330 | :: forall m a b. (MonadBaseControl IO m, Forall (Pure m)) 331 | => m a -> m b -> m () 332 | concurrently_ = liftBaseOp2_ A.concurrently_ 333 | 334 | -- | Similar to 'A.liftBaseOp_' but takes a binary function 335 | -- and leverages @'StM' m a ~ a@. 336 | liftBaseOp2_ 337 | :: forall base m a b c. (MonadBaseControl base m, Forall (Pure m)) 338 | => (base a -> base b -> base c) 339 | -> m a -> m b -> m c 340 | liftBaseOp2_ f left right = liftBaseWith $ \run -> f 341 | (run left \\ (inst :: Forall (Pure m) :- Pure m a)) 342 | (run right \\ (inst :: Forall (Pure m) :- Pure m b)) 343 | 344 | -- | Generalized version of 'A.mapConcurrently'. 345 | mapConcurrently 346 | :: (Traversable t, MonadBaseControl IO m, Forall (Pure m)) 347 | => (a -> m b) 348 | -> t a 349 | -> m (t b) 350 | mapConcurrently f = runConcurrently . traverse (Concurrently . f) 351 | 352 | -- | Generalized version of 'A.mapConcurrently_'. 353 | mapConcurrently_ 354 | :: (Foldable t, MonadBaseControl IO m, Forall (Pure m)) 355 | => (a -> m b) 356 | -> t a 357 | -> m () 358 | mapConcurrently_ f = runConcurrently . foldMap (Concurrently . void . f) 359 | 360 | -- | Generalized version of 'A.forConcurrently'. 361 | forConcurrently 362 | :: (Traversable t, MonadBaseControl IO m, Forall (Pure m)) 363 | => t a 364 | -> (a -> m b) 365 | -> m (t b) 366 | forConcurrently = flip mapConcurrently 367 | 368 | -- | Generalized version of 'A.forConcurrently_'. 369 | forConcurrently_ 370 | :: (Foldable t, MonadBaseControl IO m, Forall (Pure m)) 371 | => t a 372 | -> (a -> m b) 373 | -> m () 374 | forConcurrently_ = flip mapConcurrently_ 375 | 376 | -- | Generalized version of 'A.replicateConcurrently'. 377 | replicateConcurrently 378 | :: (MonadBaseControl IO m, Forall (Pure m)) 379 | => Int 380 | -> m a 381 | -> m [a] 382 | replicateConcurrently n = 383 | runConcurrently . sequenceA . replicate n . Concurrently 384 | 385 | -- | Generalized version of 'A.replicateConcurrently_'. 386 | replicateConcurrently_ 387 | :: (MonadBaseControl IO m, Forall (Pure m)) 388 | => Int 389 | -> m a 390 | -> m () 391 | replicateConcurrently_ n = 392 | runConcurrently . fold . replicate n . Concurrently . void 393 | 394 | -- | Generalized version of 'A.Concurrently'. 395 | -- 396 | -- A value of type @'Concurrently' m a@ is an IO-based operation that can be 397 | -- composed with other 'Concurrently' values, using the 'Applicative' and 398 | -- 'Alternative' instances. 399 | -- 400 | -- Calling 'runConcurrently' on a value of type @'Concurrently' m a@ will 401 | -- execute the IO-based lifted operations it contains concurrently, before 402 | -- delivering the result of type 'a'. 403 | -- 404 | -- For example 405 | -- 406 | -- @ 407 | -- (page1, page2, page3) <- 'runConcurrently' $ (,,) 408 | -- '<$>' 'Concurrently' (getURL "url1") 409 | -- '<*>' 'Concurrently' (getURL "url2") 410 | -- '<*>' 'Concurrently' (getURL "url3") 411 | -- @ 412 | data Concurrently m a where 413 | Concurrently 414 | :: Forall (Pure m) => { runConcurrently :: m a } -> Concurrently m a 415 | 416 | -- | Most of the functions in this module have @'Forall' ('Pure' m)@ in their 417 | -- constraints, which means they require the monad 'm' satisfies 418 | -- @'StM' m a ~ a@ for all 'a'. 419 | class StM m a ~ a => Pure m a 420 | instance StM m a ~ a => Pure m a 421 | 422 | instance Functor m => Functor (Concurrently m) where 423 | fmap f (Concurrently a) = Concurrently $ f <$> a 424 | 425 | instance (MonadBaseControl IO m, Forall (Pure m)) => 426 | Applicative (Concurrently m) where 427 | pure = Concurrently . pure 428 | Concurrently (fs :: m (a -> b)) <*> Concurrently as = 429 | Concurrently (uncurry ($) <$> concurrently fs as) 430 | \\ (inst :: Forall (Pure m) :- Pure m a) 431 | \\ (inst :: Forall (Pure m) :- Pure m (a -> b)) 432 | 433 | instance (MonadBaseControl IO m, Forall (Pure m)) => 434 | Alternative (Concurrently m) where 435 | empty = Concurrently $ liftBaseWith $ \_ -> forever $ threadDelay maxBound 436 | Concurrently (as :: m a) <|> Concurrently bs = 437 | Concurrently (either id id <$> race as bs) 438 | \\ (inst :: Forall (Pure m) :- Pure m a) 439 | \\ (inst :: Forall (Pure m) :- Pure m b) 440 | 441 | #if MIN_VERSION_base(4, 9, 0) 442 | instance (MonadBaseControl IO m, Semigroup a, Forall (Pure m)) => 443 | Semigroup (Concurrently m a) where 444 | (<>) = liftA2 (<>) 445 | 446 | instance (MonadBaseControl IO m, Semigroup a, Monoid a, Forall (Pure m)) => 447 | Monoid (Concurrently m a) where 448 | mempty = pure mempty 449 | mappend = (<>) 450 | #else 451 | instance (MonadBaseControl IO m, Monoid a, Forall (Pure m)) => 452 | Monoid (Concurrently m a) where 453 | mempty = pure mempty 454 | mappend = liftA2 mappend 455 | #endif 456 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /tests/Test/Async/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | module Test.Async.Common 4 | ( value 5 | , TestException(..) 6 | , module X 7 | ) where 8 | 9 | import Data.Typeable 10 | 11 | import Control.Exception.Lifted 12 | import Test.Tasty as X 13 | import Test.Tasty.HUnit as X 14 | import Test.Tasty.TH as X 15 | 16 | value :: Int 17 | value = 42 18 | 19 | data TestException = TestException 20 | deriving (Eq, Show, Typeable) 21 | 22 | instance Exception TestException 23 | -------------------------------------------------------------------------------- /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 | #if MIN_VERSION_monad_control(1, 0, 0) 13 | import Control.Concurrent.Async.Lifted.Safe 14 | #else 15 | import Control.Concurrent.Async.Lifted 16 | #endif 17 | import Test.Async.Common 18 | 19 | ioTestGroup :: TestTree 20 | ioTestGroup = $(testGroupGenerator) 21 | 22 | case_async_waitCatch :: Assertion 23 | case_async_waitCatch = do 24 | a <- async (return value) 25 | r <- waitCatch a 26 | case r of 27 | Left _ -> assertFailure "" 28 | Right e -> e @?= value 29 | 30 | case_async_wait :: Assertion 31 | case_async_wait = do 32 | a <- async (return value) 33 | r <- wait a 34 | assertEqual "async_wait" r value 35 | 36 | case_async_exwaitCatch :: Assertion 37 | case_async_exwaitCatch = do 38 | a <- async (throwIO TestException) 39 | r <- waitCatch a 40 | case r of 41 | Left e -> fromException e @?= Just TestException 42 | Right _ -> assertFailure "" 43 | 44 | case_async_exwait :: Assertion 45 | case_async_exwait = do 46 | a <- async (throwIO TestException) 47 | (wait a >> assertFailure "") `E.catch` \e -> e @?= TestException 48 | 49 | case_withAsync_waitCatch :: Assertion 50 | case_withAsync_waitCatch = do 51 | withAsync (return value) $ \a -> do 52 | r <- waitCatch a 53 | case r of 54 | Left _ -> assertFailure "" 55 | Right e -> e @?= value 56 | 57 | case_withAsync_wait2 :: Assertion 58 | case_withAsync_wait2 = do 59 | a <- withAsync (threadDelay 1000000) $ return 60 | r <- waitCatch a 61 | case r of 62 | Left e -> fromException e @?= Just AsyncCancelled 63 | Right _ -> assertFailure "" 64 | 65 | case_async_cancel :: Assertion 66 | case_async_cancel = sequence_ $ replicate 1000 run 67 | where 68 | run = do 69 | a <- async (return value) 70 | cancelWith a TestException 71 | r <- waitCatch a 72 | case r of 73 | Left e -> fromException e @?= Just TestException 74 | Right r' -> r' @?= value 75 | 76 | case_async_poll :: Assertion 77 | case_async_poll = do 78 | a <- async (threadDelay 1000000) 79 | r <- poll a 80 | when (isJust r) $ assertFailure "" 81 | r' <- poll a -- poll twice, just to check we don't deadlock 82 | when (isJust r') $ assertFailure "" 83 | 84 | case_async_poll2 :: Assertion 85 | case_async_poll2 = do 86 | a <- async (return value) 87 | void $ wait a 88 | r <- poll a 89 | when (isNothing r) $ assertFailure "" 90 | r' <- poll a -- poll twice, just to check we don't deadlock 91 | when (isNothing r') $ assertFailure "" 92 | -------------------------------------------------------------------------------- /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 | #if MIN_VERSION_monad_control(1, 0, 0) 15 | import Control.Concurrent.Async.Lifted.Safe 16 | #else 17 | import Control.Concurrent.Async.Lifted 18 | #endif 19 | import Test.Async.Common 20 | 21 | readerTestGroup :: TestTree 22 | readerTestGroup = $(testGroupGenerator) 23 | 24 | case_async_waitCatch :: Assertion 25 | case_async_waitCatch = do 26 | r <- flip runReaderT value $ do 27 | a <- async $ return value 28 | waitCatch a 29 | case r of 30 | Left _ -> assertFailure "An exception must not be raised." 31 | Right e -> do 32 | e @?= value 33 | 34 | case_async_wait :: Assertion 35 | case_async_wait = do 36 | r <- flip runReaderT value $ do 37 | a <- async $ return value 38 | wait a 39 | r @?= value 40 | 41 | case_async_exwaitCatch :: Assertion 42 | case_async_exwaitCatch = do 43 | r <- flip runReaderT value $ do 44 | a <- async $ throwIO TestException 45 | waitCatch a 46 | case r of 47 | Left e -> 48 | fromException e @?= Just TestException 49 | Right _ -> assertFailure "An exception must be raised." 50 | 51 | case_async_exwait :: Assertion 52 | case_async_exwait = 53 | void $ flip runReaderT value $ do 54 | a <- async $ throwIO TestException 55 | (wait a >> liftIO (assertFailure "An exception must be raised")) 56 | `E.catch` \e -> 57 | liftIO $ e @?= TestException 58 | 59 | case_withAsync_waitCatch :: Assertion 60 | case_withAsync_waitCatch = 61 | void $ flip runReaderT value $ do 62 | withAsync (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 | 69 | case_withAsync_wait2 :: Assertion 70 | case_withAsync_wait2 = do 71 | r <- flip runReaderT value $ do 72 | a <- withAsync (threadDelay 1000000) $ return 73 | waitCatch a 74 | case r of 75 | Left e -> do 76 | fromException e @?= Just AsyncCancelled 77 | Right _ -> assertFailure "An exception must be raised." 78 | 79 | case_async_cancel :: Assertion 80 | case_async_cancel = sequence_ $ replicate 1000 run 81 | where 82 | run = do 83 | r <- flip runReaderT value $ do 84 | a <- async $ return value 85 | cancelWith a TestException 86 | waitCatch a 87 | case r of 88 | Left e -> 89 | fromException e @?= Just TestException 90 | Right r' -> 91 | r' @?= value 92 | 93 | case_async_poll :: Assertion 94 | case_async_poll = 95 | void $ flip runReaderT value $ do 96 | a <- async (threadDelay 1000000) 97 | r <- poll a 98 | when (isJust r) $ 99 | liftIO $ assertFailure "The result must be nothing." 100 | r' <- poll a -- poll twice, just to check we don't deadlock 101 | when (isJust r') $ 102 | liftIO $ assertFailure "The result must be Nothing." 103 | 104 | case_async_poll2 :: Assertion 105 | case_async_poll2 = 106 | void $ flip runReaderT value $ do 107 | a <- async (return value) 108 | void $ wait a 109 | r <- poll a 110 | when (isNothing r) $ 111 | liftIO $ assertFailure "The result must not be Nothing." 112 | r' <- poll a -- poll twice, just to check we don't deadlock 113 | when (isNothing r') $ 114 | liftIO $ assertFailure "The result must not be Nothing." 115 | 116 | test_ignored :: [TestTree] 117 | test_ignored = 118 | [ ignoreTestBecause "see #26" $ testCase "link" $ do 119 | r <- try $ flip runReaderT value $ do 120 | a <- async $ threadDelay 1000000 >> return value 121 | link a 122 | cancelWith a TestException 123 | wait a 124 | case r of 125 | Left e -> case fromException e of 126 | Just (ExceptionInLinkedThread _ e') -> 127 | fromException e' @?= Just TestException 128 | Nothing -> assertFailure $ 129 | "expected ExceptionInLinkedThread _ TestException" 130 | ++ " but got " ++ show e 131 | Right _ -> assertFailure "An exception must be raised." 132 | ] 133 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /tests/TestSuite.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables,DeriveDataTypeable #-} 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 | --------------------------------------------------------------------------------