├── .github ├── PULL_REQUEST_TEMPLATE ├── dependabot.yml ├── scripts │ └── build-documentation.sh └── workflows │ ├── ci.yaml │ └── deploy-documentation.yml ├── .gitignore ├── .hlint.yaml ├── .readthedocs.yaml ├── .stylish-haskell.yaml ├── .weeder.yaml ├── CHANGELOG.rst ├── README.markdown ├── concourse └── pipeline.yml ├── concurrency ├── CHANGELOG.rst ├── Control │ ├── Concurrent │ │ ├── Classy.hs │ │ └── Classy │ │ │ ├── Async.hs │ │ │ ├── BoundedChan.hs │ │ │ ├── CRef.hs │ │ │ ├── Chan.hs │ │ │ ├── IORef.hs │ │ │ ├── Lock.hs │ │ │ ├── MVar.hs │ │ │ ├── QSem.hs │ │ │ ├── QSemN.hs │ │ │ ├── RWLock.hs │ │ │ ├── STM.hs │ │ │ └── STM │ │ │ ├── TArray.hs │ │ │ ├── TBQueue.hs │ │ │ ├── TChan.hs │ │ │ ├── TMVar.hs │ │ │ ├── TQueue.hs │ │ │ ├── TSem.hs │ │ │ └── TVar.hs │ └── Monad │ │ ├── Conc │ │ └── Class.hs │ │ └── STM │ │ └── Class.hs ├── LICENSE ├── README.markdown ├── Setup.hs └── concurrency.cabal ├── dejafu-tests ├── LICENSE ├── Setup.hs ├── dejafu-tests.cabal ├── exe │ ├── MainBench.hs │ ├── MainTest.hs │ └── Util.hs └── lib │ ├── Common.hs │ ├── Examples.hs │ ├── Examples │ ├── AutoUpdate.hs │ ├── ClassLaws.hs │ ├── Logger.hs │ ├── ParMonad.hs │ ├── ParMonad │ │ ├── Direct.hs │ │ └── DirectInternal.hs │ ├── Philosophers.hs │ ├── SearchParty.hs │ └── SearchParty │ │ └── Impredicative.hs │ ├── Integration.hs │ ├── Integration │ ├── Async.hs │ ├── Litmus.hs │ ├── MonadDejaFu.hs │ ├── MultiThreaded.hs │ ├── Names.hs │ ├── Refinement.hs │ ├── Regressions.hs │ ├── SCT.hs │ └── SingleThreaded.hs │ ├── QSemN.hs │ ├── Unit.hs │ └── Unit │ ├── Predicates.hs │ └── Properties.hs ├── dejafu ├── CHANGELOG.rst ├── LICENSE ├── README.markdown ├── Setup.hs ├── Test │ ├── DejaFu.hs │ └── DejaFu │ │ ├── Conc.hs │ │ ├── Conc │ │ ├── Internal.hs │ │ └── Internal │ │ │ ├── Common.hs │ │ │ ├── Memory.hs │ │ │ ├── Program.hs │ │ │ ├── STM.hs │ │ │ └── Threading.hs │ │ ├── Internal.hs │ │ ├── Refinement.hs │ │ ├── SCT.hs │ │ ├── SCT │ │ ├── Internal.hs │ │ └── Internal │ │ │ ├── DPOR.hs │ │ │ └── Weighted.hs │ │ ├── Schedule.hs │ │ ├── Settings.hs │ │ ├── Types.hs │ │ └── Utils.hs └── dejafu.cabal ├── docs ├── .gitignore ├── book.toml ├── readthedocs │ ├── Makefile │ ├── requirements.txt │ └── source │ │ ├── conf.py │ │ └── index.rst └── src │ ├── SUMMARY.md │ ├── advanced-usage.md │ ├── dev-docs │ ├── contributing.md │ ├── release-process.md │ └── supported-ghc-versions.md │ ├── migration-guides │ ├── 0x-1x.md │ └── 1x-2x.md │ ├── refinement-testing.md │ ├── typeclasses.md │ └── unit-testing.md ├── hunit-dejafu ├── CHANGELOG.rst ├── LICENSE ├── README.markdown ├── Setup.hs ├── Test │ └── HUnit │ │ └── DejaFu.hs └── hunit-dejafu.cabal ├── lint.sh ├── stack.yaml ├── style.sh └── tasty-dejafu ├── CHANGELOG.rst ├── LICENSE ├── README.markdown ├── Setup.hs ├── Test └── Tasty │ └── DejaFu.hs └── tasty-dejafu.cabal /.github/PULL_REQUEST_TEMPLATE: -------------------------------------------------------------------------------- 1 | ## Summary 2 | 3 | What does this pull request do? 4 | 5 | **To do:** 6 | 7 | If this pull request is a work-in-progress, add a checklist here of 8 | the remaining tasks so it's clear what still needs to be done. 9 | 10 | **Related issues:** 11 | 12 | If this pull request is related to any other issues, list them here. 13 | 14 | 15 | ## Checklist 16 | 17 | **If this is fixing a bug or adding a feature:** 18 | 19 | - [ ] Add new tests to dejafu-tests 20 | 21 | **If this is removing an unsupported GHC version:** 22 | 23 | - [ ] Bump the lower bound on `base` 24 | - [ ] Go through the other dependencies and bump any appropriate lower 25 | bounds 26 | - [ ] Remove any now-unnecessary conditional compilation 27 | 28 | 29 | ## Benchmark results (for performance issues) 30 | 31 | **Before:** 32 | 33 | ``` 34 | $ stack exec -- dejafu-tests +RTS -s 35 | 36 | ...put your results here... 37 | ``` 38 | 39 | **After:** 40 | 41 | ``` 42 | $ stack exec -- dejafu-tests +RTS -s 43 | 44 | ...put your results here... 45 | ``` 46 | -------------------------------------------------------------------------------- /.github/dependabot.yml: -------------------------------------------------------------------------------- 1 | version: 2 2 | updates: 3 | - package-ecosystem: github-actions 4 | directory: / 5 | schedule: 6 | interval: daily 7 | 8 | -------------------------------------------------------------------------------- /.github/scripts/build-documentation.sh: -------------------------------------------------------------------------------- 1 | #! /usr/bin/env nix-shell 2 | #! nix-shell -I nixpkgs=channel:nixos-23.05 -i bash --packages coreutils mdbook mdbook-admonish python3 virtualenv ghc stack 3 | 4 | set -ex 5 | 6 | OUTPUT_DIR="_site" 7 | 8 | pushd docs 9 | mdbook-admonish install 10 | popd 11 | 12 | python3 <<'EOF' > docs/src/index.md 13 | import sys 14 | 15 | with open("README.markdown") as f: 16 | mode = "title" 17 | for line in f: 18 | line = line.rstrip() 19 | if mode == "title": 20 | print("Getting Started") 21 | mode = "after-title" 22 | elif mode == "after-title": 23 | if line.startswith("- "): 24 | mode = "skip-links" 25 | else: 26 | print(line) 27 | elif mode == "skip-links": 28 | if line.startswith("- "): 29 | continue 30 | else: 31 | mode = "pre-version-table" 32 | print(line) 33 | elif mode == "pre-version-table": 34 | print(line) 35 | if line.startswith("|"): 36 | mode = "version-table" 37 | elif mode == "version-table": 38 | print(line) 39 | if line.startswith("See [the latest package documentation]"): 40 | mode = "after-version-table" 41 | elif mode == "after-version-table": 42 | if line.startswith("["): 43 | mode = "pre-contributing" 44 | print("") 45 | print(line) 46 | elif mode == "pre-contributing": 47 | if line == "Contributing": 48 | mode = "skip-to-bibliography" 49 | continue 50 | print(line) 51 | elif mode == "skip-to-bibliography": 52 | if line == "Bibliography": 53 | mode = "rest" 54 | print(line) 55 | else: 56 | print(line) 57 | 58 | if mode != "rest": 59 | print(f"unexpected mode: {mode}", file=sys.stderr) 60 | sys.exit(1) 61 | EOF 62 | 63 | bash <<'EOF' 64 | virtualenv venv 65 | source venv/bin/activate 66 | pip install "rst-to-myst" 67 | 68 | mkdir -p docs/src/release-notes 69 | for package in concurrency dejafu hunit-dejafu tasty-dejafu; do 70 | rst2myst convert --no-sphinx "${package}/CHANGELOG.rst" 71 | cat "${package}/CHANGELOG.md" | \ 72 | sed 'sZ{issue}`\([^`]*\)`Z[issue #\1](https://github.com/barrucadu/dejafu/issues/\1)Zg' | \ 73 | sed 'sZ{pull}`\([^`]*\)`Z[pull request #\1](https://github.com/barrucadu/dejafu/pull/\1)Zg' | \ 74 | sed 'sZ{tag}`\([^`]*\)`Z[\1](https://github.com/barrucadu/dejafu/releases/tag/\1)Zg' | \ 75 | sed 'sZ{u}`\([^`]*\)`Z[\1](https://github.com/\1)Zg' | \ 76 | sed 'sZ{hackage}`\([^`]*\)`Z[\1](https://hackage.haskell.org/package/\1)Zg' > "docs/src/release-notes/${package}.md" 77 | rm "${package}/CHANGELOG.md" 78 | done 79 | 80 | rm -rf venv 81 | EOF 82 | 83 | mdbook build docs 84 | mv docs/book "$OUTPUT_DIR" 85 | 86 | stack --no-install-ghc --no-nix --skip-ghc-check --system-ghc haddock concurrency dejafu hunit-dejafu tasty-dejafu 87 | rm -rf .stack-work/install/*/*/*/doc/all/ 88 | mv .stack-work/install/*/*/*/doc/ "$OUTPUT_DIR/packages" 89 | 90 | chmod -c -R +rX "$OUTPUT_DIR" | while read -r line; do 91 | echo "::warning title=Invalid file permissions automatically fixed::$line" 92 | done 93 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: Run tests 2 | 3 | on: pull_request 4 | 5 | jobs: 6 | check-docs-site: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v4 10 | - name: Check mdbook-admonish changes are not committed 11 | run: | 12 | if grep -q "do not edit: managed by \`mdbook-admonish install\`" docs/book.toml; then 13 | echo "remove generated mdbook-admonish lines from docs/books.toml" >&2 14 | exit 1 15 | fi 16 | - name: Install nix 17 | uses: cachix/install-nix-action@v31 18 | with: 19 | nix_path: nixpkgs=channel:nixos-23.05 20 | - name: Check documentation site builds 21 | run: nix-shell ./.github/scripts/build-documentation.sh 22 | 23 | lint: 24 | runs-on: ubuntu-latest 25 | steps: 26 | - uses: actions/checkout@v4 27 | - uses: haskell/actions/setup@v2.4.7 28 | with: 29 | enable-stack: true 30 | - name: Setup 31 | run: | 32 | stack --no-terminal install stylish-haskell hlint 33 | - name: Lint 34 | run: | 35 | set -ex 36 | stack --no-terminal exec ./lint.sh 37 | stack --no-terminal exec ./style.sh 38 | git diff --exit-code 39 | 40 | doctest: 41 | runs-on: ubuntu-latest 42 | steps: 43 | - uses: actions/checkout@v4 44 | - uses: haskell/actions/setup@v2.4.7 45 | with: 46 | enable-stack: true 47 | - name: Setup 48 | run: | 49 | set -ex 50 | stack --no-terminal setup 51 | stack --no-terminal install doctest 52 | - name: Build 53 | run: | 54 | stack --no-terminal build 55 | - name: Test 56 | run: | 57 | stack --no-terminal exec -- bash -c "DEJAFU_DOCTEST=y doctest dejafu/Test" 58 | 59 | test: 60 | runs-on: ubuntu-latest 61 | strategy: 62 | fail-fast: false 63 | matrix: 64 | resolver: 65 | - lts-10.0 # ghc-8.2 66 | - lts-12.0 # ghc-8.4 67 | - lts-14.0 # ghc-8.6 68 | - lts-15.0 # ghc-8.8 69 | - lts-17.0 # ghc-8.10 70 | - lts-19.0 # ghc-9.0 71 | - lts-20.0 # ghc-9.2 72 | - lts-21.0 # ghc-9.4 73 | - lts-22.0 # ghc-9.6 74 | - lts-23.0 # ghc-9.8 75 | 76 | steps: 77 | - uses: actions/checkout@v4 78 | - uses: haskell/actions/setup@v2.4.7 79 | with: 80 | enable-stack: true 81 | - name: Setup 82 | env: 83 | RESOLVER: ${{ matrix.resolver }} 84 | run: | 85 | set -ex 86 | stack --no-terminal init --resolver="$RESOLVER" --force 87 | stack --no-terminal setup 88 | - name: Build 89 | env: 90 | RESOLVER: ${{ matrix.resolver }} 91 | run: | 92 | stack --no-terminal build --ghc-options="-Werror -Wno-unused-imports -Wno-incomplete-uni-patterns" 93 | - name: Test 94 | env: 95 | RESOLVER: ${{ matrix.resolver }} 96 | run: | 97 | cd dejafu-tests 98 | stack --no-terminal exec -- dejafu-tests +RTS -s 99 | -------------------------------------------------------------------------------- /.github/workflows/deploy-documentation.yml: -------------------------------------------------------------------------------- 1 | name: Deploy documentation site 2 | 3 | on: 4 | # Runs on pushes targeting the default branch 5 | push: 6 | branches: ["master"] 7 | 8 | # Allows you to run this workflow manually from the Actions tab 9 | workflow_dispatch: 10 | 11 | # Sets permissions of the GITHUB_TOKEN to allow deployment to GitHub Pages 12 | permissions: 13 | contents: read 14 | pages: write 15 | id-token: write 16 | 17 | # Allow only one concurrent deployment, skipping runs queued between the run in-progress and latest queued. 18 | # However, do NOT cancel in-progress runs as we want to allow these production deployments to complete. 19 | concurrency: 20 | group: "pages" 21 | cancel-in-progress: false 22 | 23 | jobs: 24 | # Build job 25 | build: 26 | runs-on: ubuntu-latest 27 | steps: 28 | - name: Checkout 29 | uses: actions/checkout@v4 30 | - name: Setup Pages 31 | uses: actions/configure-pages@v5 32 | - name: Install nix 33 | uses: cachix/install-nix-action@v31 34 | with: 35 | nix_path: nixpkgs=channel:nixos-23.05 36 | - name: Build 37 | run: nix-shell ./.github/scripts/build-documentation.sh 38 | - name: Upload artifact 39 | uses: actions/upload-pages-artifact@v3 40 | 41 | # Deployment job 42 | deploy: 43 | environment: 44 | name: github-pages 45 | url: ${{ steps.deployment.outputs.page_url }} 46 | runs-on: ubuntu-latest 47 | needs: build 48 | steps: 49 | - name: Deploy to GitHub Pages 50 | id: deployment 51 | uses: actions/deploy-pages@v4 52 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox 2 | cabal.sandbox.config 3 | dist 4 | .stack-work 5 | *.tix 6 | *.prof 7 | _site 8 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # Module export lists should generally be preferred, but may be 6 | # omitted if the module is small or internal. 7 | - ignore: {name: Use module export list} 8 | 9 | # Record patterns are just ugly. 10 | - ignore: {name: Use record patterns} 11 | 12 | # Don't prefer TupleSections 13 | - ignore: {name: Use tuple-section} 14 | 15 | # I don't think this helps 16 | - ignore: {name: "Avoid lambda using `infix`"} 17 | 18 | # Breaks type inference with higher-rank types in GHC 9 19 | - ignore: {name: Use const} 20 | 21 | # Inapplicable 22 | - ignore: {name: Use readTVarIO, within: Control.Monad.Conc.Class} 23 | 24 | # Type inference errors 25 | - ignore: {name: Avoid lambda, within: Test.DejaFu.Conc.Internal.Program} 26 | - ignore: {name: Avoid lambda, within: Examples.SearchParty} 27 | 28 | # Prefer applicative operators over monadic ones. 29 | - suggest: {name: Generalise monadic functions, lhs: return, rhs: pure} 30 | 31 | # The whole point of this example is to test class laws 32 | - ignore: {name: Functor law, within: Examples.ClassLaws} 33 | - ignore: {name: Generalise monadic functions, within: Examples.ClassLaws} 34 | 35 | # These test names are copied straight from the async package 36 | - ignore: {name: Use camelCase, within: Integration.Async} 37 | 38 | # I don't think these help. 39 | - ignore: {name: Avoid lambda, within: Integration.Refinement} 40 | - ignore: {name: Reduce duplication, within: Unit.Properties} 41 | - ignore: {name: Use nonTermination, within: Unit.Properties} 42 | - ignore: {name: Reduce duplication, within: Integration.Litmus} 43 | - ignore: {name: Reduce duplication, within: Integration.MultiThreaded} 44 | - ignore: {name: Reduce duplication, within: Integration.Regressions} 45 | - ignore: {name: Reduce duplication, within: Integration.SCT} 46 | - ignore: {name: Reduce duplication, within: Integration.SingleThreaded} 47 | 48 | # These are tests of the laws 49 | - ignore: {name: "Use <$>", within: Examples.ClassLaws} 50 | - ignore: {name: "Use fmap", within: Examples.ClassLaws} 51 | - ignore: {name: "Alternative law, right identity", within: Examples.ClassLaws} 52 | - ignore: {name: "Alternative law, left identity", within: Examples.ClassLaws} 53 | - ignore: {name: "Monoid law, right identity", within: Unit.Properties} 54 | 55 | # Not implemented 56 | - ignore: {name: "Use newEmptyTMVarIO"} 57 | - ignore: {name: "Use newTMVarIO"} 58 | - ignore: {name: "Use newTVarIO"} 59 | -------------------------------------------------------------------------------- /.readthedocs.yaml: -------------------------------------------------------------------------------- 1 | version: "2" 2 | 3 | build: 4 | os: "ubuntu-22.04" 5 | tools: 6 | python: "3.10" 7 | 8 | python: 9 | install: 10 | - requirements: docs/readthedocs/requirements.txt 11 | 12 | sphinx: 13 | configuration: docs/readthedocs/source/conf.py 14 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # https://github.com/jaspervdj/stylish-haskell 3 | ########################## 4 | 5 | steps: 6 | # Import cleanup 7 | - imports: 8 | # Align the import names and import list throughout the entire 9 | # file. 10 | align: global 11 | 12 | # Import list is aligned with end of import including 'as' and 13 | # 'hiding' keywords. 14 | # 15 | # > import qualified Data.List as List (concat, foldl, foldr, head, 16 | # > init, last, length) 17 | list_align: after_alias 18 | 19 | # Put as many import specs on same line as possible. 20 | long_list_align: inline 21 | 22 | # () is right after the module name: 23 | # 24 | # > import Vector.Instances () 25 | empty_list_align: right_after 26 | 27 | # Align import list on lines after the import under the start of 28 | # the module name. 29 | list_padding: module_name 30 | 31 | # There is no space between classes and constructors and the 32 | # list of it's members. 33 | # 34 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 35 | separate_lists: false 36 | 37 | # Language pragmas 38 | - language_pragmas: 39 | # Vertical-spaced language pragmas, one per line. 40 | style: vertical 41 | 42 | # Brackets are not aligned together. There is only one space 43 | # between actual import and closing bracket. 44 | align: false 45 | 46 | # Remove redundant language pragmas. 47 | remove_redundant: true 48 | 49 | # Remove trailing whitespace 50 | - trailing_whitespace: {} 51 | 52 | # Maximum line length, used by some of the steps above. 53 | columns: 80 54 | 55 | # Convert newlines to LF ("\n"). 56 | newline: lf 57 | 58 | # For some reason, stylish-haskell thinks I need these extensions 59 | # turning on in order to parse the code. 60 | language_extensions: 61 | - MultiParamTypeClasses 62 | - TemplateHaskell 63 | -------------------------------------------------------------------------------- /.weeder.yaml: -------------------------------------------------------------------------------- 1 | - package: 2 | - name: dejafu-tests 3 | - section: 4 | - name: exe:dejafu-bench exe:dejafu-tests 5 | - message: 6 | - name: Module reused between components 7 | - module: 8 | - Util 9 | -------------------------------------------------------------------------------- /CHANGELOG.rst: -------------------------------------------------------------------------------- 1 | Change Log 2 | ========== 3 | 4 | This project is versioned according to the PVP_, the *de facto* 5 | standard Haskell versioning scheme. 6 | 7 | .. _PVP: https://pvp.haskell.org/ 8 | 9 | Each package has its own changelog: 10 | 11 | - concurrency/CHANGELOG.markdown 12 | - dejafu/CHANGELOG.markdown 13 | - hunit-dejafu/CHANGELOG.markdown 14 | - tasty-dejafu/CHANGELOG.markdown 15 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-deprecations #-} 2 | 3 | -- | 4 | -- Module : Control.Concurrent.Classy 5 | -- Copyright : (c) 2016 Michael Walker 6 | -- License : MIT 7 | -- Maintainer : Michael Walker 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- Classy concurrency. 12 | -- 13 | -- Concurrency is \"lightweight\", which means that both thread 14 | -- creation and context switching overheads are extremely 15 | -- low. Scheduling of Haskell threads is done internally in the 16 | -- Haskell runtime system, and doesn't make use of any operating 17 | -- system-supplied thread packages. 18 | -- 19 | -- Haskell threads can communicate via @MVar@s, a kind of synchronised 20 | -- mutable variable (see "Control.Concurrent.Classy.MVar"). Several 21 | -- common concurrency abstractions can be built from @MVar@s, and 22 | -- these are provided by the "Control.Concurrent.Classy" 23 | -- library. Threads may also communicate via exceptions. 24 | module Control.Concurrent.Classy 25 | ( module Control.Monad.Conc.Class 26 | , module Control.Concurrent.Classy.Chan 27 | , module Control.Concurrent.Classy.BoundedChan 28 | , module Control.Concurrent.Classy.CRef 29 | , module Control.Concurrent.Classy.IORef 30 | , module Control.Concurrent.Classy.MVar 31 | , module Control.Concurrent.Classy.STM 32 | , module Control.Concurrent.Classy.QSem 33 | , module Control.Concurrent.Classy.QSemN 34 | , module Control.Concurrent.Classy.Lock 35 | , module Control.Concurrent.Classy.RWLock 36 | ) where 37 | 38 | import Control.Concurrent.Classy.BoundedChan 39 | import Control.Concurrent.Classy.Chan 40 | import Control.Concurrent.Classy.CRef 41 | import Control.Concurrent.Classy.IORef 42 | import Control.Concurrent.Classy.Lock 43 | import Control.Concurrent.Classy.MVar 44 | import Control.Concurrent.Classy.QSem 45 | import Control.Concurrent.Classy.QSemN 46 | import Control.Concurrent.Classy.RWLock 47 | import Control.Concurrent.Classy.STM 48 | import Control.Monad.Conc.Class 49 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/CRef.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.CRef 3 | -- Copyright : (c) 2016--2018 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : experimental 7 | -- Portability : portable 8 | -- 9 | -- Deprecated re-exports of @IORef@ functions under the old @CRef@ 10 | -- names. 11 | module Control.Concurrent.Classy.CRef {-# DEPRECATED "Import Control.Concurrent.Classy.IORef instead" #-} 12 | ( -- * CRefs 13 | CRef 14 | , newCRef 15 | , newCRefN 16 | , readCRef 17 | , writeCRef 18 | , modifyCRef 19 | , modifyCRef' 20 | , atomicModifyCRef 21 | , atomicModifyCRef' 22 | , atomicWriteCRef 23 | 24 | -- ** Compare-and-swap 25 | , casCRef 26 | , modifyCRefCAS 27 | , modifyCRefCAS_ 28 | 29 | -- * Memory Model 30 | 31 | -- | In a concurrent program, @CRef@ operations may appear 32 | -- out-of-order to another thread, depending on the memory model of 33 | -- the underlying processor architecture. For example, on x86 (which 34 | -- uses total store order), loads can move ahead of stores. Consider 35 | -- this example: 36 | -- 37 | -- > crefs :: MonadConc m => m (Bool, Bool) 38 | -- > crefs = do 39 | -- > r1 <- newCRef False 40 | -- > r2 <- newCRef False 41 | -- > 42 | -- > x <- spawn $ writeCRef r1 True >> readCRef r2 43 | -- > y <- spawn $ writeCRef r2 True >> readCRef r1 44 | -- > 45 | -- > (,) <$> readMVar x <*> readMVar y 46 | -- 47 | -- Under a sequentially consistent memory model the possible results 48 | -- are @(True, True)@, @(True, False)@, and @(False, True)@. Under 49 | -- total or partial store order, @(False, False)@ is also a possible 50 | -- result, even though there is no interleaving of the threads which 51 | -- can lead to this. 52 | -- 53 | -- We can see this by testing with different memory models: 54 | -- 55 | -- > > autocheckWay defaultWay SequentialConsistency relaxed 56 | -- > [pass] Never Deadlocks 57 | -- > [pass] No Exceptions 58 | -- > [fail] Consistent Result 59 | -- > (False,True) S0---------S1----S0--S2----S0-- 60 | -- > 61 | -- > (True,True) S0---------S1-P2----S1---S0--- 62 | -- > 63 | -- > (True,False) S0---------S2----S1----S0--- 64 | -- > False 65 | -- 66 | -- > > autocheckWay defaultWay TotalStoreOrder relaxed 67 | -- > [pass] Never Deadlocks 68 | -- > [pass] No Exceptions 69 | -- > [fail] Consistent Result 70 | -- > (False,True) S0---------S1----S0--S2----S0-- 71 | -- > 72 | -- > (False,False) S0---------S1--P2----S1--S0--- 73 | -- > 74 | -- > (True,False) S0---------S2----S1----S0--- 75 | -- > 76 | -- > (True,True) S0---------S1-C-S2----S1---S0--- 77 | -- > False 78 | -- 79 | -- Traces for non-sequentially-consistent memory models show where 80 | -- writes to @CRef@s are /committed/, which makes a write visible to 81 | -- all threads rather than just the one which performed the 82 | -- write. Only 'writeCRef' is broken up into separate write and 83 | -- commit steps, 'atomicModifyCRef' is still atomic and imposes a 84 | -- memory barrier. 85 | ) where 86 | 87 | import qualified Control.Concurrent.Classy.IORef as IORef 88 | import Control.Monad.Conc.Class (IORef, MonadConc, Ticket) 89 | import qualified Control.Monad.Conc.Class as IORef 90 | 91 | -- | Type alias for 'IORef'. 92 | type CRef m a = IORef m a 93 | {-# DEPRECATED CRef "Use IORef instead" #-} 94 | 95 | -- | Create a new reference. 96 | newCRef :: MonadConc m => a -> m (CRef m a) 97 | newCRef = IORef.newIORef 98 | {-# DEPRECATED newCRef "Use newIORef instead" #-} 99 | 100 | -- | Create a new reference, but it is given a name which may be used 101 | -- to present more useful debugging information. 102 | newCRefN :: MonadConc m => String -> a -> m (CRef m a) 103 | newCRefN = IORef.newIORefN 104 | {-# DEPRECATED newCRefN "Use newIORefN instead" #-} 105 | 106 | -- | Read the current value stored in a reference. 107 | readCRef :: MonadConc m => CRef m a -> m a 108 | readCRef = IORef.readIORef 109 | {-# DEPRECATED readCRef "Use readIORef instead" #-} 110 | 111 | -- | Write a new value into an @CRef@, without imposing a memory 112 | -- barrier. This means that relaxed memory effects can be observed. 113 | writeCRef :: MonadConc m => CRef m a -> a -> m () 114 | writeCRef = IORef.writeIORef 115 | {-# DEPRECATED writeCRef "Use writeIORef instead" #-} 116 | 117 | -- | Mutate the contents of a @CRef@. 118 | -- 119 | -- Be warned that 'modifyCRef' does not apply the function strictly. 120 | -- This means if the program calls 'modifyCRef' many times, but 121 | -- seldomly uses the value, thunks will pile up in memory resulting in 122 | -- a space leak. 123 | modifyCRef :: MonadConc m => CRef m a -> (a -> a) -> m () 124 | modifyCRef = IORef.modifyIORef 125 | {-# DEPRECATED modifyCRef "Use modifyIORef instead" #-} 126 | 127 | -- | Strict version of 'modifyCRef' 128 | modifyCRef' :: MonadConc m => CRef m a -> (a -> a) -> m () 129 | modifyCRef' = IORef.modifyIORef' 130 | {-# DEPRECATED modifyCRef' "Use modifyIORef' instead" #-} 131 | 132 | -- | Atomically modify the value stored in a reference. This imposes 133 | -- a full memory barrier. 134 | atomicModifyCRef :: MonadConc m => CRef m a -> (a -> (a, b)) -> m b 135 | atomicModifyCRef = IORef.atomicModifyIORef 136 | {-# DEPRECATED atomicModifyCRef "Use atomicModifyIORef instead" #-} 137 | 138 | -- | Strict version of 'atomicModifyCRef'. This forces both the value 139 | -- stored in the @CRef@ as well as the value returned. 140 | atomicModifyCRef' :: MonadConc m => CRef m a -> (a -> (a,b)) -> m b 141 | atomicModifyCRef' = IORef.atomicModifyIORef' 142 | {-# DEPRECATED atomicModifyCRef' "Use atomicModifyIORef' instead" #-} 143 | 144 | -- | Replace the value stored in a reference, with the 145 | -- barrier-to-reordering property that 'atomicModifyIORef' has. 146 | atomicWriteCRef :: MonadConc m => CRef m a -> a -> m () 147 | atomicWriteCRef = IORef.atomicWriteIORef 148 | {-# DEPRECATED atomicWriteCRef "Use atomicWriteIORef instead" #-} 149 | 150 | -- | Perform a machine-level compare-and-swap (CAS) operation on a 151 | -- @CRef@. Returns an indication of success and a @Ticket@ for the 152 | -- most current value in the @CRef@. 153 | -- This is strict in the \"new\" value argument. 154 | casCRef :: MonadConc m => CRef m a -> Ticket m a -> a -> m (Bool, Ticket m a) 155 | casCRef = IORef.casIORef 156 | {-# DEPRECATED casCRef "Use casIORef instead" #-} 157 | 158 | -- | A replacement for 'atomicModifyCRef' using a compare-and-swap. 159 | -- 160 | -- This is strict in the \"new\" value argument. 161 | modifyCRefCAS :: MonadConc m => CRef m a -> (a -> (a, b)) -> m b 162 | modifyCRefCAS = IORef.modifyIORefCAS 163 | {-# DEPRECATED modifyCRefCAS "Use modifyIORefCAS instead" #-} 164 | 165 | -- | A variant of 'modifyCRefCAS' which doesn't return a result. 166 | modifyCRefCAS_ :: MonadConc m => CRef m a -> (a -> a) -> m () 167 | modifyCRefCAS_ = IORef.modifyIORefCAS_ 168 | {-# DEPRECATED modifyCRefCAS_ "Use modifyIORefCAS_ instead" #-} 169 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/Chan.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.Chan 3 | -- Copyright : (c) 2016 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- Unbounded channels. 10 | -- 11 | -- __Deviations:__ @Chan@ as defined here does not have an @Eq@ 12 | -- instance, this is because the @MonadConc@ @MVar@ type does not have 13 | -- an @Eq@ constraint. The deprecated @unGetChan@ and @isEmptyCHan@ 14 | -- functions are not provided. Furthermore, the @getChanContents@ 15 | -- function is not provided as it needs unsafe I/O. 16 | module Control.Concurrent.Classy.Chan 17 | ( -- * The 'Chan' type 18 | Chan 19 | 20 | -- * Operations 21 | , newChan 22 | , writeChan 23 | , readChan 24 | , dupChan 25 | 26 | -- * Stream interface 27 | , writeList2Chan 28 | ) where 29 | 30 | import Control.Concurrent.Classy.MVar 31 | import Control.Monad.Catch (mask_) 32 | import Control.Monad.Conc.Class (MonadConc) 33 | 34 | -- | 'Chan' is an abstract type representing an unbounded FIFO 35 | -- channel. 36 | -- 37 | -- @since 1.0.0.0 38 | data Chan m a 39 | = Chan (MVar m (Stream m a)) 40 | (MVar m (Stream m a)) -- Invariant: the Stream a is always an empty MVar 41 | 42 | type Stream m a = MVar m (ChItem m a) 43 | 44 | data ChItem m a = ChItem a (Stream m a) 45 | 46 | -- | Build and returns a new instance of 'Chan'. 47 | -- 48 | -- @since 1.0.0.0 49 | newChan :: MonadConc m => m (Chan m a) 50 | newChan = do 51 | hole <- newEmptyMVar 52 | readVar <- newMVar hole 53 | writeVar <- newMVar hole 54 | pure (Chan readVar writeVar) 55 | 56 | -- | Write a value to a 'Chan'. 57 | -- 58 | -- @since 1.0.0.0 59 | writeChan :: MonadConc m => Chan m a -> a -> m () 60 | writeChan (Chan _ writeVar) val = do 61 | new_hole <- newEmptyMVar 62 | mask_ $ do 63 | old_hole <- takeMVar writeVar 64 | putMVar old_hole (ChItem val new_hole) 65 | putMVar writeVar new_hole 66 | 67 | -- | Read the next value from the 'Chan'. 68 | -- 69 | -- @since 1.0.0.0 70 | readChan :: MonadConc m => Chan m a -> m a 71 | readChan (Chan readVar _) = modifyMVarMasked readVar $ \read_end -> do 72 | (ChItem val new_read_end) <- readMVar read_end 73 | pure (new_read_end, val) 74 | 75 | -- | Duplicate a 'Chan': the duplicate channel begins empty, but data 76 | -- written to either channel from then on will be available from both. 77 | -- Hence this creates a kind of broadcast channel, where data written 78 | -- by anyone is seen by everyone else. 79 | -- 80 | -- @since 1.0.0.0 81 | dupChan :: MonadConc m => Chan m a -> m (Chan m a) 82 | dupChan (Chan _ writeVar) = do 83 | hole <- readMVar writeVar 84 | newReadVar <- newMVar hole 85 | pure (Chan newReadVar writeVar) 86 | 87 | -- | Write an entire list of items to a 'Chan'. 88 | -- 89 | -- @since 1.0.0.0 90 | writeList2Chan :: MonadConc m => Chan m a -> [a] -> m () 91 | writeList2Chan = mapM_ . writeChan 92 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/IORef.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.IORef 3 | -- Copyright : (c) 2018 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- Mutable references in a concurrency monad. 10 | -- 11 | -- __Deviations:__ There is no @Eq@ instance for @MonadConc@ the 12 | -- @IORef@ type. Furthermore, the @mkWeakIORef@ function is not 13 | -- provided. 14 | module Control.Concurrent.Classy.IORef 15 | ( -- * IORefs 16 | newIORef 17 | , readIORef 18 | , writeIORef 19 | , modifyIORef 20 | , modifyIORef' 21 | , atomicModifyIORef 22 | , atomicModifyIORef' 23 | , atomicWriteIORef 24 | 25 | -- * Memory Model 26 | 27 | -- | In a concurrent program, @IORef@ operations may appear 28 | -- out-of-order to another thread, depending on the memory model of 29 | -- the underlying processor architecture. For example, on x86 (which 30 | -- uses total store order), loads can move ahead of stores. Consider 31 | -- this example: 32 | -- 33 | -- > iorefs :: MonadConc m => m (Bool, Bool) 34 | -- > iorefs = do 35 | -- > r1 <- newIORef False 36 | -- > r2 <- newIORef False 37 | -- > 38 | -- > x <- spawn $ writeIORef r1 True >> readIORef r2 39 | -- > y <- spawn $ writeIORef r2 True >> readIORef r1 40 | -- > 41 | -- > (,) <$> readMVar x <*> readMVar y 42 | -- 43 | -- Under a sequentially consistent memory model the possible results 44 | -- are @(True, True)@, @(True, False)@, and @(False, True)@. Under 45 | -- total or partial store order, @(False, False)@ is also a possible 46 | -- result, even though there is no interleaving of the threads which 47 | -- can lead to this. 48 | -- 49 | -- We can see this by testing with different memory models: 50 | -- 51 | -- > > autocheckWay defaultWay SequentialConsistency relaxed 52 | -- > [pass] Never Deadlocks 53 | -- > [pass] No Exceptions 54 | -- > [fail] Consistent Result 55 | -- > (False,True) S0---------S1----S0--S2----S0-- 56 | -- > 57 | -- > (True,True) S0---------S1-P2----S1---S0--- 58 | -- > 59 | -- > (True,False) S0---------S2----S1----S0--- 60 | -- > False 61 | -- 62 | -- > > autocheckWay defaultWay TotalStoreOrder relaxed 63 | -- > [pass] Never Deadlocks 64 | -- > [pass] No Exceptions 65 | -- > [fail] Consistent Result 66 | -- > (False,True) S0---------S1----S0--S2----S0-- 67 | -- > 68 | -- > (False,False) S0---------S1--P2----S1--S0--- 69 | -- > 70 | -- > (True,False) S0---------S2----S1----S0--- 71 | -- > 72 | -- > (True,True) S0---------S1-C-S2----S1---S0--- 73 | -- > False 74 | -- 75 | -- Traces for non-sequentially-consistent memory models show where 76 | -- writes to @IORef@s are /committed/, which makes a write visible to 77 | -- all threads rather than just the one which performed the 78 | -- write. Only 'writeIORef' is broken up into separate write and 79 | -- commit steps, 'atomicModifyIORef' is still atomic and imposes a 80 | -- memory barrier. 81 | ) where 82 | 83 | import Control.Monad.Conc.Class 84 | 85 | -- | Mutate the contents of a @IORef@. 86 | -- 87 | -- Be warned that 'modifyIORef' does not apply the function strictly. 88 | -- This means if the program calls 'modifyIORef' many times, but 89 | -- seldomly uses the value, thunks will pile up in memory resulting in 90 | -- a space leak. This is a common mistake made when using a @IORef@ as 91 | -- a counter. For example, the following will likely produce a stack 92 | -- overflow: 93 | -- 94 | -- >ref <- newIORef 0 95 | -- >replicateM_ 1000000 $ modifyIORef ref (+1) 96 | -- >readIORef ref >>= print 97 | -- 98 | -- To avoid this problem, use 'modifyIORef'' instead. 99 | -- 100 | -- @since 1.6.0.0 101 | modifyIORef :: MonadConc m => IORef m a -> (a -> a) -> m () 102 | modifyIORef ref f = readIORef ref >>= writeIORef ref . f 103 | 104 | -- | Strict version of 'modifyIORef' 105 | -- 106 | -- @since 1.6.0.0 107 | modifyIORef' :: MonadConc m => IORef m a -> (a -> a) -> m () 108 | modifyIORef' ref f = do 109 | x <- readIORef ref 110 | writeIORef ref $! f x 111 | 112 | -- | Strict version of 'atomicModifyIORef'. This forces both the value 113 | -- stored in the @IORef@ as well as the value returned. 114 | -- 115 | -- @since 1.6.0.0 116 | atomicModifyIORef' :: MonadConc m => IORef m a -> (a -> (a,b)) -> m b 117 | atomicModifyIORef' ref f = do 118 | b <- atomicModifyIORef ref $ \a -> case f a of 119 | v@(a',_) -> a' `seq` v 120 | pure $! b 121 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/MVar.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.MVar 3 | -- Copyright : (c) 2016 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- An @'MVar' t@ is mutable location that is either empty or contains 10 | -- a value of type @t@. It has two fundamental operations: 'putMVar' 11 | -- which fills an 'MVar' if it is empty and blocks otherwise, and 12 | -- 'takeMVar' which empties an 'MVar' if it is full and blocks 13 | -- otherwise. They can be used in multiple different ways: 14 | -- 15 | -- 1. As synchronized mutable variables, 16 | -- 17 | -- 2. As channels, with 'takeMVar' and 'putMVar' as receive and 18 | -- send, and 19 | -- 20 | -- 3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and 21 | -- 'putMVar' as wait and signal. 22 | -- 23 | -- __Deviations:__ There is no @Eq@ instance for @MonadConc@ the 24 | -- @MVar@ type. Furthermore, the @mkWeakMVar@ and @addMVarFinalizer@ 25 | -- functions are not provided. Finally, normal @MVar@s have a fairness 26 | -- guarantee, which dejafu does not currently make use of when 27 | -- generating schedules to test, so your program may be tested with 28 | -- /unfair/ schedules. 29 | module Control.Concurrent.Classy.MVar 30 | ( -- *@MVar@s 31 | MVar 32 | , newEmptyMVar 33 | , newEmptyMVarN 34 | , newMVar 35 | , newMVarN 36 | , takeMVar 37 | , putMVar 38 | , readMVar 39 | , swapMVar 40 | , tryTakeMVar 41 | , tryPutMVar 42 | , isEmptyMVar 43 | , withMVar 44 | , withMVarMasked 45 | , modifyMVar_ 46 | , modifyMVar 47 | , modifyMVarMasked_ 48 | , modifyMVarMasked 49 | ) where 50 | 51 | import Control.Monad.Catch (onException) 52 | import Control.Monad.Conc.Class 53 | import Data.Maybe (isJust) 54 | 55 | -- | Swap the contents of a @MVar@, and return the value taken. This 56 | -- function is atomic only if there are no other producers fro this 57 | -- @MVar@. 58 | -- 59 | -- @since 1.0.0.0 60 | swapMVar :: MonadConc m => MVar m a -> a -> m a 61 | swapMVar cvar a = mask_ $ do 62 | old <- takeMVar cvar 63 | putMVar cvar a 64 | pure old 65 | 66 | -- | Check if a @MVar@ is empty. 67 | -- 68 | -- The boolean value returned is just a snapshot of the state of the 69 | -- @MVar@, it may have been emptied (or filled) by the time you 70 | -- actually access it. Generally prefer 'tryPutMVar', 'tryTakeMVar', 71 | -- and 'tryReadMVar'. 72 | -- 73 | -- @since 1.0.0.0 74 | isEmptyMVar :: MonadConc m => MVar m a -> m Bool 75 | isEmptyMVar = fmap isJust . tryReadMVar 76 | 77 | -- | Operate on the contents of a @MVar@, replacing the contents after 78 | -- finishing. This operation is exception-safe: it will replace the 79 | -- original contents of the @MVar@ if an exception is raised. However, 80 | -- it is only atomic if there are no other producers for this @MVar@. 81 | -- 82 | -- @since 1.0.0.0 83 | {-# INLINE withMVar #-} 84 | withMVar :: MonadConc m => MVar m a -> (a -> m b) -> m b 85 | withMVar cvar f = mask $ \restore -> do 86 | val <- takeMVar cvar 87 | out <- restore (f val) `onException` putMVar cvar val 88 | putMVar cvar val 89 | 90 | pure out 91 | 92 | -- | Like 'withMVar', but the @IO@ action in the second argument is 93 | -- executed with asynchronous exceptions masked. 94 | -- 95 | -- @since 1.0.0.0 96 | {-# INLINE withMVarMasked #-} 97 | withMVarMasked :: MonadConc m => MVar m a -> (a -> m b) -> m b 98 | withMVarMasked cvar f = mask_ $ do 99 | val <- takeMVar cvar 100 | out <- f val `onException` putMVar cvar val 101 | putMVar cvar val 102 | 103 | pure out 104 | 105 | -- | An exception-safe wrapper for modifying the contents of a @MVar@. 106 | -- Like 'withMVar', 'modifyMVar' will replace the original contents of 107 | -- the @MVar@ if an exception is raised during the operation. This 108 | -- function is only atomic if there are no other producers for this 109 | -- @MVar@. 110 | -- 111 | -- @since 1.0.0.0 112 | {-# INLINE modifyMVar_ #-} 113 | modifyMVar_ :: MonadConc m => MVar m a -> (a -> m a) -> m () 114 | modifyMVar_ cvar f = modifyMVar cvar $ fmap (\a -> (a,())) . f 115 | 116 | -- | A slight variation on 'modifyMVar_' that allows a value to be 117 | -- returned (@b@) in addition to the modified value of the @MVar@. 118 | -- 119 | -- @since 1.0.0.0 120 | {-# INLINE modifyMVar #-} 121 | modifyMVar :: MonadConc m => MVar m a -> (a -> m (a, b)) -> m b 122 | modifyMVar cvar f = mask $ \restore -> do 123 | val <- takeMVar cvar 124 | (val', out) <- restore (f val) `onException` putMVar cvar val 125 | putMVar cvar val' 126 | pure out 127 | 128 | -- | Like 'modifyMVar_', but the @IO@ action in the second argument is 129 | -- executed with asynchronous exceptions masked. 130 | -- 131 | -- @since 1.0.0.0 132 | {-# INLINE modifyMVarMasked_ #-} 133 | modifyMVarMasked_ :: MonadConc m => MVar m a -> (a -> m a) -> m () 134 | modifyMVarMasked_ cvar f = modifyMVarMasked cvar $ fmap (\a -> (a,())) . f 135 | 136 | -- | Like 'modifyMVar', but the @IO@ action in the second argument is 137 | -- executed with asynchronous exceptions masked. 138 | -- 139 | -- @since 1.0.0.0 140 | {-# INLINE modifyMVarMasked #-} 141 | modifyMVarMasked :: MonadConc m => MVar m a -> (a -> m (a, b)) -> m b 142 | modifyMVarMasked cvar f = mask_ $ do 143 | val <- takeMVar cvar 144 | (val', out) <- f val `onException` putMVar cvar val 145 | putMVar cvar val' 146 | pure out 147 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/QSem.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.QSem 3 | -- Copyright : (c) 2016 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- Simple quantity semaphores. 10 | module Control.Concurrent.Classy.QSem 11 | ( -- * Simple Quantity Semaphores 12 | QSem 13 | , newQSem 14 | , waitQSem 15 | , signalQSem 16 | ) where 17 | 18 | import Control.Concurrent.Classy.QSemN 19 | import Control.Monad.Conc.Class (MonadConc) 20 | import Control.Monad.Fail (MonadFail) 21 | 22 | -- | @QSem@ is a quantity semaphore in which the resource is acquired 23 | -- and released in units of one. It provides guaranteed FIFO ordering 24 | -- for satisfying blocked 'waitQSem' calls. 25 | -- 26 | -- The pattern 27 | -- 28 | -- > bracket_ qaitQSem signalSSem (...) 29 | -- 30 | -- is safe; it never loses a unit of the resource. 31 | -- 32 | -- @since 1.0.0.0 33 | newtype QSem m = QSem (QSemN m) 34 | 35 | -- | Build a new 'QSem' with a supplied initial quantity. The initial 36 | -- quantity must be at least 0. 37 | -- 38 | -- @since 1.0.0.0 39 | newQSem :: (MonadConc m, MonadFail m) => Int -> m (QSem m) 40 | newQSem initial 41 | | initial < 0 = fail "newQSem: Initial quantity mus tbe non-negative." 42 | | otherwise = QSem <$> newQSemN initial 43 | 44 | -- | Wait for a unit to become available. 45 | -- 46 | -- @since 1.0.0.0 47 | waitQSem :: MonadConc m => QSem m -> m () 48 | waitQSem (QSem qSemN) = waitQSemN qSemN 1 49 | 50 | -- | Signal that a unit of the 'QSem' is available. 51 | -- 52 | -- @since 1.0.0.0 53 | signalQSem :: MonadConc m => QSem m -> m () 54 | signalQSem (QSem qSemN) = signalQSemN qSemN 1 55 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/QSemN.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.QSemN 3 | -- Copyright : (c) 2016 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- Quantity semaphores in which each thread may wait for an arbitrary 10 | -- \"amount\". 11 | module Control.Concurrent.Classy.QSemN 12 | ( -- * General Quantity Semaphores 13 | QSemN 14 | , newQSemN 15 | , waitQSemN 16 | , signalQSemN 17 | ) where 18 | 19 | import Control.Concurrent.Classy.MVar 20 | import Control.Monad.Catch (mask_, onException, 21 | uninterruptibleMask_) 22 | import Control.Monad.Conc.Class (MonadConc) 23 | import Control.Monad.Fail (MonadFail) 24 | import Data.Maybe 25 | 26 | -- | 'QSemN' is a quantity semaphore in which the resource is aqcuired 27 | -- and released in units of one. It provides guaranteed FIFO ordering 28 | -- for satisfying blocked `waitQSemN` calls. 29 | -- 30 | -- The pattern 31 | -- 32 | -- > bracket_ (waitQSemN n) (signalQSemN n) (...) 33 | -- 34 | -- is safe; it never loses any of the resource. 35 | -- 36 | -- @since 1.0.0.0 37 | newtype QSemN m = QSemN (MVar m (Int, [(Int, MVar m ())], [(Int, MVar m ())])) 38 | 39 | -- | Build a new 'QSemN' with a supplied initial quantity. 40 | -- The initial quantity must be at least 0. 41 | -- 42 | -- @since 1.0.0.0 43 | newQSemN :: (MonadConc m, MonadFail m) => Int -> m (QSemN m) 44 | newQSemN initial 45 | | initial < 0 = fail "newQSemN: Initial quantity must be non-negative" 46 | | otherwise = QSemN <$> newMVar (initial, [], []) 47 | 48 | -- | Wait for the specified quantity to become available 49 | -- 50 | -- @since 1.0.0.0 51 | waitQSemN :: MonadConc m => QSemN m -> Int -> m () 52 | waitQSemN (QSemN m) sz = mask_ $ do 53 | (quantity, b1, b2) <- takeMVar m 54 | let remaining = quantity - sz 55 | if remaining < 0 56 | -- Enqueue and block the thread 57 | then do 58 | b <- newEmptyMVar 59 | putMVar m (quantity, b1, (sz,b):b2) 60 | wait b 61 | -- Claim the resource 62 | else 63 | putMVar m (remaining, b1, b2) 64 | 65 | where 66 | wait b = takeMVar b `onException` uninterruptibleMask_ (do 67 | (quantity, b1, b2) <- takeMVar m 68 | r <- tryTakeMVar b 69 | r' <- if isJust r 70 | then signal sz (quantity, b1, b2) 71 | else putMVar b () >> pure (quantity, b1, b2) 72 | putMVar m r') 73 | 74 | -- | Signal that a given quantity is now available from the 'QSemN'. 75 | -- 76 | -- @since 1.0.0.0 77 | signalQSemN :: MonadConc m => QSemN m -> Int -> m () 78 | signalQSemN (QSemN m) sz = uninterruptibleMask_ $ do 79 | r <- takeMVar m 80 | r' <- signal sz r 81 | putMVar m r' 82 | 83 | -- | Fix the queue and signal as many threads as we can. 84 | signal :: MonadConc m 85 | => Int 86 | -> (Int, [(Int,MVar m ())], [(Int,MVar m ())]) 87 | -> m (Int, [(Int,MVar m ())], [(Int,MVar m ())]) 88 | signal sz0 (i,a1,a2) = loop (sz0 + i) a1 a2 where 89 | -- No more resource left, done. 90 | loop 0 bs b2 = pure (0, bs, b2) 91 | 92 | -- Fix the queue 93 | loop sz [] [] = pure (sz, [], []) 94 | loop sz [] b2 = loop sz (reverse b2) [] 95 | 96 | -- Signal as many threads as there is enough resource to satisfy, 97 | -- stopping as soon as one thread requires more resource than there 98 | -- is. 99 | loop sz ((j,b):bs) b2 100 | | j > sz = do 101 | r <- isEmptyMVar b 102 | if r then pure (sz, (j,b):bs, b2) 103 | else loop sz bs b2 104 | | otherwise = do 105 | r <- tryPutMVar b () 106 | if r then loop (sz-j) bs b2 107 | else loop sz bs b2 108 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/STM.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.STM 3 | -- Copyright : (c) 2016 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : experimental 7 | -- Portability : non-portable 8 | -- 9 | -- Classy software transactional memory. 10 | module Control.Concurrent.Classy.STM 11 | ( module Control.Monad.STM.Class 12 | , module Control.Concurrent.Classy.STM.TVar 13 | , module Control.Concurrent.Classy.STM.TMVar 14 | , module Control.Concurrent.Classy.STM.TChan 15 | , module Control.Concurrent.Classy.STM.TQueue 16 | , module Control.Concurrent.Classy.STM.TBQueue 17 | , module Control.Concurrent.Classy.STM.TArray 18 | , module Control.Concurrent.Classy.STM.TSem 19 | ) where 20 | 21 | import Control.Concurrent.Classy.STM.TArray 22 | import Control.Concurrent.Classy.STM.TBQueue 23 | import Control.Concurrent.Classy.STM.TChan 24 | import Control.Concurrent.Classy.STM.TMVar 25 | import Control.Concurrent.Classy.STM.TQueue 26 | import Control.Concurrent.Classy.STM.TSem 27 | import Control.Concurrent.Classy.STM.TVar 28 | import Control.Monad.STM.Class 29 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/STM/TArray.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | 4 | -- | 5 | -- Module : Control.Concurrent.Classy.STM. 6 | -- Copyright : (c) 2016 Michael Walker 7 | -- License : MIT 8 | -- Maintainer : Michael Walker 9 | -- Stability : stable 10 | -- Portability : FlexibleInstances, MultiParamTypeClasses 11 | -- 12 | -- TArrays: transactional arrays, for use in STM-like monads. 13 | -- 14 | -- __Deviations:__ @TArray@ as defined here does not have an @Eq@ 15 | -- instance, this is because the @MonadSTM@ @TVar@ type does not have 16 | -- an @Eq@ constraint. 17 | module Control.Concurrent.Classy.STM.TArray (TArray) where 18 | 19 | import Data.Array (Array, bounds) 20 | import Data.Array.Base (IArray(numElements), MArray(..), 21 | arrEleBottom, listArray, unsafeAt) 22 | import Data.Ix (rangeSize) 23 | 24 | import Control.Monad.STM.Class 25 | 26 | -- | @TArray@ is a transactional array, supporting the usual 'MArray' 27 | -- interface for mutable arrays. 28 | -- 29 | -- It is currently implemented as @Array ix (TVar stm e)@, but it may 30 | -- be replaced by a more efficient implementation in the future (the 31 | -- interface will remain the same, however). 32 | -- 33 | -- @since 1.0.0.0 34 | newtype TArray stm i e = TArray (Array i (TVar stm e)) 35 | 36 | -- | @since 1.0.0.0 37 | instance MonadSTM stm => MArray (TArray stm) e stm where 38 | getBounds (TArray a) = pure (bounds a) 39 | 40 | newArray b e = 41 | TArray . listArray b <$> rep (rangeSize b) (newTVar e) 42 | 43 | newArray_ b = newArray b arrEleBottom 44 | 45 | unsafeRead (TArray a) = readTVar . unsafeAt a 46 | unsafeWrite (TArray a) = writeTVar . unsafeAt a 47 | 48 | getNumElements (TArray a) = pure (numElements a) 49 | 50 | -- | Like 'replicateM' but uses an accumulator to prevent stack overflows. 51 | -- Unlike 'replicateM' the returned list is in reversed order. This 52 | -- doesn't matter though since this function is only used to create 53 | -- arrays with identical elements. 54 | rep :: Monad m => Int -> m a -> m [a] 55 | rep n m = go n [] where 56 | go 0 xs = pure xs 57 | go i xs = do 58 | x <- m 59 | go (i-1) (x:xs) 60 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/STM/TBQueue.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.STM.TBQueue 3 | -- Copyright : (c) 2016 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- 'TBQueue' is a bounded version of 'TQueue'. The queue has a maximum 10 | -- capacity set when it is created. If the queue already contains the 11 | -- maximum number of elements, then 'writeTBQueue' blocks until an 12 | -- element is removed from the queue. 13 | -- 14 | -- The implementation is based on the traditional purely-functional 15 | -- queue representation that uses two lists to obtain amortised /O(1)/ 16 | -- enqueue and dequeue operations. 17 | -- 18 | -- __Deviations:__ @TBQueue@ as defined here does not have an @Eq@ 19 | -- instance, this is because the @MonadSTM@ @TVar@ type does not have 20 | -- an @Eq@ constraint. Furthermore, the @newTBQueueIO@ function is not 21 | -- provided. 22 | module Control.Concurrent.Classy.STM.TBQueue 23 | ( -- * TBQueue 24 | TBQueue 25 | , newTBQueue 26 | , readTBQueue 27 | , tryReadTBQueue 28 | , flushTBQueue 29 | , peekTBQueue 30 | , tryPeekTBQueue 31 | , writeTBQueue 32 | , unGetTBQueue 33 | , lengthTBQueue 34 | , isEmptyTBQueue 35 | , isFullTBQueue 36 | ) where 37 | 38 | import Control.Monad.STM.Class 39 | import Numeric.Natural 40 | 41 | -- | 'TBQueue' is an abstract type representing a bounded FIFO 42 | -- channel. 43 | -- 44 | -- @since 1.9.0.0 45 | data TBQueue stm a 46 | = TBQueue (TVar stm Natural) 47 | (TVar stm [a]) 48 | (TVar stm Natural) 49 | (TVar stm [a]) 50 | !Natural 51 | 52 | -- | Builds and returns a new instance of 'TBQueue' 53 | -- 54 | -- @since 1.9.0.0 55 | newTBQueue :: MonadSTM stm 56 | => Natural -- ^ maximum number of elements the queue can hold 57 | -> stm (TBQueue stm a) 58 | newTBQueue size = do 59 | readT <- newTVar [] 60 | writeT <- newTVar [] 61 | rsize <- newTVar 0 62 | wsize <- newTVar size 63 | pure (TBQueue rsize readT wsize writeT size) 64 | 65 | -- | Write a value to a 'TBQueue'; retries if the queue is full. 66 | -- 67 | -- @since 1.0.0.0 68 | writeTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm () 69 | writeTBQueue (TBQueue rsize _ wsize writeT _) a = do 70 | w <- readTVar wsize 71 | if w > 0 72 | then writeTVar wsize $! w - 1 73 | else do 74 | r <- readTVar rsize 75 | if r > 0 76 | then do 77 | writeTVar rsize 0 78 | writeTVar wsize $! r - 1 79 | else retry 80 | listend <- readTVar writeT 81 | writeTVar writeT (a:listend) 82 | 83 | -- | Read the next value from the 'TBQueue'. 84 | -- 85 | -- @since 1.0.0.0 86 | readTBQueue :: MonadSTM stm => TBQueue stm a -> stm a 87 | readTBQueue (TBQueue rsize readT _ writeT _) = do 88 | xs <- readTVar readT 89 | r <- readTVar rsize 90 | writeTVar rsize $! r + 1 91 | case xs of 92 | (x:xs') -> do 93 | writeTVar readT xs' 94 | pure x 95 | [] -> do 96 | ys <- readTVar writeT 97 | case ys of 98 | [] -> retry 99 | _ -> do 100 | let (z:zs) = reverse ys 101 | writeTVar writeT [] 102 | writeTVar readT zs 103 | pure z 104 | 105 | -- | A version of 'readTBQueue' which does not retry. Instead it 106 | -- returns @Nothing@ if no value is available. 107 | -- 108 | -- @since 1.0.0.0 109 | tryReadTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a) 110 | tryReadTBQueue c = (Just <$> readTBQueue c) `orElse` pure Nothing 111 | 112 | -- | Efficiently read the entire contents of a 'TBQueue' into a list. This 113 | -- function never retries. 114 | -- 115 | -- @since 1.6.1.0 116 | flushTBQueue :: MonadSTM stm => TBQueue stm a -> stm [a] 117 | flushTBQueue (TBQueue rsize r wsize w size) = do 118 | xs <- readTVar r 119 | ys <- readTVar w 120 | if null xs && null ys 121 | then pure [] 122 | else do 123 | writeTVar r [] 124 | writeTVar w [] 125 | writeTVar rsize 0 126 | writeTVar wsize size 127 | pure (xs ++ reverse ys) 128 | 129 | -- | Get the next value from the @TBQueue@ without removing it, 130 | -- retrying if the channel is empty. 131 | -- 132 | -- @since 1.0.0.0 133 | peekTBQueue :: MonadSTM stm => TBQueue stm a -> stm a 134 | peekTBQueue (TBQueue _ readT _ writeT _) = do 135 | xs <- readTVar readT 136 | case xs of 137 | (x:_) -> pure x 138 | [] -> do 139 | ys <- readTVar writeT 140 | case ys of 141 | [] -> retry 142 | _ -> do 143 | let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be 144 | -- short, otherwise it will conflict 145 | writeTVar writeT [] 146 | writeTVar readT (z:zs) 147 | pure z 148 | 149 | -- | A version of 'peekTBQueue' which does not retry. Instead it 150 | -- returns @Nothing@ if no value is available. 151 | -- 152 | -- @since 1.0.0.0 153 | tryPeekTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a) 154 | tryPeekTBQueue c = do 155 | m <- tryReadTBQueue c 156 | case m of 157 | Nothing -> pure Nothing 158 | Just x -> do 159 | unGetTBQueue c x 160 | pure m 161 | 162 | -- | Put a data item back onto a channel, where it will be the next item read. 163 | -- Retries if the queue is full. 164 | -- 165 | -- @since 1.0.0.0 166 | unGetTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm () 167 | unGetTBQueue (TBQueue rsize readT wsize _ _) a = do 168 | r <- readTVar rsize 169 | if r > 0 170 | then writeTVar rsize $! r - 1 171 | else do 172 | w <- readTVar wsize 173 | if w > 0 174 | then writeTVar wsize $! w - 1 175 | else retry 176 | xs <- readTVar readT 177 | writeTVar readT (a:xs) 178 | 179 | -- |Return the length of a 'TBQueue'. 180 | -- 181 | -- @since 1.9.0.0 182 | lengthTBQueue :: MonadSTM stm => TBQueue stm a -> stm Natural 183 | lengthTBQueue (TBQueue rsize _ wsize _ size) = do 184 | r <- readTVar rsize 185 | w <- readTVar wsize 186 | pure $! size - r - w 187 | 188 | -- | Returns 'True' if the supplied 'TBQueue' is empty. 189 | -- 190 | -- @since 1.0.0.0 191 | isEmptyTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool 192 | isEmptyTBQueue (TBQueue _ readT _ writeT _) = do 193 | xs <- readTVar readT 194 | case xs of 195 | (_:_) -> pure False 196 | [] -> null <$> readTVar writeT 197 | 198 | -- | Returns 'True' if the supplied 'TBQueue' is full. 199 | -- 200 | -- @since 1.0.0.0 201 | isFullTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool 202 | isFullTBQueue (TBQueue rsize _ wsize _ _) = do 203 | w <- readTVar wsize 204 | if w > 0 205 | then pure False 206 | else (>0) <$> readTVar rsize 207 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/STM/TChan.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.STM.TChan 3 | -- Copyright : (c) 2016 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- Transactional channels 10 | -- 11 | -- __Deviations:__ @TChan@ as defined here does not have an @Eq@ 12 | -- instance, this is because the @MonadSTM@ @TVar@ type does not have 13 | -- an @Eq@ constraint. Furthermore, the @newTChanIO@ and 14 | -- @newBroadcastTChanIO@ functions are not provided. 15 | module Control.Concurrent.Classy.STM.TChan 16 | ( -- * TChans 17 | TChan 18 | 19 | -- * Construction 20 | , newTChan 21 | , newBroadcastTChan 22 | , dupTChan 23 | , cloneTChan 24 | 25 | -- * Reading and writing 26 | , readTChan 27 | , tryReadTChan 28 | , peekTChan 29 | , tryPeekTChan 30 | , writeTChan 31 | , unGetTChan 32 | , isEmptyTChan 33 | ) where 34 | 35 | import Control.Monad.STM.Class 36 | 37 | -- | 'TChan' is an abstract type representing an unbounded FIFO 38 | -- channel. 39 | -- 40 | -- @since 1.0.0.0 41 | data TChan stm a = TChan (TVar stm (TVarList stm a)) 42 | (TVar stm (TVarList stm a)) 43 | 44 | type TVarList stm a = TVar stm (TList stm a) 45 | data TList stm a = TNil | TCons a (TVarList stm a) 46 | 47 | -- |Build and return a new instance of 'TChan' 48 | -- 49 | -- @since 1.0.0.0 50 | newTChan :: MonadSTM stm => stm (TChan stm a) 51 | newTChan = do 52 | hole <- newTVar TNil 53 | readH <- newTVar hole 54 | writeH <- newTVar hole 55 | pure (TChan readH writeH) 56 | 57 | -- | Create a write-only 'TChan'. More precisely, 'readTChan' will 'retry' 58 | -- even after items have been written to the channel. The only way to 59 | -- read a broadcast channel is to duplicate it with 'dupTChan'. 60 | -- 61 | -- @since 1.0.0.0 62 | newBroadcastTChan :: MonadSTM stm => stm (TChan stm a) 63 | newBroadcastTChan = do 64 | hole <- newTVar TNil 65 | readT <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first") 66 | writeT <- newTVar hole 67 | pure (TChan readT writeT) 68 | 69 | -- | Write a value to a 'TChan'. 70 | -- 71 | -- @since 1.0.0.0 72 | writeTChan :: MonadSTM stm => TChan stm a -> a -> stm () 73 | writeTChan (TChan _ writeT) a = do 74 | listend <- readTVar writeT 75 | listend' <- newTVar TNil 76 | writeTVar listend (TCons a listend') 77 | writeTVar writeT listend' 78 | 79 | -- | Read the next value from the 'TChan'. 80 | -- 81 | -- @since 1.0.0.0 82 | readTChan :: MonadSTM stm => TChan stm a -> stm a 83 | readTChan tchan = tryReadTChan tchan >>= maybe retry pure 84 | 85 | -- | A version of 'readTChan' which does not retry. Instead it 86 | -- returns @Nothing@ if no value is available. 87 | -- 88 | -- @since 1.0.0.0 89 | tryReadTChan :: MonadSTM stm => TChan stm a -> stm (Maybe a) 90 | tryReadTChan (TChan readT _) = do 91 | listhead <- readTVar readT 92 | hd <- readTVar listhead 93 | case hd of 94 | TNil -> pure Nothing 95 | TCons a tl -> do 96 | writeTVar readT tl 97 | pure (Just a) 98 | 99 | -- | Get the next value from the 'TChan' without removing it, 100 | -- retrying if the channel is empty. 101 | -- 102 | -- @since 1.0.0.0 103 | peekTChan :: MonadSTM stm => TChan stm a -> stm a 104 | peekTChan tchan = tryPeekTChan tchan >>= maybe retry pure 105 | 106 | -- | A version of 'peekTChan' which does not retry. Instead it 107 | -- returns @Nothing@ if no value is available. 108 | -- 109 | -- @since 1.0.0.0 110 | tryPeekTChan :: MonadSTM stm => TChan stm a -> stm (Maybe a) 111 | tryPeekTChan (TChan readT _) = do 112 | listhead <- readTVar readT 113 | hd <- readTVar listhead 114 | pure $ case hd of 115 | TNil -> Nothing 116 | TCons a _ -> Just a 117 | 118 | -- | Duplicate a 'TChan': the duplicate channel begins empty, but data written to 119 | -- either channel from then on will be available from both. Hence 120 | -- this creates a kind of broadcast channel, where data written by 121 | -- anyone is seen by everyone else. 122 | -- 123 | -- @since 1.0.0.0 124 | dupTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a) 125 | dupTChan (TChan _ writeT) = do 126 | hole <- readTVar writeT 127 | readT' <- newTVar hole 128 | pure (TChan readT' writeT) 129 | 130 | -- | Put a data item back onto a channel, where it will be the next 131 | -- item read. 132 | -- 133 | -- @since 1.0.0.0 134 | unGetTChan :: MonadSTM stm => TChan stm a -> a -> stm () 135 | unGetTChan (TChan readT _) a = do 136 | listhead <- readTVar readT 137 | head' <- newTVar (TCons a listhead) 138 | writeTVar readT head' 139 | 140 | -- | Returns 'True' if the supplied 'TChan' is empty. 141 | -- 142 | -- @since 1.0.0.0 143 | isEmptyTChan :: MonadSTM stm => TChan stm a -> stm Bool 144 | isEmptyTChan (TChan readT _) = do 145 | listhead <- readTVar readT 146 | hd <- readTVar listhead 147 | pure $ case hd of 148 | TNil -> True 149 | TCons _ _ -> False 150 | 151 | -- | Clone a 'TChan': similar to 'dupTChan', but the cloned channel starts with the 152 | -- same content available as the original channel. 153 | -- 154 | -- @since 1.0.0.0 155 | cloneTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a) 156 | cloneTChan (TChan readT writeT) = do 157 | readpos <- readTVar readT 158 | readT' <- newTVar readpos 159 | pure (TChan readT' writeT) 160 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/STM/TMVar.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.STM.TMVar 3 | -- Copyright : (c) 2016 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- Transactional @MVar@s, for use with 'MonadSTM'. 10 | -- 11 | -- __Deviations:__ @TMVar@ as defined here does not have an @Eq@ 12 | -- instance, this is because the @MonadSTM@ @TVar@ type does not have 13 | -- an @Eq@ constraint. Furthermore, the @newTMVarIO@, 14 | -- @newEmptyTMVarIO@, and @mkWeakTMVar@ functions are not provided. 15 | module Control.Concurrent.Classy.STM.TMVar 16 | ( -- * @TMVar@s 17 | TMVar 18 | , newTMVar 19 | , newTMVarN 20 | , newEmptyTMVar 21 | , newEmptyTMVarN 22 | , takeTMVar 23 | , putTMVar 24 | , readTMVar 25 | , tryTakeTMVar 26 | , tryPutTMVar 27 | , tryReadTMVar 28 | , isEmptyTMVar 29 | , swapTMVar 30 | ) where 31 | 32 | import Control.Monad (unless, when) 33 | import Control.Monad.STM.Class 34 | import Data.Maybe (isJust, isNothing) 35 | 36 | -- | A @TMVar@ is like an @MVar@ or a @mVar@, but using transactional 37 | -- memory. As transactions are atomic, this makes dealing with 38 | -- multiple @TMVar@s easier than wrangling multiple @mVar@s. 39 | -- 40 | -- @since 1.0.0.0 41 | newtype TMVar stm a = TMVar (TVar stm (Maybe a)) 42 | 43 | -- | Create a 'TMVar' containing the given value. 44 | -- 45 | -- @since 1.0.0.0 46 | newTMVar :: MonadSTM stm => a -> stm (TMVar stm a) 47 | newTMVar = newTMVarN "" 48 | 49 | -- | Create a 'TMVar' containing the given value, with the given 50 | -- name. 51 | -- 52 | -- Name conflicts are handled as usual for 'TVar's. The name is 53 | -- prefixed with \"ctmvar-\". 54 | -- 55 | -- @since 1.0.0.0 56 | newTMVarN :: MonadSTM stm => String -> a -> stm (TMVar stm a) 57 | newTMVarN n a = do 58 | let n' = if null n then "ctmvar" else "ctmvar-" ++ n 59 | ctvar <- newTVarN n' $ Just a 60 | pure (TMVar ctvar) 61 | 62 | -- | Create a new empty 'TMVar'. 63 | -- 64 | -- @since 1.0.0.0 65 | newEmptyTMVar :: MonadSTM stm => stm (TMVar stm a) 66 | newEmptyTMVar = newEmptyTMVarN "" 67 | 68 | -- | Create a new empty 'TMVar' with the given name. 69 | -- 70 | -- Name conflicts are handled as usual for 'TVar's. The name is 71 | -- prefixed with \"ctmvar-\". 72 | -- 73 | -- @since 1.0.0.0 74 | newEmptyTMVarN :: MonadSTM stm => String -> stm (TMVar stm a) 75 | newEmptyTMVarN n = do 76 | let n' = if null n then "ctmvar" else "ctmvar-" ++ n 77 | ctvar <- newTVarN n' Nothing 78 | pure (TMVar ctvar) 79 | 80 | -- | Take the contents of a 'TMVar', or 'retry' if it is empty. 81 | -- 82 | -- @since 1.0.0.0 83 | takeTMVar :: MonadSTM stm => TMVar stm a -> stm a 84 | takeTMVar ctmvar = do 85 | taken <- tryTakeTMVar ctmvar 86 | maybe retry pure taken 87 | 88 | -- | Write to a 'TMVar', or 'retry' if it is full. 89 | -- 90 | -- @since 1.0.0.0 91 | putTMVar :: MonadSTM stm => TMVar stm a -> a -> stm () 92 | putTMVar ctmvar a = do 93 | putted <- tryPutTMVar ctmvar a 94 | unless putted retry 95 | 96 | -- | Read from a 'TMVar' without emptying, or 'retry' if it is empty. 97 | -- 98 | -- @since 1.0.0.0 99 | readTMVar :: MonadSTM stm => TMVar stm a -> stm a 100 | readTMVar ctmvar = do 101 | readed <- tryReadTMVar ctmvar 102 | maybe retry pure readed 103 | 104 | -- | Try to take the contents of a 'TMVar', returning 'Nothing' if it 105 | -- is empty. 106 | -- 107 | -- @since 1.0.0.0 108 | tryTakeTMVar :: MonadSTM stm => TMVar stm a -> stm (Maybe a) 109 | tryTakeTMVar (TMVar ctvar) = do 110 | val <- readTVar ctvar 111 | when (isJust val) $ writeTVar ctvar Nothing 112 | pure val 113 | 114 | -- | Try to write to a 'TMVar', returning 'False' if it is full. 115 | -- 116 | -- @since 1.0.0.0 117 | tryPutTMVar :: MonadSTM stm => TMVar stm a -> a -> stm Bool 118 | tryPutTMVar (TMVar ctvar) a = do 119 | val <- readTVar ctvar 120 | when (isNothing val) $ writeTVar ctvar (Just a) 121 | pure (isNothing val) 122 | 123 | -- | Try to read from a 'TMVar' without emptying, returning 'Nothing' 124 | -- if it is empty. 125 | -- 126 | -- @since 1.0.0.0 127 | tryReadTMVar :: MonadSTM stm => TMVar stm a -> stm (Maybe a) 128 | tryReadTMVar (TMVar ctvar) = readTVar ctvar 129 | 130 | -- | Check if a 'TMVar' is empty or not. 131 | -- 132 | -- @since 1.0.0.0 133 | isEmptyTMVar :: MonadSTM stm => TMVar stm a -> stm Bool 134 | isEmptyTMVar ctmvar = isNothing <$> tryReadTMVar ctmvar 135 | 136 | -- | Swap the contents of a 'TMVar' returning the old contents, or 137 | -- 'retry' if it is empty. 138 | -- 139 | -- @since 1.0.0.0 140 | swapTMVar :: MonadSTM stm => TMVar stm a -> a -> stm a 141 | swapTMVar ctmvar a = do 142 | val <- takeTMVar ctmvar 143 | putTMVar ctmvar a 144 | pure val 145 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/STM/TQueue.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.STM.TQueue 3 | -- Copyright : (c) 2016 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- A 'TQueue' is like a 'TChan', with two important differences: 10 | -- 11 | -- * it has faster throughput than both 'TChan' and 'Chan' (although 12 | -- the costs are amortised, so the cost of individual operations 13 | -- can vary a lot). 14 | -- 15 | -- * it does /not/ provide equivalents of the 'dupTChan' and 16 | -- 'cloneTChan' operations. 17 | -- 18 | -- The implementation is based on the traditional purely-functional 19 | -- queue representation that uses two lists to obtain amortised /O(1)/ 20 | -- enqueue and dequeue operations. 21 | -- 22 | -- __Deviations:__ @TQueue@ as defined here does not have an @Eq@ 23 | -- instance, this is because the @MonadSTM@ @TVar@ type does not have 24 | -- an @Eq@ constraint. Furthermore, the @newTQueueIO@ function is not 25 | -- provided. 26 | module Control.Concurrent.Classy.STM.TQueue 27 | ( -- * TQueue 28 | TQueue 29 | , newTQueue 30 | , readTQueue 31 | , tryReadTQueue 32 | , flushTQueue 33 | , peekTQueue 34 | , tryPeekTQueue 35 | , writeTQueue 36 | , unGetTQueue 37 | , isEmptyTQueue 38 | ) where 39 | 40 | import Control.Monad (unless) 41 | import Control.Monad.STM.Class 42 | 43 | -- | 'TQueue' is an abstract type representing an unbounded FIFO channel. 44 | -- 45 | -- @since 1.0.0.0 46 | data TQueue stm a = TQueue (TVar stm [a]) 47 | (TVar stm [a]) 48 | 49 | -- | Build and returns a new instance of 'TQueue' 50 | -- 51 | -- @since 1.0.0.0 52 | newTQueue :: MonadSTM stm => stm (TQueue stm a) 53 | newTQueue = do 54 | readT <- newTVar [] 55 | writeT <- newTVar [] 56 | pure (TQueue readT writeT) 57 | 58 | -- | Write a value to a 'TQueue'. 59 | -- 60 | -- @since 1.0.0.0 61 | writeTQueue :: MonadSTM stm => TQueue stm a -> a -> stm () 62 | writeTQueue (TQueue _ writeT) a = do 63 | listend <- readTVar writeT 64 | writeTVar writeT (a:listend) 65 | 66 | -- | Read the next value from the 'TQueue'. 67 | -- 68 | -- @since 1.0.0.0 69 | readTQueue :: MonadSTM stm => TQueue stm a -> stm a 70 | readTQueue (TQueue readT writeT) = do 71 | xs <- readTVar readT 72 | case xs of 73 | (x:xs') -> do 74 | writeTVar readT xs' 75 | pure x 76 | [] -> do 77 | ys <- readTVar writeT 78 | case ys of 79 | [] -> retry 80 | _ -> do 81 | let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be 82 | -- short, otherwise it will conflict 83 | writeTVar writeT [] 84 | writeTVar readT zs 85 | pure z 86 | 87 | -- | A version of 'readTQueue' which does not retry. Instead it 88 | -- returns @Nothing@ if no value is available. 89 | -- 90 | -- @since 1.0.0.0 91 | tryReadTQueue :: MonadSTM stm => TQueue stm a -> stm (Maybe a) 92 | tryReadTQueue c = (Just <$> readTQueue c) `orElse` pure Nothing 93 | 94 | -- | Efficiently read the entire contents of a 'TQueue' into a list. This 95 | -- function never retries. 96 | -- 97 | -- @since 1.6.1.0 98 | flushTQueue :: MonadSTM stm => TQueue stm a -> stm [a] 99 | flushTQueue (TQueue r w) = do 100 | xs <- readTVar r 101 | ys <- readTVar w 102 | unless (null xs) $ writeTVar r [] 103 | unless (null ys) $ writeTVar w [] 104 | pure (xs ++ reverse ys) 105 | 106 | -- | Get the next value from the @TQueue@ without removing it, 107 | -- retrying if the channel is empty. 108 | -- 109 | -- @since 1.0.0.0 110 | peekTQueue :: MonadSTM stm => TQueue stm a -> stm a 111 | peekTQueue (TQueue readT writeT) = do 112 | xs <- readTVar readT 113 | case xs of 114 | (x:_) -> pure x 115 | [] -> do 116 | ys <- readTVar writeT 117 | case ys of 118 | [] -> retry 119 | _ -> do 120 | let (z:zs) = reverse ys -- NB. lazy: we want the transaction to be 121 | -- short, otherwise it will conflict 122 | writeTVar writeT [] 123 | writeTVar readT (z:zs) 124 | pure z 125 | 126 | -- | A version of 'peekTQueue' which does not retry. Instead it 127 | -- returns @Nothing@ if no value is available. 128 | -- 129 | -- @since 1.0.0.0 130 | tryPeekTQueue :: MonadSTM stm => TQueue stm a -> stm (Maybe a) 131 | tryPeekTQueue c = do 132 | m <- tryReadTQueue c 133 | case m of 134 | Nothing -> pure Nothing 135 | Just x -> do 136 | unGetTQueue c x 137 | pure m 138 | 139 | -- |Put a data item back onto a channel, where it will be the next item read. 140 | -- 141 | -- @since 1.0.0.0 142 | unGetTQueue :: MonadSTM stm => TQueue stm a -> a -> stm () 143 | unGetTQueue (TQueue readT _) a = do 144 | xs <- readTVar readT 145 | writeTVar readT (a:xs) 146 | 147 | -- |Returns 'True' if the supplied 'TQueue' is empty. 148 | -- 149 | -- @since 1.0.0.0 150 | isEmptyTQueue :: MonadSTM stm => TQueue stm a -> stm Bool 151 | isEmptyTQueue (TQueue readT writeT) = do 152 | xs <- readTVar readT 153 | case xs of 154 | (_:_) -> pure False 155 | [] -> null <$> readTVar writeT 156 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/STM/TSem.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.STM.TSem 3 | -- Copyright : (c) 2018 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- 'TSem': transactional semaphores. 10 | -- 11 | -- __Deviations:__ There is no @Eq@ instance for @TSem@ type. 12 | module Control.Concurrent.Classy.STM.TSem 13 | ( TSem 14 | , newTSem 15 | , waitTSem 16 | , signalTSem 17 | , signalTSemN 18 | ) where 19 | 20 | import Control.Monad (when) 21 | import Control.Monad.STM.Class 22 | import Numeric.Natural (Natural) 23 | 24 | -- | 'TSem' is a transactional semaphore. It holds a certain number 25 | -- of units, and units may be acquired or released by 'waitTSem' and 26 | -- 'signalTSem' respectively. When the 'TSem' is empty, 'waitTSem' 27 | -- blocks. 28 | -- 29 | -- Note that 'TSem' has no concept of fairness, and there is no 30 | -- guarantee that threads blocked in `waitTSem` will be unblocked in 31 | -- the same order; in fact they will all be unblocked at the same time 32 | -- and will fight over the 'TSem'. Hence 'TSem' is not suitable if 33 | -- you expect there to be a high number of threads contending for the 34 | -- resource. However, like other STM abstractions, 'TSem' is 35 | -- composable. 36 | -- 37 | -- @since 1.6.1.0 38 | newtype TSem stm = TSem (TVar stm Integer) 39 | 40 | -- | Construct new 'TSem' with an initial counter value. 41 | -- 42 | -- A positive initial counter value denotes availability of 43 | -- units 'waitTSem' can acquire. 44 | -- 45 | -- The initial counter value can be negative which denotes a resource 46 | -- \"debt\" that requires a respective amount of 'signalTSem' 47 | -- operations to counter-balance. 48 | -- 49 | -- @since 1.6.1.0 50 | newTSem :: MonadSTM stm => Integer -> stm (TSem stm) 51 | newTSem i = fmap TSem (newTVar $! i) 52 | 53 | -- | Wait on 'TSem' (aka __P__ operation). 54 | -- 55 | -- This operation acquires a unit from the semaphore (i.e. decreases 56 | -- the internal counter) and blocks (via 'retry') if no units are 57 | -- available (i.e. if the counter is /not/ positive). 58 | -- 59 | -- @since 2.4.2 60 | waitTSem :: MonadSTM stm => TSem stm -> stm () 61 | waitTSem (TSem t) = do 62 | i <- readTVar t 63 | when (i <= 0) retry 64 | writeTVar t $! (i-1) 65 | 66 | -- | Signal a 'TSem' (aka __V__ operation). 67 | -- 68 | -- This operation adds\/releases a unit back to the semaphore 69 | -- (i.e. increments the internal counter). 70 | -- 71 | -- @since 1.6.1.0 72 | signalTSem :: MonadSTM stm => TSem stm -> stm () 73 | signalTSem (TSem t) = do 74 | i <- readTVar t 75 | writeTVar t $! i+1 76 | 77 | -- | Multi-signal a 'TSem' 78 | -- 79 | -- This operation adds\/releases multiple units back to the semaphore 80 | -- (i.e. increments the internal counter). 81 | -- 82 | -- > signalTSem == signalTSemN 1 83 | -- 84 | -- @since 1.6.1.0 85 | signalTSemN :: MonadSTM stm => Natural -> TSem stm -> stm () 86 | signalTSemN 0 _ = pure () 87 | signalTSemN 1 s = signalTSem s 88 | signalTSemN n (TSem t) = do 89 | i <- readTVar t 90 | writeTVar t $! i + toInteger n 91 | -------------------------------------------------------------------------------- /concurrency/Control/Concurrent/Classy/STM/TVar.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Control.Concurrent.Classy.STM.TVar 3 | -- Copyright : (c) 2016 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : stable 7 | -- Portability : portable 8 | -- 9 | -- Transactional variables, for use with 'MonadSTM'. 10 | -- 11 | -- __Deviations:__ There is no @Eq@ instance for @MonadSTM@ the @TVar@ 12 | -- type. Furthermore, the @newTVarIO@ and @mkWeakTVar@ functions are 13 | -- not provided. 14 | module Control.Concurrent.Classy.STM.TVar 15 | ( -- * @TVar@s 16 | TVar 17 | , newTVar 18 | , newTVarN 19 | , readTVar 20 | , readTVarConc 21 | , writeTVar 22 | , modifyTVar 23 | , modifyTVar' 24 | , stateTVar 25 | , swapTVar 26 | , registerDelay 27 | ) where 28 | 29 | import Control.Monad.Conc.Class 30 | import Control.Monad.STM.Class 31 | import Data.Functor (void) 32 | 33 | -- * @TVar@s 34 | 35 | -- | Mutate the contents of a 'TVar'. This is non-strict. 36 | -- 37 | -- @since 1.0.0.0 38 | modifyTVar :: MonadSTM stm => TVar stm a -> (a -> a) -> stm () 39 | modifyTVar ctvar f = do 40 | a <- readTVar ctvar 41 | writeTVar ctvar $ f a 42 | 43 | -- | Mutate the contents of a 'TVar' strictly. 44 | -- 45 | -- @since 1.0.0.0 46 | modifyTVar' :: MonadSTM stm => TVar stm a -> (a -> a) -> stm () 47 | modifyTVar' ctvar f = do 48 | a <- readTVar ctvar 49 | writeTVar ctvar $! f a 50 | 51 | -- | Like 'modifyTVar'' but the function is a simple state transition that can 52 | -- return a side value which is passed on as the result of the STM. 53 | -- 54 | -- @since 1.6.1.0 55 | stateTVar :: MonadSTM stm => TVar stm s -> (s -> (a, s)) -> stm a 56 | stateTVar var f = do 57 | s <- readTVar var 58 | let (a, s') = f s -- since we destructure this, we are strict in f 59 | writeTVar var s' 60 | pure a 61 | 62 | -- | Swap the contents of a 'TVar', returning the old value. 63 | -- 64 | -- @since 1.0.0.0 65 | swapTVar :: MonadSTM stm => TVar stm a -> a -> stm a 66 | swapTVar ctvar a = do 67 | old <- readTVar ctvar 68 | writeTVar ctvar a 69 | pure old 70 | 71 | -- | Set the value of returned 'TVar' to @True@ after a given number 72 | -- of microseconds. The caveats associated with 'threadDelay' also 73 | -- apply. 74 | -- 75 | -- @since 1.0.0.0 76 | registerDelay :: MonadConc m => Int -> m (TVar (STM m) Bool) 77 | registerDelay delay = do 78 | var <- atomically (newTVar False) 79 | void . fork $ do 80 | threadDelay delay 81 | atomically (writeTVar var True) 82 | pure var 83 | -------------------------------------------------------------------------------- /concurrency/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016--2017, Michael Walker 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /concurrency/README.markdown: -------------------------------------------------------------------------------- 1 | concurrency 2 | =========== 3 | 4 | A typeclass abstraction over much of Control.Concurrent (and some 5 | extras!). If you're looking for a general introduction to Haskell 6 | concurrency, you should check out the excellent [Parallel and 7 | Concurrent Programming in Haskell][parconc], by Simon Marlow. If you 8 | are already familiar with concurrent Haskell, just change all the 9 | imports from Control.Concurrent.* to Control.Concurrent.Classy.* and 10 | fix the type errors. 11 | 12 | A brief list of supported functionality: 13 | 14 | - Threads: both unbound and bound. 15 | - Getting and setting capablities. 16 | - Yielding and delaying. 17 | - Mutable state: STM, `MVar`, and `IORef`. 18 | - Atomic compare-and-swap for `IORef`. 19 | - Exceptions. 20 | - All of the data structures in Control.Concurrent.* and 21 | Control.Concurrent.STM.* have typeclass-abstracted equivalents. 22 | - A reimplementation of the [async][] package, providing a 23 | higher-level interface over threads, allowing users to conveniently 24 | run `MonadConc` operations asynchronously and wait for their 25 | results. 26 | 27 | This is quite a rich set of functionality, although it is not 28 | complete. If there is something else you need, file an issue! 29 | 30 | This used to be part of dejafu, but with the dejafu-0.4.0.0 release, 31 | it was split out into its own package. 32 | 33 | Why this and not something else? 34 | -------------------------------- 35 | 36 | - **Why not base:** like lifted-base, concurrency uses typeclasses to 37 | make function types more generic. This automatically eliminates 38 | calls to `lift` in many cases, resulting in clearer and simpler 39 | code. 40 | 41 | - **Why not lifted-base:** fundamentally, lifted-base is still using 42 | actual threads and actual mutable variables. When using a 43 | concurrency-specific typeclass, this isn't necessarily the case. The 44 | dejafu library provides non-IO-based implementations to allow 45 | testing concurrent programs. 46 | 47 | - **Why not IOSpec:** IOSpec provides many of the operations this 48 | library does, however it uses a free monad to do so, which has extra 49 | allocation overhead. Furthermore, it does not expose enough of the 50 | internals in order to accurately test real-execution semantics, such 51 | as relaxed memory. 52 | 53 | Contributing 54 | ------------ 55 | 56 | Bug reports, pull requests, and comments are very welcome! 57 | 58 | Feel free to contact me on GitHub, through IRC (#haskell on 59 | libera.chat), or email (mike@barrucadu.co.uk). 60 | 61 | [async]: https://hackage.haskell.org/package/async 62 | [parconc]: http://chimera.labs.oreilly.com/books/1230000000929 63 | -------------------------------------------------------------------------------- /concurrency/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /concurrency/concurrency.cabal: -------------------------------------------------------------------------------- 1 | -- Initial monad-conc.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: concurrency 5 | version: 1.11.0.3 6 | synopsis: Typeclasses, functions, and data types for concurrency and STM. 7 | 8 | description: 9 | A typeclass abstraction over much of Control.Concurrent (and some 10 | extras!). If you're looking for a general introduction to Haskell 11 | concurrency, you should check out the excellent Parallel and 12 | Concurrent Programming in Haskell, by Simon Marlow. If you are 13 | already familiar with concurrent Haskell, just change all the 14 | imports from Control.Concurrent.* to Control.Concurrent.Classy.* and 15 | fix the type errors. 16 | 17 | homepage: https://github.com/barrucadu/dejafu 18 | license: MIT 19 | license-file: LICENSE 20 | author: Michael Walker 21 | maintainer: mike@barrucadu.co.uk 22 | copyright: (c) 2016--2020 Michael Walker 23 | category: Concurrency 24 | build-type: Simple 25 | extra-source-files: README.markdown CHANGELOG.rst 26 | cabal-version: >=1.10 27 | 28 | source-repository head 29 | type: git 30 | location: https://github.com/barrucadu/dejafu.git 31 | 32 | source-repository this 33 | type: git 34 | location: https://github.com/barrucadu/dejafu.git 35 | tag: concurrency-1.11.0.3 36 | 37 | library 38 | exposed-modules: Control.Monad.Conc.Class 39 | , Control.Monad.STM.Class 40 | 41 | , Control.Concurrent.Classy 42 | , Control.Concurrent.Classy.Async 43 | , Control.Concurrent.Classy.Chan 44 | , Control.Concurrent.Classy.BoundedChan 45 | , Control.Concurrent.Classy.CRef 46 | , Control.Concurrent.Classy.IORef 47 | , Control.Concurrent.Classy.MVar 48 | , Control.Concurrent.Classy.QSem 49 | , Control.Concurrent.Classy.QSemN 50 | , Control.Concurrent.Classy.Lock 51 | , Control.Concurrent.Classy.RWLock 52 | , Control.Concurrent.Classy.STM 53 | , Control.Concurrent.Classy.STM.TVar 54 | , Control.Concurrent.Classy.STM.TMVar 55 | , Control.Concurrent.Classy.STM.TChan 56 | , Control.Concurrent.Classy.STM.TQueue 57 | , Control.Concurrent.Classy.STM.TBQueue 58 | , Control.Concurrent.Classy.STM.TArray 59 | , Control.Concurrent.Classy.STM.TSem 60 | 61 | -- other-modules: 62 | -- other-extensions: 63 | build-depends: base >=4.9 && <5 64 | , array >=0.5.1 && <0.6 65 | , atomic-primops >=0.8 && <0.9 66 | , exceptions >=0.7 && <0.11 67 | , monad-control >=1.0 && <1.1 68 | , mtl >=2.2 && <2.4 69 | , stm >=2.4 && <2.6 70 | , transformers >=0.5 && <0.7 71 | -- hs-source-dirs: 72 | default-language: Haskell2010 73 | ghc-options: -Wall 74 | -------------------------------------------------------------------------------- /dejafu-tests/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Michael Walker 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /dejafu-tests/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /dejafu-tests/dejafu-tests.cabal: -------------------------------------------------------------------------------- 1 | -- Initial dejafu-tests.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: dejafu-tests 5 | version: 0.4.0.0 6 | synopsis: The test suite for dejafu 7 | -- description: 8 | homepage: https://github.com/barrucadu/dejafu 9 | license: MIT 10 | license-file: LICENSE 11 | author: Michael Walker 12 | maintainer: mike@barrucadu.co.uk 13 | -- copyright: 14 | -- category: 15 | build-type: Simple 16 | -- extra-source-files: 17 | cabal-version: >=1.10 18 | 19 | library 20 | exposed-modules: Unit 21 | , Unit.Predicates 22 | , Unit.Properties 23 | 24 | , Integration 25 | , Integration.Async 26 | , Integration.Litmus 27 | , Integration.MonadDejaFu 28 | , Integration.MultiThreaded 29 | , Integration.Names 30 | , Integration.Refinement 31 | , Integration.Regressions 32 | , Integration.SCT 33 | , Integration.SingleThreaded 34 | 35 | , Examples 36 | , Examples.AutoUpdate 37 | , Examples.ClassLaws 38 | , Examples.Logger 39 | , Examples.ParMonad 40 | , Examples.ParMonad.Direct 41 | , Examples.ParMonad.DirectInternal 42 | , Examples.Philosophers 43 | , Examples.SearchParty 44 | , Examples.SearchParty.Impredicative 45 | 46 | , Common 47 | , QSemN 48 | 49 | build-depends: base 50 | , abstract-deque 51 | , concurrency 52 | , containers 53 | , contravariant 54 | , deepseq 55 | , dejafu 56 | , exceptions 57 | , hedgehog 58 | , mtl 59 | , mwc-random 60 | , random 61 | , tasty 62 | , tasty-expected-failure 63 | , tasty-dejafu 64 | , tasty-hedgehog 65 | , tasty-hunit 66 | , vector 67 | hs-source-dirs: lib 68 | default-language: Haskell2010 69 | ghc-options: -Wall 70 | 71 | executable dejafu-tests 72 | main-is: MainTest.hs 73 | other-modules: Util 74 | build-depends: base 75 | , dejafu-tests 76 | , tasty 77 | hs-source-dirs: exe 78 | default-language: Haskell2010 79 | ghc-options: -Wall -threaded -rtsopts 80 | 81 | executable dejafu-bench 82 | main-is: MainBench.hs 83 | other-modules: Util 84 | build-depends: base 85 | , criterion 86 | , dejafu-tests 87 | , tasty 88 | hs-source-dirs: exe 89 | default-language: Haskell2010 90 | ghc-options: -Wall -threaded -rtsopts 91 | -------------------------------------------------------------------------------- /dejafu-tests/exe/MainBench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Main where 4 | 5 | import qualified Criterion.Main as C 6 | import Data.Monoid (mempty) 7 | import qualified Test.Tasty.Options as T 8 | import qualified Test.Tasty.Providers as T 9 | import qualified Test.Tasty.Runners as T 10 | 11 | import Util 12 | 13 | main :: IO () 14 | main = C.defaultMain (T.foldTestTree mkBench mempty tests) 15 | 16 | -- | Turn a test tree into a list of benchmarks. 17 | mkBench :: T.TreeFold [C.Benchmark] 18 | #if MIN_VERSION_tasty(1,5,0) 19 | mkBench = T.trivialFold 20 | { T.foldSingle = \opts lbl t -> [C.bench lbl (benchTest opts t)] 21 | , T.foldGroup = \_ lbl bs -> map (C.bgroup lbl) bs 22 | } 23 | #elif MIN_VERSION_tasty(1,4,0) 24 | mkBench = T.trivialFold 25 | { T.foldSingle = \opts lbl t -> [C.bench lbl (benchTest opts t)] 26 | , T.foldGroup = \_ lbl bs -> [C.bgroup lbl bs] 27 | } 28 | #else 29 | mkBench = T.trivialFold 30 | { T.foldSingle = \opts lbl t -> [C.bench lbl (benchTest opts t)] 31 | , T.foldGroup = \lbl bs -> [C.bgroup lbl bs] 32 | } 33 | #endif 34 | 35 | -- | Turn a test into a benchmark. 36 | benchTest :: T.IsTest t => T.OptionSet -> t -> C.Benchmarkable 37 | benchTest opts t = C.nfIO $ do 38 | res <- T.run opts t (\_ -> pure ()) 39 | pure (show (T.resultOutcome res), T.resultTime res) 40 | -------------------------------------------------------------------------------- /dejafu-tests/exe/MainTest.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Tasty (defaultMainWithIngredients) 4 | 5 | import Util 6 | 7 | main :: IO () 8 | main = defaultMainWithIngredients ingredients tests 9 | -------------------------------------------------------------------------------- /dejafu-tests/exe/Util.hs: -------------------------------------------------------------------------------- 1 | module Util (ingredients, tests) where 2 | 3 | import qualified Test.Tasty as T 4 | import qualified Test.Tasty.Options as T 5 | import qualified Test.Tasty.Runners as T 6 | 7 | import qualified Examples as E 8 | import qualified Integration as I 9 | import qualified Unit as U 10 | 11 | ingredients :: [T.Ingredient] 12 | ingredients = T.includingOptions options : T.defaultIngredients 13 | 14 | tests :: T.TestTree 15 | tests = T.testGroup "Tests" 16 | [ T.testGroup "Unit" U.tests 17 | , T.testGroup "Integration" I.tests 18 | , T.testGroup "Examples" E.tests 19 | ] 20 | 21 | options :: [T.OptionDescription] 22 | options = U.options ++ I.options ++ E.options 23 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Examples.hs: -------------------------------------------------------------------------------- 1 | module Examples where 2 | 3 | import Data.Maybe (fromJust) 4 | import Data.Proxy (Proxy(..)) 5 | import Test.Tasty (askOption, localOption) 6 | import Test.Tasty.Hedgehog (HedgehogDiscardLimit(..), 7 | HedgehogShrinkLimit(..), 8 | HedgehogShrinkRetries(..), 9 | HedgehogTestLimit) 10 | import Test.Tasty.Options (IsOption(..), OptionDescription(..)) 11 | 12 | import qualified Examples.AutoUpdate as A 13 | import qualified Examples.ClassLaws as C 14 | import qualified Examples.Logger as L 15 | import qualified Examples.ParMonad as PM 16 | import qualified Examples.Philosophers as P 17 | import qualified Examples.SearchParty as S 18 | 19 | import Common 20 | 21 | -- | Run all the example tests. 22 | tests :: [TestTree] 23 | tests = map applyHedgehogOptions 24 | [ testGroup "AutoUpdate" A.tests 25 | , testGroup "ClassLaws" C.tests 26 | , testGroup "Logger" L.tests 27 | , testGroup "ParMonad" PM.tests 28 | , testGroup "Philosophers" P.tests 29 | , testGroup "SearchParty" S.tests 30 | ] 31 | 32 | -- | Tasty options 33 | options :: [OptionDescription] 34 | options = 35 | [ Option (Proxy :: Proxy ExampleHedgehogTestLimit) 36 | , Option (Proxy :: Proxy ExampleHedgehogDiscardLimit) 37 | , Option (Proxy :: Proxy ExampleHedgehogShrinkLimit) 38 | , Option (Proxy :: Proxy ExampleHedgehogShrinkRetries) 39 | ] 40 | 41 | 42 | ------------------------------------------------------------------------------- 43 | -- Hedgehog options 44 | 45 | -- | The number of successful test cases required before Hedgehog will pass a test 46 | newtype ExampleHedgehogTestLimit = ExampleHedgehogTestLimit HedgehogTestLimit 47 | deriving (Eq, Ord, Show) 48 | 49 | instance IsOption ExampleHedgehogTestLimit where 50 | defaultValue = ExampleHedgehogTestLimit . fromJust $ parseValue "25" 51 | parseValue = fmap ExampleHedgehogTestLimit . parseValue 52 | optionName = pure "example-hedgehog-tests" 53 | optionHelp = pure "hedgehog-tests for the example tests" 54 | 55 | -- | The number of discarded cases allowed before Hedgehog will fail a test 56 | newtype ExampleHedgehogDiscardLimit = ExampleHedgehogDiscardLimit HedgehogDiscardLimit 57 | deriving (Eq, Ord, Show) 58 | 59 | instance IsOption ExampleHedgehogDiscardLimit where 60 | defaultValue = ExampleHedgehogDiscardLimit defaultValue 61 | parseValue = fmap ExampleHedgehogDiscardLimit . parseValue 62 | optionName = pure "example-hedgehog-discards" 63 | optionHelp = pure "hedgehog-discards for the example tests" 64 | 65 | -- | The number of shrinks allowed before Hedgehog will fail a test 66 | newtype ExampleHedgehogShrinkLimit = ExampleHedgehogShrinkLimit HedgehogShrinkLimit 67 | deriving (Eq, Ord, Show) 68 | 69 | instance IsOption ExampleHedgehogShrinkLimit where 70 | defaultValue = ExampleHedgehogShrinkLimit defaultValue 71 | parseValue = fmap ExampleHedgehogShrinkLimit . parseValue 72 | optionName = pure "example-hedgehog-shrinks" 73 | optionHelp = pure "hedgehog-shrinks for the example tests" 74 | 75 | -- | The number of times to re-run a test during shrinking 76 | newtype ExampleHedgehogShrinkRetries = ExampleHedgehogShrinkRetries HedgehogShrinkRetries 77 | deriving (Eq, Ord, Show) 78 | 79 | instance IsOption ExampleHedgehogShrinkRetries where 80 | defaultValue = ExampleHedgehogShrinkRetries defaultValue 81 | parseValue = fmap ExampleHedgehogShrinkRetries . parseValue 82 | optionName = pure "example-hedgehog-retries" 83 | optionHelp = pure "hedgehog-retries for the example tests" 84 | 85 | -- | Apply the Hedgehog options. 86 | applyHedgehogOptions :: TestTree -> TestTree 87 | applyHedgehogOptions tt0 = 88 | askOption $ \(ExampleHedgehogTestLimit tl) -> 89 | askOption $ \(ExampleHedgehogDiscardLimit dl) -> 90 | askOption $ \(ExampleHedgehogShrinkLimit sl) -> 91 | askOption $ \(ExampleHedgehogShrinkRetries sr) -> 92 | localOption tl $ 93 | localOption dl $ 94 | localOption sl $ 95 | localOption sr tt0 96 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Examples/AutoUpdate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {- 4 | The auto-update package: 5 | https://hackage.haskell.org/package/auto-update 6 | 7 | Users found a possible deadlock and livelock: 8 | https://www.reddit.com/r/haskell/comments/2i5d7m/updating_autoupdate/ 9 | 10 | This is the code from Control.AutoUpdate modified to use the 11 | @MonadConc@ abstraction, with tests added to verify that the issues 12 | identified are caught.. The original code is available under the MIT 13 | license, which is reproduced below. 14 | 15 | - - - - - 16 | 17 | Copyright (c) 2014 Michael Snoyman 18 | 19 | Permission is hereby granted, free of charge, to any person obtaining 20 | a copy of this software and associated documentation files (the 21 | "Software"), to deal in the Software without restriction, including 22 | without limitation the rights to use, copy, modify, merge, publish, 23 | distribute, sublicense, and/or sell copies of the Software, and to 24 | permit persons to whom the Software is furnished to do so, subject to 25 | the following conditions: 26 | 27 | The above copyright notice and this permission notice shall be included 28 | in all copies or substantial portions of the Software. 29 | 30 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 31 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 32 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 33 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 34 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 35 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 36 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 37 | -} 38 | 39 | module Examples.AutoUpdate where 40 | 41 | import Control.Exception (SomeException) 42 | import Control.Monad 43 | import Control.Monad.Conc.Class 44 | 45 | -- test imports 46 | import Common 47 | import Test.DejaFu (Condition(..), gives) 48 | 49 | tests :: [TestTree] 50 | tests = toTestList 51 | [ T "deadlocks" deadlocks (gives [Left Deadlock, Right ()]) 52 | , T "nondeterministic" nondeterministic (gives [Left Deadlock, Right 0, Right 1]) 53 | ] 54 | 55 | -- This exhibits a deadlock with no preemptions. 56 | deadlocks :: MonadConc m => m () 57 | deadlocks = join (mkAutoUpdate defaultUpdateSettings) 58 | 59 | -- This exhibits nondeterminism with three preemptions. However, as 60 | -- the program explicitly yields, the bounds don't need changing. 61 | nondeterministic :: forall m. MonadConc m => m Int 62 | nondeterministic = do 63 | var <- newIORef 0 64 | let settings = (defaultUpdateSettings :: UpdateSettings m ()) 65 | { updateAction = atomicModifyIORef var (\x -> (x+1, x)) } 66 | auto <- mkAutoUpdate settings 67 | void auto 68 | auto 69 | 70 | ------------------------------------------------------------------------------- 71 | 72 | data UpdateSettings m a = UpdateSettings 73 | { updateFreq :: Int 74 | , updateSpawnThreshold :: Int 75 | , updateAction :: m a 76 | } 77 | 78 | defaultUpdateSettings :: MonadConc m => UpdateSettings m () 79 | defaultUpdateSettings = UpdateSettings 80 | { updateFreq = 1000000 81 | , updateSpawnThreshold = 3 82 | , updateAction = pure () 83 | } 84 | 85 | mkAutoUpdate :: MonadConc m => UpdateSettings m a -> m (m a) 86 | mkAutoUpdate us = do 87 | currRef <- newIORef Nothing 88 | needsRunning <- newEmptyMVar 89 | lastValue <- newEmptyMVar 90 | 91 | void $ fork $ forever $ do 92 | takeMVar needsRunning 93 | 94 | a <- catchSome $ updateAction us 95 | 96 | writeIORef currRef $ Just a 97 | void $ tryTakeMVar lastValue 98 | putMVar lastValue a 99 | 100 | threadDelay $ updateFreq us 101 | 102 | writeIORef currRef Nothing 103 | void $ takeMVar lastValue 104 | 105 | pure $ do 106 | mval <- readIORef currRef 107 | case mval of 108 | Just val -> pure val 109 | Nothing -> do 110 | void $ tryPutMVar needsRunning () 111 | readMVar lastValue 112 | 113 | catchSome :: MonadConc m => m a -> m a 114 | catchSome act = catch act $ 115 | \e -> throw (e :: SomeException) 116 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Examples/Logger.hs: -------------------------------------------------------------------------------- 1 | -- Modification (to introduce bug) of an example in Parallel and 2 | -- Concurrent Programming in Haskell, chapter 7. 3 | module Examples.Logger where 4 | 5 | import Control.Concurrent.Classy hiding (check) 6 | import Data.Functor (void) 7 | import Test.DejaFu hiding (MemType(..), check) 8 | 9 | import Common 10 | 11 | tests :: [TestTree] 12 | tests = toTestList 13 | [ T "allowed" raceyLogger validResult 14 | , T "correct occurs" raceyLogger isGood 15 | , T "bug exists" raceyLogger isBad 16 | ] 17 | 18 | -------------------------------------------------------------------------------- 19 | 20 | data Logger m = Logger (MVar m LogCommand) (MVar m [String]) 21 | 22 | data LogCommand = Message String | Stop 23 | 24 | -- | Create a new logger with no internal log. 25 | initLogger :: MonadConc m => m (Logger m) 26 | initLogger = do 27 | cmd <- newEmptyMVar 28 | logg <- newMVar [] 29 | let l = Logger cmd logg 30 | void . fork $ logger l 31 | pure l 32 | 33 | logger :: MonadConc m => Logger m -> m () 34 | logger (Logger cmd logg) = loop where 35 | loop = do 36 | command <- takeMVar cmd 37 | case command of 38 | Message str -> do 39 | strs <- takeMVar logg 40 | putMVar logg (strs ++ [str]) 41 | loop 42 | Stop -> pure () 43 | 44 | -- | Add a string to the log. 45 | logMessage :: MonadConc m => Logger m -> String -> m () 46 | logMessage (Logger cmd _) str = putMVar cmd $ Message str 47 | 48 | -- | Stop the logger and return the contents of the log. 49 | logStop :: MonadConc m => Logger m -> m [String] 50 | logStop (Logger cmd logg) = do 51 | putMVar cmd Stop 52 | readMVar logg 53 | 54 | -- | Race condition! Can you see where? 55 | raceyLogger :: MonadConc m => m [String] 56 | raceyLogger = do 57 | l <- initLogger 58 | logMessage l "Hello" 59 | logMessage l "World" 60 | logMessage l "Foo" 61 | logMessage l "Bar" 62 | logMessage l "Baz" 63 | logStop l 64 | 65 | -- | Test that the result is always in the set of allowed values, and 66 | -- doesn't deadlock. 67 | validResult :: Predicate [String] 68 | validResult = alwaysTrue check where 69 | check (Right strs) = strs `elem` [ ["Hello", "World", "Foo", "Bar", "Baz"] 70 | , ["Hello", "World", "Foo", "Bar"] 71 | ] 72 | check _ = False 73 | 74 | -- | Test that the "proper" result occurs at least once. 75 | isGood :: Predicate [String] 76 | isGood = somewhereTrue check where 77 | check (Right a) = length a == 5 78 | check _ = False 79 | 80 | -- | Test that the erroneous result occurs at least once. 81 | isBad :: Predicate [String] 82 | isBad = somewhereTrue check where 83 | check (Right a) = length a == 4 84 | check _ = False 85 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Examples/ParMonad.hs: -------------------------------------------------------------------------------- 1 | module Examples.ParMonad where 2 | 3 | import Control.Monad.Conc.Class (MonadConc) 4 | import Control.Monad.IO.Class (MonadIO) 5 | import System.Random (mkStdGen) 6 | import Test.DejaFu (deadlocksSometimes) 7 | 8 | import qualified Examples.ParMonad.Direct as Par 9 | 10 | import Common 11 | 12 | tests :: [TestTree] 13 | tests = toTestList 14 | [ TEST' False "testing exposes a deadlock" parFilter deadlocksSometimes [("randomly", toSettings (randomly (mkStdGen 0) 150)), ("systematically", defaultSettings)] True 15 | ] 16 | 17 | parFilter :: (MonadConc m, MonadIO m) => m Bool 18 | parFilter = do 19 | let xs = [0..1] :: [Int] 20 | s <- Par.runParIO $ parfilter even xs 21 | pure (s == filter even xs) 22 | where 23 | parfilter _ [] = pure [] 24 | parfilter f [x] = pure [x | f x] 25 | parfilter f xs = do 26 | let (as, bs) = halve xs 27 | v1 <- Par.spawn $ parfilter f as 28 | v2 <- Par.spawn $ parfilter f bs 29 | left <- Par.get v1 30 | right <- Par.get v2 31 | pure (left ++ right) 32 | 33 | halve xs = splitAt (length xs `div` 2) xs 34 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Examples/ParMonad/DirectInternal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE PackageImports #-} 3 | 4 | {- 5 | The monad-par package: 6 | https://hackage.haskell.org/package/monad-par 7 | 8 | This is the code from Control.Monad.Par.Scheds.DirectInternal, with 9 | CPP expanded in its default configuration, modified to use MonadConc. 10 | 11 | - - - - - 12 | 13 | Copyright Simon Marlow, Ryan Newton 2011 14 | 15 | All rights reserved. 16 | 17 | Redistribution and use in source and binary forms, with or without 18 | modification, are permitted provided that the following conditions are met: 19 | 20 | * Redistributions of source code must retain the above copyright 21 | notice, this list of conditions and the following disclaimer. 22 | 23 | * Redistributions in binary form must reproduce the above 24 | copyright notice, this list of conditions and the following 25 | disclaimer in the documentation and/or other materials provided 26 | with the distribution. 27 | 28 | * Neither the name of the authors nor the names of other 29 | contributors may be used to endorse or promote products derived 30 | from this software without specific prior written permission. 31 | 32 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 33 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 34 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 35 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 36 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 37 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 38 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 39 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 40 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 41 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 42 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 43 | 44 | -} 45 | 46 | -- | Type definiton and some helpers. This is used mainly by 47 | -- Direct.hs but can also be used by other modules that want access to 48 | -- the internals of the scheduler (i.e. the private `Par` type constructor). 49 | 50 | module Examples.ParMonad.DirectInternal where 51 | 52 | import "mtl" Control.Monad.Cont as C 53 | import qualified "mtl" Control.Monad.Reader as RD 54 | 55 | import qualified System.Random.MWC as Random 56 | 57 | import Control.Concurrent.Classy 58 | import Data.Concurrent.Deque.Class (WSDeque) 59 | import qualified Data.Set as S 60 | import Data.Word (Word64) 61 | 62 | 63 | -- Our monad stack looks like this: 64 | -- --------- 65 | -- ContT 66 | -- ReaderT 67 | -- IO 68 | -- --------- 69 | -- The ReaderT monad is there for retrieving the scheduler given the 70 | -- fact that the API calls do not get it as an argument. 71 | -- 72 | -- Note that the result type for continuations is unit. Forked 73 | -- computations return nothing. 74 | -- 75 | newtype Par m a = Par { unPar :: C.ContT () (ROnly m) a } 76 | deriving (Functor, Applicative, Monad, MonadCont, RD.MonadReader (Sched m)) 77 | type ROnly m = RD.ReaderT (Sched m) m 78 | 79 | type SessionID = Word64 80 | 81 | -- An ID along with a flag to signal completion: 82 | data Session m = Session SessionID (HotVar m Bool) 83 | 84 | data Sched m = Sched 85 | { 86 | ---- Per worker ---- 87 | no :: {-# UNPACK #-} !Int, 88 | workpool :: WSDeque (Par m ()), 89 | rng :: HotVar m Random.GenIO, -- Random number gen for work stealing. 90 | isMain :: Bool, -- Are we the main/master thread? 91 | 92 | -- The stack of nested sessions that THIS worker is participating in. 93 | -- When a session finishes, the worker can return to its Haskell 94 | -- calling context (it's "real" continuation). 95 | sessions :: HotVar m [Session m], 96 | -- (1) This is always non-empty, containing at least the root 97 | -- session corresponding to the anonymous system workers. 98 | -- (2) The original invocation of runPar also counts as a session 99 | -- and pushes a second 100 | -- (3) Nested runPar invocations may push further sessions onto the stack. 101 | 102 | ---- Global data: ---- 103 | idle :: HotVar m [MVar m Bool], -- waiting idle workers 104 | scheds :: [Sched m], -- A global list of schedulers. 105 | 106 | -- Any thread that enters runPar (original or nested) registers 107 | -- itself in this global list. When the list becomes null, 108 | -- worker threads may shut down or at least go idle. 109 | activeSessions :: HotVar m (S.Set SessionID), 110 | 111 | -- A counter to support unique session IDs: 112 | sessionCounter :: HotVar m SessionID 113 | } 114 | 115 | 116 | -------------------------------------------------------------------------------- 117 | -- Helpers #1: Atomic Variables 118 | -------------------------------------------------------------------------------- 119 | -- TEMP: Experimental 120 | 121 | newHotVar :: MonadConc m => a -> m (HotVar m a) 122 | modifyHotVar :: MonadConc m => HotVar m a -> (a -> (a,b)) -> m b 123 | modifyHotVar_ :: MonadConc m => HotVar m a -> (a -> a) -> m () 124 | writeHotVar :: MonadConc m => HotVar m a -> a -> m () 125 | readHotVar :: MonadConc m => HotVar m a -> m a 126 | readHotVarRaw :: MonadConc m => HotVar m a -> m a 127 | writeHotVarRaw :: MonadConc m => HotVar m a -> a -> m () 128 | 129 | {-# INLINE newHotVar #-} 130 | {-# INLINE modifyHotVar #-} 131 | {-# INLINE modifyHotVar_ #-} 132 | {-# INLINE readHotVar #-} 133 | {-# INLINE writeHotVar #-} 134 | 135 | type HotVar m a = IORef m a 136 | newHotVar = newIORef 137 | modifyHotVar = atomicModifyIORef 138 | modifyHotVar_ v fn = atomicModifyIORef v (\a -> (fn a, ())) 139 | readHotVar = readIORef 140 | writeHotVar = writeIORef 141 | 142 | readHotVarRaw = readHotVar 143 | writeHotVarRaw = writeHotVar 144 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Examples/Philosophers.hs: -------------------------------------------------------------------------------- 1 | -- An implementation of the Dining Philosophers. This is interesting 2 | -- as it show-cases testing a non-terminating program. 3 | module Examples.Philosophers where 4 | 5 | import Control.Monad (forever, replicateM) 6 | import Control.Monad.Conc.Class 7 | import System.Random (mkStdGen) 8 | import Test.DejaFu 9 | 10 | import Common 11 | 12 | tests :: [TestTree] 13 | tests = 14 | [ testDejafuWithSettings settings "deadlocks" deadlocksAlways test 15 | , let settings' = set llengthBound (Just 30) $ 16 | fromWayAndMemType (randomly (mkStdGen 0) 150) defaultMemType 17 | in testDejafuWithSettings settings' "deadlocks (with random scheduling)" deadlocksAlways test 18 | , let settings' = set lshowAborts True settings 19 | in testDejafuWithSettings settings' "loops (with aborts present)" abortsSometimes test 20 | , expectFail $ testDejafuWithSettings settings "loops (with aborts hidden)" abortsSometimes test 21 | ] 22 | where 23 | test = philosophers 3 24 | 25 | -- | Shorter execution length bound 26 | settings :: Settings IO a 27 | settings = set llengthBound (Just 30) defaultSettings 28 | 29 | -------------------------------------------------------------------------------- 30 | 31 | -- | Run the Dining Philosophers. Result is irrelevant, we just care 32 | -- about deadlocks. 33 | philosophers :: MonadConc m => Int -> m () 34 | philosophers n = do 35 | forks <- replicateM n newEmptyMVar 36 | let phils = zipWith (\i p -> p i forks) [0..] (replicate n philosopher) 37 | cvars <- mapM spawn phils 38 | mapM_ takeMVar cvars 39 | 40 | where 41 | philosopher ident forks = forever $ do 42 | let leftId = ident 43 | let rightId = (ident + 1) `mod` length forks 44 | putMVar (forks !! leftId) () 45 | putMVar (forks !! rightId) () 46 | -- In the traditional approach, we'd wait for a random time 47 | -- here, but we want the only source of (important) 48 | -- nondeterminism to come from the scheduler, which it does, as 49 | -- pre-emption is effectively a delay. 50 | takeMVar $ forks !! leftId 51 | takeMVar $ forks !! rightId 52 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Examples/SearchParty/Impredicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ImpredicativeTypes #-} 2 | 3 | -- | This is a separate module because of the need for 4 | -- ImpredicativeTypes, which breaks things elsewhere in the main 5 | -- SearchParty module. 6 | module Examples.SearchParty.Impredicative where 7 | 8 | import Control.Concurrent.Classy.STM.TMVar (TMVar, newTMVar) 9 | import Control.Monad.Conc.Class 10 | import Unsafe.Coerce (unsafeCoerce) 11 | 12 | -- | A unit of work in a monad @m@ which will produce a final result 13 | -- of type @a@. 14 | newtype WorkItem m a = WorkItem { unWrap :: forall x. WorkItem' m x a } 15 | 16 | instance Functor (WorkItem m) where 17 | fmap f (WorkItem w) = workItem (_result w) (f . _mapped w) (_killme w) 18 | 19 | -- | A unit of work in a monad @m@ producing a result of type @x@, 20 | -- which will then be transformed into a value of type @a@. 21 | data WorkItem' m x a = WorkItem' 22 | { _result :: TMVar (STM m) (Maybe x) 23 | -- ^ The future result of the computation. 24 | , _mapped :: x -> a 25 | -- ^ Some post-processing to do. 26 | , _killme :: m () 27 | -- ^ Fail the computation, if it's still running. 28 | } 29 | 30 | -- | The possible states that a work item may be in. 31 | data WorkState = StillComputing | HasFailed | HasSucceeded 32 | deriving (Eq) 33 | 34 | -- | Construct a 'WorkItem'. 35 | workItem :: TMVar (STM m) (Maybe x) -> (x -> a) -> m () -> WorkItem m a 36 | workItem res mapp kill = wrap $ WorkItem' res mapp kill where 37 | -- Really not nice, but I have had difficulty getting GHC to unify 38 | -- @WorkItem' m x a@ with @forall x. WorkItem' m x a@ 39 | -- 40 | -- This needs ImpredicativeTypes in GHC 7.8. 41 | wrap :: WorkItem' m x a -> WorkItem m a 42 | wrap = WorkItem . unsafeCoerce 43 | 44 | -- | Construct a 'WorkItem' containing a result. 45 | workItem' :: MonadConc m => Maybe a -> m (WorkItem m a) 46 | workItem' a = (\v -> workItem v id $ pure ()) <$> atomically (newTMVar a) 47 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Integration.hs: -------------------------------------------------------------------------------- 1 | module Integration where 2 | 3 | import Test.Tasty.Options (OptionDescription) 4 | 5 | import qualified Integration.Async as A 6 | import qualified Integration.Litmus as L 7 | import qualified Integration.MonadDejaFu as MD 8 | import qualified Integration.MultiThreaded as M 9 | import qualified Integration.Names as N 10 | import qualified Integration.Refinement as R 11 | import qualified Integration.Regressions as G 12 | import qualified Integration.SCT as SC 13 | import qualified Integration.SingleThreaded as S 14 | 15 | import Common 16 | 17 | -- | Run all the integration tests. 18 | tests :: [TestTree] 19 | tests = 20 | [ testGroup "Async" A.tests 21 | , testGroup "Litmus" L.tests 22 | , testGroup "MultiThreaded" M.tests 23 | , testGroup "MonadDejaFu" MD.tests 24 | , testGroup "Names" N.tests 25 | , testGroup "Refinement" R.tests 26 | , testGroup "Regressions" G.tests 27 | , testGroup "SingleThreaded" S.tests 28 | , testGroup "SCT" SC.tests 29 | ] 30 | 31 | -- | Tasty options 32 | options :: [OptionDescription] 33 | options = [] 34 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Integration/Async.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Integration.Async where 5 | 6 | import Control.Concurrent.Classy.Async 7 | import Control.Concurrent.Classy.IORef 8 | import Control.Exception (AsyncException(..), Exception, 9 | SomeException, fromException) 10 | import Control.Monad (when) 11 | import Control.Monad.Catch (try) 12 | import Control.Monad.Conc.Class hiding (threadDelay) 13 | import qualified Control.Monad.Conc.Class as C 14 | import Data.List (sort) 15 | import Data.Maybe (isJust, isNothing) 16 | import Data.Typeable (Typeable) 17 | import Test.DejaFu (alwaysTrue) 18 | 19 | import Common 20 | 21 | {- 22 | Tests from https://github.com/simonmar/async/blob/master/test/test-async.hs 23 | 24 | The following are omitted: 25 | 26 | * withasync_waitCatch_blocked: because dejafu does not do 27 | BlockedIndefinitelyOnMVar 28 | 29 | * concurrently+success, concurrently+failure, race+success, 30 | race+failure, cancel, withAsync: because they rely on timing 31 | -} 32 | 33 | tests :: [TestTree] 34 | tests = 35 | [ testGroup "async" 36 | [ testCase "async_wait" async_wait 37 | , testCase "async_waitCatch" async_waitCatch 38 | , testCase "async_exwait" async_exwait 39 | , testCase "async_exwaitCatch" async_exwaitCatch 40 | , testCase "async_cancel" async_cancel 41 | , testCase "async_poll" async_poll 42 | , testCase "async_poll2" async_poll2 43 | ] 44 | 45 | , testGroup "withAsync" 46 | [ testCase "withasync_waitCatch" withasync_waitCatch 47 | , testCase "withasync_wait2" withasync_wait2 48 | ] 49 | 50 | , testGroup "concurrently" 51 | [ testCase "concurrently_" case_concurrently_ 52 | , testCase "replicateConcurrently_" case_replicateConcurrently 53 | , testCase "replicateConcurrently" case_replicateConcurrently_ 54 | ] 55 | ] 56 | 57 | value :: Int 58 | value = 42 59 | 60 | data TestException = TestException deriving (Eq,Show,Typeable) 61 | instance Exception TestException 62 | 63 | async_waitCatch :: MonadConc m => m () 64 | async_waitCatch = do 65 | a <- async (pure value) 66 | r <- waitCatch a 67 | case r of 68 | Left _ -> assertFailure "" 69 | Right e -> e @?= value 70 | 71 | async_wait :: MonadConc m => m () 72 | async_wait = do 73 | a <- async (pure value) 74 | r <- wait a 75 | assertEqual "async_wait" r value 76 | 77 | async_exwaitCatch :: MonadConc m => m () 78 | async_exwaitCatch = do 79 | a <- async (throwIO TestException) 80 | r <- waitCatch a 81 | case r of 82 | Left e -> fromException e @?= Just TestException 83 | Right _ -> assertFailure "" 84 | 85 | async_exwait :: MonadConc m => m () 86 | async_exwait = do 87 | a <- async (throwIO TestException) 88 | (wait a >> assertFailure "") `catch` \e -> e @?= TestException 89 | 90 | withasync_waitCatch :: MonadConc m => m () 91 | withasync_waitCatch = 92 | withAsync (pure value) $ \a -> do 93 | r <- waitCatch a 94 | case r of 95 | Left _ -> assertFailure "" 96 | Right e -> e @?= value 97 | 98 | withasync_wait2 :: MonadConc m => m () 99 | withasync_wait2 = do 100 | a <- withAsync (threadDelay 1000000) pure 101 | r <- waitCatch a 102 | case r of 103 | Left e -> fromException e @?= Just ThreadKilled 104 | Right _ -> assertFailure "" 105 | 106 | async_cancel :: MonadConc m => m () 107 | async_cancel = do 108 | a <- async (pure value) 109 | cancelWith a TestException 110 | r <- waitCatch a 111 | case r of 112 | Left e -> fromException e @?= Just TestException 113 | Right r_ -> r_ @?= value 114 | 115 | async_poll :: MonadConc m => m () 116 | async_poll = do 117 | a <- async (threadDelay 1000000) 118 | r1 <- poll a 119 | when (isJust r1) $ assertFailure "" 120 | r2 <- poll a -- poll twice, just to check we don't deadlock 121 | when (isJust r2) $ assertFailure "" 122 | 123 | async_poll2 :: MonadConc m => m () 124 | async_poll2 = do 125 | a <- async (pure value) 126 | _ <- wait a 127 | r1 <- poll a 128 | when (isNothing r1) $ assertFailure "" 129 | r2 <- poll a -- poll twice, just to check we don't deadlock 130 | when (isNothing r2) $ assertFailure "" 131 | 132 | case_concurrently_ :: MonadConc m => m () 133 | case_concurrently_ = do 134 | ref <- newIORefInt 0 135 | () <- concurrently_ 136 | (atomicModifyIORef ref (\x -> (x + 1, True))) 137 | (atomicModifyIORef ref (\x -> (x + 2, 'x'))) 138 | res <- readIORef ref 139 | res @?= 3 140 | 141 | case_replicateConcurrently :: MonadConc m => m () 142 | case_replicateConcurrently = do 143 | ref <- newIORefInt 0 144 | let action = atomicModifyIORef ref (\x -> (x + 1, x + 1)) 145 | resList <- replicateConcurrently 4 action 146 | resVal <- readIORef ref 147 | resVal @?= 4 148 | sort resList @?= [1..4] 149 | 150 | case_replicateConcurrently_ :: MonadConc m => m () 151 | case_replicateConcurrently_ = do 152 | ref <- newIORefInt 0 153 | let action = atomicModifyIORef ref (\x -> (x + 1, x + 1)) 154 | () <- replicateConcurrently_ 4 action 155 | resVal <- readIORef ref 156 | resVal @?= 4 157 | 158 | ------------------------------------------------------------------------------- 159 | 160 | newtype TestFailed = TestFailed String deriving (Eq,Show,Typeable) 161 | instance Exception TestFailed 162 | 163 | assertFailure :: MonadConc m => String -> m b 164 | assertFailure = throw . TestFailed 165 | 166 | throwIO :: (Exception e, MonadConc m) => e -> m a 167 | throwIO = throw 168 | 169 | -- the tests use 'threadDelay' with a big delay to represent a blocked thread 170 | threadDelay :: MonadConc m => Int -> m () 171 | threadDelay 0 = yield 172 | threadDelay n = C.threadDelay 1 >> threadDelay (n-1) 173 | 174 | (@?=) :: (Eq a, MonadConc m) => a -> a -> m () 175 | (@?=) = assertEqual "not equal" 176 | 177 | assertEqual :: (Eq a, MonadConc m) => String -> a -> a -> m () 178 | assertEqual err a1 a2 179 | | a1 == a2 = pure () 180 | | otherwise = assertFailure err 181 | 182 | testCase :: String -> ConcIO () -> [TestTree] 183 | testCase name c = djfu name (alwaysTrue p) (try c) where 184 | p (Right (Left (_::SomeException))) = False 185 | p (Right _) = True 186 | p (Left _) = False 187 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Integration/Litmus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Integration.Litmus where 4 | 5 | import Control.Monad (replicateM, void) 6 | import Data.List (nub, sort) 7 | import Test.DejaFu (gives') 8 | import Test.DejaFu.SCT (runSCT) 9 | import qualified Test.Tasty.Hedgehog as H 10 | 11 | import Control.Monad.Conc.Class 12 | 13 | import Common 14 | 15 | tests :: [TestTree] 16 | tests = 17 | [ let sq = [(a,b) | a <- [0..1], b <- [0..1], (a,b) /= (1,0)] 18 | tso = sq 19 | pso = [(a,b) | a <- [0..1], b <- [0..1]] 20 | in litmusTest "Loads are not reordered with other loads and stores are not reordered with other stores" intelWP21 sq tso pso 21 | 22 | , let out = [(a,b) | a <- [0..1], b <- [0..1], (a,b) /= (1,1)] 23 | in litmusTest "Stores are not reordered with older loads" intelWP22 out out out 24 | 25 | , let sq = [(a,b) | a <- [0..1], b <- [0..1], (a,b) /= (0,0)] 26 | rel = [(a,b) | a <- [0..1], b <- [0..1]] 27 | in litmusTest "Loads may be reordered with older stores to different locations" intelWP23 sq rel rel 28 | 29 | , let out = [(1,1)] 30 | in litmusTest "Loads are not reordered with older stores to the same location" intelWP24 out out out 31 | 32 | , let sq = [((1,0),(1,1)),((1,1),(1,0)),((1,1),(1,1))] 33 | rel = [((1,0),(1,0)),((1,0),(1,1)),((1,1),(1,0)),((1,1),(1,1))] 34 | in litmusTest "Intra-processor forwarding is allowed" intelWP25 sq rel rel 35 | 36 | , let out = [(0,0,0),(0,0,1),(1,0,0),(1,0,1)] 37 | in litmusTest "Stores are transitively visible" intelWP26 out out out 38 | 39 | , let out = [((0,0),(0,0)),((0,0),(0,1)),((0,0),(0,2)),((0,0),(1,1)),((0,0),(1,2)),((0,0),(2,1)),((0,0),(2,2)),((0,1),(0,0)),((0,1),(0,1)),((0,1),(0,2)),((0,1),(1,1)),((0,1),(1,2)),((0,1),(2,1)),((0,1),(2,2)),((0,2),(0,0)),((0,2),(0,1)),((0,2),(0,2)),((0,2),(1,1)),((0,2),(1,2)),((0,2),(2,1)),((0,2),(2,2)),((1,1),(0,0)),((1,1),(0,1)),((1,1),(0,2)),((1,1),(1,1)),((1,1),(1,2)),((1,1),(2,1)),((1,1),(2,2)),((1,2),(0,0)),((1,2),(0,1)),((1,2),(0,2)),((1,2),(1,1)),((1,2),(1,2)),((1,2),(2,2)),((2,1),(0,0)),((2,1),(0,1)),((2,1),(0,2)),((2,1),(1,1)),((2,1),(2,1)),((2,1),(2,2)),((2,2),(0,0)),((2,2),(0,1)),((2,2),(0,2)),((2,2),(1,1)),((2,2),(1,2)),((2,2),(2,1)),((2,2),(2,2))] 40 | in litmusTest "Total order on stores to the same location" intelWP27 out out out 41 | 42 | , let out = [((a,b),(c,d)) | a <- [0..1], b <- [0..1], c <- [0..1], d <- [0..1], ((a,b),(c,d)) /= ((1,0),(1,0))] 43 | in litmusTest "Independent Read Independent Write" intelWP28 out out out 44 | ] 45 | 46 | litmusTest :: (Eq a, Show a) => String -> ConcIO a -> [a] -> [a] -> [a] -> TestTree 47 | litmusTest name act sq tso pso = testGroup name 48 | [ testDejafuWithSettings (set lmemtype SequentialConsistency (toSettings defaultWay)) "SQ" (gives' sq) act 49 | , testDejafuWithSettings (set lmemtype TotalStoreOrder (toSettings defaultWay)) "TSO" (gives' tso) act 50 | , testDejafuWithSettings (set lmemtype PartialStoreOrder (toSettings defaultWay)) "PSO" (gives' pso) act 51 | , H.testProperty "dependency func." (prop_dep_fun False act) 52 | ] 53 | 54 | -- | Run a litmus test against the three different memory models, and 55 | -- real IO, and print the results. 56 | -- 57 | -- Make sure before doing this that you have more than 1 capability, 58 | -- or the @IO@ behaviour will be severely constrained! The @IO@ test 59 | -- is run 99,999 times, but is still not guaranteed to see all the 60 | -- possible results. This is why dejafu is good! 61 | compareTest :: forall a. (Ord a, Show a) => (forall m. MonadConc m => m a) -> IO () 62 | compareTest act = do 63 | void $ putStr "DejaFu-SQ: " >> results SequentialConsistency 64 | void $ putStr "DejaFu-TSO: " >> results TotalStoreOrder 65 | void $ putStr "DejaFu-PSO: " >> results PartialStoreOrder 66 | void $ putStr "IO: " >> ioResults >>= putStrLn 67 | 68 | where 69 | results memtype = show . nub . sort . map (\(Right a,_) -> a) <$> 70 | runSCT defaultWay memtype act 71 | 72 | ioResults = show . nub . sort <$> replicateM 99999 act 73 | 74 | ------------------------------------------------------------------------------- 75 | 76 | -- The following collection of litmus tests are all from 77 | -- 78 | 79 | -- | Loads are not reordered with other loads and stores are not 80 | -- reordered with other stores. 81 | intelWP21 :: MonadConc m => m (Int, Int) 82 | intelWP21 = snd <$> litmus2 83 | (\x y -> writeIORef x 1 >> writeIORef y 1) 84 | (\x y -> (,) <$> readIORef y <*> readIORef x) 85 | 86 | -- | Stores are not reordered with older loads. 87 | intelWP22 :: MonadConc m => m (Int, Int) 88 | intelWP22 = litmus2 89 | (\x y -> do r1 <- readIORef x; writeIORef y 1; pure r1) 90 | (\x y -> do r2 <- readIORef y; writeIORef x 1; pure r2) 91 | 92 | -- | Loads may be reordered with older stores to different locations. 93 | intelWP23 :: MonadConc m => m (Int, Int) 94 | intelWP23 = litmus2 95 | (\x y -> writeIORef x 1 >> readIORef y) 96 | (\x y -> writeIORef y 1 >> readIORef x) 97 | 98 | -- | Loads are not reordered with older stores to the same location. 99 | intelWP24 :: MonadConc m => m (Int, Int) 100 | intelWP24 = litmus2 101 | (\x _ -> writeIORef x 1 >> readIORef x) 102 | (\_ y -> writeIORef y 1 >> readIORef y) 103 | 104 | -- | Intra-processor forwarding is allowed 105 | intelWP25 :: MonadConc m => m ((Int, Int), (Int, Int)) 106 | intelWP25 = litmus2 107 | (\x y -> do writeIORef x 1; r1 <- readIORef x; r2 <- readIORef y; pure (r1, r2)) 108 | (\x y -> do writeIORef y 1; r3 <- readIORef y; r4 <- readIORef x; pure (r3, r4)) 109 | 110 | -- | Stores are transitively visible. 111 | intelWP26 :: MonadConc m => m (Int, Int, Int) 112 | intelWP26 = do 113 | x <- newIORef 0 114 | y <- newIORef 0 115 | j1 <- spawn (writeIORef x 1) 116 | j2 <- spawn (do r1 <- readIORef x; writeIORef x 1; pure r1) 117 | j3 <- spawn (do r2 <- readIORef y; r3 <- readIORef x; pure (r2,r3)) 118 | (\() r1 (r2,r3) -> (r1,r2,r3)) <$> readMVar j1 <*> readMVar j2 <*> readMVar j3 119 | 120 | -- | Total order on stores to the same location. 121 | intelWP27 :: MonadConc m => m ((Int, Int), (Int, Int)) 122 | intelWP27 = do 123 | x <- newIORef 0 124 | j1 <- spawn (writeIORef x 1) 125 | j2 <- spawn (writeIORef x 2) 126 | j3 <- spawn (do r1 <- readIORef x; r2 <- readIORef x; pure (r1, r2)) 127 | j4 <- spawn (do r3 <- readIORef x; r4 <- readIORef x; pure (r3, r4)) 128 | (\() () r12 r23 -> (r12, r23)) <$> readMVar j1 <*> readMVar j2 <*> readMVar j3 <*> readMVar j4 129 | 130 | -- | Independent Read Independent Write. 131 | -- 132 | -- IRIW is a standard litmus test which allows in some architectures 133 | -- ((1,0),(1,0)). Intel (and TSO/PSO) forbid it. 134 | intelWP28 :: MonadConc m => m ((Int, Int), (Int, Int)) 135 | intelWP28 = do 136 | x <- newIORef 0 137 | y <- newIORef 0 138 | j1 <- spawn (writeIORef x 1) 139 | j2 <- spawn (writeIORef y 1) 140 | j3 <- spawn (do r1 <- readIORef x; r2 <- readIORef y; pure (r1, r2)) 141 | j4 <- spawn (do r3 <- readIORef y; r4 <- readIORef x; pure (r3, r4)) 142 | (\() () r12 r23 -> (r12, r23)) <$> readMVar j1 <*> readMVar j2 <*> readMVar j3 <*> readMVar j4 143 | 144 | ------------------------------------------------------------------------------- 145 | 146 | -- | Create two @IORef@s, fork the two threads, and return the result. 147 | litmus2 :: MonadConc m 148 | => (IORef m Int -> IORef m Int -> m b) 149 | -> (IORef m Int -> IORef m Int -> m c) 150 | -> m (b, c) 151 | litmus2 thread1 thread2 = do 152 | x <- newIORef 0 153 | y <- newIORef 0 154 | j1 <- spawn (thread1 x y) 155 | j2 <- spawn (thread2 x y) 156 | (,) <$> readMVar j1 <*> readMVar j2 157 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Integration/MonadDejaFu.hs: -------------------------------------------------------------------------------- 1 | module Integration.MonadDejaFu where 2 | 3 | import qualified Control.Concurrent.Classy as C 4 | 5 | import Control.Monad.Catch.Pure (runCatchT) 6 | import Control.Monad.ST (runST) 7 | import Test.DejaFu.Conc (Condition(..), roundRobinSched, 8 | runConcurrent) 9 | import Test.DejaFu.Types (MonadDejaFu) 10 | import qualified Test.Tasty.HUnit as TH 11 | 12 | import Common 13 | 14 | tests :: [TestTree] 15 | tests = 16 | [ testGroup "IO" ioTests 17 | , testGroup "ST" stTests 18 | ] 19 | 20 | -------------------------------------------------------------------------------- 21 | 22 | ioTests :: [TestTree] 23 | ioTests = toTestList 24 | [ TH.testCase "Supports bound threads" $ 25 | let res = single C.supportsBoundThreads 26 | in TH.assertEqual "" (Right True) =<< res 27 | 28 | , TH.testCase "Main thread is bound" $ 29 | let res = single C.isCurrentThreadBound 30 | in TH.assertEqual "" (Right True) =<< res 31 | 32 | , TH.testCase "Can fork bound threads" $ 33 | let res = single $ do 34 | _ <- C.forkOS (pure ()) 35 | pure True 36 | in TH.assertEqual "" (Right True) =<< res 37 | ] 38 | 39 | -------------------------------------------------------------------------------- 40 | 41 | stTests :: [TestTree] 42 | stTests = toTestList 43 | [ TH.testCase "Doesn't support bound threads" $ 44 | let res = runST $ runCatchT $ single C.supportsBoundThreads 45 | in TH.assertEqual "" (Right (Right False)) res 46 | 47 | , TH.testCase "Main thread isn't bound" $ 48 | let res = runST $ runCatchT $ single C.isCurrentThreadBound 49 | in TH.assertEqual "" (Right (Right False)) res 50 | 51 | , TH.testCase "Can't fork bound threads" $ 52 | let res = runST $ runCatchT $ single $ do 53 | _ <- C.forkOS (pure ()) 54 | pure True 55 | in case res of 56 | Right (Left (UncaughtException _)) -> pure () 57 | _ -> TH.assertFailure ("expected: Right (Left (UncaughtException _))\n but got: " ++ show res) 58 | ] 59 | 60 | -------------------------------------------------------------------------------- 61 | 62 | single :: MonadDejaFu n => Program pty n a -> n (Either Condition a) 63 | single program = 64 | let fst3 (a, _, _) = a 65 | in fst3 <$> runConcurrent roundRobinSched defaultMemType () program 66 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Integration/Names.hs: -------------------------------------------------------------------------------- 1 | module Integration.Names where 2 | 3 | import Control.Concurrent.Classy hiding (check) 4 | import Data.Maybe (mapMaybe) 5 | import Test.DejaFu.Internal (iorefOf, mvarOf, simplifyAction, 6 | tidsOf, tvarsOf) 7 | import Test.DejaFu.SCT (runSCT) 8 | import Test.DejaFu.Types 9 | import Test.Tasty.HUnit 10 | 11 | import Common 12 | 13 | tests :: [TestTree] 14 | tests = 15 | toTestList 16 | [ testCase "MVar names" testMVarNames 17 | , testCase "IORef names" testIORefNames 18 | , testCase "TVar names" testTVarNames 19 | , testCase "Thread names" testThreadNames 20 | ] 21 | 22 | check :: 23 | String 24 | -> ([ThreadAction] -> Bool) 25 | -> ConcIO a 26 | -> Assertion 27 | check msg validActions testAction = do 28 | outcomes <- runSCT defaultWay defaultMemType testAction 29 | let extractActions = map $ \(_, _, action) -> action 30 | actions = [extractActions trace | (_, trace) <- outcomes] 31 | assertBool msg $ any validActions actions 32 | 33 | testMVarNames :: Assertion 34 | testMVarNames = 35 | check "All traces should use only required MVar names" checkMVars $ do 36 | mvar1 <- newEmptyMVarN mvarName1 37 | mvar2 <- newEmptyMVarN mvarName2 38 | _ <- takeMVar mvar1 39 | _ <- fork $ putMVar mvar1 (1 :: Int) 40 | _ <- fork $ putMVar mvar2 (2 :: Int) 41 | _ <- fork $ putMVar mvar1 3 42 | (,) <$> readMVar mvar1 <*> readMVar mvar2 43 | where 44 | mvarName1 = "first-mvar" 45 | mvarName2 = "second-mvar" 46 | mvarName (MVarId (Id (Just n) _)) = Just n 47 | mvarName _ = Nothing 48 | mvar (NewMVar mvid) = Just mvid 49 | mvar a = mvarOf (simplifyAction a) 50 | checkMVars = 51 | let validMVid = maybe False (`elem` [mvarName1, mvarName2]) . mvarName 52 | in all validMVid . mapMaybe mvar 53 | 54 | testIORefNames :: Assertion 55 | testIORefNames = 56 | check "All traces should use only required IORef names" checkIORefs $ do 57 | x <- newIORefN iorefName1 (0::Int) 58 | y <- newIORefN iorefName2 (0::Int) 59 | _ <- fork $ modifyIORefCAS x (const (1, ())) 60 | _ <- fork $ writeIORef y 2 61 | (,) <$> readIORef x <*> readIORef y 62 | where 63 | iorefName1 = "ioref-one" 64 | iorefName2 = "ioref-two" 65 | iorefName (IORefId (Id (Just n) _)) = Just n 66 | iorefName _ = Nothing 67 | ioref (NewIORef ref) = Just ref 68 | ioref a = iorefOf (simplifyAction a) 69 | checkIORefs = 70 | let validIORef = maybe False (`elem` [iorefName1, iorefName2]) . iorefName 71 | in all validIORef . mapMaybe ioref 72 | 73 | testTVarNames :: Assertion 74 | testTVarNames = 75 | check "All traces should use only required TVar names" checkTVars $ do 76 | v1 <- atomically $ newTVarN tvarName1 (0::Int) 77 | v2 <- atomically $ newTVarN tvarName2 (0::Int) 78 | _ <- 79 | fork . atomically $ do 80 | writeTVar v1 1 81 | modifyTVar v2 (+ 100) 82 | _ <- 83 | fork . atomically $ do 84 | modifyTVar v1 (* 100) 85 | writeTVar v2 42 86 | pure () 87 | where 88 | tvarName1 = "tvar-one" 89 | tvarName2 = "tvar-two" 90 | tvarName (TVarId (Id (Just n) _)) = Just n 91 | tvarName _ = Nothing 92 | checkTVars = 93 | let validTVar = 94 | maybe False (`elem` [tvarName1, tvarName2]) . tvarName 95 | in all (all validTVar . tvarsOf) 96 | 97 | testThreadNames :: Assertion 98 | testThreadNames = 99 | check "All traces should use only required thread names" checkThreads $ do 100 | x <- newEmptyMVar 101 | tid <- forkN threadName2 $ putMVar x () 102 | _ <- forkN threadName1 $ readMVar x 103 | _ <- forkN threadName3 $ pure () 104 | killThread tid 105 | where 106 | threadName1 = "thread-one" 107 | threadName2 = "thread-two" 108 | threadName3 = "thread-three" 109 | threadName (ThreadId (Id (Just n) _)) = Just n 110 | threadName _ = Nothing 111 | checkThreads = 112 | let validTid = 113 | maybe False (`elem` [threadName1, threadName2, threadName3]) . 114 | threadName 115 | in all (all validTid . tidsOf) 116 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Integration/Refinement.hs: -------------------------------------------------------------------------------- 1 | module Integration.Refinement where 2 | 3 | import Control.Concurrent.Classy.MVar 4 | import Control.Monad (void) 5 | import Test.DejaFu.Refinement 6 | import Test.Tasty.DejaFu (testProperty) 7 | 8 | import Common hiding (testProperty) 9 | 10 | tests :: [TestTree] 11 | tests = [ testGroup "MVar" mvarProps ] 12 | 13 | ------------------------------------------------------------------------------- 14 | 15 | mvar :: (MVar ConcIO Int -> ConcIO a) -> Sig (MVar ConcIO Int) (Maybe Int) (Maybe Int) 16 | mvar e = Sig 17 | { initialise = maybe newEmptyMVar newMVar 18 | , observe = const . tryTakeMVar 19 | , interfere = \v mi -> tryTakeMVar v >> maybe (pure ()) (void . tryPutMVar v) mi 20 | , expression = void . e 21 | } 22 | 23 | mvarProps :: [TestTree] 24 | mvarProps = toTestList 25 | [ testProperty "readMVar is idempotent when composed sequentially" $ 26 | mvar readMVar === mvar (\v -> readMVar v >> readMVar v) 27 | 28 | , testProperty "readMVar is idempotent when composed concurrently" $ 29 | mvar readMVar === mvar (\v -> readMVar v ||| readMVar v) 30 | 31 | , testProperty "readMVar is not equivalent to a take followed by a put" $ 32 | expectFailure $ mvar readMVar === mvar (\v -> takeMVar v >>= putMVar v) 33 | 34 | , testProperty "readMVar is a strict refinement of a take followed by a put" $ 35 | mvar readMVar ->- mvar (\v -> takeMVar v >>= putMVar v) 36 | 37 | , testProperty "takeMVar is equivalent to a read followed by a take" $ 38 | mvar takeMVar === mvar (\v -> readMVar v >> takeMVar v) 39 | 40 | , testProperty "takeMVar is not equivalent to a read concurrently composed with a take" $ 41 | expectFailure $ mvar takeMVar === mvar (\v -> readMVar v ||| takeMVar v) 42 | 43 | , testProperty "takeMVar is a strict refinement of a read concurrently composed with a take" $ 44 | mvar takeMVar ->- mvar (\v -> readMVar v ||| takeMVar v) 45 | 46 | , testProperty "putMVar is not equivalent to a put followed by a read" $ 47 | \x -> expectFailure $ mvar (\v -> putMVar v x) === mvar (\v -> putMVar v x >> readMVar v) 48 | 49 | , testProperty "putMVar is a strict refinement of a put followed by a read" $ 50 | \x -> mvar (\v -> putMVar v x) ->- mvar (\v -> putMVar v x >> readMVar v) 51 | 52 | , testProperty "putMVar is not equivalent to a put concurrently composed with a read" $ 53 | \x -> expectFailure $ mvar (\v -> putMVar v x) === mvar (\v -> putMVar v x ||| readMVar v) 54 | 55 | , testProperty "putMVar is a strict refinement of a put concurrently composed with a read" $ 56 | \x -> mvar (\v -> putMVar v x) ->- mvar (\v -> putMVar v x ||| readMVar v) 57 | ] 58 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Integration/Regressions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Integration.Regressions where 4 | 5 | import Test.DejaFu (exceptionsAlways, gives') 6 | 7 | import Control.Concurrent.Classy 8 | import Control.Exception (AsyncException(..)) 9 | import Control.Monad (void) 10 | import qualified Control.Monad.Catch as E 11 | import System.Random (mkStdGen) 12 | 13 | import Common 14 | 15 | tests :: [TestTree] 16 | tests = toTestList 17 | [ djfu "https://github.com/barrucadu/dejafu/issues/40" (gives' [0,1]) $ do 18 | x <- newIORefInt 0 19 | _ <- fork $ myThreadId >> writeIORef x 1 20 | readIORef x 21 | 22 | , djfu "https://github.com/barrucadu/dejafu/issues/55" (gives' [True]) $ do 23 | a <- atomically newTQueue 24 | b <- atomically newTQueue 25 | _ <- fork . atomically $ writeTQueue b True 26 | let both x y = readTQueue x `orElse` readTQueue y `orElse` retry 27 | atomically $ both a b 28 | 29 | , djfu "https://github.com/barrucadu/dejafu/issues/111" (gives' [1]) $ do 30 | v <- atomically $ newTVarInt 1 31 | _ <- fork . atomically $ do 32 | writeTVar v 2 33 | writeTVar v 3 34 | retry 35 | readTVarConc v 36 | 37 | , djfu "https://github.com/barrucadu/dejafu/issues/118" exceptionsAlways $ 38 | catchSomeException 39 | (uninterruptibleMask_ (throw ThreadKilled)) 40 | (\_ -> myThreadId >>= killThread) 41 | 42 | , djfu "https://github.com/barrucadu/dejafu/issues/139" (gives' [()]) $ 43 | catchSomeException 44 | (catchSomeException (throw ThreadKilled) (\_ -> pure ()) 45 | >> throw ThreadKilled) 46 | (\_ -> pure ()) 47 | 48 | , djfu "https://github.com/barrucadu/dejafu/issues/161" (gives' [Just (), Nothing]) $ do 49 | let try a = void a `E.catch` (\(_ :: E.SomeException) -> pure ()) 50 | let act s = uninterruptibleMask_ (putMVar s ()) 51 | s <- newEmptyMVar 52 | t <- mask $ \restore -> fork (void (try (restore (act s)))) 53 | killThread t 54 | tryReadMVar s 55 | 56 | , djfu "https://github.com/barrucadu/dejafu/issues/243" (gives' [1,2,3]) $ do 57 | setNumCapabilities 1 58 | _ <- fork (setNumCapabilities 2) 59 | _ <- fork (setNumCapabilities 3) 60 | getNumCapabilities 61 | 62 | , djfu "https://github.com/barrucadu/dejafu/issues/267" exceptionsAlways $ do 63 | tid <- myThreadId 64 | uninterruptibleMask_ (throwTo tid ThreadKilled) 65 | 66 | , djfu "https://github.com/barrucadu/dejafu/issues/324 (a)" (gives' [Left ThreadKilled, Left UserInterrupt]) $ do 67 | var <- newEmptyMVar 68 | tId <- uninterruptibleMask $ \restore -> fork $ do 69 | result <- (Right <$> restore (throw UserInterrupt)) `E.catch` (pure . Left) 70 | putMVar var result 71 | killThread tId 72 | v <- takeMVar var 73 | pure (v :: Either AsyncException ()) 74 | 75 | , djfu "https://github.com/barrucadu/dejafu/issues/324 (b)" (gives' [Left ThreadKilled, Left UserInterrupt]) $ do 76 | var <- newEmptyMVar 77 | tId <- uninterruptibleMask $ \restore -> fork $ do 78 | result <- (Right <$> restore (atomically $ throwSTM UserInterrupt)) `E.catch` (pure . Left) 79 | putMVar var result 80 | killThread tId 81 | v <- takeMVar var 82 | pure (v :: Either AsyncException ()) 83 | 84 | , (:[]) . testDejafuWithSettings (fromWayAndMemType (randomly (mkStdGen 0) 10) defaultMemType) "https://github.com/barrucadu/dejafu/issues/331" (gives' [1]) $ 85 | withSetup (atomically $ newTVar (0::Int)) $ \tvar -> atomically $ do 86 | modifyTVar tvar (+1) 87 | readTVar tvar 88 | ] 89 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Integration/SCT.hs: -------------------------------------------------------------------------------- 1 | module Integration.SCT where 2 | 3 | import Control.Concurrent.Classy hiding (check) 4 | import Control.Monad (void) 5 | import Control.Monad.IO.Class (liftIO) 6 | import Data.Foldable (for_) 7 | import qualified Data.IORef as IORef 8 | import qualified Data.Set as S 9 | import System.Random (mkStdGen) 10 | import Test.DejaFu (gives') 11 | import Test.DejaFu.SCT 12 | import Test.DejaFu.Types (Condition(..)) 13 | import Test.Tasty.HUnit 14 | 15 | import Common 16 | 17 | tests :: [TestTree] 18 | tests = 19 | [ testGroup "Discard" discardTests 20 | , testGroup "EarlyExit" earlyExitTests 21 | , testGroup "Results" resultsSetTests 22 | ] 23 | 24 | ------------------------------------------------------------------------------- 25 | 26 | discardTests :: [TestTree] 27 | discardTests = toTestList 28 | [ check "All results are kept when none are discarded" [1, 2, 3] $ 29 | const Nothing 30 | , check "No results are kept when all are discarded" [] $ 31 | const (Just DiscardResultAndTrace) 32 | , check "Results failing the test are not present" [1, 2] $ 33 | \x -> if x == Right 3 then Just DiscardResultAndTrace else Nothing 34 | , testCase "No traces kept when they get discared" $ testDiscardTrace testAction 35 | ] 36 | where 37 | check name xs f = testDejafuWithSettings (set ldiscard (Just f) defaultSettings) name (gives' xs) testAction 38 | testAction = do 39 | mvar <- newEmptyMVarInt 40 | _ <- fork $ putMVar mvar 1 41 | _ <- fork $ putMVar mvar 2 42 | _ <- fork $ putMVar mvar 3 43 | readMVar mvar 44 | 45 | discarder (Right 2) = Just DiscardTrace 46 | discarder (Right 3) = Just DiscardResultAndTrace 47 | discarder _ = Nothing 48 | 49 | testDiscardTrace action = do 50 | results <- runSCTWithSettings (set ldiscard (Just discarder) defaultSettings) action 51 | for_ results $ \(efa, trace) -> case discarder efa of 52 | Just DiscardResultAndTrace -> assertFailure "expected result to be discarded" 53 | Just DiscardTrace 54 | | null trace -> pure () 55 | | otherwise -> assertFailure "expected trace to be discarded" 56 | Nothing -> pure () 57 | 58 | ------------------------------------------------------------------------------- 59 | 60 | earlyExitTests :: [TestTree] 61 | earlyExitTests = toTestList 62 | [ eeTest "Without discarding" [1,2,3,4,5] Nothing 63 | , eeTest "Discarding some result" [1,2,4,5] $ Just (\efa -> if efa == Right 3 then Just DiscardResultAndTrace else Nothing) 64 | , eeTest "Discarding the stop condition" [1,2,3,4] $ Just (\efa -> if efa == Right 5 then Just DiscardResultAndTrace else Nothing) 65 | ] 66 | where 67 | eeTest name expected d = testCase name $ do 68 | -- abuse IO to get a different result form every execution 69 | r <- liftIO (IORef.newIORef (0::Int)) 70 | actual <- resultsSetWithSettings (eeSettings d) $ do 71 | liftIO (IORef.modifyIORef r (+1)) 72 | liftIO (IORef.readIORef r) 73 | S.fromList (map Right expected) @=? actual 74 | 75 | eeSettings d = 76 | set ldiscard d $ 77 | set learlyExit (Just (==Right 5)) $ 78 | fromWayAndMemType (randomly (mkStdGen 0) 150) defaultMemType 79 | 80 | ------------------------------------------------------------------------------- 81 | 82 | resultsSetTests :: [TestTree] 83 | resultsSetTests = toTestList 84 | [ testCase "Proper results from resultsSet" $ do 85 | tested <- resultsSet defaultWay defaultMemType testAction 86 | results @=? tested 87 | , testCase "Proper results from resultsSet'" $ do 88 | tested <- resultsSet' defaultWay defaultMemType testAction 89 | results @=? tested 90 | ] 91 | where 92 | results = S.fromList $ map Right [1, 2] ++ [Left Deadlock] 93 | testAction = do 94 | mvar <- newEmptyMVarInt 95 | _ <- fork $ putMVar mvar 1 96 | _ <- fork $ putMVar mvar 2 97 | _ <- fork $ mapM_ (\_ -> void $ takeMVar mvar) [1 :: Int, 2] 98 | readMVar mvar 99 | -------------------------------------------------------------------------------- /dejafu-tests/lib/QSemN.hs: -------------------------------------------------------------------------------- 1 | -- | This is almost Control.Concurrent.Classy.QSemN, but it also has a function to snapshot the remaining quantity. 2 | module QSemN where 3 | 4 | import Control.Concurrent.Classy.MVar 5 | import Control.Monad.Catch (mask_, onException, 6 | uninterruptibleMask_) 7 | import Control.Monad.Conc.Class (MonadConc) 8 | import Control.Monad.Fail (MonadFail) 9 | import Data.Maybe 10 | 11 | newtype QSemN m = QSemN (MVar m (Int, [(Int, MVar m ())], [(Int, MVar m ())])) 12 | 13 | newQSemN :: (MonadConc m, MonadFail m) => Int -> m (QSemN m) 14 | newQSemN initial 15 | | initial < 0 = fail "newQSemN: Initial quantity must be non-negative" 16 | | otherwise = QSemN <$> newMVar (initial, [], []) 17 | 18 | remainingQSemN :: MonadConc m => QSemN m -> m Int 19 | remainingQSemN (QSemN m) = (\(quantity, _, _) -> quantity) <$> readMVar m 20 | 21 | waitQSemN :: MonadConc m => QSemN m -> Int -> m () 22 | waitQSemN (QSemN m) sz = mask_ $ do 23 | (quantity, b1, b2) <- takeMVar m 24 | let remaining = quantity - sz 25 | if remaining < 0 26 | then do 27 | b <- newEmptyMVar 28 | putMVar m (quantity, b1, (sz,b):b2) 29 | wait b 30 | else 31 | putMVar m (remaining, b1, b2) 32 | where 33 | wait b = takeMVar b `onException` uninterruptibleMask_ (do 34 | (quantity, b1, b2) <- takeMVar m 35 | r <- tryTakeMVar b 36 | r' <- if isJust r 37 | then signal sz (quantity, b1, b2) 38 | else putMVar b () >> pure (quantity, b1, b2) 39 | putMVar m r') 40 | 41 | signalQSemN :: MonadConc m => QSemN m -> Int -> m () 42 | signalQSemN (QSemN m) sz = uninterruptibleMask_ $ do 43 | r <- takeMVar m 44 | r' <- signal sz r 45 | putMVar m r' 46 | 47 | signal :: MonadConc m 48 | => Int 49 | -> (Int, [(Int,MVar m ())], [(Int,MVar m ())]) 50 | -> m (Int, [(Int,MVar m ())], [(Int,MVar m ())]) 51 | signal sz0 (i,a1,a2) = loop (sz0 + i) a1 a2 where 52 | loop 0 bs b2 = pure (0, bs, b2) 53 | loop sz [] [] = pure (sz, [], []) 54 | loop sz [] b2 = loop sz (reverse b2) [] 55 | loop sz ((j,b):bs) b2 56 | | j > sz = do 57 | r <- isEmptyMVar b 58 | if r then pure (sz, (j,b):bs, b2) 59 | else loop sz bs b2 60 | | otherwise = do 61 | r <- tryPutMVar b () 62 | if r then loop (sz-j) bs b2 63 | else loop sz bs b2 64 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Unit.hs: -------------------------------------------------------------------------------- 1 | module Unit where 2 | 3 | import Data.Maybe (fromJust) 4 | import Data.Proxy (Proxy(..)) 5 | import Test.Tasty (askOption, localOption) 6 | import Test.Tasty.Hedgehog (HedgehogDiscardLimit(..), 7 | HedgehogShrinkLimit(..), 8 | HedgehogShrinkRetries(..), 9 | HedgehogTestLimit) 10 | import Test.Tasty.Options (IsOption(..), OptionDescription(..)) 11 | 12 | import qualified Unit.Predicates as PE 13 | import qualified Unit.Properties as PO 14 | 15 | import Common 16 | 17 | -- | Run all the unit tests. 18 | tests :: [TestTree] 19 | tests = map applyHedgehogOptions 20 | [ testGroup "Predicates" PE.tests 21 | , testGroup "Properties" PO.tests 22 | ] 23 | 24 | -- | Tasty options 25 | options :: [OptionDescription] 26 | options = 27 | [ Option (Proxy :: Proxy UnitHedgehogTestLimit) 28 | , Option (Proxy :: Proxy UnitHedgehogDiscardLimit) 29 | , Option (Proxy :: Proxy UnitHedgehogShrinkLimit) 30 | , Option (Proxy :: Proxy UnitHedgehogShrinkRetries) 31 | ] 32 | 33 | 34 | ------------------------------------------------------------------------------- 35 | -- Hedgehog options 36 | 37 | -- | The number of successful test cases required before Hedgehog will pass a test 38 | newtype UnitHedgehogTestLimit = UnitHedgehogTestLimit HedgehogTestLimit 39 | deriving (Eq, Ord, Show) 40 | 41 | instance IsOption UnitHedgehogTestLimit where 42 | defaultValue = UnitHedgehogTestLimit . fromJust $ parseValue "1500" 43 | parseValue = fmap UnitHedgehogTestLimit . parseValue 44 | optionName = pure "unit-hedgehog-tests" 45 | optionHelp = pure "hedgehog-tests for the unit tests" 46 | 47 | -- | The number of discarded cases allowed before Hedgehog will fail a test 48 | newtype UnitHedgehogDiscardLimit = UnitHedgehogDiscardLimit HedgehogDiscardLimit 49 | deriving (Eq, Ord, Show) 50 | 51 | instance IsOption UnitHedgehogDiscardLimit where 52 | defaultValue = UnitHedgehogDiscardLimit . fromJust $ parseValue "1000" 53 | parseValue = fmap UnitHedgehogDiscardLimit . parseValue 54 | optionName = pure "unit-hedgehog-discards" 55 | optionHelp = pure "hedgehog-discards for the unit tests" 56 | 57 | -- | The number of shrinks allowed before Hedgehog will fail a test 58 | newtype UnitHedgehogShrinkLimit = UnitHedgehogShrinkLimit HedgehogShrinkLimit 59 | deriving (Eq, Ord, Show) 60 | 61 | instance IsOption UnitHedgehogShrinkLimit where 62 | defaultValue = UnitHedgehogShrinkLimit defaultValue 63 | parseValue = fmap UnitHedgehogShrinkLimit . parseValue 64 | optionName = pure "unit-hedgehog-shrinks" 65 | optionHelp = pure "hedgehog-shrinks for the unit tests" 66 | 67 | -- | The number of times to re-run a test during shrinking 68 | newtype UnitHedgehogShrinkRetries = UnitHedgehogShrinkRetries HedgehogShrinkRetries 69 | deriving (Eq, Ord, Show) 70 | 71 | instance IsOption UnitHedgehogShrinkRetries where 72 | defaultValue = UnitHedgehogShrinkRetries defaultValue 73 | parseValue = fmap UnitHedgehogShrinkRetries . parseValue 74 | optionName = pure "unit-hedgehog-retries" 75 | optionHelp = pure "hedgehog-retries for the unit tests" 76 | 77 | -- | Apply the Hedgehog options. 78 | applyHedgehogOptions :: TestTree -> TestTree 79 | applyHedgehogOptions tt0 = 80 | askOption $ \(UnitHedgehogTestLimit tl) -> 81 | askOption $ \(UnitHedgehogDiscardLimit dl) -> 82 | askOption $ \(UnitHedgehogShrinkLimit sl) -> 83 | askOption $ \(UnitHedgehogShrinkRetries sr) -> 84 | localOption tl $ 85 | localOption dl $ 86 | localOption sl $ 87 | localOption sr tt0 88 | -------------------------------------------------------------------------------- /dejafu-tests/lib/Unit/Predicates.hs: -------------------------------------------------------------------------------- 1 | module Unit.Predicates where 2 | 3 | import qualified Test.DejaFu as D 4 | import Test.Tasty.HUnit 5 | 6 | import Common 7 | 8 | tests :: [TestTree] 9 | tests = 10 | [ testGroup "alwaysSameBy" alwaysSameBy 11 | , testGroup "notAlwaysSameBy" notAlwaysSameBy 12 | , testGroup "alwaysNothing" alwaysNothing 13 | , testGroup "somewhereNothing" somewhereNothing 14 | , testGroup "gives" gives 15 | ] 16 | 17 | ------------------------------------------------------------------------------- 18 | 19 | alwaysSameBy :: [TestTree] 20 | alwaysSameBy = toTestList 21 | [ passes "Equal successes" (D.alwaysSameBy (==)) [Right 1, Right 1, Right 1] 22 | , fails "Unequal successes" (D.alwaysSameBy (==)) [Right 1, Right 2, Right 3] 23 | , fails "Equal conditions" (D.alwaysSameBy (==)) [Left D.Deadlock, Left D.Deadlock, Left D.Deadlock] 24 | , fails "Unequal conditions" (D.alwaysSameBy (==)) [Left D.Deadlock, Left D.Abort, Left D.Abort] 25 | , fails "Mixed conditions and successes" (D.alwaysSameBy (==)) [Left D.Deadlock, Right 1, Right 1] 26 | ] 27 | 28 | ------------------------------------------------------------------------------- 29 | 30 | notAlwaysSameBy :: [TestTree] 31 | notAlwaysSameBy = toTestList 32 | [ fails "Equal successes" (D.notAlwaysSameBy (==)) [Right 1, Right 1, Right 1] 33 | , passes "Unequal successes" (D.notAlwaysSameBy (==)) [Right 1, Right 2, Right 3] 34 | , fails "Equal conditions" (D.notAlwaysSameBy (==)) [Left D.Deadlock, Left D.Deadlock, Left D.Deadlock] 35 | , fails "Unequal conditions" (D.notAlwaysSameBy (==)) [Left D.Deadlock, Left D.Abort, Left D.Abort] 36 | , fails "Mixed conditions and successes" (D.notAlwaysSameBy (==)) [Left D.Deadlock, Right 1, Right 1] 37 | ] 38 | 39 | ------------------------------------------------------------------------------- 40 | 41 | alwaysNothing :: [TestTree] 42 | alwaysNothing = toTestList 43 | [ passes "Always" (D.alwaysNothing (const Nothing)) [Right 1, Right 2, Left D.Deadlock] 44 | , fails "Somewhere" (D.alwaysNothing (either (Just . Left) (const Nothing))) [Right 1, Right 2, Left D.Deadlock] 45 | , fails "Never" (D.alwaysNothing Just) [Right 1, Right 2, Left D.Deadlock] 46 | ] 47 | 48 | ------------------------------------------------------------------------------- 49 | 50 | somewhereNothing :: [TestTree] 51 | somewhereNothing = toTestList 52 | [ passes "Always" (D.somewhereNothing (const Nothing)) [Right 1, Right 2, Left D.Deadlock] 53 | , passes "Somewhere" (D.somewhereNothing (either (Just . Left) (const Nothing))) [Right 1, Right 2, Left D.Deadlock] 54 | , fails "Never" (D.somewhereNothing Just) [Right 1, Right 2, Left D.Deadlock] 55 | ] 56 | 57 | ------------------------------------------------------------------------------- 58 | 59 | gives :: [TestTree] 60 | gives = toTestList 61 | [ passes "Exact match" (D.gives [Right 1, Right 2]) [Right 1, Right 2] 62 | , fails "Extra results" (D.gives [Right 1, Right 2]) [Right 1, Right 2, Right 3] 63 | , fails "Missing results" (D.gives [Right 1, Right 2]) [Right 1] 64 | ] 65 | 66 | ------------------------------------------------------------------------------- 67 | 68 | -- | Check a predicate passes 69 | passes :: String -> D.Predicate Int -> [Either D.Condition Int] -> TestTree 70 | passes = checkPredicate D._pass 71 | 72 | -- | Check a predicate fails 73 | fails :: String -> D.Predicate Int -> [Either D.Condition Int] -> TestTree 74 | fails = checkPredicate (not . D._pass) 75 | 76 | -- | Check a predicate 77 | checkPredicate :: (D.Result Int -> Bool) -> String -> D.Predicate Int -> [Either D.Condition Int] -> TestTree 78 | checkPredicate f msg p = testCase msg . assertBool "" . f . D.peval p . map (\efa -> (efa, [])) 79 | -------------------------------------------------------------------------------- /dejafu/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015--2018, Michael Walker 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /dejafu/README.markdown: -------------------------------------------------------------------------------- 1 | dejafu 2 | ====== 3 | 4 | > [Déjà Fu is] A martial art in which the user's limbs move in time as 5 | > well as space, […] It is best described as "the feeling that you 6 | > have been kicked in the head this way before" 7 | > 8 | > -- Terry Pratchett, Thief of Time 9 | 10 | - [Installation](#installation) 11 | - [Quick start guide](#quick-start-guide) 12 | - [Why Déjà Fu?](#why-déjà-fu) 13 | - [Contributing](#contributing) 14 | - [Release notes](#release-notes) 15 | - [Questions, feedback, discussion](#questions-feedback-discussion) 16 | - [Bibliography](#bibliography) 17 | - **[The website!](https://dejafu.docs.barrucadu.co.uk/)** 18 | 19 | Déjà Fu is a unit-testing library for concurrent Haskell programs. 20 | Tests are deterministic and expressive, making it easy and convenient 21 | to test your threaded code. Available on [GitHub][], [Hackage][], and 22 | [Stackage][]. 23 | 24 | [GitHub]: https://github.com/barrucadu/dejafu 25 | [Hackage]: https://hackage.haskell.org/package/dejafu 26 | [Stackage]: https://www.stackage.org/package/dejafu 27 | 28 | 29 | Installation 30 | ------------ 31 | 32 | Install from Hackage globally: 33 | 34 | ``` 35 | $ cabal install dejafu 36 | ``` 37 | 38 | Or add it to your cabal file: 39 | 40 | ``` 41 | build-depends: ... 42 | , dejafu 43 | ``` 44 | 45 | Or to your package.yaml: 46 | 47 | ``` 48 | dependencies: 49 | ... 50 | - dejafu 51 | ``` 52 | 53 | 54 | Quick start guide 55 | ----------------- 56 | 57 | Déjà Fu supports unit testing, and comes with a helper function called 58 | `autocheck` to look for some common issues. Let's see it in action: 59 | 60 | ```haskell 61 | import Control.Concurrent.Classy 62 | 63 | myFunction :: MonadConc m => m String 64 | myFunction = do 65 | var <- newEmptyMVar 66 | fork (putMVar var "hello") 67 | fork (putMVar var "world") 68 | readMVar var 69 | ``` 70 | 71 | That `MonadConc` is a typeclass abstraction over concurrency, but 72 | we'll get onto that shortly. First, the result of testing: 73 | 74 | ``` 75 | > autocheck myFunction 76 | [pass] Never Deadlocks 77 | [pass] No Exceptions 78 | [fail] Consistent Result 79 | "hello" S0----S1--S0-- 80 | 81 | "world" S0----S2--S0-- 82 | False 83 | ``` 84 | 85 | There are no deadlocks or uncaught exceptions, which is good; but the 86 | program is (as you probably spotted) nondeterministic! 87 | 88 | Along with each result, Déjà Fu gives us a representative execution 89 | trace in an abbreviated form. `Sn` means that thread `n` started 90 | executing, and `Pn` means that thread `n` pre-empted the previously 91 | running thread. 92 | 93 | 94 | Why Déjà Fu? 95 | ------------ 96 | 97 | Testing concurrent programs is difficult, because in general they are 98 | nondeterministic. This leads to people using work-arounds like 99 | running their testsuite many thousands of times; or running their 100 | testsuite while putting their machine under heavy load. 101 | 102 | These approaches are inadequate for a few reasons: 103 | 104 | - **How many runs is enough?** When you are just hopping to spot a bug 105 | by coincidence, how do you know to stop? 106 | - **How do you know if you've fixed a bug you saw previously?** 107 | Because the scheduler is a black box, you don't know if the 108 | previously buggy schedule has been re-run. 109 | - **You won't get that much scheduling variety!** Operating systems 110 | and language runtimes like to run threads for long periods of time, 111 | which reduces the variety you get (and so drives up the number of 112 | runs you need). 113 | 114 | Déjà Fu addresses these points by offering *complete* testing. You 115 | can run a test case and be guaranteed to find all results with some 116 | bounds. These bounds can be configured, or even disabled! The 117 | underlying approach used is smarter than merely trying all possible 118 | executions, and will in general explore the state-space quickly. 119 | 120 | If your test case is just too big for complete testing, there is also 121 | a random scheduling mode, which is necessarily *incomplete*. However, 122 | Déjà Fu will tend to produce much more schedule variety than just 123 | running your test case in `IO` the same number of times, and so bugs 124 | will tend to crop up sooner. Furthermore, as you get execution traces 125 | out, you can be certain that a bug has been fixed by simply following 126 | the trace by eye. 127 | 128 | 129 | Contributing 130 | ------------ 131 | 132 | Bug reports, pull requests, and comments are very welcome! 133 | 134 | Feel free to contact me on GitHub, through IRC (#haskell on 135 | libera.chat), or email (mike@barrucadu.co.uk). 136 | -------------------------------------------------------------------------------- /dejafu/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /dejafu/Test/DejaFu/Conc.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.DejaFu.Conc 3 | -- Copyright : (c) 2016--2019 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : experimental 7 | -- Portability : portable 8 | -- 9 | -- Deterministic traced execution of concurrent computations. 10 | -- 11 | -- This works by executing the computation on a single thread, calling 12 | -- out to the supplied scheduler after each step to determine which 13 | -- thread runs next. 14 | module Test.DejaFu.Conc 15 | ( -- * Expressing concurrent programs 16 | Program 17 | , Basic 18 | , ConcT 19 | , ConcIO 20 | 21 | -- ** Setup and teardown 22 | , WithSetup 23 | , WithSetupAndTeardown 24 | , withSetup 25 | , withTeardown 26 | , withSetupAndTeardown 27 | 28 | -- ** Invariants 29 | , Invariant 30 | , registerInvariant 31 | , inspectIORef 32 | , inspectMVar 33 | , inspectTVar 34 | 35 | -- * Executing concurrent programs 36 | , Snapshot 37 | , MemType(..) 38 | , runConcurrent 39 | , recordSnapshot 40 | , runSnapshot 41 | 42 | -- ** Scheduling 43 | , module Test.DejaFu.Schedule 44 | 45 | -- * Results 46 | , Condition(..) 47 | , Trace 48 | , Decision(..) 49 | , ThreadId(..) 50 | , ThreadAction(..) 51 | , Lookahead(..) 52 | , MVarId 53 | , IORefId 54 | , MaskingState(..) 55 | , showTrace 56 | , showCondition 57 | ) where 58 | 59 | import Control.Exception (MaskingState(..)) 60 | import Control.Monad (void) 61 | 62 | import Test.DejaFu.Conc.Internal.Common 63 | import Test.DejaFu.Conc.Internal.Program 64 | import Test.DejaFu.Conc.Internal.STM (ModelTVar) 65 | import Test.DejaFu.Schedule 66 | import Test.DejaFu.Types 67 | import Test.DejaFu.Utils 68 | 69 | ------------------------------------------------------------------------------- 70 | -- Expressing concurrent programs 71 | 72 | -- | @since 1.4.0.0 73 | type ConcT = Program Basic 74 | 75 | -- | A 'MonadConc' implementation using @IO@. 76 | -- 77 | -- @since 0.4.0.0 78 | type ConcIO = ConcT IO 79 | 80 | ------------------------------------------------------------------------------- 81 | -- Setup & teardown 82 | 83 | -- | A concurrent program with some set-up action. 84 | -- 85 | -- In terms of results, this is the same as @setup >>= program@. 86 | -- However, the setup action will be __snapshotted__ (see 87 | -- 'recordSnapshot' and 'runSnapshot') by the testing functions. This 88 | -- means that even if dejafu runs this program many many times, the 89 | -- setup action will only be run the first time, and its effects 90 | -- remembered for subsequent executions. 91 | -- 92 | -- @since 2.0.0.0 93 | withSetup 94 | :: Program Basic n x 95 | -- ^ Setup action 96 | -> (x -> Program Basic n a) 97 | -- ^ Main program 98 | -> Program (WithSetup x) n a 99 | withSetup setup p = WithSetup 100 | { wsSetup = setup 101 | , wsProgram = p 102 | } 103 | 104 | -- | A concurrent program with some set-up and teardown actions. 105 | -- 106 | -- This is similar to 107 | -- 108 | -- @ 109 | -- do 110 | -- x <- setup 111 | -- y <- program x 112 | -- teardown x y 113 | -- @ 114 | -- 115 | -- But with two differences: 116 | -- 117 | -- * The setup action can be __snapshotted__, as described for 118 | -- 'withSetup' 119 | -- 120 | -- * The teardown action will be executed even if the main action 121 | -- fails to produce a value. 122 | -- 123 | -- @since 2.0.0.0 124 | withTeardown 125 | :: (x -> Either Condition y -> Program Basic n a) 126 | -- ^ Teardown action 127 | -> Program (WithSetup x) n y 128 | -- ^ Main program 129 | -> Program (WithSetupAndTeardown x y) n a 130 | withTeardown teardown ws = WithSetupAndTeardown 131 | { wstSetup = wsSetup ws 132 | , wstProgram = wsProgram ws 133 | , wstTeardown = teardown 134 | } 135 | 136 | -- | A combination of 'withSetup' and 'withTeardown' for convenience. 137 | -- 138 | -- @ 139 | -- withSetupAndTeardown setup teardown = 140 | -- withTeardown teardown . withSetup setup 141 | -- @ 142 | -- 143 | -- @since 2.0.0.0 144 | withSetupAndTeardown 145 | :: Program Basic n x 146 | -- ^ Setup action 147 | -> (x -> Either Condition y -> Program Basic n a) 148 | -- ^ Teardown action 149 | -> (x -> Program Basic n y) 150 | -- ^ Main program 151 | -> Program (WithSetupAndTeardown x y) n a 152 | withSetupAndTeardown setup teardown = 153 | withTeardown teardown . withSetup setup 154 | 155 | ------------------------------------------------------------------------------- 156 | -- Invariants 157 | 158 | -- | Call this in the setup phase to register new invariant which will 159 | -- be checked after every scheduling point in the main phase. 160 | -- Invariants are atomic actions which can inspect the shared state of 161 | -- your computation. 162 | -- 163 | -- If the invariant throws an exception, the execution will be aborted 164 | -- with n @InvariantFailure@. Any teardown action will still be run. 165 | -- 166 | -- @since 2.0.0.0 167 | registerInvariant :: Invariant n a -> Program Basic n () 168 | registerInvariant inv = ModelConc (\c -> ANewInvariant (void inv) (c ())) 169 | 170 | -- | Read the content of an @IORef@. 171 | -- 172 | -- This returns the globally visible value, which may not be the same 173 | -- as the value visible to any particular thread when using a memory 174 | -- model other than 'SequentialConsistency'. 175 | -- 176 | -- @since 2.0.0.0 177 | inspectIORef :: ModelIORef n a -> Invariant n a 178 | inspectIORef = Invariant . IInspectIORef 179 | 180 | -- | Read the content of an @MVar@. 181 | -- 182 | -- This is essentially @tryReadMVar@. 183 | -- 184 | -- @since 2.0.0.0 185 | inspectMVar :: ModelMVar n a -> Invariant n (Maybe a) 186 | inspectMVar = Invariant . IInspectMVar 187 | 188 | -- | Read the content of a @TVar@. 189 | -- 190 | -- This is essentially @readTVar@. 191 | -- 192 | -- @since 2.0.0.0 193 | inspectTVar :: ModelTVar n a -> Invariant n a 194 | inspectTVar = Invariant . IInspectTVar 195 | -------------------------------------------------------------------------------- /dejafu/Test/DejaFu/SCT/Internal/Weighted.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | -- | 5 | -- Module : Test.DejaFu.SCT.Internal.Weighted 6 | -- Copyright : (c) 2015--2019 Michael Walker 7 | -- License : MIT 8 | -- Maintainer : Michael Walker 9 | -- Stability : experimental 10 | -- Portability : DeriveAnyClass, DeriveGeneric 11 | -- 12 | -- Internal types and functions for SCT via weighted random 13 | -- scheduling. This module is NOT considered to form part of the 14 | -- public interface of this library. 15 | module Test.DejaFu.SCT.Internal.Weighted where 16 | 17 | import Control.DeepSeq (NFData) 18 | import Data.List.NonEmpty (toList) 19 | import Data.Map.Strict (Map) 20 | import qualified Data.Map.Strict as M 21 | import GHC.Generics (Generic) 22 | import System.Random (RandomGen, randomR) 23 | 24 | import Test.DejaFu.Schedule (Scheduler(..)) 25 | import Test.DejaFu.Types 26 | 27 | ------------------------------------------------------------------------------- 28 | -- * Weighted random scheduler 29 | 30 | -- | The scheduler state 31 | data RandSchedState g = RandSchedState 32 | { schedWeights :: Map ThreadId Int 33 | -- ^ The thread weights: used in determining which to run. 34 | , schedLengthBound :: Maybe LengthBound 35 | -- ^ The optional length bound. 36 | , schedGen :: g 37 | -- ^ The random number generator. 38 | } deriving (Eq, Show, Generic, NFData) 39 | 40 | -- | Initial weighted random scheduler state. 41 | initialRandSchedState :: Maybe LengthBound -> g -> RandSchedState g 42 | initialRandSchedState = RandSchedState M.empty 43 | 44 | -- | Weighted random scheduler: assigns to each new thread a weight, 45 | -- and makes a weighted random choice out of the runnable threads at 46 | -- every step. 47 | randSched :: RandomGen g => (g -> (Int, g)) -> Scheduler (RandSchedState g) 48 | randSched weightf = Scheduler $ \_ threads _ s -> 49 | let 50 | -- Select a thread 51 | pick idx ((x, f):xs) 52 | | idx < f = Just x 53 | | otherwise = pick (idx - f) xs 54 | pick _ [] = Nothing 55 | (choice, g'') = randomR (0, sum (map snd enabled) - 1) g' 56 | enabled = M.toList $ M.filterWithKey (\tid _ -> tid `elem` tids) weights' 57 | 58 | -- The weights, with any new threads added. 59 | (weights', g') = foldr assignWeight (M.empty, schedGen s) tids 60 | assignWeight tid ~(ws, g0) = 61 | let (w, g) = maybe (weightf g0) (\w0 -> (w0, g0)) (M.lookup tid (schedWeights s)) 62 | in (M.insert tid w ws, g) 63 | 64 | -- The runnable threads. 65 | tids = map fst (toList threads) 66 | in case schedLengthBound s of 67 | Just 0 -> (Nothing, s) 68 | Just n -> (pick choice enabled, RandSchedState weights' (Just (n - 1)) g'') 69 | Nothing -> (pick choice enabled, RandSchedState weights' Nothing g'') 70 | -------------------------------------------------------------------------------- /dejafu/Test/DejaFu/Schedule.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.DejaFu.Schedule 3 | -- Copyright : (c) 2016--2018 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : experimental 7 | -- Portability : portable 8 | -- 9 | -- Scheduling for concurrent computations. 10 | module Test.DejaFu.Schedule 11 | ( -- * Scheduling 12 | Scheduler(..) 13 | 14 | -- ** Preemptive 15 | , randomSched 16 | , roundRobinSched 17 | 18 | -- ** Non-preemptive 19 | , randomSchedNP 20 | , roundRobinSchedNP 21 | 22 | -- * Utilities 23 | , makeNonPreemptive 24 | ) where 25 | 26 | import Data.List.NonEmpty (NonEmpty(..), toList) 27 | import System.Random (RandomGen, randomR) 28 | 29 | import Test.DejaFu.Internal 30 | import Test.DejaFu.Types 31 | 32 | -- | A @Scheduler@ drives the execution of a concurrent program. The 33 | -- parameters it takes are: 34 | -- 35 | -- 1. The last thread executed (if this is the first invocation, this 36 | -- is @Nothing@). 37 | -- 38 | -- 2. The unblocked threads. 39 | -- 40 | -- 3. The concurrency state. 41 | -- 42 | -- 4. The scheduler state. 43 | -- 44 | -- It returns a thread to execute, or @Nothing@ if execution should 45 | -- abort here, and also a new state. 46 | -- 47 | -- @since 2.0.0.0 48 | newtype Scheduler state = Scheduler 49 | { scheduleThread 50 | :: Maybe (ThreadId, ThreadAction) 51 | -> NonEmpty (ThreadId, Lookahead) 52 | -> ConcurrencyState 53 | -> state 54 | -> (Maybe ThreadId, state) 55 | } 56 | 57 | ------------------------------------------------------------------------------- 58 | -- Preemptive 59 | 60 | -- | A simple random scheduler which, at every step, picks a random 61 | -- thread to run. 62 | -- 63 | -- @since 0.8.0.0 64 | randomSched :: RandomGen g => Scheduler g 65 | randomSched = Scheduler go where 66 | go _ threads _ g = 67 | let threads' = map fst (toList threads) 68 | (choice, g') = randomR (0, length threads' - 1) g 69 | in (Just $ eidx threads' choice, g') 70 | 71 | -- | A round-robin scheduler which, at every step, schedules the 72 | -- thread with the next 'ThreadId'. 73 | -- 74 | -- @since 0.8.0.0 75 | roundRobinSched :: Scheduler () 76 | roundRobinSched = Scheduler go where 77 | go Nothing ((tid,_):|_) _ _ = (Just tid, ()) 78 | go (Just (prior, _)) threads _ _ = 79 | let threads' = map fst (toList threads) 80 | candidates = 81 | if prior >= maximum threads' 82 | then threads' 83 | else filter (>prior) threads' 84 | in (Just (minimum candidates), ()) 85 | 86 | ------------------------------------------------------------------------------- 87 | -- Non-preemptive 88 | 89 | -- | A random scheduler which doesn't preempt the running thread. That 90 | -- is, if the previously scheduled thread is not blocked, it is picked 91 | -- again, otherwise schedule randomly. 92 | -- 93 | -- @since 0.8.0.0 94 | randomSchedNP :: RandomGen g => Scheduler g 95 | randomSchedNP = makeNonPreemptive randomSched 96 | 97 | -- | A round-robin scheduler which doesn't preempt the running 98 | -- thread. That is, if the previously scheduled thread is not blocked, 99 | -- it is picked again, otherwise schedule the thread with the next 100 | -- 'ThreadId'. 101 | -- 102 | -- @since 0.8.0.0 103 | roundRobinSchedNP :: Scheduler () 104 | roundRobinSchedNP = makeNonPreemptive roundRobinSched 105 | 106 | ------------------------------------------------------------------------------- 107 | -- Utilities 108 | 109 | -- | Turn a potentially preemptive scheduler into a non-preemptive 110 | -- one. 111 | -- 112 | -- @since 0.8.0.0 113 | makeNonPreemptive :: Scheduler s -> Scheduler s 114 | makeNonPreemptive sched = Scheduler newsched where 115 | newsched p@(Just (prior, _)) threads cs s 116 | | prior `elem` map fst (toList threads) = (Just prior, s) 117 | | otherwise = scheduleThread sched p threads cs s 118 | newsched Nothing threads cs s = scheduleThread sched Nothing threads cs s 119 | -------------------------------------------------------------------------------- /dejafu/Test/DejaFu/Utils.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.DejaFu.Utils 3 | -- Copyright : (c) 2017--2018 Michael Walker 4 | -- License : MIT 5 | -- Maintainer : Michael Walker 6 | -- Stability : experimental 7 | -- Portability : portable 8 | -- 9 | -- Utility functions for users of dejafu. 10 | module Test.DejaFu.Utils where 11 | 12 | import Control.Exception (Exception(..), displayException) 13 | import Data.List (intercalate, minimumBy) 14 | import Data.Maybe (mapMaybe) 15 | import Data.Ord (comparing) 16 | 17 | import Test.DejaFu.Types 18 | 19 | ------------------------------------------------------------------------------- 20 | -- * Traces 21 | 22 | -- | Turn a 'Trace' into an abbreviated form. 23 | -- 24 | -- @since 1.3.2.0 25 | toTIdTrace :: Trace -> [(ThreadId, ThreadAction)] 26 | toTIdTrace = 27 | drop 1 . scanl (\(t, _) (d, _, a) -> (tidOf t d, a)) (initialThread, undefined) 28 | 29 | -- | Pretty-print a trace, including a key of the thread IDs (not 30 | -- including thread 0). Each line of the key is indented by two 31 | -- spaces. 32 | -- 33 | -- @since 0.5.0.0 34 | showTrace :: Trace -> String 35 | showTrace [] = "" 36 | showTrace trc = intercalate "\n" $ go False trc : strkey where 37 | go _ ((_,_,CommitIORef _ _):rest) = "C-" ++ go False rest 38 | go _ ((Start (ThreadId (Id _ i)),_,a):rest) = "S" ++ show i ++ "-" ++ go (didYield a) rest 39 | go y ((SwitchTo (ThreadId (Id _ i)),_,a):rest) = (if y then "p" else "P") ++ show i ++ "-" ++ go (didYield a) rest 40 | go _ ((Continue,_,a):rest) = '-' : go (didYield a) rest 41 | go _ _ = "" 42 | 43 | strkey = 44 | [" " ++ show i ++ ": " ++ name | (i, name) <- threadNames trc] 45 | 46 | didYield Yield = True 47 | didYield (ThreadDelay _) = True 48 | didYield _ = False 49 | 50 | -- | Get all named threads in the trace. 51 | -- 52 | -- @since 0.7.3.0 53 | threadNames :: Trace -> [(Int, String)] 54 | threadNames = mapMaybe go where 55 | go (_, _, Fork (ThreadId (Id (Just name) i))) = Just (i, name) 56 | go (_, _, ForkOS (ThreadId (Id (Just name) i))) = Just (i, name) 57 | go _ = Nothing 58 | 59 | -- | Find the \"simplest\" trace leading to each result. 60 | simplestsBy :: (x -> x -> Bool) -> [(x, Trace)] -> [(x, Trace)] 61 | simplestsBy f = map choose . collect where 62 | collect = groupBy' [] (\(a,_) (b,_) -> f a b) 63 | choose = minimumBy . comparing $ \(_, trc) -> 64 | let switchTos = length . filter (\(d,_,_) -> case d of SwitchTo _ -> True; _ -> False) 65 | starts = length . filter (\(d,_,_) -> case d of Start _ -> True; _ -> False) 66 | commits = length . filter (\(_,_,a) -> case a of CommitIORef _ _ -> True; _ -> False) 67 | in (switchTos trc, commits trc, length trc, starts trc) 68 | 69 | groupBy' res _ [] = res 70 | groupBy' res eq (y:ys) = groupBy' (insert' eq y res) eq ys 71 | 72 | insert' _ x [] = [[x]] 73 | insert' eq x (ys@(y:_):yss) 74 | | x `eq` y = (x:ys) : yss 75 | | otherwise = ys : insert' eq x yss 76 | insert' _ _ ([]:_) = undefined 77 | 78 | ------------------------------------------------------------------------------- 79 | -- * Conditions 80 | 81 | -- | Pretty-print a condition 82 | -- 83 | -- @since 1.12.0.0 84 | showCondition :: Condition -> String 85 | showCondition Abort = "[abort]" 86 | showCondition Deadlock = "[deadlock]" 87 | showCondition (UncaughtException exc) = "[" ++ displayException exc ++ "]" 88 | showCondition (InvariantFailure _) = "[invariant failure]" 89 | 90 | ------------------------------------------------------------------------------- 91 | -- * Scheduling 92 | 93 | -- | Get the resultant thread identifier of a 'Decision', with a default case 94 | -- for 'Continue'. 95 | -- 96 | -- @since 0.5.0.0 97 | tidOf :: ThreadId -> Decision -> ThreadId 98 | tidOf _ (Start t) = t 99 | tidOf _ (SwitchTo t) = t 100 | tidOf tid _ = tid 101 | 102 | -- | Get the 'Decision' that would have resulted in this thread 103 | -- identifier, given a prior thread (if any) and collection of threads 104 | -- which are unblocked at this point. 105 | -- 106 | -- @since 0.5.0.0 107 | decisionOf :: Foldable f 108 | => Maybe ThreadId 109 | -- ^ The prior thread. 110 | -> f ThreadId 111 | -- ^ The threads. 112 | -> ThreadId 113 | -- ^ The current thread. 114 | -> Decision 115 | decisionOf Nothing _ chosen = Start chosen 116 | decisionOf (Just prior) runnable chosen 117 | | prior == chosen = Continue 118 | | prior `elem` runnable = SwitchTo chosen 119 | | otherwise = Start chosen 120 | -------------------------------------------------------------------------------- /dejafu/dejafu.cabal: -------------------------------------------------------------------------------- 1 | -- Initial monad-conc.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: dejafu 5 | version: 2.4.0.7 6 | synopsis: A library for unit-testing concurrent programs. 7 | 8 | description: 9 | /[Déjà Fu is] A martial art in which the user's limbs move in time as well as space, […] It is best described as "the feeling that you have been kicked in the head this way before"/ -- Terry Pratchett, Thief of Time 10 | . 11 | This package builds on the 12 | 13 | package by enabling you to deterministically test your concurrent 14 | programs. 15 | . 16 | See the or README for more. 17 | 18 | homepage: https://github.com/barrucadu/dejafu 19 | license: MIT 20 | license-file: LICENSE 21 | author: Michael Walker 22 | maintainer: mike@barrucadu.co.uk 23 | copyright: (c) 2015--2020 Michael Walker 24 | category: Concurrency 25 | build-type: Simple 26 | extra-source-files: README.markdown CHANGELOG.rst 27 | cabal-version: >=1.10 28 | 29 | source-repository head 30 | type: git 31 | location: https://github.com/barrucadu/dejafu.git 32 | 33 | source-repository this 34 | type: git 35 | location: https://github.com/barrucadu/dejafu.git 36 | tag: dejafu-2.4.0.7 37 | 38 | library 39 | exposed-modules: Test.DejaFu 40 | , Test.DejaFu.Conc 41 | , Test.DejaFu.Refinement 42 | , Test.DejaFu.SCT 43 | , Test.DejaFu.Settings 44 | , Test.DejaFu.Schedule 45 | , Test.DejaFu.Types 46 | , Test.DejaFu.Utils 47 | 48 | , Test.DejaFu.Conc.Internal 49 | , Test.DejaFu.Conc.Internal.Common 50 | , Test.DejaFu.Conc.Internal.Memory 51 | , Test.DejaFu.Conc.Internal.Program 52 | , Test.DejaFu.Conc.Internal.STM 53 | , Test.DejaFu.Conc.Internal.Threading 54 | , Test.DejaFu.Internal 55 | , Test.DejaFu.SCT.Internal 56 | , Test.DejaFu.SCT.Internal.DPOR 57 | , Test.DejaFu.SCT.Internal.Weighted 58 | 59 | -- other-modules: 60 | -- other-extensions: 61 | build-depends: base >=4.9 && <5 62 | , concurrency >=1.11 && <1.12 63 | , containers >=0.5 && <0.8 64 | , contravariant >=1.2 && <1.6 65 | , deepseq >=1.1 && <2 66 | , exceptions >=0.7 && <0.11 67 | , leancheck >=0.6 && <2 68 | , profunctors >=4.0 && <6 69 | , random >=1.0 && <1.4 70 | , transformers >=0.5 && <0.7 71 | -- hs-source-dirs: 72 | default-language: Haskell2010 73 | ghc-options: -Wall 74 | -------------------------------------------------------------------------------- /docs/.gitignore: -------------------------------------------------------------------------------- 1 | book 2 | 3 | # generated by the build script 4 | src/index.md 5 | src/release-notes/concurrency.md 6 | src/release-notes/dejafu.md 7 | src/release-notes/hunit-dejafu.md 8 | src/release-notes/tasty-dejafu.md 9 | mdbook-admonish.css 10 | -------------------------------------------------------------------------------- /docs/book.toml: -------------------------------------------------------------------------------- 1 | [book] 2 | title = "Déjà Fu" 3 | authors = ["Michael Walker (barrucadu)"] 4 | description = "Systematic concurrency testing meets Haskell." 5 | language = "en" 6 | multilingual = false 7 | 8 | [build] 9 | create-missing = false 10 | 11 | [output.html] 12 | git-repository-url = "https://github.com/barrucadu/dejafu" 13 | cname = "dejafu.docs.barrucadu.co.uk" 14 | 15 | [preprocessor.admonish] 16 | on_failure = "bail" 17 | command = "mdbook-admonish" 18 | -------------------------------------------------------------------------------- /docs/readthedocs/Makefile: -------------------------------------------------------------------------------- 1 | # Minimal makefile for Sphinx documentation 2 | # 3 | 4 | # You can set these variables from the command line, and also 5 | # from the environment for the first two. 6 | SPHINXOPTS ?= 7 | SPHINXBUILD ?= sphinx-build 8 | SOURCEDIR = source 9 | BUILDDIR = build 10 | 11 | # Put it first so that "make" without argument is like "make help". 12 | help: 13 | @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 14 | 15 | .PHONY: help Makefile 16 | 17 | # Catch-all target: route all unknown targets to Sphinx using the new 18 | # "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). 19 | %: Makefile 20 | @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) 21 | -------------------------------------------------------------------------------- /docs/readthedocs/requirements.txt: -------------------------------------------------------------------------------- 1 | sphinx==7.1.2 2 | sphinx-rtd-theme==1.3.0rc1 3 | -------------------------------------------------------------------------------- /docs/readthedocs/source/conf.py: -------------------------------------------------------------------------------- 1 | # Configuration file for the Sphinx documentation builder. 2 | 3 | # -- Project information 4 | 5 | project = 'Déjà Fu' 6 | copyright = 'Michael Walker (barrucadu)' 7 | author = 'Michael Walker (barrucadu)' 8 | 9 | release = 'HEAD' 10 | version = 'HEAD' 11 | 12 | # -- General configuration 13 | 14 | extensions = [] 15 | 16 | templates_path = ['_templates'] 17 | 18 | # -- Options for HTML output 19 | 20 | html_theme = 'sphinx_rtd_theme' 21 | 22 | # -- Options for EPUB output 23 | epub_show_urls = 'footnote' 24 | -------------------------------------------------------------------------------- /docs/readthedocs/source/index.rst: -------------------------------------------------------------------------------- 1 | The Déjà Fu documentation has moved! 2 | ==================================== 3 | 4 | [Déjà Fu is] A martial art in which the user's limbs move in time 5 | as well as space, […] It is best described as "the feeling that 6 | you have been kicked in the head this way before" 7 | 8 | **Terry Pratchett, Thief of Time** 9 | 10 | `Visit the new documentation website `. 11 | -------------------------------------------------------------------------------- /docs/src/SUMMARY.md: -------------------------------------------------------------------------------- 1 | # Summary 2 | 3 | - [Getting Started](./index.md) 4 | - [Typeclasses](./typeclasses.md) 5 | - [Unit Testing](./unit-testing.md) 6 | - [Refinement Testing](./refinement-testing.md) 7 | - [Advanced Usage](./advanced-usage.md) 8 | 9 | # Migration Guides 10 | 11 | - [1.x to 2.x](./migration-guides/1x-2x.md) 12 | - [0.x to 1.x](./migration-guides/0x-1x.md) 13 | 14 | # Developer Documentation 15 | 16 | - [Contributing](./dev-docs/contributing.md) 17 | - [Supported GHC Versions](./dev-docs/supported-ghc-versions.md) 18 | - [Release Process](./dev-docs/release-process.md) 19 | 20 | # Release Notes 21 | 22 | - [concurrency](./release-notes/concurrency.md) 23 | - [dejafu](./release-notes/dejafu.md) 24 | - [hunit-dejafu](./release-notes/hunit-dejafu.md) 25 | - [tasty-dejafu](./release-notes/tasty-dejafu.md) 26 | -------------------------------------------------------------------------------- /docs/src/advanced-usage.md: -------------------------------------------------------------------------------- 1 | Advanced Usage 2 | ============== 3 | 4 | Déjà Fu tries to have a sensible set of defaults, but there are some 5 | times when the defaults are not suitable. There are a lot of knobs 6 | provided to tweak how things work. 7 | 8 | 9 | Execution settings 10 | ------------------ 11 | 12 | The `autocheckWithSettings`, `dejafuWithSettings`, and `dejafusWithSettings` let 13 | you provide a `Settings` value, which controls some of Déjà Fu's behaviour: 14 | 15 | ```haskell 16 | dejafuWithSettings mySettings "Assert the thing holds" myPredicate myAction 17 | ``` 18 | 19 | The available settings are: 20 | 21 | - **"Way"**, how to explore the behaviours of the program under test. 22 | 23 | - **Length bound**, a cut-off point to terminate an execution even if it's not 24 | done yet. 25 | 26 | - **Memory model**, which affects how non-synchronised operations, such as 27 | `readIORef` and `writeIORef` behave. 28 | 29 | - **Discarding**, which allows throwing away uninteresting results, rather than 30 | keeping them around in memory. 31 | 32 | - **Early exit**, which allows exiting as soon as a result matching a predicate 33 | is found. 34 | 35 | - **Representative traces**, keeping only one execution trace for each distinct 36 | result. 37 | 38 | - **Trace simplification**, rewriting execution traces into a simpler form 39 | (particularly effective with the random testing). 40 | 41 | - **Safe IO**, pruning needless schedules when your IO is only used to manage 42 | thread-local state. 43 | 44 | See the `Test.DejaFu.Settings` module for more information. 45 | 46 | 47 | Performance tuning 48 | ------------------ 49 | 50 | - Are you happy to trade space for time? 51 | 52 | Consider computing the results once and running multiple predicates over the 53 | output: this is what `dejafus` / `testDejafus` / etc does. 54 | 55 | - Can you sacrifice completeness? 56 | 57 | Consider using the random testing functionality. See the `*WithSettings` 58 | functions. 59 | 60 | - Would strictness help? 61 | 62 | Consider using the strict functions in `Test.DejaFu.SCT` (the ones ending 63 | with a `'`). 64 | 65 | - Do you just want the set of results, and don't care about traces? 66 | 67 | Consider using `Test.DejaFu.SCT.resultsSet`. 68 | 69 | - Do you know something about the sort of results you care about? 70 | 71 | Consider discarding results you *don't* care about. See the `*WithSettings` 72 | functions in `Test.DejaFu`, `Test.DejaFu.SCT`, and 73 | `Test.{HUnit,Tasty}.DejaFu`. 74 | 75 | For example, let's say you want to know if your test case deadlocks, but you 76 | don't care about the execution trace, and you are going to sacrifice 77 | completeness because your possible state-space is huge. You could do it like 78 | this: 79 | 80 | ```haskell 81 | dejafuWithSettings 82 | ( set ldiscard 83 | -- "efa" == "either failure a", discard everything but deadlocks 84 | (Just $ \efa -> Just (if either isDeadlock (const False) efa then DiscardTrace else DiscardResultAndTrace)) 85 | . set lway 86 | -- try 10000 executions with random scheduling 87 | (randomly (mkStdGen 42) 10000) 88 | $ defaultSettings 89 | ) 90 | -- the name of the test 91 | "Never Deadlocks" 92 | -- the predicate to check 93 | deadlocksNever 94 | -- your test case 95 | testCase 96 | ``` 97 | -------------------------------------------------------------------------------- /docs/src/dev-docs/release-process.md: -------------------------------------------------------------------------------- 1 | Release Process 2 | =============== 3 | 4 | ```admonish warning 5 | If it's early in the year, make sure you put down the right year in the CHANGELOG! 6 | ``` 7 | 8 | 1. Figure out what the next version number is. See the PVP_ page if unsure. 9 | 10 | 2. Update version numbers in the relevant cabal files: 11 | 12 | * Update the `version` field 13 | * Update the `tag` in the `source-repository` block 14 | 15 | 3. Fill in all `@since unreleased` Haddock comments with the relevant version 16 | number. 17 | 18 | 4. Update version numbers in the tables in the README page. 19 | 20 | 5. Ensure the relevant CHANGELOG files have all the entries they should. 21 | 22 | 6. Add the release information to the relevant CHANGELOG files: 23 | 24 | * Change the `unreleased` title to the version number 25 | * Add the current date 26 | * Add the git tag name 27 | * Add the Hackage URL 28 | * Add the contributors list 29 | 30 | 7. Commit. 31 | 32 | 8. Push to GitHub and wait for GitHub Actions to confirm everything is 33 | OK. If it's not OK, fix what is broken before continuing. 34 | 35 | 9. Merge the PR. 36 | 37 | 10. Tag the merge commit. Tags are in the form `-`, and the 38 | message is the changelog entry. 39 | 40 | 11. Push tags to GitHub. 41 | 42 | When the merge commit successfully builds on `master` the updated packages will 43 | be pushed to Hackage by Concourse. 44 | 45 | 46 | Pro tips 47 | -------- 48 | 49 | * If a release would have a combination of breaking and non-breaking changes, if 50 | possible make two releases: the non-breaking ones first, and then a major 51 | release with the breaking ones. 52 | 53 | This makes it possible for users who don't want the breaking changes to still 54 | benefit from the non-breaking improvements. 55 | 56 | * Before uploading to Hackage, check you have no changes to the files (for 57 | example, temporarily changing the GHC options, or adding `trace` calls, for 58 | debugging reasons). 59 | 60 | `stack upload` will upload the files on the disk, not the files in version 61 | control, so your unwanted changes will be published! 62 | -------------------------------------------------------------------------------- /docs/src/dev-docs/supported-ghc-versions.md: -------------------------------------------------------------------------------- 1 | Supported GHC Versions 2 | ====================== 3 | 4 | Déjà Fu supports the latest four GHC releases, at least. For testing purposes, 5 | we use Stackage snapshots as a proxy for GHC versions. The currently supported 6 | versions are: 7 | 8 | | GHC | Stackage | base | 9 | | --- | -------- | ---- | 10 | | 9.8 | LTS 23.0 | 4.19.2.0 | 11 | | 9.6 | LTS 22.0 | 4.18.1.0 | 12 | | 9.4 | LTS 21.0 | 4.17.0.0 | 13 | | 9.2 | LTS 20.0 | 4.16.0.0 | 14 | | 9.0 | LTS 19.0 | 4.15.0.0 | 15 | | 8.1 | LTS 17.0 | 4.14.1.0 | 16 | | 8.8 | LTS 15.0 | 4.13.0.0 | 17 | | 8.6 | LTS 14.0 | 4.12.0.0 | 18 | | 8.4 | LTS 12.0 | 4.11.0.0 | 19 | | 8.2 | LTS 10.0 | 4.10.1.0 | 20 | 21 | In practice, we may *compile with* older versions of GHC, but keeping them 22 | working is not a priority. 23 | 24 | 25 | Adding new GHC releases 26 | ----------------------- 27 | 28 | When a new version of GHC is released, we need to make some changes for 29 | everything to go smoothly. In general, these changes should only cause a 30 | **patch level version bump**. 31 | 32 | 1. Bump the upper bound of [base][] and set up any needed conditional 33 | compilation 34 | 2. Add the GHC and base versions to the table. 35 | 3. Remove any unsupported versions from the table. 36 | 4. Make a patch release. 37 | 38 | A new GHC release won't get a Stackage snapshot for little while. When it 39 | does: 40 | 41 | 1. Add the snapshot to the GitHub Actions configuration. 42 | 2. Update the resolver in the stack.yaml. 43 | 3. Put the snapshot in the table. 44 | 45 | 46 | Dropping old GHC releases 47 | ------------------------- 48 | 49 | When we want to drop an unsupported version of GHC, we need to bump the version 50 | bound on [base][] to preclude it. This is a backwards-incompatible change which 51 | causes a **major version bump**. 52 | 53 | 1. Remove the dropped GHC version from the GitHub Actions configuration. 54 | 2. Bump the lower bound of [base][]. 55 | 3. Look through the other dependencies. Some may not work with our new lower 56 | bound on [base][], so we should bump those too. 57 | 4. Remove any now-irrelevant conditional compilation (mostly CPP, but there may 58 | also be some cabal file bits). 59 | 5. Make whatever change required the bump. 60 | 6. Make a major release. 61 | 62 | GHC versions shouldn't be dropped just because we can, but here are some good 63 | reasons to do it: 64 | 65 | - We want to bump the lower bounds of a dependency to a version which doesn't 66 | support that GHC. 67 | - We want to add a new dependency which doesn't support that GHC. 68 | - The conditional compilation needed to keep that GHC working is getting 69 | confusing. 70 | 71 | [base]: https://hackage.haskell.org/package/base 72 | -------------------------------------------------------------------------------- /docs/src/migration-guides/0x-1x.md: -------------------------------------------------------------------------------- 1 | 0.x to 1.x 2 | ========== 3 | 4 | [dejafu-1.0.0.0][] is a super-major release which breaks compatibility with 5 | [dejafu-0.x][] quite significantly, but brings with it support for bound 6 | threads, and significantly improves memory usage in the general case. 7 | 8 | Highlights reel: 9 | 10 | - Most predicates now only need to keep around the failures, rather than all 11 | results. 12 | - Support for bound threads (with [concurrency-1.3.0.0][]). 13 | - The `ST` / `IO` interface duplication is gone, everything is now monadic. 14 | - Function parameter order is closer to other testing libraries. 15 | - Much improved API documentation. 16 | 17 | See the changelogs for the full details. 18 | 19 | 20 | `ST` and `IO` functions 21 | ----------------------- 22 | 23 | There is only one set of functions now. Testing bound threads requires being 24 | able to fork actual threads, so testing with `ST` is no longer possible. The 25 | `ConcST` type is gone, there is only `ConcIO`. 26 | 27 | For [dejafu][] change: 28 | 29 | - `autocheckIO` to `autocheck` 30 | - `dejafuIO` to `dejafu` 31 | - `dejafusIO` to `dejafus` 32 | - `autocheckWayIO` to `autocheckWay` 33 | - `dejafuWayIO` to `dejafuWay` 34 | - `dejafusWayIO` to `dejafusWay` 35 | - `dejafuDiscardIO` to `dejafuDiscard` 36 | - `runTestM` to `runTest` 37 | - `runTestWayM` to `runTestWay` 38 | 39 | If you relied on being able to get a pure result from the `ConcST` functions, 40 | you can no longer do this. 41 | 42 | For [hunit-dejafu][] and [tasty-dejafu][] change: 43 | 44 | - `testAutoIO` to `testAuto` 45 | - `testDejafuIO` to `testDejafu` 46 | - `testDejafusIO` to `testDejafus` 47 | - `testAutoWayIO` to `testAutoWay` 48 | - `testDejafuWayIO` to `testDejafuWay` 49 | - `testDejafusWayIO` to `testDejafusWay` 50 | - `testDejafuDiscardIO` to `testDejafuDiscard` 51 | 52 | 53 | Function parameter order 54 | ------------------------ 55 | 56 | Like [HUnit][], the monadic action to test is now the last parameter of the 57 | testing functions. This makes it convenient to write tests without needing to 58 | define the action elsewhere. 59 | 60 | For [dejafu][] change: 61 | 62 | - `dejafu ma (s, p)` to `dejafu s p ma` 63 | - `dejafus ma ps` to `dejafus ps ma` 64 | - `dejafuWay way mem ma (s, p)` to `dejafuWay way mem s p ma` 65 | - `dejafusWay way mem ma ps` to `dejafuWay way mem ps ma` 66 | - `dejafuDiscard d way mem ma (s, p)` to `dejafuDiscard d way mem s p ma` 67 | 68 | For [hunit-dejafu][] and [tasty-dejafu][] change: 69 | 70 | - `testDejafu ma s p` to `testDejafu s p ma` 71 | - `testDejafus ma ps` to `testDejafus ps ma` 72 | - `testDejafuWay way mem ma s p` to `testDejafuWay way mem s p ma` 73 | - `testDejafusWay way mem ma ps` to `testDejafusWay way mem ps ma` 74 | - `testDejafuDiscard d way mem ma s p` to `testDejafuDiscard d way mem s p ma` 75 | 76 | 77 | Predicates 78 | ---------- 79 | 80 | The `Predicate a` type is now an alias for `ProPredicate a a`, defined like so: 81 | 82 | ```haskell 83 | data ProPredicate a b = ProPredicate 84 | { pdiscard :: Either Failure a -> Maybe Discard 85 | -- ^ Selectively discard results before computing the result. 86 | , peval :: [(Either Failure a, Trace)] -> Result b 87 | -- ^ Compute the result with the un-discarded results. 88 | } 89 | ``` 90 | 91 | If you use the predicate helper functions to construct a predicate, you do not 92 | need to change anything (and should get a nice reduction in your resident memory 93 | usage). If you supply a function directly, you can recover the old behaviour 94 | like so: 95 | 96 | ```haskell 97 | old :: ([(Either Failure a, Trace)] -> Result a) -> ProPredicate a a 98 | old p = ProPredicate 99 | { pdiscard = const Nothing 100 | , peval = p 101 | } 102 | ``` 103 | 104 | The `alwaysTrue2` helper function is gone. If you use it, use `alwaysSameOn` or 105 | `alwaysSameBy` instead. 106 | 107 | 108 | Need help? 109 | ---------- 110 | 111 | - For general help talk to me in IRC (barrucadu in #haskell) or shoot me an 112 | email (mike@barrucadu.co.uk) 113 | - For bugs, issues, or requests, please [file an issue][]. 114 | 115 | [dejafu-1.0.0.0]: https://hackage.haskell.org/package/dejafu-1.0.0.0 116 | [dejafu-0.x]: https://hackage.haskell.org/package/dejafu-0.9.1.1 117 | [concurrency-1.3.0.0]: https://hackage.haskell.org/package/concurrency-1.3.0.0 118 | [dejafu]: https://hackage.haskell.org/package/dejafu 119 | [hunit-dejafu]: https://hackage.haskell.org/package/hunit-dejafu 120 | [tasty-dejafu]: https://hackage.haskell.org/package/tasty-dejafu 121 | [HUnit]: https://hackage.haskell.org/package/HUnit 122 | [file an issue]: https://github.com/barrucadu/dejafu/issues/ 123 | -------------------------------------------------------------------------------- /docs/src/migration-guides/1x-2x.md: -------------------------------------------------------------------------------- 1 | 1.x to 2.x 2 | ========== 3 | 4 | [dejafu-2.0.0.0][] is a super-major release which breaks compatibility with 5 | [dejafu-1.x][]. 6 | 7 | Highlights reel: 8 | 9 | - Test cases are written in terms of a new `Program` type. 10 | - The `Failure` type has been replaced with a `Condition` type (actually in 11 | 1.12). 12 | - Random testing takes an optional length bound. 13 | - Atomically-checked invariants over shared mutable state. 14 | 15 | See the changelogs for the full details. 16 | 17 | 18 | The `Program` type 19 | ------------------ 20 | 21 | The `ConcT` type is now an alias for `Program Basic`. 22 | 23 | A `Program Basic` has all the instances `ConcT` did, defined using the `~` 24 | instance trick, so this shouldn't be a breaking change: 25 | 26 | ```haskell 27 | instance (pty ~ Basic) => MonadTrans (Program pty) 28 | instance (pty ~ Basic) => MonadCatch (Program pty n) 29 | instance (pty ~ Basic) => MonadThrow (Program pty n) 30 | instance (pty ~ Basic) => MonadMask (Program pty n) 31 | instance (pty ~ Basic, Monad n) => MonadConc (Program pty n) 32 | instance (pty ~ Basic, MonadIO n) => MonadIO (Program pty n) 33 | ``` 34 | 35 | The `dontCheck` function has been removed in favour of `withSetup`: 36 | 37 | ```haskell 38 | do x <- dontCheck setup 39 | action x 40 | 41 | -- becomes 42 | 43 | withSetup setup action 44 | ``` 45 | 46 | The `subconcurrency` function has been removed in favour of 47 | `withSetupAndTeardown`: 48 | 49 | ```haskell 50 | do x <- setup 51 | y <- subconcurrency (action x) 52 | teardown x y 53 | 54 | -- becomes 55 | 56 | withSetupAndTeardown setup teardown action 57 | ``` 58 | 59 | The `dontCheck` and `subconcurrency` functions used to throw runtime errors if 60 | nested. This is not possible with `withSetup` and `withSetupAndTeardown` due to 61 | their types: 62 | 63 | ```haskell 64 | withSetup 65 | :: Program Basic n x 66 | -- ^ Setup action 67 | -> (x -> Program Basic n a) 68 | -- ^ Main program 69 | -> Program (WithSetup x) n a 70 | 71 | withSetupAndTeardown 72 | :: Program Basic n x 73 | -- ^ Setup action 74 | -> (x -> Either Condition y -> Program Basic n a) 75 | -- ^ Teardown action 76 | -> (x -> Program Basic n y) 77 | -- ^ Main program 78 | -> Program (WithSetupAndTeardown x y) n a 79 | ``` 80 | 81 | Previously, multiple calls to `subconcurrency` could be sequenced in the same 82 | test case. This is not possible using `withSetupAndTeardown`. If you rely on 83 | this behaviour, please [file an issue][]. 84 | 85 | 86 | The `Condition` type 87 | -------------------- 88 | 89 | This is a change in [dejafu-1.12.0.0][dejafu-1.x], but the alias `Failure = 90 | Condition` is removed in [dejafu-2.0.0.0][]. 91 | 92 | - The `STMDeadlock` and `Deadlock` constructors have been merged. 93 | - Internal errors have been split into the `Error` type and are raised as 94 | exceptions, instead of being returned as conditions. 95 | 96 | The name "failure" has been a recurring source of confusion, because an 97 | individual execution can "fail" without the predicate as a whole failing. My 98 | hope is that the more neutral "condition" will prevent this confusion. 99 | 100 | 101 | Deprecated functions 102 | -------------------- 103 | 104 | All the deprecated special-purpose functions have been removed. Use more 105 | general `*WithSettings` functions instead. 106 | 107 | 108 | Need help? 109 | ---------- 110 | 111 | - For general help talk to me in IRC (barrucadu in #haskell) or shoot me an 112 | email (mike@barrucadu.co.uk) 113 | - For bugs, issues, or requests, please [file an issue][]. 114 | 115 | [dejafu-2.0.0.0]: https://hackage.haskell.org/package/dejafu-2.0.0.0 116 | [dejafu-1.x]: https://hackage.haskell.org/package/dejafu-1.12.0.0 117 | [file an issue]: https://github.com/barrucadu/dejafu/issues/ 118 | -------------------------------------------------------------------------------- /docs/src/refinement-testing.md: -------------------------------------------------------------------------------- 1 | Refinement Testing 2 | ================== 3 | 4 | Déjà Fu also supports a form of property-testing where you can check things 5 | about the side-effects of stateful operations. For example, we can assert that 6 | `readMVar` is equivalent to sequencing `takeMVar` and `putMVar` like so: 7 | 8 | ```haskell 9 | prop_mvar_read_take_put = 10 | sig readMVar `equivalentTo` sig (\v -> takeMVar v >>= putMVar v) 11 | ``` 12 | 13 | Given the signature function, `sig`, defined in the next section. If we check 14 | this, our property fails! 15 | 16 | ```text 17 | > check prop_mvar_read_take_put 18 | *** Failure: (seed Just 0) 19 | left: [(Nothing,Just 0)] 20 | right: [(Nothing,Just 0),(Just Deadlock,Just 0)] 21 | False 22 | ``` 23 | 24 | This is because `readMVar` is atomic, whereas sequencing `takeMVar` with 25 | `putMVar` is not, and so another thread can interfere with the `MVar` in the 26 | middle. The `check` and `equivalentTo` functions come from 27 | `Test.DejaFu.Refinement` (also re-exported from `Test.DejaFu`). 28 | 29 | 30 | Signatures 31 | ---------- 32 | 33 | A signature tells the property-tester something about the state your operation 34 | acts upon, it has a few components: 35 | 36 | ```haskell 37 | data Sig s o x = Sig 38 | { initialise :: x -> ConcIO s 39 | , observe :: s -> x -> ConcIO o 40 | , interfere :: s -> x -> ConcIO () 41 | , expression :: s -> ConcIO () 42 | } 43 | ``` 44 | 45 | - `s` is the **state type**, it's the thing which your operations mutate. For 46 | `readMVar`, the state is some `MVar a`. 47 | 48 | - `o` is the **observation type**, it's some pure (and comparable) proxy for a 49 | snapshot of your mutable state. For `MVar a`, the observation is probably a 50 | `Maybe a`. 51 | 52 | - `x` is the **seed type**, it's some pure value used to construct the initial 53 | mutable state. For `MVar a`, the seed is probably a `Maybe a`. 54 | 55 | - `ConcIO` is just one of the instances of `MonadConc` that Déjà Fu defines for 56 | testing purposes. Just write code polymorphic in the monad as usual, and all 57 | will work. 58 | 59 | The `initialise`, `observe`, and `expression` functions should be 60 | self-explanatory, but the `interfere` one may not be. It's the job of the 61 | `interfere` function to change the state in some way; it's run concurrently with 62 | the expression, to simulate the nondeterministic action of other threads. 63 | 64 | Here's a concrete example for our `MVar` example: 65 | 66 | ```haskell 67 | sig :: (MVar ConcIO Int -> ConcIO a) -> Sig (MVar ConcIO Int) (Maybe Int) (Maybe Int) 68 | sig e = Sig 69 | { initialise = maybe newEmptyMVar newMVar 70 | , observe = \v _ -> tryTakeMVar v 71 | , interfere = \v s -> tryTakeMVar v >> maybe (pure ()) (\x -> void $ tryPutMVar v (x * 1000)) s 72 | , expression = void . e 73 | } 74 | ``` 75 | 76 | The `observe` function should be deterministic, but as it is run after the 77 | normal execution ends, it may have side-effects on the state. The `interfere` 78 | function can do just about anything (there are probably some concrete rules for 79 | a good function, but I haven't figured them out yet), but a poor one may result 80 | in the property-checker being unable to distinguish between atomic and nonatomic 81 | expressions. 82 | 83 | 84 | Properties 85 | ---------- 86 | 87 | A property is a pair of signatures linked by one of three provided 88 | functions. These functions are: 89 | 90 | | Function | Operator | Checks that... | 91 | | - | - | - | 92 | | `equivalentTo` | `===` | ... the left and right have exactly the same behaviours | 93 | | `refines` | `=>=` | ... every behaviour of the left is also a behaviour of the right | 94 | | `strictlyRefines` | `->-` | ... `left =>= right` holds but `left === right` does not | 95 | 96 | The signatures can have different state types, as long as the seed and 97 | observation types are the same. This lets you compare different implementations 98 | of the same idea: for example, comparing a concurrent stack implemented using 99 | `MVar` with one implemented using `IORef`. 100 | 101 | Properties can have parameters, given in the obvious way: 102 | 103 | ```haskell 104 | check $ \a b c -> sig1 ... `op` sig2 ... 105 | ``` 106 | 107 | Under the hood, seed and parameter values are generated using the [leancheck][] 108 | package, an enumerative property-based testing library. This means that any 109 | types you use will need to have a `Listable` instance. 110 | 111 | You can also think about the three functions in terms of sets of results, where 112 | a result is a `(Maybe Failure, o)` value. A `Failure` is something like 113 | deadlocking, or being killed by an exception; `o` is the observation type. An 114 | observation is always made, even if execution of the expression fails. 115 | 116 | | Function | Result-set operation | 117 | | - | - | 118 | | `refines` | For all seed and parameter assignments, subset-or-equal | 119 | | `strictlyRefines` | For at least one seed and parameter assignment, proper subset; for all others, subset-or-equal | 120 | | `equivalentTo` | For all seed and parameter assignments, equality | 121 | 122 | Finally, there is an `expectFailure` function, which inverts the expected result 123 | of a property. 124 | 125 | The Déjà Fu testsuite has [a collection of refinement properties][], which may 126 | help you get a feel for this sort of testing. 127 | 128 | [leancheck]: https://hackage.haskell.org/package/leancheck 129 | [a collection of refinement properties]: https://github.com/barrucadu/dejafu/blob/2a15549d97c2fa12f5e8b92ab918fdb34da78281/dejafu-tests/Cases/Refinement.hs 130 | 131 | 132 | Using HUnit and Tasty 133 | --------------------- 134 | 135 | As for unit testing, [HUnit][] and [tasty][] integration is provided for 136 | refinement testing in the [hunit-dejafu][] and [tasty-dejafu][] packages. 137 | 138 | The `testProperty` function is used to check properties. Our example from the 139 | start becomes: 140 | 141 | ```haskell 142 | testProperty "Read is equivalent to Take then Put" prop_mvar_read_take_put 143 | ``` 144 | 145 | [HUnit]: https://hackage.haskell.org/package/HUnit 146 | [tasty]: https://hackage.haskell.org/package/tasty 147 | [hunit-dejafu]: https://hackage.haskell.org/package/hunit-dejafu 148 | [tasty-dejafu]: https://hackage.haskell.org/package/tasty-dejafu 149 | -------------------------------------------------------------------------------- /docs/src/typeclasses.md: -------------------------------------------------------------------------------- 1 | Typeclasses 2 | =========== 3 | 4 | We don't use the regular `Control.Concurrent` and `Control.Exception` modules, 5 | we use typeclass-generalised ones instead from the [concurrency][h:conc] and 6 | [exceptions][h:exc] packages. 7 | 8 | [h:conc]: https://hackage.haskell.org/package/concurrency 9 | [h:exc]: https://hackage.haskell.org/package/exceptions 10 | 11 | 12 | Porting guide 13 | ------------- 14 | 15 | If you want to test some existing code, you'll need to port it to the 16 | appropriate typeclass. The typeclass is necessary, because we can't peek inside 17 | `IO` and `STM` values, so we need to able to plug in an alternative 18 | implementation when testing. 19 | 20 | Fortunately, this tends to be a fairly mechanical and type-driven process: 21 | 22 | 1. Import `Control.Concurrent.Classy.*` instead of `Control.Concurrent.*` 23 | 24 | 2. Import `Control.Monad.Catch` instead of `Control.Exception` 25 | 26 | 3. Change your monad type: 27 | 28 | - `IO a` becomes `MonadConc m => m a` 29 | - `STM a` becomes `MonadSTM stm => stm a` 30 | 31 | 4. Parameterise your state types by the monad: 32 | 33 | - `TVar` becomes `TVar stm` 34 | - `MVar` becomes `MVar m` 35 | - `IORef` becomes `IORef m` 36 | 37 | 5. Some functions are renamed: 38 | 39 | - `forkIO*` becomes `fork*` 40 | - `atomicModifyIORefCAS` becomes `modifyIORefCAS*` 41 | 42 | 6. Fix the type errors 43 | 44 | If you're lucky enough to be starting a new concurrent Haskell project, you can 45 | just program against the `MonadConc` interface. 46 | 47 | 48 | What if I really need I/O? 49 | -------------------------- 50 | 51 | You can use `MonadIO` and `liftIO` with `MonadConc`, for instance if you need to 52 | talk to a database (or just use some existing library which needs real I/O). 53 | 54 | To test `IO`-using code, there are some rules you need to follow: 55 | 56 | 1. Given the same set of scheduling decisions, your `IO` code must be 57 | deterministic (see below). 58 | 59 | 2. As dejafu can't inspect `IO` values, they should be kept small; otherwise 60 | dejafu may miss buggy interleavings. 61 | 62 | 3. You absolutely cannot block on the action of another thread inside `IO`, or 63 | the test execution will just deadlock. 64 | 65 | ```admonish tip 66 | Deterministic `IO` is only essential if you're using the systematic testing (the 67 | default). Nondeterministic `IO` won't break the random testing, it'll just make 68 | things more confusing. 69 | ``` 70 | 71 | 72 | Deriving your own instances 73 | --------------------------- 74 | 75 | There are `MonadConc` and `MonadSTM` instances for many common monad 76 | transformers. In the simple case, where you want an instance for a newtype 77 | wrapper around a type that has an instance, you may be able to derive it. For 78 | example: 79 | 80 | ```haskell 81 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 82 | {-# LANGUAGE StandaloneDeriving #-} 83 | {-# LANGUAGE UndecidableInstances #-} 84 | 85 | data Env = Env 86 | 87 | newtype MyMonad m a = MyMonad { runMyMonad :: ReaderT Env m a } 88 | deriving (Functor, Applicative, Monad) 89 | 90 | deriving instance MonadThrow m => MonadThrow (MyMonad m) 91 | deriving instance MonadCatch m => MonadCatch (MyMonad m) 92 | deriving instance MonadMask m => MonadMask (MyMonad m) 93 | 94 | deriving instance MonadConc m => MonadConc (MyMonad m) 95 | ``` 96 | 97 | `MonadSTM` needs a slightly different set of classes: 98 | 99 | ```haskell 100 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 101 | {-# LANGUAGE StandaloneDeriving #-} 102 | {-# LANGUAGE UndecidableInstances #-} 103 | 104 | data Env = Env 105 | 106 | newtype MyMonad m a = MyMonad { runMyMonad :: ReaderT Env m a } 107 | deriving (Functor, Applicative, Monad, Alternative, MonadPlus) 108 | 109 | deriving instance MonadThrow m => MonadThrow (MyMonad m) 110 | deriving instance MonadCatch m => MonadCatch (MyMonad m) 111 | 112 | deriving instance MonadSTM m => MonadSTM (MyMonad m) 113 | ``` 114 | 115 | Don't be put off by the use of `UndecidableInstances`, it's safe here. 116 | -------------------------------------------------------------------------------- /hunit-dejafu/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015--2017, Michael Walker 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /hunit-dejafu/README.markdown: -------------------------------------------------------------------------------- 1 | hunit-dejafu 2 | ============ 3 | 4 | Integration between the [dejafu][] library for concurrency testing and 5 | [HUnit][]. This lets you easily incorporate concurrency testing into 6 | your existing test suites. 7 | 8 | Contributing 9 | ------------ 10 | 11 | Bug reports, pull requests, and comments are very welcome! 12 | 13 | Feel free to contact me on GitHub, through IRC (#haskell on 14 | libera.chat), or email (mike@barrucadu.co.uk). 15 | 16 | [dejafu]: https://hackage.haskell.org/package/dejafu 17 | [HUnit]: https://hackage.haskell.org/package/HUnit 18 | -------------------------------------------------------------------------------- /hunit-dejafu/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hunit-dejafu/hunit-dejafu.cabal: -------------------------------------------------------------------------------- 1 | -- Initial hunit-dejafu.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: hunit-dejafu 5 | version: 2.0.0.6 6 | synopsis: Deja Fu support for the HUnit test framework. 7 | 8 | description: 9 | Integration between the 10 | library for concurrency testing and 11 | . This lets you 12 | easily incorporate concurrency testing into your existing test 13 | suites. 14 | 15 | homepage: https://github.com/barrucadu/dejafu 16 | license: MIT 17 | license-file: LICENSE 18 | author: Michael Walker 19 | maintainer: mike@barrucadu.co.uk 20 | copyright: (c) 2015--2020 Michael Walker 21 | category: Testing 22 | build-type: Simple 23 | extra-source-files: README.markdown CHANGELOG.rst 24 | cabal-version: >=1.10 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/barrucadu/dejafu.git 29 | 30 | source-repository this 31 | type: git 32 | location: https://github.com/barrucadu/dejafu.git 33 | tag: hunit-dejafu-2.0.0.6 34 | 35 | library 36 | exposed-modules: Test.HUnit.DejaFu 37 | -- other-modules: 38 | -- other-extensions: 39 | build-depends: base >=4.9 && <5 40 | , exceptions >=0.7 && <0.11 41 | , dejafu >=2.0 && <2.5 42 | , HUnit >=1.3.1 && <1.7 43 | -- hs-source-dirs: 44 | default-language: Haskell2010 45 | -------------------------------------------------------------------------------- /lint.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | LINT_FAIL_FATAL=true 4 | if hlint --version | grep "^HLint v1" -q; then 5 | echo "Warning: .hlint.yaml configuration file only supported in HLint v2 and later. NOT considering lint issues an error." 6 | echo 7 | LINT_FAIL_FATAL=false 8 | fi 9 | 10 | LINT_FAIL=false 11 | for package in concurrency dejafu hunit-dejafu tasty-dejafu dejafu-tests; do 12 | if ! hlint --no-summary $package; then 13 | LINT_FAIL=true 14 | fi 15 | done 16 | 17 | if $LINT_FAIL; then 18 | echo "Lint issues found." 19 | if $LINT_FAIL_FATAL; then 20 | exit 1 21 | fi 22 | fi 23 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.0 2 | 3 | packages: 4 | - concurrency 5 | - dejafu 6 | - dejafu-tests 7 | - hunit-dejafu 8 | - tasty-dejafu 9 | 10 | nix: 11 | packages: [git] 12 | -------------------------------------------------------------------------------- /style.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | for package in concurrency dejafu hunit-dejafu tasty-dejafu dejafu-tests; do 4 | find $package -name '*.hs' -exec stylish-haskell -i {} \; 5 | done 6 | -------------------------------------------------------------------------------- /tasty-dejafu/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015--2017, Michael Walker 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /tasty-dejafu/README.markdown: -------------------------------------------------------------------------------- 1 | tasty-dejafu 2 | ============ 3 | 4 | Integration between the [dejafu][] library for concurrency testing and 5 | [tasty][]. This lets you easily incorporate concurrency testing into 6 | your existing test suites. 7 | 8 | Contributing 9 | ------------ 10 | 11 | Bug reports, pull requests, and comments are very welcome! 12 | 13 | Feel free to contact me on GitHub, through IRC (#haskell on 14 | libera.chat), or email (mike@barrucadu.co.uk). 15 | 16 | [dejafu]: https://hackage.haskell.org/package/dejafu 17 | [tasty]: https://hackage.haskell.org/package/tasty 18 | -------------------------------------------------------------------------------- /tasty-dejafu/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /tasty-dejafu/tasty-dejafu.cabal: -------------------------------------------------------------------------------- 1 | -- Initial tasty-dejafu.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: tasty-dejafu 5 | version: 2.1.0.2 6 | synopsis: Deja Fu support for the Tasty test framework. 7 | 8 | description: 9 | Integration between the 10 | library for concurrency testing and 11 | . This lets you 12 | easily incorporate concurrency testing into your existing test 13 | suites. 14 | 15 | homepage: https://github.com/barrucadu/dejafu 16 | license: MIT 17 | license-file: LICENSE 18 | author: Michael Walker 19 | maintainer: mike@barrucadu.co.uk 20 | copyright: (c) 2015--2020 Michael Walker 21 | category: Testing 22 | build-type: Simple 23 | extra-source-files: README.markdown CHANGELOG.rst 24 | cabal-version: >=1.10 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/barrucadu/dejafu.git 29 | 30 | source-repository this 31 | type: git 32 | location: https://github.com/barrucadu/dejafu.git 33 | tag: tasty-dejafu-2.1.0.2 34 | 35 | library 36 | exposed-modules: Test.Tasty.DejaFu 37 | -- other-modules: 38 | -- other-extensions: 39 | build-depends: base >=4.9 && <5 40 | , dejafu >=2.0 && <2.5 41 | , random >=1.0 && <1.4 42 | , tagged >=0.8 && <0.9 43 | , tasty >=0.10 && <1.6 44 | -- hs-source-dirs: 45 | default-language: Haskell2010 46 | --------------------------------------------------------------------------------