├── .envrc ├── .github ├── pull_request_template.md └── workflows │ ├── ci-haddock.sh │ ├── ci.yaml │ ├── publish.yaml │ └── release.yaml ├── .gitignore ├── CODE-OF-CONDUCT.md ├── CONTRIBUTING.md ├── README.md ├── cabal.project ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── nix └── outputs.nix └── quickcheck-dynamic ├── CHANGELOG.md ├── LICENSE ├── NOTICE ├── README.md ├── quickcheck-dynamic.cabal ├── src └── Test │ └── QuickCheck │ ├── DynamicLogic.hs │ ├── DynamicLogic │ ├── CanGenerate.hs │ ├── Internal.hs │ ├── Quantify.hs │ ├── SmartShrinking.hs │ └── Utils.hs │ ├── Extras.hs │ ├── StateModel.hs │ └── StateModel │ └── Variables.hs └── test ├── Spec.hs ├── Spec └── DynamicLogic │ ├── Counters.hs │ ├── Registry.hs │ └── RegistryModel.hs └── Test └── QuickCheck ├── DynamicLogic └── QuantifySpec.hs └── StateModelSpec.hs /.envrc: -------------------------------------------------------------------------------- 1 | use flake 2 | -------------------------------------------------------------------------------- /.github/pull_request_template.md: -------------------------------------------------------------------------------- 1 | *Short description of your PR* 2 | 3 | Checklist: 4 | - [ ] Check source-code formatting is consistent 5 | -------------------------------------------------------------------------------- /.github/workflows/ci-haddock.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -e 3 | 4 | cabal haddock --haddock-tests all 5 | 6 | [ ! -d docs/ ] && mkdir -p docs/ 7 | 8 | doc_indices=$(find dist-newstyle/build -name html -a -type d) 9 | 10 | for index in ${doc_indices}; do 11 | echo "Copying ${index}/* to docs/" 12 | cp -fr ${index}/* docs/ 13 | done 14 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: "CI" 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | 8 | jobs: 9 | build-test: 10 | name: "Build & test" 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: actions/checkout@v2.3.1 14 | with: 15 | repository: input-output-hk/quickcheck-dynamic 16 | # On pull_request events, we want to check out the latest commit of the 17 | # PR, which is different to github.ref (the default, which would point 18 | # to a "fake merge" commit). On push events, the default is fine as it 19 | # refers to the pushed commit. 20 | ref: ${{ github.event.pull_request.head.sha || github.ref }} 21 | # Also ensure we have all history with all tags 22 | fetch-depth: 0 23 | 24 | - name: Prepare nix 25 | uses: cachix/install-nix-action@v22 26 | with: 27 | extra_nix_config: | 28 | accept-flake-config = true 29 | log-lines = 1000 30 | 31 | - name: Github cache ~/.cabal/packages, ~/.cabal/store and dist-newstyle 32 | uses: actions/cache@v4 33 | with: 34 | path: | 35 | ~/.cabal/packages 36 | ~/.cabal/store 37 | dist-newstyle 38 | key: | 39 | cabal-${{ runner.os }}-${{ hashFiles('cabal.project', 'default.nix', 'shell.nix') }} 40 | restore-keys: | 41 | cabal-${{ runner.os }}-${{ hashFiles('cabal.project', 'default.nix', 'shell.nix') }} 42 | 43 | - name: Prepare nix shell 44 | run: 45 | nix develop --build 46 | 47 | - name: Formatting 48 | run: 49 | nix develop --command fourmolu --mode check . 50 | 51 | - name: Build 52 | run: | 53 | nix develop --command cabal update 54 | nix develop --command cabal build all --ghc-options=-Werror 55 | 56 | - name: Test 57 | run: 58 | nix develop --command cabal test all 59 | 60 | - name: Documentation (Haddock) 61 | run: | 62 | nix develop --command .github/workflows/ci-haddock.sh 63 | 64 | - name: Upload Documentation 65 | uses: actions/upload-artifact@v4 66 | with: 67 | name: haddocks 68 | path: ./docs 69 | 70 | documentation: 71 | name: Documentation 72 | needs: [build-test] 73 | runs-on: ubuntu-latest 74 | steps: 75 | - name: Download generated documentation 76 | uses: actions/download-artifact@v4 77 | with: 78 | name: haddocks 79 | path: docs 80 | 81 | - name: Publish Documentation 82 | if: github.event_name == 'push' 83 | uses: peaceiris/actions-gh-pages@v3 84 | with: 85 | github_token: ${{ secrets.GITHUB_TOKEN || github.token }} 86 | publish_dir: docs/ 87 | enable_jekyll: true 88 | force_orphan: true 89 | -------------------------------------------------------------------------------- /.github/workflows/publish.yaml: -------------------------------------------------------------------------------- 1 | name: "Publish" 2 | on: 3 | workflow_dispatch: 4 | jobs: 5 | release: 6 | name: "Pack & Upload" 7 | if: github.ref == 'refs/heads/main' 8 | runs-on: ubuntu-latest 9 | steps: 10 | - name: Download artifact 11 | uses: dawidd6/action-download-artifact@v2 12 | with: 13 | workflow: release.yaml 14 | name: distribution 15 | 16 | - uses: haskell-actions/hackage-publish@v1 17 | with: 18 | hackageToken: ${{ secrets.HACKAGE }} 19 | packagesPath: '.' 20 | docsPath: '.' 21 | publish: true 22 | -------------------------------------------------------------------------------- /.github/workflows/release.yaml: -------------------------------------------------------------------------------- 1 | name: "Release" 2 | on: 3 | push: 4 | # trigger on version tags matching SemVer 5 | tags: 6 | - "[0-9]+.[0-9]+.[0-9]+" 7 | 8 | jobs: 9 | release: 10 | name: "Pack & Upload" 11 | runs-on: ubuntu-latest 12 | steps: 13 | - uses: actions/checkout@v2.3.1 14 | with: 15 | repository: input-output-hk/quickcheck-dynamic 16 | ref: ${{ github.ref }} 17 | # Also ensure we have all history with all tags 18 | fetch-depth: 0 19 | 20 | - name: Prepare nix 21 | uses: cachix/install-nix-action@v22 22 | with: 23 | extra_nix_config: | 24 | accept-flake-config = true 25 | log-lines = 1000 26 | 27 | - name: Github cache ~/.cabal/packages, ~/.cabal/store and dist-newstyle 28 | uses: actions/cache@v4 29 | with: 30 | path: | 31 | ~/.cabal/packages 32 | ~/.cabal/store 33 | dist-newstyle 34 | key: | 35 | cabal-${{ runner.os }}-${{ hashFiles('cabal.project', 'default.nix', 'shell.nix') }} 36 | 37 | - name: Prepare nix shell 38 | run: 39 | nix develop --build 40 | 41 | - name: Cabal check 42 | run: | 43 | cd quickcheck-dynamic 44 | nix develop --command cabal check 45 | 46 | - name: Package 47 | run: | 48 | nix develop --command cabal sdist quickcheck-dynamic 49 | nix develop --command cabal haddock --haddock-for-hackage quickcheck-dynamic 50 | 51 | - name: Get the version 52 | id: get_version 53 | run: echo "VERSION=${GITHUB_REF/refs\/tags\//}" >> $GITHUB_OUTPUT 54 | 55 | - name: Upload distribution 56 | uses: actions/upload-artifact@v2 57 | with: 58 | name: distribution 59 | path: | 60 | ./dist-newstyle/sdist/quickcheck-dynamic-${{ steps.get_version.outputs.VERSION }}.tar.gz 61 | ./dist-newstyle/quickcheck-dynamic-${{ steps.get_version.outputs.VERSION }}-docs.tar.gz 62 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist-newstyle/ 2 | cabal.project.local 3 | *~ 4 | /.direnv/ 5 | .pre-commit-config.yaml 6 | result -------------------------------------------------------------------------------- /CODE-OF-CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | In the interest of fostering an open and welcoming environment, we as 6 | contributors and maintainers pledge to making participation in our project and 7 | our community a harassment-free experience for everyone, regardless of age, body 8 | size, disability, ethnicity, gender identity and expression, level of experience, 9 | education, socio-economic status, nationality, personal appearance, race, 10 | religion, or sexual identity and orientation. 11 | 12 | ## Our Standards 13 | 14 | Examples of behavior that contributes to creating a positive environment 15 | include: 16 | 17 | * Using welcoming and inclusive language 18 | * Being respectful of differing viewpoints and experiences 19 | * Gracefully accepting constructive criticism 20 | * Focusing on what is best for the community 21 | * Showing empathy towards other community members 22 | 23 | Examples of unacceptable behavior by participants include: 24 | 25 | * The use of sexualized language or imagery and unwelcome sexual attention or 26 | advances 27 | * Trolling, insulting/derogatory comments, and personal or political attacks 28 | * Public or private harassment 29 | * Publishing others' private information, such as a physical or electronic 30 | address, without explicit permission 31 | * Other conduct which could reasonably be considered inappropriate in a 32 | professional setting 33 | 34 | ## Our Responsibilities 35 | 36 | Project maintainers are responsible for clarifying the standards of acceptable 37 | behavior and are expected to take appropriate and fair corrective action in 38 | response to any instances of unacceptable behavior. 39 | 40 | Project maintainers have the right and responsibility to remove, edit, or 41 | reject comments, commits, code, wiki edits, issues, and other contributions 42 | that are not aligned to this Code of Conduct, or to ban temporarily or 43 | permanently any contributor for other behaviors that they deem inappropriate, 44 | threatening, offensive, or harmful. 45 | 46 | ## Scope 47 | 48 | This Code of Conduct applies both within project spaces and in public spaces 49 | when an individual is representing the project or its community. Examples of 50 | representing a project or community include using an official project e-mail 51 | address, posting via an official social media account, or acting as an appointed 52 | representative at an online or offline event. Representation of a project may be 53 | further defined and clarified by project maintainers. 54 | 55 | ## Enforcement 56 | 57 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 58 | reported by contacting the project team at {{ email }}. All 59 | complaints will be reviewed and investigated and will result in a response that 60 | is deemed necessary and appropriate to the circumstances. The project team is 61 | obligated to maintain confidentiality with regard to the reporter of an incident. 62 | Further details of specific enforcement policies may be posted separately. 63 | 64 | Project maintainers who do not follow or enforce the Code of Conduct in good 65 | faith may face temporary or permanent repercussions as determined by other 66 | members of the project's leadership. 67 | 68 | ## Attribution 69 | 70 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, 71 | available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html 72 | 73 | [homepage]: https://www.contributor-covenant.org 74 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to quickcheck-dynamic 2 | 3 | Thanks for considering contributing to the development of quickcheck-dynamic. 4 | 5 | The best way to contribute right now is to try things out and provide feedback, 6 | but we also accept contributions to the documentation and the obviously to the 7 | code itself. 8 | 9 | This document contains guidelines to help you get started and how to make sure 10 | your contribution gets accepted. 11 | 12 | ## Communication channels 13 | 14 | Should you have any questions or need some help in getting set up, you can use Github [Discussions](https://github.com/input-output-hk/quickcheck-dynamic/discussions) 15 | to reach out to the team before submitting issues. 16 | 17 | ## Your first contribution 18 | 19 | Contributing to the documentation, reporting bugs or proposing features are awesome ways to get started. 20 | 21 | ### Issues 22 | 23 | Whether reporting a bug or requesting a new feature, use GitHub to [submit an issue](https://github.com/input-output-hk/quickcheck-dynamic/issues/new/). 24 | 25 | For bug reports, it's very important to explain 26 | * what version you used, 27 | * steps to reproduce (or steps you took), 28 | * what behavior you saw (ideally supported by logs), and 29 | * what behavior you expected. 30 | 31 | For feature requests or ideas, we expect a description of: 32 | * why you (or the user) need/want something (e.g. problem, challenge, pain, benefit), and 33 | * what this is roughly about. 34 | 35 | Note that we do NOT require a detailed technical description, but are much more 36 | interested in *why* a feature is needed. This also helps in understanding the 37 | relevance and ultimately the priority of such an item. 38 | 39 | ## Making changes 40 | 41 | When contributing code, it helps to have discussed the rationale and (ideally) 42 | how something is implemented in a feature idea or bug ticket beforehand. 43 | 44 | ### Building & Testing 45 | 46 | See the [README.md](./README.md#building) file for instructions on how to build and test this package. 47 | 48 | ### Creating a pull request 49 | 50 | Thank you for contributing your changes by opening a pull requests! To get 51 | something merged we usually require: 52 | + Description of the changes - if your commit messages are great, this is less important 53 | + Quality of changes is ensured - through new or updated automated tests 54 | + Change is related to an issue, feature (idea) or bug report - ideally discussed beforehand 55 | + Well-scoped - we prefer multiple PRs, rather than a big one 56 | 57 | ### Coding Standards 58 | 59 | * Ensure your code is formatted using [fourmolu](https://github.com/fourmolu/fourmolu) with the provided [configuration file](./fourmolu.yaml). 60 | 61 | ### Versioning & Changelog 62 | 63 | During development 64 | + Make sure `CHANGELOG.md` is kept up-to-date with high-level, technical, but user-focused list of changes according to [keepachangelog](https://keepachangelog.com/en/1.0.0/) 65 | + Bump `UNRELEASED` version in `CHANGELOG.md` according to [Semantic Versioning](https://semver.org/) 66 | 67 | ### Releasing 68 | 69 | To perform a release (requires maintainers' rights on the repository): 70 | + Check version to be released is also correct in software components, e.g. `.cabal` files. 71 | + Replace `UNRELEASED` with a date in [ISO8601](https://en.wikipedia.org/wiki/ISO_8601) 72 | + Create a signed, annotated git tag of the version: `git tag -as `, using the released changes as annotation 73 | + Push the new tag to the remote repository `git push --tags`. This should trigger the [Release](https://github.com/input-output-hk/quickcheck-dynamic/actions/workflows/release.yaml) workflow. 74 | * Note that it's fine to "repush" the tag and retrigger the workflow if a problem is spotted at this moment 75 | * _(Optional)_ Retrieve the artifact attached to the workflow and upload it as a _candidate_ on [Hackage](https://hackage.haskell.org/packages/candidates/upload). This is useful to check everything's right before publishing the release 76 | + Publish package on [Hackage](https://hackage.haskell.org/) by manually triggering the [Publish workflow](https://github.com/input-output-hk/quickcheck-dynamic/actions/workflows/publish.yaml) 77 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # quickcheck-dynamic 2 | 3 |
4 |   5 | 6 |
7 | 8 | A library for testing stateful programs using [QuickCheck](https://hackage.haskell.org/package/QuickCheck) and [dynamic logic](https://en.wikipedia.org/wiki/Dynamic_logic_(modal_logic)). 9 | 10 | ## Documentation 11 | 12 | * The original stateful testing approach is described in John Hughes' research paper: [https://www.cs.tufts.edu/~nr/cs257/archive/john-hughes/quviq-testing.pdf ](https://publications.lib.chalmers.se/records/fulltext/232550/local_232550.pdf) 13 | * The [Registry example](https://github.com/input-output-hk/quickcheck-dynamic/blob/main/quickcheck-dynamic/test/Spec/DynamicLogic/RegistryModel.hs) is a common case study that's been explored in two papers: 14 | * [How well are your requirements tested?](https://publications.lib.chalmers.se/records/fulltext/232552/local_232552.pdf) 15 | * and [Understanding Formal Specifications through Good Examples](https://mengwangoxf.github.io/Papers/Erlang18.pdf) 16 | * The dynamic logic addition allows you to specify that after a generated test sequence, the system is able to reach a specific required state. In other words, you can specify that some "good" state is reachable from any possible state. 17 | 18 | The following talks provide concrete examples on how this approach is used to test smart contracts in Plutus: 19 | * John Hughes high level talk on how to test Plutus smart contracts using this library: https://youtu.be/V9_14jjJiuQ 20 | * 55 minutes in to this lecture an example of using the state machine formalism: https://www.youtube.com/watch?v=zW3D2iM5uVg&t=3300 21 | 22 | The following blog posts and talks provide some more in-depth educational material on quickcheck-dynamic: 23 | * Edsko de Vries wrote a [nice post](https://well-typed.com/blog/2022/09/lockstep-with-quickcheck-dynamic/) to compare `quickcheck-dynamic` with [quickcheck-state-machine](https://hackage.haskell.org/package/quickcheck-state-machine), another library to write model-based tests on top of QuickCheck. This blog post introduces [quickcheck-lockstep](https://github.com/well-typed/quickcheck-lockstep) which provides _lockstep-style_ testing on top of quickcheck-dynamic, 24 | * IOG published an [introductory post](https://engineering.iog.io/2022-09-28-introduce-q-d) on `quickcheck-dynamic`, detailing some rationale and background for this work, and suggesting a step-by-step approach to use it based on some real world experience. 25 | * A [presentation](https://abailly.github.io/slides/model-based-testing-with-quickcheck.html#/title-slide) from [BOBKonf 2024](https://bobkonf.de/2024/en/program.html) which provides a good overview of why one would want to use such a library, how it's been applied in some concrete projects, and some basic understanding of the mechanics. 26 | 27 | ## Building 28 | 29 | ### Without nix 30 | 31 | This package uses [Cabal](https://www.haskell.org/cabal/)-based build. To build from source: 32 | 33 | * Ensure both `ghc` and `cabal` executables are in your `PATH`. 34 | * [ghcup](https://www.haskell.org/ghcup/) is a great way to manage Haskell toolchain. 35 | * quickcheck-dynamic currently requires a GHC version > 8.10 36 | * Run 37 | ``` 38 | cabal update && cabal build all 39 | ``` 40 | * To run tests: 41 | ``` 42 | cabal test all 43 | ``` 44 | 45 | ### With nix 46 | 47 | This repository uses nix to provide a development and build environment. 48 | 49 | For instructions on how to install and configure nix (including how to enable access to our binary caches), refer to [this document](https://github.com/input-output-hk/iogx/blob/main/doc/nix-setup-guide.md). 50 | 51 | If you already have nix installed and configured, you may enter the development shell by running `nix develop`. 52 | 53 | * To enter a shell providing a complete haskell toolchain: 54 | ``` 55 | nix develop 56 | ``` 57 | This can automated using [direnv](https://direnv.net/): 58 | ``` 59 | direnv allow 60 | ``` 61 | * Then go back to [Without nix](#without-nix) instructions 62 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | quickcheck-dynamic 3 | 4 | tests: true 5 | 6 | test-show-details: direct 7 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "QuickCheck Dynamic"; 3 | 4 | 5 | inputs = { 6 | 7 | iogx = { 8 | url = "github:input-output-hk/iogx"; 9 | inputs.hackage.follows = "hackage"; 10 | inputs.CHaP.follows = "CHaP"; 11 | inputs.haskell-nix.follows = "haskell-nix"; 12 | inputs.nixpkgs.follows = "nixpkgs"; 13 | }; 14 | 15 | nixpkgs.follows = "haskell-nix/nixpkgs"; 16 | 17 | hackage = { 18 | url = "github:input-output-hk/hackage.nix"; 19 | flake = false; 20 | }; 21 | 22 | CHaP = { 23 | url = "github:input-output-hk/cardano-haskell-packages?ref=repo"; 24 | flake = false; 25 | }; 26 | 27 | haskell-nix = { 28 | url = "github:input-output-hk/haskell.nix"; 29 | inputs.hackage.follows = "hackage"; 30 | }; 31 | }; 32 | 33 | 34 | outputs = inputs: inputs.iogx.lib.mkFlake { 35 | inherit inputs; 36 | repoRoot = ./.; 37 | systems = [ "x86_64-darwin" "x86_64-linux" "aarch64-darwin" ]; 38 | outputs = import ./nix/outputs.nix; 39 | }; 40 | 41 | 42 | nixConfig = { 43 | extra-substituters = [ 44 | "https://iohk.cachix.org" 45 | "https://cache.iog.io" 46 | ]; 47 | extra-trusted-public-keys = [ 48 | "iohk.cachix.org-1:DpRUyj7h7V830dp/i6Nti+NEO2/nhblbov/8MW7Rqoo=" 49 | "hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ=" 50 | ]; 51 | accept-flake-config = true; 52 | allow-import-from-derivation = true; 53 | }; 54 | } 55 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | comma-style: leading # for lists, tuples etc. - can also be 'trailing' 3 | function-arrows: leading 4 | record-brace-space: false # rec {x = 1} vs. rec{x = 1} 5 | indent-wheres: true # 'false' means save space by only half-indenting the 'where' keyword 6 | diff-friendly-import-export: true # 'false' uses Ormolu-style lists 7 | respectful: true # don't be too opinionated about newlines etc. 8 | haddock-style: single-line # '--' vs. '{-' 9 | newlines-between-decls: 1 # number of newlines between top-level declarations 10 | single-constraint-parens: auto -------------------------------------------------------------------------------- /nix/outputs.nix: -------------------------------------------------------------------------------- 1 | { repoRoot, inputs, pkgs, lib, system }: 2 | 3 | let 4 | 5 | project = lib.iogx.mkHaskellProject { 6 | 7 | cabalProject = pkgs.haskell-nix.cabalProject' { 8 | name = "quickcheck-dynamic"; 9 | src = ../.; 10 | compiler-nix-name = lib.mkDefault "ghc962"; 11 | flake.variants.ghc8107.compiler-nix-name = "ghc8107"; 12 | flake.variants.ghc928.compiler-nix-name = "ghc928"; 13 | shell.withHoogle = false; 14 | inputMap = { 15 | "https://input-output-hk.github.io/cardano-haskell-packages" = inputs.iogx.inputs.CHaP; 16 | }; 17 | }; 18 | 19 | shellArgs = _cabalProject: { 20 | name = "quickcheck-dynamic"; 21 | preCommit = { 22 | cabal-fmt.enable = true; 23 | fourmolu.enable = true; 24 | fourmolu.extraOptions = "-o -XImportQualifiedPost -o -XTypeApplications -o -XPatternSynonyms"; 25 | }; 26 | }; 27 | }; 28 | 29 | in 30 | 31 | [ 32 | ( 33 | project.flake 34 | ) 35 | ] 36 | -------------------------------------------------------------------------------- /quickcheck-dynamic/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | All notable changes to this project will be documented in this file. 4 | 5 | The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/), and this project adheres to [Semantic Versioning](https://semver.org/). 6 | 7 | As a minor extension, we also keep a semantic version for the `UNRELEASED` 8 | changes. 9 | 10 | ## 4.0.0 - 2025-03-12 11 | 12 | * **BREAKING**: Removed `Realized` 13 | - To migrate uses of `Realized` with `IOSim`, index the state type on the choice of `RunModel` monad 14 | and index the relevant types: 15 | ``` 16 | -- Turn: 17 | data ModelState = State { threadId :: Var ThreadId } 18 | -- Into: 19 | data ModelState m = State { threadId :: Var (ThreadId m) } 20 | ``` 21 | * **BREAKING**: Moved `Error state` from `StateModel` to `RunModel` and indexed it on both the `state` and the monad `m` 22 | * **BREAKING**: Changed `PerformResult` from `PerformResult (Error state) a` to `PerformResult state m a` 23 | * Added a `moreActions` property modifier to allow controlling the length of action sequences. 24 | 25 | ## 3.4.1 - 2024-03-22 26 | 27 | * [#70](https://github.com/input-output-hk/quickcheck-dynamic/pull/70) Expose `IsPerformResult` typeclass 28 | 29 | ## 3.4.0 - 2024-03-01 30 | 31 | * Added some lightweight negative-shrinking based on a simple dependency analysis. 32 | * Added the option to return errors from actions by defining `type Error state`. 33 | When this is defined `perform` has return type `m (Either (Error state) (Realized m a))`, 34 | when it is left as the default the type remains `m (Realized m a)`. 35 | * Changed `withGenQ` to _require_ a predicate when defining a `Quantification`. **Note**: This is technically a breaking change as the interface changed 36 | 37 | ## 3.3.1 38 | 39 | * Adapt code to _not_ constrain [mtl](https://hackage.haskell.org/package/mtl) version too much 40 | 41 | ## 3.3.0 42 | 43 | * Added suppport for GHC 9.6.2 compiler 44 | 45 | ## 3.2.0 46 | 47 | * Added support for negative testing via `validFailingAction` and `postconditionOnFailure` 48 | callbacks in `StateModel` and `RunModel`. 49 | 50 | ## 3.1.1 - 2023-06-26 51 | 52 | * Added instances for `HasVariables` with custom error messages to avoid the issue of 53 | missing `Generic` instances causing difficult to understand type errors. 54 | 55 | ## 3.1.0 - 2023-04-10 56 | 57 | * **BREAKING**: Change the type of `postcondition` to allow you to 58 | express property monitoring (e.g. stats or counterexamples) in the 59 | postcondition itself - rather than duplicating code for counterexamples 60 | in the `monitoring` function. 61 | 62 | ## 3.0.3 - 2023-04-18 63 | 64 | * Added `hasNoVariablesQ` and `forAllNonVariableDL` functions to help make 65 | quantification require less boilerplate in `DL` properties. 66 | 67 | ## 3.0.2 - 2023-02-17 68 | 69 | * Added instances of `HasVariables` for Word types 70 | * Exported definition of `HasNoVariables` to make it useable 71 | with deriving via in downstream packages (whoops!) 72 | * Fixed impossible to use `nextVar` arguments to `forAllUniqueDL` 73 | 74 | ## 3.0.1 - 2023-02-15 75 | 76 | * Remove template haskell dependency 77 | 78 | ## 3.0.0 - 2023-02-14 79 | 80 | * **BREAKING**: Add `HasVariables` class to keep track of symbolic variables and automatically insert precondition 81 | checks for well-scopedness of variables. 82 | * **BREAKING**: Remove some unnecessary and unusead features in dynamic logic, including re-running tests from a 83 | counterexample directly. 84 | * Improved printing of counterexamples in DL - they are now printed as code that can be copied more-or-less verbatim to 85 | create a runnable counterexample in code. 86 | * Made the variable context explicit to avoid having to keep track of symbolic variables in the model 87 | * This introduces the `ctxAtType` and `arbitraryVar` functions to use in action generators (c.f. the 88 | `RegistryModel.hs` example). 89 | 90 | ## 2.0.0 - 2022-10-11 91 | 92 | * **BREAKING**: Add `Realized` type family to distinguish between the model- and real type of an action 93 | * **BREAKING**: Introduce `RunModel` type class to interpret Model-generated sequence of actions against real-world implementation 94 | * Move `perform` method from `StateModel` to this new type-class 95 | * Also split `postcondition` and `monitoring` out from the `StateModel` to the `RunModel` type class 96 | * Added Thread registry example based on io-sim concurrency simulation library 97 | 98 | ## 1.1.0 - 2022-08-27 99 | 100 | * Fix broken links in Hackage-generated documentation and link to other Quviq papers 101 | * Add `Show a` constraint on `monitoring` 102 | 103 | ## 1.0.0 104 | 105 | * Initial publication of quickcheck-dynamic library on Hackage 106 | * Provide base `StateModel` and `DynamicLogic` tools to write quickcheck-based models, express properties, and test them 107 | -------------------------------------------------------------------------------- /quickcheck-dynamic/LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | 3 | Version 2.0, January 2004 4 | 5 | http://www.apache.org/licenses/ 6 | 7 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 8 | 9 | 1. Definitions. 10 | 11 | "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. 16 | 17 | "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. 18 | 19 | "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. 20 | 21 | "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. 22 | 23 | "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). 24 | 25 | "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. 26 | 27 | "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." 28 | 29 | "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 30 | 31 | 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 32 | 33 | 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 34 | 35 | 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: 36 | 37 | You must give any other recipients of the Work or Derivative Works a copy of this License; and 38 | You must cause any modified files to carry prominent notices stating that You changed the files; and 39 | You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and 40 | If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. 41 | 42 | You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 43 | 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 44 | 45 | 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 46 | 47 | 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 48 | 49 | 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 50 | 51 | 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. 52 | 53 | END OF TERMS AND CONDITIONS 54 | -------------------------------------------------------------------------------- /quickcheck-dynamic/NOTICE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Input Output (Hong Kong) Ltd. 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | 15 | -------------------------------------------------------------------------------- /quickcheck-dynamic/README.md: -------------------------------------------------------------------------------- 1 | # quickcheck-dynamic 2 | 3 | A library for testing stateful programs using [QuickCheck](https://hackage.haskell.org/package/QuickCheck) and [dynamic logic](https://en.wikipedia.org/wiki/Dynamic_logic_(modal_logic)). 4 | 5 | ## Background 6 | 7 | This library was initially designed by [QuviQ](http://www.quviq.com/) in collaboration with 8 | [IOG](https://iohk.io/) to provide a dedicated test framework for [Plutus](https://docs.cardano.org/plutus/learn-about-plutus) "Smart 9 | contracts". As the need of a _Model-Based Testing_ framework arises in 10 | quite a lot of contexts, it was deemed useful to extract the most 11 | generic part as a standalone package with no strings attached to 12 | Plutus or Cardano. 13 | 14 | ## Usage 15 | 16 | * Documentation is currenly mostly provided inline as Haddock 17 | comments. Checkout [StateModel](https://hackage.haskell.org/package/quickcheck-dynamic/docs/src/Test.QuickCheck.StateModel.html) 18 | and [DynamicLogic](https://hackage.haskell.org/package/quickcheck-dynamic/docs/Test-QuickCheck-DynamicLogic.html) modules for 19 | some usage instructions. 20 | * For a concrete standalone example, have a look at the [`Registry`](https://github.com/input-output-hk/quickcheck-dynamic/blob/main/quickcheck-dynamic/test/Spec/DynamicLogic/Registry.hs) and [`RegistryModel`](https://github.com/input-output-hk/quickcheck-dynamic/blob/main/quickcheck-dynamic/test/Spec/DynamicLogic/RegistryModel.hs) module from the test suite, which respectively implement and model a multithreaded Thread registry inspired by the Erlang version of QuickCheck described in [this article](https://mengwangoxf.github.io/Papers/Erlang18.pdf) 21 | * For more documentation on how to quickcheck-dynamic is used to test 22 | Plutus DApps, check this 23 | [tutorial](https://plutus-apps.readthedocs.io/en/latest/plutus/tutorials/contract-models.html). 24 | * Apart from Plutus, this library is now in use in the 25 | [Hydra](https://github.com/input-output-hk/hydra-poc) project to 26 | verify the _Head Protocol_ implementation with respect to the 27 | original research paper. 28 | -------------------------------------------------------------------------------- /quickcheck-dynamic/quickcheck-dynamic.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: quickcheck-dynamic 3 | version: 4.0.0 4 | license: Apache-2.0 5 | license-files: 6 | LICENSE 7 | NOTICE 8 | 9 | maintainer: sebastian.nagel@iohk.io 10 | author: Ulf Norell 11 | category: Testing 12 | synopsis: A library for stateful property-based testing 13 | homepage: 14 | https://github.com/input-output-hk/quickcheck-dynamic#readme 15 | 16 | bug-reports: 17 | https://github.com/input-output-hk/quickcheck-dynamic/issues 18 | 19 | description: 20 | Please see the README on GitHub at 21 | 22 | build-type: Simple 23 | extra-doc-files: README.md 24 | extra-source-files: CHANGELOG.md 25 | 26 | source-repository head 27 | type: git 28 | location: https://github.com/input-output-hk/quickcheck-dynamic 29 | 30 | common lang 31 | default-language: Haskell2010 32 | default-extensions: 33 | ConstraintKinds 34 | DataKinds 35 | DefaultSignatures 36 | DeriveDataTypeable 37 | DeriveFoldable 38 | DeriveFunctor 39 | DeriveGeneric 40 | DeriveTraversable 41 | DerivingVia 42 | FlexibleContexts 43 | FlexibleInstances 44 | GADTs 45 | GeneralizedNewtypeDeriving 46 | ImportQualifiedPost 47 | LambdaCase 48 | MultiParamTypeClasses 49 | MultiWayIf 50 | PatternSynonyms 51 | QuantifiedConstraints 52 | RankNTypes 53 | ScopedTypeVariables 54 | StandaloneDeriving 55 | TupleSections 56 | TypeApplications 57 | TypeFamilies 58 | TypeOperators 59 | ViewPatterns 60 | 61 | ghc-options: 62 | -Wall -Wnoncanonical-monad-instances -Wunused-packages 63 | -Wincomplete-uni-patterns -Wincomplete-record-updates 64 | -Wredundant-constraints -Widentities -Wno-unused-do-bind 65 | 66 | library 67 | import: lang 68 | hs-source-dirs: src 69 | exposed-modules: 70 | Test.QuickCheck.DynamicLogic 71 | Test.QuickCheck.DynamicLogic.CanGenerate 72 | Test.QuickCheck.DynamicLogic.Internal 73 | Test.QuickCheck.DynamicLogic.Quantify 74 | Test.QuickCheck.DynamicLogic.SmartShrinking 75 | Test.QuickCheck.DynamicLogic.Utils 76 | Test.QuickCheck.Extras 77 | Test.QuickCheck.StateModel 78 | Test.QuickCheck.StateModel.Variables 79 | 80 | build-depends: 81 | , base >=4.7 && <5 82 | , containers 83 | , mtl 84 | , QuickCheck 85 | , random 86 | 87 | test-suite quickcheck-dynamic-test 88 | import: lang 89 | type: exitcode-stdio-1.0 90 | main-is: Spec.hs 91 | hs-source-dirs: test 92 | other-modules: 93 | Spec.DynamicLogic.Counters 94 | Spec.DynamicLogic.Registry 95 | Spec.DynamicLogic.RegistryModel 96 | Test.QuickCheck.DynamicLogic.QuantifySpec 97 | Test.QuickCheck.StateModelSpec 98 | 99 | ghc-options: -rtsopts 100 | build-depends: 101 | , base 102 | , containers 103 | , mtl 104 | , QuickCheck 105 | , quickcheck-dynamic 106 | , stm 107 | , tasty 108 | , tasty-hunit 109 | , tasty-quickcheck 110 | -------------------------------------------------------------------------------- /quickcheck-dynamic/src/Test/QuickCheck/DynamicLogic.hs: -------------------------------------------------------------------------------- 1 | -- | Monadic interface for writing /Dynamic Logic/ properties. 2 | -- 3 | -- This interface offers a much nicer experience than manipulating the 4 | -- expressions it is implemented on top of, especially as it improves 5 | -- readability. It's still possible to express properties as pure 6 | -- expressions using the `Test.QuickCheck.DynamicLogic.Internal` module 7 | -- and it might make sense depending on the context and the kind of 8 | -- properties one wants to express. 9 | module Test.QuickCheck.DynamicLogic ( 10 | DL, 11 | action, 12 | failingAction, 13 | anyAction, 14 | anyActions, 15 | anyActions_, 16 | stopping, 17 | weight, 18 | getSize, 19 | getModelStateDL, 20 | getVarContextDL, 21 | forAllVar, 22 | assert, 23 | assertModel, 24 | monitorDL, 25 | forAllQ, 26 | forAllNonVariableQ, 27 | forAllDL, 28 | forAllMappedDL, 29 | forAllUniqueDL, 30 | DL.DynLogicModel (..), 31 | module Test.QuickCheck.DynamicLogic.Quantify, 32 | ) where 33 | 34 | import Control.Applicative 35 | import Control.Monad 36 | import Data.Typeable 37 | import Test.QuickCheck hiding (getSize) 38 | import Test.QuickCheck.DynamicLogic.Internal qualified as DL 39 | import Test.QuickCheck.DynamicLogic.Quantify 40 | import Test.QuickCheck.StateModel 41 | 42 | -- | The `DL` monad provides a nicer interface to dynamic logic formulae than the plain API. 43 | -- It's a continuation monad producing a `DL.DynFormula` formula, with a state component (with 44 | -- variable context) threaded through. 45 | newtype DL s a = DL {unDL :: Annotated s -> (a -> Annotated s -> DL.DynFormula s) -> DL.DynFormula s} 46 | deriving (Functor) 47 | 48 | instance Applicative (DL s) where 49 | pure x = DL $ \s k -> k x s 50 | (<*>) = ap 51 | 52 | instance Alternative (DL s) where 53 | empty = DL $ \_ _ -> DL.ignore 54 | DL h <|> DL j = DL $ \s k -> h s k DL.||| j s k 55 | 56 | instance Monad (DL s) where 57 | return = pure 58 | DL h >>= j = DL $ \s k -> h s $ \x s1 -> unDL (j x) s1 k 59 | 60 | instance MonadFail (DL s) where 61 | fail = errorDL 62 | 63 | action :: (Typeable a, Eq (Action s a), Show (Action s a)) => Action s a -> DL s (Var a) 64 | action cmd = DL $ \_ k -> DL.after cmd k 65 | 66 | failingAction :: (Typeable a, Eq (Action s a), Show (Action s a)) => Action s a -> DL s () 67 | failingAction cmd = DL $ \_ k -> DL.afterNegative cmd (k ()) 68 | 69 | anyAction :: DL s () 70 | anyAction = DL $ \_ k -> DL.afterAny $ k () 71 | 72 | anyActions :: Int -> DL s () 73 | anyActions n = 74 | stopping 75 | <|> pure () 76 | <|> (weight (fromIntegral n) >> anyAction >> anyActions n) 77 | 78 | -- average number of actions same as average length of a list 79 | anyActions_ :: DL s () 80 | anyActions_ = do 81 | n <- getSize 82 | anyActions (n `div` 2 + 1) 83 | 84 | stopping :: DL s () 85 | stopping = DL $ \s k -> DL.toStop (k () s) 86 | 87 | weight :: Double -> DL s () 88 | weight w = DL $ \s k -> DL.weight w (k () s) 89 | 90 | getSize :: DL s Int 91 | getSize = DL $ \s k -> DL.withSize $ \n -> k n s 92 | 93 | getModelStateDL :: DL s s 94 | getModelStateDL = DL $ \s k -> k (underlyingState s) s 95 | 96 | getVarContextDL :: DL s VarContext 97 | getVarContextDL = DL $ \s k -> k (vars s) s 98 | 99 | forAllVar :: forall a s. Typeable a => DL s (Var a) 100 | forAllVar = do 101 | xs <- ctxAtType <$> getVarContextDL 102 | forAllQ $ elementsQ xs 103 | 104 | errorDL :: String -> DL s a 105 | errorDL name = DL $ \_ _ -> DL.errorDL name 106 | 107 | -- | Fail if the boolean is @False@. 108 | -- 109 | -- Equivalent to 110 | -- 111 | -- @ 112 | -- assert msg b = unless b (fail msg) 113 | -- @ 114 | assert :: String -> Bool -> DL s () 115 | assert name b = if b then return () else errorDL name 116 | 117 | assertModel :: String -> (s -> Bool) -> DL s () 118 | assertModel name p = assert name . p =<< getModelStateDL 119 | 120 | monitorDL :: (Property -> Property) -> DL s () 121 | monitorDL f = DL $ \s k -> DL.monitorDL f (k () s) 122 | 123 | -- | Generate a random value using the given `Quantification` (or list/tuple of quantifications). 124 | -- Generated values will only shrink to smaller values that could also have been generated. 125 | forAllQ :: Quantifiable q => q -> DL s (Quantifies q) 126 | forAllQ q = DL $ \s k -> DL.forAllQ q $ \x -> k x s 127 | 128 | -- | Generate a random value using the given `Quantification` (or list/tuple of quantifications). 129 | -- Generated values will only shrink to smaller values that could also have been generated. 130 | forAllNonVariableQ :: QuantifyConstraints (HasNoVariables a) => Quantification a -> DL s a 131 | forAllNonVariableQ q = DL $ \s k -> DL.forAllQ (hasNoVariablesQ q) $ \(HasNoVariables x) -> k x s 132 | 133 | runDL :: Annotated s -> DL s () -> DL.DynFormula s 134 | runDL s dl = unDL dl s $ \_ _ -> DL.passTest 135 | 136 | forAllUniqueDL 137 | :: (DL.DynLogicModel s, Testable a) 138 | => Annotated s 139 | -> DL s () 140 | -> (Actions s -> a) 141 | -> Property 142 | forAllUniqueDL initState d = DL.forAllUniqueScripts initState (runDL initState d) 143 | 144 | forAllDL 145 | :: (DL.DynLogicModel s, Testable a) 146 | => DL s () 147 | -> (Actions s -> a) 148 | -> Property 149 | forAllDL d = DL.forAllScripts (runDL initialAnnotatedState d) 150 | 151 | forAllMappedDL 152 | :: (DL.DynLogicModel s, Testable a) 153 | => (rep -> DL.DynLogicTest s) 154 | -> (DL.DynLogicTest s -> rep) 155 | -> (Actions s -> srep) 156 | -> DL s () 157 | -> (srep -> a) 158 | -> Property 159 | forAllMappedDL to from fromScript d prop = 160 | DL.forAllMappedScripts to from (runDL initialAnnotatedState d) (prop . fromScript) 161 | -------------------------------------------------------------------------------- /quickcheck-dynamic/src/Test/QuickCheck/DynamicLogic/CanGenerate.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.DynamicLogic.CanGenerate (canGenerate) where 2 | 3 | import System.IO.Unsafe 4 | import Test.QuickCheck 5 | 6 | -- | @canGenerate prob g p@ 7 | -- returns @False@ if we are sure @Prob(g generates x satisfying p) >= prob@ 8 | -- otherwise @True@ (and we know such an x can be generated). 9 | canGenerate :: Double -> Gen a -> (a -> Bool) -> Bool 10 | canGenerate prob g p = unsafePerformIO $ tryToGenerate 1 11 | where 12 | tryToGenerate luck 13 | | luck < eps = return False 14 | | otherwise = do 15 | x <- generate g 16 | if p x 17 | then return True 18 | else tryToGenerate (luck * (1 - prob)) 19 | 20 | -- Our confidence level is 1-eps 21 | eps = 1.0e-9 22 | -------------------------------------------------------------------------------- /quickcheck-dynamic/src/Test/QuickCheck/DynamicLogic/Internal.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.DynamicLogic.Internal where 2 | 3 | import Control.Applicative 4 | import Control.Arrow (second) 5 | import Control.Monad 6 | import Data.Typeable 7 | import Test.QuickCheck hiding (generate) 8 | import Test.QuickCheck.DynamicLogic.CanGenerate 9 | import Test.QuickCheck.DynamicLogic.Quantify 10 | import Test.QuickCheck.DynamicLogic.SmartShrinking 11 | import Test.QuickCheck.DynamicLogic.Utils qualified as QC 12 | import Test.QuickCheck.StateModel 13 | 14 | -- | A `DynFormula` may depend on the QuickCheck size parameter 15 | newtype DynFormula s = DynFormula {unDynFormula :: Int -> DynLogic s} 16 | 17 | -- | Base Dynamic logic formulae language. 18 | -- Formulae are parameterised 19 | -- over the type of state `s` to which they apply. A `DynLogic` value 20 | -- cannot be constructed directly, one has to use the various "smart 21 | -- constructors" provided, see the /Building formulae/ section. 22 | data DynLogic s 23 | = -- | False 24 | EmptySpec 25 | | -- | True 26 | Stop 27 | | -- | After any action the predicate should hold 28 | AfterAny (DynPred s) 29 | | -- | Choice (angelic or demonic) 30 | Alt ChoiceType (DynLogic s) (DynLogic s) 31 | | -- | Prefer this branch if trying to stop. 32 | Stopping (DynLogic s) 33 | | -- | After a specific action the predicate should hold 34 | forall a. 35 | (Eq (Action s a), Show (Action s a), Typeable a) => 36 | After (ActionWithPolarity s a) (Var a -> DynPred s) 37 | | Error String (DynPred s) 38 | | -- | Adjust the probability of picking a branch 39 | Weight Double (DynLogic s) 40 | | -- | Generating a random value 41 | forall a. 42 | QuantifyConstraints a => 43 | ForAll (Quantification a) (a -> DynLogic s) 44 | | -- | Apply a QuickCheck property modifier (like `tabulate` or `collect`) 45 | Monitor (Property -> Property) (DynLogic s) 46 | 47 | data ChoiceType = Angelic | Demonic 48 | deriving (Eq, Show) 49 | 50 | type DynPred s = Annotated s -> DynLogic s 51 | 52 | -- * Building formulae 53 | 54 | -- | Ignore this formula, i.e. backtrack and try something else. @forAllScripts ignore (const True)@ 55 | -- will discard all test cases (equivalent to @False ==> True@). 56 | ignore :: DynFormula s 57 | ignore = DynFormula . const $ EmptySpec 58 | 59 | -- | `True` for DL formulae. 60 | passTest :: DynFormula s 61 | passTest = DynFormula . const $ Stop 62 | 63 | -- | Given `f` must be `True` given /any/ state. 64 | afterAny :: (Annotated s -> DynFormula s) -> DynFormula s 65 | afterAny f = DynFormula $ \n -> AfterAny $ \s -> unDynFormula (f s) n 66 | 67 | afterPolar 68 | :: (Typeable a, Eq (Action s a), Show (Action s a)) 69 | => ActionWithPolarity s a 70 | -> (Var a -> Annotated s -> DynFormula s) 71 | -> DynFormula s 72 | afterPolar act f = DynFormula $ \n -> After act $ \x s -> unDynFormula (f x s) n 73 | 74 | -- | Given `f` must be `True` after /some/ action. 75 | -- `f` is passed the state resulting from executing the `Action`. 76 | after 77 | :: (Typeable a, Eq (Action s a), Show (Action s a)) 78 | => Action s a 79 | -> (Var a -> Annotated s -> DynFormula s) 80 | -> DynFormula s 81 | after act f = afterPolar (ActionWithPolarity act PosPolarity) f 82 | 83 | -- | Given `f` must be `True` after /some/ negative action. 84 | -- `f` is passed the state resulting from executing the `Action` 85 | -- as a negative action. 86 | afterNegative 87 | :: (Typeable a, Eq (Action s a), Show (Action s a)) 88 | => Action s a 89 | -> (Annotated s -> DynFormula s) 90 | -> DynFormula s 91 | afterNegative act f = afterPolar (ActionWithPolarity act NegPolarity) (const f) 92 | 93 | -- | Disjunction for DL formulae. 94 | -- Is `True` if either formula is `True`. The choice is /angelic/, ie. it is 95 | -- always made by the "caller". This is mostly important in case a test is 96 | -- `Stuck`. 97 | (|||) :: DynFormula s -> DynFormula s -> DynFormula s 98 | -- In formulae, we use only angelic choice. But it becomes demonic 99 | -- after one step (that is, the choice has been made). 100 | DynFormula f ||| DynFormula g = DynFormula $ \n -> Alt Angelic (f n) (g n) 101 | 102 | -- | First-order quantification of variables. 103 | -- Formula @f@ is `True` iff. it is `True` /for all/ possible values of `q`. The 104 | -- underlying framework will generate values of `q` and check the formula holds 105 | -- for those values. `Quantifiable` values are thus values that can be generated 106 | -- and checked and the `Test.QuickCheck.DynamicLogic.Quantify` module defines 107 | -- basic combinators to build those from building blocks. 108 | forAllQ 109 | :: Quantifiable q 110 | => q 111 | -> (Quantifies q -> DynFormula s) 112 | -> DynFormula s 113 | forAllQ q f 114 | | isEmptyQ q' = ignore 115 | | otherwise = DynFormula $ \n -> ForAll q' $ ($ n) . unDynFormula . f 116 | where 117 | q' = quantify q 118 | 119 | -- | Adjust weight for selecting formula. 120 | -- This is mostly useful in relation with `(|||)` combinator, in order to tweak the 121 | -- priority for generating the next step(s) of the test that matches the formula. 122 | weight :: Double -> DynFormula s -> DynFormula s 123 | weight w f = DynFormula $ Weight w . unDynFormula f 124 | 125 | -- | Get the current QuickCheck size parameter. 126 | withSize :: (Int -> DynFormula s) -> DynFormula s 127 | withSize f = DynFormula $ \n -> unDynFormula (f n) n 128 | 129 | -- | Prioritise doing this if we are 130 | -- trying to stop generation. 131 | toStop :: DynFormula s -> DynFormula s 132 | toStop (DynFormula f) = DynFormula $ Stopping . f 133 | 134 | -- | Successfully ends the test. 135 | done :: Annotated s -> DynFormula s 136 | done _ = passTest 137 | 138 | -- | Ends test with given error message. 139 | errorDL :: String -> DynFormula s 140 | errorDL s = DynFormula . const $ Error s (const EmptySpec) 141 | 142 | -- | Embed QuickCheck's monitoring functions (eg. `label`, `tabulate`) in 143 | -- a formula. 144 | -- This is useful to improve the reporting from test execution, esp. in the 145 | -- case of failures. 146 | monitorDL :: (Property -> Property) -> DynFormula s -> DynFormula s 147 | monitorDL m (DynFormula f) = DynFormula $ Monitor m . f 148 | 149 | -- | Formula should hold at any state. 150 | -- In effect this leads to exploring alternatives from a given state `s` and ensuring 151 | -- formula holds in all those states. 152 | always :: (Annotated s -> DynFormula s) -> (Annotated s -> DynFormula s) 153 | always p s = withSize $ \n -> toStop (p s) ||| p s ||| weight (fromIntegral n) (afterAny (always p)) 154 | 155 | data FailingAction s 156 | = ErrorFail String 157 | | forall a. (Typeable a, Eq (Action s a)) => ActionFail (ActionWithPolarity s a) 158 | 159 | instance StateModel s => HasVariables (FailingAction s) where 160 | getAllVariables ErrorFail{} = mempty 161 | getAllVariables (ActionFail a) = getAllVariables a 162 | 163 | instance StateModel s => Eq (FailingAction s) where 164 | ErrorFail s == ErrorFail s' = s == s' 165 | ActionFail (a :: ActionWithPolarity s a) == ActionFail (a' :: ActionWithPolarity s' a') 166 | | Just Refl <- eqT @a @a' = a == a' 167 | _ == _ = False 168 | 169 | instance StateModel s => Show (FailingAction s) where 170 | show (ErrorFail s) = "Error " ++ show s 171 | show (ActionFail (ActionWithPolarity a pol)) = show pol ++ " : " ++ show a 172 | 173 | data DynLogicTest s 174 | = BadPrecondition (TestSequence s) (FailingAction s) (Annotated s) 175 | | Looping (TestSequence s) 176 | | Stuck (TestSequence s) (Annotated s) 177 | | DLScript (TestSequence s) 178 | 179 | data Witnesses r where 180 | Do :: r -> Witnesses r 181 | Witness :: QuantifyConstraints a => a -> Witnesses r -> Witnesses r 182 | 183 | discardWitnesses :: Witnesses r -> r 184 | discardWitnesses (Do r) = r 185 | discardWitnesses (Witness _ k) = discardWitnesses k 186 | 187 | pattern Witnesses :: Witnesses () -> r -> Witnesses r 188 | pattern Witnesses w r <- ((\wit -> (void wit, discardWitnesses wit)) -> (w, r)) 189 | where 190 | Witnesses w r = r <$ w 191 | 192 | {-# COMPLETE Witnesses #-} 193 | 194 | deriving instance Functor Witnesses 195 | deriving instance Foldable Witnesses 196 | deriving instance Traversable Witnesses 197 | 198 | instance Eq r => Eq (Witnesses r) where 199 | Do r == Do r' = r == r' 200 | Witness (a :: a) k == Witness (a' :: a') k' = 201 | case eqT @a @a' of 202 | Just Refl -> a == a' && k == k' 203 | Nothing -> False 204 | _ == _ = False 205 | 206 | instance Show r => Show (Witnesses r) where 207 | show (Do r) = "Do $ " ++ show r 208 | show (Witness a k) = "Witness (" ++ show a ++ " :: " ++ show (typeOf a) ++ ")\n" ++ show k -- TODO 209 | 210 | type TestStep s = Witnesses (Step s) 211 | 212 | newtype TestSequence s = TestSeq (Witnesses (TestContinuation s)) 213 | 214 | deriving instance StateModel s => Show (TestSequence s) 215 | deriving instance StateModel s => Eq (TestSequence s) 216 | 217 | data TestContinuation s 218 | = ContStep (Step s) (TestSequence s) 219 | | ContStop 220 | 221 | pattern TestSeqStop :: TestSequence s 222 | pattern TestSeqStop = TestSeq (Do ContStop) 223 | 224 | pattern TestSeqStep :: Step s -> TestSequence s -> TestSequence s 225 | pattern TestSeqStep s ss = TestSeq (Do (ContStep s ss)) 226 | 227 | -- The `()` are the constraints required to use the pattern, and the `(Typeable a, ...)` are the 228 | -- ones provided when you do (including a fresh type variable `a`). 229 | -- See https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/pattern_synonyms.html#typing-of-pattern-synonyms 230 | pattern TestSeqWitness :: () => forall a. QuantifyConstraints a => a -> TestSequence s -> TestSequence s 231 | pattern TestSeqWitness a ss <- TestSeq (Witness a (TestSeq -> ss)) 232 | where 233 | TestSeqWitness a (TestSeq ss) = TestSeq (Witness a ss) 234 | 235 | {-# COMPLETE TestSeqWitness, TestSeqStep, TestSeqStop #-} 236 | 237 | deriving instance StateModel s => Show (TestContinuation s) 238 | deriving instance StateModel s => Eq (TestContinuation s) 239 | 240 | consSeq :: TestStep s -> TestSequence s -> TestSequence s 241 | consSeq step ss = TestSeq $ flip ContStep ss <$> step 242 | 243 | unconsSeq :: TestSequence s -> Maybe (TestStep s, TestSequence s) 244 | unconsSeq (TestSeq ss) = 245 | case discardWitnesses ss of 246 | ContStop -> Nothing 247 | ContStep s rest -> Just (s <$ ss, rest) 248 | 249 | unstopSeq :: TestSequence s -> Maybe (Witnesses ()) 250 | unstopSeq (TestSeq ss) = 251 | case discardWitnesses ss of 252 | ContStop -> Just $ () <$ ss 253 | ContStep{} -> Nothing 254 | 255 | pattern TestSeqStopW :: Witnesses () -> TestSequence s 256 | pattern TestSeqStopW w <- (unstopSeq -> Just w) 257 | where 258 | TestSeqStopW w = TestSeq (ContStop <$ w) 259 | 260 | pattern (:>) :: TestStep s -> TestSequence s -> TestSequence s 261 | pattern step :> ss <- (unconsSeq -> Just (step, ss)) 262 | where 263 | step :> ss = consSeq step ss 264 | 265 | {-# COMPLETE TestSeqStopW, (:>) #-} 266 | 267 | nullSeq :: TestSequence s -> Bool 268 | nullSeq TestSeqStop = True 269 | nullSeq _ = False 270 | 271 | dropSeq :: Int -> TestSequence s -> TestSequence s 272 | dropSeq n _ | n < 0 = error "dropSeq: negative number" 273 | dropSeq 0 ss = ss 274 | dropSeq _ TestSeqStop = TestSeqStop 275 | dropSeq n (TestSeqWitness _ ss) = dropSeq (n - 1) ss 276 | dropSeq n (TestSeqStep _ ss) = dropSeq (n - 1) ss 277 | 278 | getContinuation :: TestSequence s -> TestSequence s 279 | getContinuation (TestSeq w) = case discardWitnesses w of 280 | ContStop -> TestSeqStop 281 | ContStep _ s -> s 282 | 283 | unlines' :: [String] -> String 284 | unlines' [] = "" 285 | unlines' xs = init $ unlines xs 286 | 287 | prettyTestSequence :: VarContext -> TestSequence s -> String 288 | prettyTestSequence ctx ss = unlines' $ zipWith (++) ("do " : repeat " ") $ prettySeq ss 289 | where 290 | prettySeq (TestSeqStopW w) = prettyWitnesses w 291 | prettySeq (Witnesses w step :> ss') = prettyWitnesses w ++ show (WithUsedVars ctx step) : prettySeq ss' 292 | 293 | prettyWitnesses :: Witnesses () -> [String] 294 | prettyWitnesses (Witness a w) = ("_ <- forAllQ $ exactlyQ $ " ++ show a) : prettyWitnesses w 295 | prettyWitnesses Do{} = [] 296 | 297 | instance StateModel s => Show (DynLogicTest s) where 298 | show (BadPrecondition ss bad s) = 299 | prettyTestSequence (usedVariables ss <> allVariables bad) ss 300 | ++ "\n -- In state: " 301 | ++ show s 302 | ++ "\n " 303 | ++ prettyBad bad 304 | where 305 | prettyBad :: FailingAction s -> String 306 | prettyBad (ErrorFail e) = "assert " ++ show e ++ " False" 307 | prettyBad (ActionFail (ActionWithPolarity a p)) = f ++ " $ " ++ show a ++ " -- Failed precondition\n pure ()" 308 | where 309 | f 310 | | p == PosPolarity = "action" 311 | | otherwise = "failingAction" 312 | show (Looping ss) = prettyTestSequence (usedVariables ss) ss ++ "\n pure ()\n -- Looping" 313 | show (Stuck ss s) = prettyTestSequence (usedVariables ss) ss ++ "\n pure ()\n -- Stuck in state " ++ show s 314 | show (DLScript ss) = prettyTestSequence (usedVariables ss) ss ++ "\n pure ()\n" 315 | 316 | usedVariables :: forall s. StateModel s => TestSequence s -> VarContext 317 | usedVariables = go initialAnnotatedState 318 | where 319 | go :: Annotated s -> TestSequence s -> VarContext 320 | go aState TestSeqStop = allVariables (underlyingState aState) 321 | go aState (TestSeqWitness a ss) = allVariables a <> go aState ss 322 | go aState (TestSeqStep step@(_ := act) ss) = 323 | allVariables act 324 | <> allVariables (underlyingState aState) 325 | <> go (nextStateStep step aState) ss 326 | 327 | -- | Restricted calls are not generated by "AfterAny"; they are included 328 | -- in tests explicitly using "After" in order to check specific 329 | -- properties at controlled times, so they are likely to fail if 330 | -- invoked at other times. 331 | class StateModel s => DynLogicModel s where 332 | restricted :: Action s a -> Bool 333 | restricted _ = False 334 | 335 | restrictedPolar :: DynLogicModel s => ActionWithPolarity s a -> Bool 336 | restrictedPolar (ActionWithPolarity a _) = restricted a 337 | 338 | -- * Generate Properties 339 | 340 | -- | Simplest "execution" function for `DynFormula`. 341 | -- Turns a given a `DynFormula` paired with an interpreter function to produce some result from an 342 | -- `Actions` sequence into a proper `Property` that can be run by QuickCheck. 343 | forAllScripts 344 | :: (DynLogicModel s, Testable a) 345 | => DynFormula s 346 | -> (Actions s -> a) 347 | -> Property 348 | forAllScripts = forAllMappedScripts id id 349 | 350 | -- | `Property` function suitable for formulae without choice. 351 | forAllUniqueScripts 352 | :: (DynLogicModel s, Testable a) 353 | => Annotated s 354 | -> DynFormula s 355 | -> (Actions s -> a) 356 | -> Property 357 | forAllUniqueScripts s f k = 358 | QC.withSize $ \sz -> 359 | let d = unDynFormula f sz 360 | n = unsafeNextVarIndex $ vars s 361 | in case generate chooseUniqueNextStep d n s 500 of 362 | Nothing -> counterexample "Generating Non-unique script in forAllUniqueScripts" False 363 | Just test -> validDLTest test . applyMonitoring d test . property $ k (scriptFromDL test) 364 | 365 | -- | Creates a `Property` from `DynFormula` with some specialised isomorphism for shrinking purpose. 366 | forAllMappedScripts 367 | :: (DynLogicModel s, Testable a) 368 | => (rep -> DynLogicTest s) 369 | -> (DynLogicTest s -> rep) 370 | -> DynFormula s 371 | -> (Actions s -> a) 372 | -> Property 373 | forAllMappedScripts to from f k = 374 | QC.withSize $ \n -> 375 | let d = unDynFormula f n 376 | in forAllShrinkBlind 377 | (Smart 0 <$> sized ((from <$>) . generateDLTest d)) 378 | (shrinkSmart ((from <$>) . shrinkDLTest d . to)) 379 | $ \(Smart _ script) -> 380 | withDLScript d k (to script) 381 | 382 | withDLScript :: (DynLogicModel s, Testable a) => DynLogic s -> (Actions s -> a) -> DynLogicTest s -> Property 383 | withDLScript d k test = 384 | validDLTest test . applyMonitoring d test . property $ k (scriptFromDL test) 385 | 386 | withDLScriptPrefix :: (DynLogicModel s, Testable a) => DynFormula s -> (Actions s -> a) -> DynLogicTest s -> Property 387 | withDLScriptPrefix f k test = 388 | QC.withSize $ \n -> 389 | let d = unDynFormula f n 390 | test' = unfailDLTest d test 391 | in validDLTest test' . applyMonitoring d test' . property $ k (scriptFromDL test') 392 | 393 | -- | Validate generated test case. 394 | -- 395 | -- Test case generation does not always produce a valid test case. In 396 | -- some cases, we did not find a suitable test case matching some 397 | -- `DynFormula` and we are `Stuck`, hence we want to discard the test 398 | -- case and start over ; in other cases we found a genuine issue with 399 | -- the formula leading to the impossibility of producing a valid test 400 | -- case. 401 | validDLTest :: StateModel s => DynLogicTest s -> Property -> Property 402 | validDLTest test prop = 403 | case test of 404 | DLScript{} -> counterexample (show test) prop 405 | Stuck{} -> property Discard 406 | _other -> counterexample (show test) False 407 | 408 | generateDLTest :: DynLogicModel s => DynLogic s -> Int -> Gen (DynLogicTest s) 409 | generateDLTest d size = generate chooseNextStep d 0 (initialStateFor d) size 410 | 411 | onDLTestSeq :: (TestSequence s -> TestSequence s) -> DynLogicTest s -> DynLogicTest s 412 | onDLTestSeq f (BadPrecondition ss bad s) = BadPrecondition (f ss) bad s 413 | onDLTestSeq f (Looping ss) = Looping (f ss) 414 | onDLTestSeq f (Stuck ss s) = Stuck (f ss) s 415 | onDLTestSeq f (DLScript ss) = DLScript (f ss) 416 | 417 | consDLTest :: TestStep s -> DynLogicTest s -> DynLogicTest s 418 | consDLTest step = onDLTestSeq (step :>) 419 | 420 | consDLTestW :: Witnesses () -> DynLogicTest s -> DynLogicTest s 421 | consDLTestW w = onDLTestSeq (addW w) 422 | where 423 | addW Do{} ss = ss 424 | addW (Witness a w') ss = TestSeqWitness a (addW w' ss) 425 | 426 | generate 427 | :: (Monad m, DynLogicModel s) 428 | => (Annotated s -> Int -> DynLogic s -> m (NextStep s)) 429 | -> DynLogic s 430 | -> Int 431 | -> Annotated s 432 | -> Int 433 | -> m (DynLogicTest s) 434 | generate chooseNextStepFun d n s size = 435 | if n > sizeLimit size 436 | then return $ Looping TestSeqStop 437 | else do 438 | let preferred = if n > size then stopping d else noStopping d 439 | useStep (BadAction (Witnesses ws bad)) _ = return $ BadPrecondition (TestSeqStopW ws) bad s 440 | useStep StoppingStep _ = return $ DLScript TestSeqStop 441 | useStep (Stepping step d') _ = 442 | case discardWitnesses step of 443 | var := act -> 444 | consDLTest step 445 | <$> generate 446 | chooseNextStepFun 447 | d' 448 | (n + 1) 449 | (computeNextState s act var) 450 | size 451 | useStep NoStep alt = alt 452 | foldr 453 | (\step k -> do try <- chooseNextStepFun s n step; useStep try k) 454 | (return $ Stuck TestSeqStop s) 455 | [preferred, noAny preferred, d, noAny d] 456 | 457 | sizeLimit :: Int -> Int 458 | sizeLimit size = 2 * size + 20 459 | 460 | initialStateFor :: StateModel s => DynLogic s -> Annotated s 461 | initialStateFor _ = initialAnnotatedState 462 | 463 | stopping :: DynLogic s -> DynLogic s 464 | stopping EmptySpec = EmptySpec 465 | stopping Stop = Stop 466 | stopping (After act k) = After act k 467 | stopping (Error m k) = Error m k 468 | stopping (AfterAny _) = EmptySpec 469 | stopping (Alt b d d') = Alt b (stopping d) (stopping d') 470 | stopping (Stopping d) = d 471 | stopping (Weight w d) = Weight w (stopping d) 472 | stopping (ForAll _ _) = EmptySpec -- ??? 473 | stopping (Monitor f d) = Monitor f (stopping d) 474 | 475 | noStopping :: DynLogic s -> DynLogic s 476 | noStopping EmptySpec = EmptySpec 477 | noStopping Stop = EmptySpec 478 | noStopping (After act k) = After act k 479 | noStopping (Error m k) = Error m k 480 | noStopping (AfterAny k) = AfterAny k 481 | noStopping (Alt b d d') = Alt b (noStopping d) (noStopping d') 482 | noStopping (Stopping _) = EmptySpec 483 | noStopping (Weight w d) = Weight w (noStopping d) 484 | noStopping (ForAll q f) = ForAll q f 485 | noStopping (Monitor f d) = Monitor f (noStopping d) 486 | 487 | noAny :: DynLogic s -> DynLogic s 488 | noAny EmptySpec = EmptySpec 489 | noAny Stop = Stop 490 | noAny (After act k) = After act k 491 | noAny (Error m k) = Error m k 492 | noAny (AfterAny _) = EmptySpec 493 | noAny (Alt b d d') = Alt b (noAny d) (noAny d') 494 | noAny (Stopping d) = Stopping (noAny d) 495 | noAny (Weight w d) = Weight w (noAny d) 496 | noAny (ForAll q f) = ForAll q f 497 | noAny (Monitor f d) = Monitor f (noAny d) 498 | 499 | nextSteps :: DynLogic s -> Gen [(Double, Witnesses (DynLogic s))] 500 | nextSteps = nextSteps' generateQ 501 | 502 | nextSteps' :: Monad m => (forall a. Quantification a -> m a) -> DynLogic s -> m [(Double, Witnesses (DynLogic s))] 503 | nextSteps' _ EmptySpec = pure [] 504 | nextSteps' _ Stop = pure [(1, Do $ Stop)] 505 | nextSteps' _ (After act k) = pure [(1, Do $ After act k)] 506 | nextSteps' _ (Error m k) = pure [(1, Do $ Error m k)] 507 | nextSteps' _ (AfterAny k) = pure [(1, Do $ AfterAny k)] 508 | nextSteps' gen (Alt _ d d') = (++) <$> nextSteps' gen d <*> nextSteps' gen d' 509 | nextSteps' gen (Stopping d) = nextSteps' gen d 510 | nextSteps' gen (Weight w d) = do 511 | steps <- nextSteps' gen d 512 | pure [(w * w', s) | (w', s) <- steps, w * w' > never] 513 | nextSteps' gen (ForAll q f) = do 514 | x <- gen q 515 | map (second $ Witness x) <$> nextSteps' gen (f x) 516 | nextSteps' gen (Monitor _f d) = nextSteps' gen d 517 | 518 | chooseOneOf :: [(Double, a)] -> Gen a 519 | chooseOneOf steps = frequency [(round (w / never), return s) | (w, s) <- steps] 520 | 521 | never :: Double 522 | never = 1.0e-9 523 | 524 | data NextStep s 525 | = StoppingStep 526 | | Stepping (Witnesses (Step s)) (DynLogic s) 527 | | NoStep 528 | | BadAction (Witnesses (FailingAction s)) 529 | 530 | chooseNextStep :: DynLogicModel s => Annotated s -> Int -> DynLogic s -> Gen (NextStep s) 531 | chooseNextStep s n d = do 532 | nextSteps d >>= \case 533 | [] -> return NoStep 534 | steps -> do 535 | let bads = concatMap (findBad . snd) steps 536 | findBad = traverse $ flip badActions s 537 | case bads of 538 | [] -> do 539 | chosen <- chooseOneOf steps 540 | let takeStep = \case 541 | Stop -> return StoppingStep 542 | After a k -> 543 | return $ Stepping (Do $ mkVar n := a) (k (mkVar n) (computeNextState s a (mkVar n))) 544 | AfterAny k -> do 545 | m <- keepTryingUntil 100 (computeArbitraryAction s) $ 546 | \case 547 | Some act -> computePrecondition s act && not (restrictedPolar act) 548 | case m of 549 | Nothing -> return NoStep 550 | Just (Some a@ActionWithPolarity{}) -> 551 | return $ 552 | Stepping 553 | (Do $ mkVar n := a) 554 | (k (computeNextState s a (mkVar n))) 555 | EmptySpec -> error "chooseNextStep: EmptySpec" 556 | ForAll{} -> error "chooseNextStep: ForAll" 557 | Error{} -> error "chooseNextStep: Error" 558 | Alt{} -> error "chooseNextStep: Alt" 559 | Stopping{} -> error "chooseNextStep: Stopping" 560 | Weight{} -> error "chooseNextStep: Weight" 561 | Monitor{} -> error "chooseNextStep: Monitor" 562 | go (Do d') = takeStep d' 563 | go (Witness a step) = 564 | go step 565 | >>= pure . \case 566 | StoppingStep -> StoppingStep -- TODO: This is a bit fishy 567 | Stepping step' dl -> Stepping (Witness a step') dl 568 | NoStep -> NoStep 569 | BadAction bad -> BadAction (Witness a bad) 570 | go chosen 571 | b : _ -> return $ BadAction b 572 | 573 | chooseUniqueNextStep :: (MonadFail m, DynLogicModel s) => Annotated s -> Int -> DynLogic s -> m (NextStep s) 574 | chooseUniqueNextStep s n d = do 575 | steps <- map snd <$> nextSteps' (const bad) d 576 | case steps of 577 | [] -> return NoStep 578 | [Do EmptySpec] -> return NoStep 579 | [Do Stop] -> return StoppingStep 580 | [Do (After a k)] -> return $ Stepping (Do $ mkVar n := a) (k (mkVar n) (computeNextState s a (mkVar n))) 581 | _ -> bad 582 | where 583 | bad = fail "chooseUniqueNextStep: non-unique action in DynLogic" 584 | 585 | keepTryingUntil :: Int -> Gen a -> (a -> Bool) -> Gen (Maybe a) 586 | keepTryingUntil 0 _ _ = return Nothing 587 | keepTryingUntil n g p = do 588 | x <- g 589 | if p x then return $ Just x else scale (+ 1) $ keepTryingUntil (n - 1) g p 590 | 591 | shrinkDLTest :: DynLogicModel s => DynLogic s -> DynLogicTest s -> [DynLogicTest s] 592 | shrinkDLTest _ (Looping _) = [] 593 | shrinkDLTest d tc = 594 | [ test | as' <- shrinkScript d (getScript tc), let pruned = pruneDLTest d as' 595 | test = makeTestFromPruned d pruned, 596 | -- Don't shrink a non-executable test case to an executable one. 597 | case (tc, test) of 598 | (DLScript _, _) -> True 599 | (_, DLScript _) -> False 600 | _ -> True 601 | ] 602 | 603 | nextStateStep :: StateModel s => Step s -> Annotated s -> Annotated s 604 | nextStateStep (var := act) s = computeNextState s act var 605 | 606 | shrinkScript :: forall s. DynLogicModel s => DynLogic s -> TestSequence s -> [TestSequence s] 607 | shrinkScript = shrink' initialAnnotatedState 608 | where 609 | shrink' :: Annotated s -> DynLogic s -> TestSequence s -> [TestSequence s] 610 | shrink' s d ss = structural s d ss ++ nonstructural s d ss 611 | 612 | nonstructural s d (TestSeqWitness a ss) = 613 | [ TestSeqWitness a' ss' 614 | | a' <- shrinkWitness @s d a 615 | , ss' <- ss : shrink' s (stepDLSeq d s $ TestSeqWitness a TestSeqStop) ss 616 | ] 617 | nonstructural s d (TestSeqStep step@(var := act) ss) = 618 | [TestSeqStep (unsafeCoerceVar var := act') ss | Some act'@ActionWithPolarity{} <- computeShrinkAction s act] 619 | ++ [ TestSeqStep step ss' 620 | | ss' <- 621 | shrink' 622 | (nextStateStep step s) 623 | (stepDLStep d s step) 624 | ss 625 | ] 626 | nonstructural _ _ TestSeqStop = [] 627 | 628 | structural _ _ TestSeqStopW{} = [] 629 | structural s d (step :> rest) = 630 | TestSeqStop 631 | : reverse (takeWhile (not . nullSeq) [dropSeq (n - 1) rest | n <- iterate (* 2) 1]) 632 | ++ map (step :>) (shrink' (nextStateStep (discardWitnesses step) s) (stepDLSeq d s (step :> TestSeqStop)) rest) 633 | 634 | shrinkWitness :: (StateModel s, Typeable a) => DynLogic s -> a -> [a] 635 | shrinkWitness (ForAll (q :: Quantification a) _) (a :: a') = 636 | case eqT @a @a' of 637 | Just Refl | isaQ q a -> shrinkQ q a 638 | _ -> [] 639 | shrinkWitness (Alt _ d d') a = shrinkWitness d a ++ shrinkWitness d' a 640 | shrinkWitness (Stopping d) a = shrinkWitness d a 641 | shrinkWitness (Weight _ d) a = shrinkWitness d a 642 | shrinkWitness (Monitor _ d) a = shrinkWitness d a 643 | shrinkWitness EmptySpec{} _ = [] 644 | shrinkWitness Stop{} _ = [] 645 | shrinkWitness Error{} _ = [] 646 | shrinkWitness After{} _ = [] 647 | shrinkWitness AfterAny{} _ = [] 648 | 649 | -- The result of pruning a list of actions is a prefix of a list of actions that 650 | -- could have been generated by the dynamic logic. 651 | pruneDLTest :: forall s. DynLogicModel s => DynLogic s -> TestSequence s -> TestSequence s 652 | pruneDLTest dl = prune [dl] initialAnnotatedState 653 | where 654 | prune [] _ _ = TestSeqStop 655 | prune _ _ TestSeqStop = TestSeqStop 656 | prune ds s (TestSeqWitness a ss) = 657 | case [d' | d <- ds, d' <- stepDLW @s d a] of 658 | [] -> prune ds s ss 659 | ds' -> TestSeqWitness a $ prune ds' s ss 660 | prune ds s (TestSeqStep step@(_ := act) ss) 661 | | computePrecondition s act = 662 | case [d' | d <- ds, d' <- stepDL d s (Do step)] of 663 | [] -> prune ds s ss 664 | ds' -> TestSeqStep step $ prune ds' (nextStateStep step s) ss 665 | | otherwise = prune ds s ss 666 | 667 | stepDL :: DynLogicModel s => DynLogic s -> Annotated s -> TestStep s -> [DynLogic s] 668 | stepDL (After a k) s (Do (var := act)) 669 | -- TOOD: make this nicer when we migrate to 9.2 where we can just bind 670 | -- the type variables cleanly and do `Just Refl <- eqT ...` here instead. 671 | | Some a == Some act = [k (unsafeCoerceVar var) (computeNextState s act (unsafeCoerceVar var))] 672 | stepDL (AfterAny k) s (Do (var := act)) 673 | | not (restrictedPolar act) = [k (computeNextState s act var)] 674 | stepDL (Alt _ d d') s step = stepDL d s step ++ stepDL d' s step 675 | stepDL (Stopping d) s step = stepDL d s step 676 | stepDL (Weight _ d) s step = stepDL d s step 677 | stepDL (ForAll (q :: Quantification a) f) s (Witness (a :: a') step) = 678 | case eqT @a @a' of 679 | Just Refl -> [d | isaQ q a, d <- stepDL (f a) s step] 680 | Nothing -> [] 681 | stepDL (Monitor _f d) s step = stepDL d s step 682 | stepDL _ _ _ = [] 683 | 684 | stepDLW :: forall s a. (DynLogicModel s, Typeable a) => DynLogic s -> a -> [DynLogic s] 685 | stepDLW (ForAll (q :: Quantification a') k) a = 686 | case eqT @a @a' of 687 | Just Refl -> [k a | isaQ q a] 688 | Nothing -> [] 689 | stepDLW (Alt _ d d') a = stepDLW d a ++ stepDLW d' a 690 | stepDLW (Monitor _ d) a = stepDLW d a 691 | stepDLW (Weight _ d) a = stepDLW d a 692 | stepDLW (Stopping d) a = stepDLW d a 693 | stepDLW _ _ = [] 694 | 695 | stepDLSeq :: DynLogicModel s => DynLogic s -> Annotated s -> TestSequence s -> DynLogic s 696 | stepDLSeq d _ (TestSeqStopW Do{}) = d 697 | stepDLSeq d s (TestSeqStopW (Witness a w)) = stepDLSeq (stepDLWitness d a) s (TestSeqStopW w) 698 | stepDLSeq d s (step@(Witnesses _ (var := act)) :> ss) = 699 | stepDLSeq (demonicAlt $ stepDL d s step) (computeNextState s act var) ss 700 | 701 | stepDLWitness :: forall a s. (DynLogicModel s, Typeable a) => DynLogic s -> a -> DynLogic s 702 | stepDLWitness d a = demonicAlt $ stepDLW d a 703 | 704 | stepDLStep :: DynLogicModel s => DynLogic s -> Annotated s -> Step s -> DynLogic s 705 | stepDLStep d s step = stepDLSeq d s (TestSeqStep step TestSeqStop) 706 | 707 | demonicAlt :: [DynLogic s] -> DynLogic s 708 | demonicAlt [] = EmptySpec 709 | demonicAlt ds = foldr1 (Alt Demonic) ds 710 | 711 | propPruningGeneratedScriptIsNoop :: DynLogicModel s => DynLogic s -> Property 712 | propPruningGeneratedScriptIsNoop d = 713 | forAll (sized $ \n -> choose (1, max 1 n) >>= generateDLTest d) $ \test -> 714 | let script = case test of 715 | BadPrecondition s _ _ -> s 716 | Looping s -> s 717 | Stuck s _ -> s 718 | DLScript s -> s 719 | in script == pruneDLTest d script 720 | 721 | getScript :: DynLogicTest s -> TestSequence s 722 | getScript (BadPrecondition s _ _) = s 723 | getScript (Looping s) = s 724 | getScript (Stuck s _) = s 725 | getScript (DLScript s) = s 726 | 727 | makeTestFromPruned :: forall s. DynLogicModel s => DynLogic s -> TestSequence s -> DynLogicTest s 728 | makeTestFromPruned dl = make dl initialAnnotatedState 729 | where 730 | make d s TestSeqStop 731 | | b : _ <- badActions @s d s = BadPrecondition TestSeqStop b s 732 | | stuck d s = Stuck TestSeqStop s 733 | | otherwise = DLScript TestSeqStop 734 | make d s (TestSeqWitness a ss) = 735 | onDLTestSeq (TestSeqWitness a) $ 736 | make 737 | (stepDLWitness d a) 738 | s 739 | ss 740 | make d s (TestSeqStep step ss) = 741 | onDLTestSeq (TestSeqStep step) $ 742 | make 743 | (stepDLStep d s step) 744 | (nextStateStep step s) 745 | ss 746 | 747 | -- | If failed, return the prefix up to the failure. Also prunes the test in case the model has 748 | -- changed. 749 | unfailDLTest :: DynLogicModel s => DynLogic s -> DynLogicTest s -> DynLogicTest s 750 | unfailDLTest d test = makeTestFromPruned d $ pruneDLTest d steps 751 | where 752 | steps = case test of 753 | BadPrecondition as _ _ -> as 754 | Stuck as _ -> as 755 | DLScript as -> as 756 | Looping as -> as 757 | 758 | stuck :: DynLogicModel s => DynLogic s -> Annotated s -> Bool 759 | stuck EmptySpec _ = True 760 | stuck Stop _ = False 761 | stuck (After _ _) _ = False 762 | stuck (Error _ _) _ = False 763 | stuck (AfterAny _) s = 764 | not $ 765 | canGenerate 766 | 0.01 767 | (computeArbitraryAction s) 768 | ( \case 769 | Some act -> 770 | computePrecondition s act 771 | && not (restrictedPolar act) 772 | ) 773 | stuck (Alt Angelic d d') s = stuck d s && stuck d' s 774 | stuck (Alt Demonic d d') s = stuck d s || stuck d' s 775 | stuck (Stopping d) s = stuck d s 776 | stuck (Weight w d) s = w < never || stuck d s 777 | stuck (ForAll _ _) _ = False 778 | stuck (Monitor _ d) s = stuck d s 779 | 780 | scriptFromDL :: DynLogicTest s -> Actions s 781 | scriptFromDL (DLScript s) = Actions $ sequenceSteps s 782 | scriptFromDL _ = Actions [] 783 | 784 | sequenceSteps :: TestSequence s -> [Step s] 785 | sequenceSteps (TestSeq ss) = 786 | case discardWitnesses ss of 787 | ContStop -> [] 788 | ContStep s ss' -> s : sequenceSteps ss' 789 | 790 | badActionsGiven :: StateModel s => DynLogic s -> Annotated s -> Witnesses a -> [Witnesses (FailingAction s)] 791 | badActionsGiven Stop _ _ = [] 792 | badActionsGiven EmptySpec _ _ = [] 793 | badActionsGiven AfterAny{} _ _ = [] 794 | badActionsGiven (ForAll _ k) s (Witness a step) = 795 | case cast a of 796 | Just a' -> Witness a' <$> badActionsGiven (k a') s step 797 | _ -> [] 798 | badActionsGiven (Alt _ d d') s w = badActionsGiven d s w ++ badActionsGiven d' s w 799 | badActionsGiven (Stopping d) s w = badActionsGiven d s w 800 | badActionsGiven (Weight k d) s w = if k < never then [] else badActionsGiven d s w 801 | badActionsGiven (Monitor _ d) s w = badActionsGiven d s w 802 | badActionsGiven d s (Do _) = Do <$> badActions d s 803 | badActionsGiven Error{} _ _ = [] 804 | badActionsGiven After{} _ _ = [] 805 | 806 | badActions :: StateModel s => DynLogic s -> Annotated s -> [FailingAction s] 807 | badActions EmptySpec _ = [] 808 | badActions Stop _ = [] 809 | badActions (After a _) s 810 | | computePrecondition s a = [] 811 | | otherwise = [ActionFail a] 812 | badActions (Error m _) _s = [ErrorFail m] 813 | badActions (AfterAny _) _ = [] 814 | badActions (Alt _ d d') s = badActions d s ++ badActions d' s 815 | badActions (Stopping d) s = badActions d s 816 | badActions (Weight w d) s = if w < never then [] else badActions d s 817 | badActions (ForAll _ _) _ = [] 818 | badActions (Monitor _ d) s = badActions d s 819 | 820 | applyMonitoring :: DynLogicModel s => DynLogic s -> DynLogicTest s -> Property -> Property 821 | applyMonitoring d (DLScript s) p = 822 | case findMonitoring d initialAnnotatedState s of 823 | Just f -> f p 824 | Nothing -> p 825 | applyMonitoring _ Stuck{} p = p 826 | applyMonitoring _ Looping{} p = p 827 | applyMonitoring _ BadPrecondition{} p = p 828 | 829 | findMonitoring :: DynLogicModel s => DynLogic s -> Annotated s -> TestSequence s -> Maybe (Property -> Property) 830 | findMonitoring Stop _s TestSeqStop = Just id 831 | findMonitoring (After a k) s (TestSeqStep (var := a') as) 832 | -- TODO: do nicely with eqT instead (avoids `unsafeCoerceVar`) 833 | | Some a == Some a' = findMonitoring (k (unsafeCoerceVar var) s') s' as 834 | where 835 | s' = computeNextState s a' (unsafeCoerceVar var) 836 | findMonitoring (AfterAny k) s as@(TestSeqStep (_var := a) _) 837 | | not (restrictedPolar a) = findMonitoring (After a $ const k) s as 838 | findMonitoring (Alt _b d d') s as = 839 | -- Give priority to monitoring matches to the left. Combining both 840 | -- results in repeated monitoring from always, which is unexpected. 841 | findMonitoring d s as <|> findMonitoring d' s as 842 | findMonitoring (Stopping d) s as = findMonitoring d s as 843 | findMonitoring (Weight _ d) s as = findMonitoring d s as 844 | findMonitoring (ForAll (_q :: Quantification a) k) s (TestSeq (Witness (a :: a') as)) = 845 | case eqT @a @a' of 846 | Just Refl -> findMonitoring (k a) s (TestSeq as) 847 | Nothing -> Nothing 848 | findMonitoring (Monitor m d) s as = 849 | (m .) <$> findMonitoring d s as 850 | findMonitoring _ _ _ = Nothing 851 | -------------------------------------------------------------------------------- /quickcheck-dynamic/src/Test/QuickCheck/DynamicLogic/Quantify.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-name-shadowing #-} 2 | 3 | -- | This module defines Quantifications, which are used together with 4 | -- forAllQ in DynamicLogic. A `Quantification t` can be used to generate 5 | -- a `t`, shrink a `t`, and recognise a generated `t`. 6 | module Test.QuickCheck.DynamicLogic.Quantify ( 7 | Quantification (isaQ), 8 | QuantifyConstraints, 9 | isEmptyQ, 10 | generateQ, 11 | shrinkQ, 12 | arbitraryQ, 13 | exactlyQ, 14 | elementsQ, 15 | oneofQ, 16 | frequencyQ, 17 | mapQ, 18 | whereQ, 19 | chooseQ, 20 | withGenQ, 21 | hasNoVariablesQ, 22 | validQuantification, 23 | Quantifiable (..), 24 | ) where 25 | 26 | import Control.Monad 27 | import Data.Coerce 28 | import Data.Maybe 29 | import Data.Typeable 30 | import System.Random 31 | import Test.QuickCheck 32 | import Test.QuickCheck.DynamicLogic.CanGenerate 33 | import Test.QuickCheck.StateModel 34 | 35 | -- | A `Quantification` over a type @a@ is a generator that can be used to generate random values in 36 | -- DL scenarios. 37 | -- 38 | -- A `Quantification` is similar to a `Test.QuickCheck.Arbitrary`, it groups together: 39 | -- 40 | -- * A standard QuickCheck _generator_ in the `Gen` monad, which can be "empty", 41 | -- * A _shrinking_ strategy for generated values in the case of a 42 | -- failures ensuring they stay within the domain, 43 | -- * A _predicate_ allowing finer grained control on generation 44 | -- and shrinking process, e.g in the case the range of the generator 45 | -- depends on trace context. 46 | -- 47 | -- NOTE: Leaving the possibility of generating `Nothing` is useful to simplify the generation 48 | -- process for `elements` or `frequency` which may normally crash when the list to select 49 | -- elements from is empty. This makes writing `DL` formulas cleaner, removing the need to 50 | -- handle non-existence cases explicitly. 51 | data Quantification a = Quantification 52 | { genQ :: Maybe (Gen a) 53 | , isaQ :: a -> Bool 54 | , shrQ :: a -> [a] 55 | } 56 | 57 | isEmptyQ :: Quantification a -> Bool 58 | isEmptyQ = isNothing . genQ 59 | 60 | generateQ :: Quantification a -> Gen a 61 | generateQ q = fromJust (genQ q) `suchThat` isaQ q 62 | 63 | shrinkQ :: Quantification a -> a -> [a] 64 | shrinkQ q a = filter (isaQ q) (shrQ q a) 65 | 66 | -- | Construct a `Quantification a` from its constituents. 67 | -- Note the predicate provided is used to restrict both the range of values 68 | -- generated and the list of possible shrinked values. 69 | withGenQ :: Gen a -> (a -> Bool) -> (a -> [a]) -> Quantification a 70 | withGenQ gen isA = Quantification (Just $ gen `suchThat` isA) isA 71 | 72 | -- | Pack up an `Arbitrary` instance as a `Quantification`. Treats all values as being in range. 73 | arbitraryQ :: Arbitrary a => Quantification a 74 | arbitraryQ = Quantification (Just arbitrary) (const True) shrink 75 | 76 | -- | Generates exactly the given value. Does not shrink. 77 | exactlyQ :: Eq a => a -> Quantification a 78 | exactlyQ a = 79 | Quantification 80 | (Just $ return a) 81 | (== a) 82 | (const []) 83 | 84 | -- | Generate a random value in a given range (inclusive). 85 | chooseQ :: (Arbitrary a, Random a, Ord a) => (a, a) -> Quantification a 86 | chooseQ r@(a, b) = 87 | Quantification 88 | (guard (a <= b) >> Just (choose r)) 89 | is 90 | (filter is . shrink) 91 | where 92 | is x = a <= x && x <= b 93 | 94 | -- | Pick a random value from a list. Treated as an empty choice if the list is empty: 95 | -- 96 | -- @ 97 | -- `Plutus.Contract.Test.ContractModel.forAllQ` (`elementsQ` []) == `Control.Applicative.empty` 98 | -- @ 99 | elementsQ :: Eq a => [a] -> Quantification a 100 | elementsQ as = Quantification g (`elem` as) (\a -> takeWhile (/= a) as) 101 | where 102 | g 103 | | null as = Nothing 104 | | otherwise = Just (elements as) 105 | 106 | -- | Choose from a weighted list of quantifications. Treated as an `Control.Applicative.empty` 107 | -- choice if no quantification has weight > 0. 108 | frequencyQ :: [(Int, Quantification a)] -> Quantification a 109 | frequencyQ iqs = 110 | Quantification 111 | ( case [(i, g) | (i, q) <- iqs, i > 0, Just g <- [genQ q]] of 112 | [] -> Nothing 113 | igs -> Just (frequency igs) 114 | ) 115 | (isa iqs) 116 | (shr iqs) 117 | where 118 | isa [] _ = False 119 | isa ((i, q) : iqs) a = (i > 0 && isaQ q a) || isa iqs a 120 | shr [] _ = [] 121 | shr ((i, q) : iqs) a = 122 | [a' | i > 0, isaQ q a, a' <- shrQ q a] 123 | ++ shr iqs a 124 | 125 | -- | Choose from a list of quantifications. Same as `frequencyQ` with all weights the same (and > 126 | -- 0). 127 | oneofQ :: [Quantification a] -> Quantification a 128 | oneofQ qs = frequencyQ $ map (1,) qs 129 | 130 | -- | `Quantification` is not a `Functor`, since it also keeps track of the range of the generators. 131 | -- However, if you have two functions 132 | -- @ 133 | -- to :: a -> b 134 | -- from :: b -> a 135 | -- @ 136 | -- satisfying @from . to = id@ you can go from a quantification over @a@ to one over @b@. Note 137 | -- that the @from@ function need only be defined on the image of @to@. 138 | mapQ :: (a -> b, b -> a) -> Quantification a -> Quantification b 139 | mapQ (f, g) q = 140 | Quantification 141 | ((f <$>) <$> genQ q) 142 | (isaQ q . g) 143 | (map f . shrQ q . g) 144 | 145 | -- | Restrict the range of a quantification. 146 | whereQ :: Quantification a -> (a -> Bool) -> Quantification a 147 | whereQ q p = 148 | Quantification 149 | ( case genQ q of 150 | Just g | canGenerate 0.01 g p -> Just (g `suchThat` p) 151 | _ -> Nothing 152 | ) 153 | (\a -> p a && isaQ q a) 154 | (\a -> if p a then filter p (shrQ q a) else []) 155 | 156 | pairQ :: Quantification a -> Quantification b -> Quantification (a, b) 157 | pairQ q q' = 158 | Quantification 159 | (liftM2 (,) <$> genQ q <*> genQ q') 160 | (\(a, a') -> isaQ q a && isaQ q' a') 161 | (\(a, a') -> map (,a') (shrQ q a) ++ map (a,) (shrQ q' a')) 162 | 163 | -- | Wrap a Quantification in `HasNoVariables` to indicate that you know 164 | -- what you're doing and there are no symbolic variables in the thing you 165 | -- are quantifying over. WARNING: use this function carefully as there is 166 | -- no guarantee that you won't get bitten by very strange failures if you 167 | -- were in fact not honest about the lack of variables. 168 | hasNoVariablesQ :: Quantification a -> Quantification (HasNoVariables a) 169 | hasNoVariablesQ = coerce 170 | 171 | type QuantifyConstraints a = (Eq a, Show a, Typeable a, HasVariables a) 172 | 173 | -- | Generalization of `Quantification`s, which lets you treat lists and tuples of quantifications 174 | -- as quantifications. For instance, 175 | -- 176 | -- @ 177 | -- ... 178 | -- (die1, die2) <- `Plutus.Contract.Test.ContractModel.forAllQ` (`chooseQ` (1, 6), `chooseQ` (1, 6)) 179 | -- ... 180 | -- @ 181 | class 182 | QuantifyConstraints (Quantifies q) => 183 | Quantifiable q 184 | where 185 | -- | The type of values quantified over. 186 | -- 187 | -- @ 188 | -- `Quantifies` (`Quantification` a) = a 189 | -- @ 190 | type Quantifies q 191 | 192 | -- | Computing the actual `Quantification`. 193 | quantify :: q -> Quantification (Quantifies q) 194 | 195 | instance QuantifyConstraints a => Quantifiable (Quantification a) where 196 | type Quantifies (Quantification a) = a 197 | quantify = id 198 | 199 | instance (Quantifiable a, Quantifiable b) => Quantifiable (a, b) where 200 | type Quantifies (a, b) = (Quantifies a, Quantifies b) 201 | quantify (a, b) = pairQ (quantify a) (quantify b) 202 | 203 | instance (Quantifiable a, Quantifiable b, Quantifiable c) => Quantifiable (a, b, c) where 204 | type Quantifies (a, b, c) = (Quantifies a, Quantifies b, Quantifies c) 205 | quantify (a, b, c) = mapQ (to, from) (quantify a `pairQ` (quantify b `pairQ` quantify c)) 206 | where 207 | to (a, (b, c)) = (a, b, c) 208 | from (a, b, c) = (a, (b, c)) 209 | 210 | instance (Quantifiable a, Quantifiable b, Quantifiable c, Quantifiable d) => Quantifiable (a, b, c, d) where 211 | type 212 | Quantifies (a, b, c, d) = 213 | (Quantifies a, Quantifies b, Quantifies c, Quantifies d) 214 | quantify (a, b, c, d) = 215 | mapQ (to, from) (quantify a `pairQ` (quantify b `pairQ` (quantify c `pairQ` quantify d))) 216 | where 217 | to (a, (b, (c, d))) = (a, b, c, d) 218 | from (a, b, c, d) = (a, (b, (c, d))) 219 | 220 | instance 221 | (Quantifiable a, Quantifiable b, Quantifiable c, Quantifiable d, Quantifiable e) 222 | => Quantifiable (a, b, c, d, e) 223 | where 224 | type 225 | Quantifies (a, b, c, d, e) = 226 | (Quantifies a, Quantifies b, Quantifies c, Quantifies d, Quantifies e) 227 | quantify (a, b, c, d, e) = 228 | mapQ (to, from) (quantify a `pairQ` (quantify b `pairQ` (quantify c `pairQ` (quantify d `pairQ` quantify e)))) 229 | where 230 | to (a, (b, (c, (d, e)))) = (a, b, c, d, e) 231 | from (a, b, c, d, e) = (a, (b, (c, (d, e)))) 232 | 233 | instance Quantifiable a => Quantifiable [a] where 234 | type Quantifies [a] = [Quantifies a] 235 | quantify [] = Quantification (Just $ return []) null (const []) 236 | quantify (a : as) = 237 | mapQ (to, from) (pairQ (quantify a) (quantify as)) 238 | `whereQ` (not . null) 239 | where 240 | to (x, xs) = x : xs 241 | from (x : xs) = (x, xs) 242 | from [] = error "quantify: impossible" 243 | 244 | -- | Turns a `Quantification` into a `Property` to enable QuickChecking its 245 | -- validity. 246 | validQuantification :: Show a => Quantification a -> Property 247 | validQuantification q = 248 | forAllShrink (fromJust $ genQ q) (shrinkQ q) $ isaQ q 249 | -------------------------------------------------------------------------------- /quickcheck-dynamic/src/Test/QuickCheck/DynamicLogic/SmartShrinking.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.DynamicLogic.SmartShrinking (shrinkSmart) where 2 | 3 | import Test.QuickCheck 4 | 5 | -- | This combinator captures the 'smart shrinking' implemented for the 6 | -- `Smart` type wrapper in [Test.QuickCheck.Modifiers](https://hackage.haskell.org/package/QuickCheck-2.14.3/docs/Test-QuickCheck-Modifiers.html#t:Smart). 7 | -- It interleaves the output of the given shrinker to try to converge to more 8 | -- interesting values faster. 9 | shrinkSmart :: (a -> [a]) -> Smart a -> [Smart a] 10 | shrinkSmart shrinker (Smart i x) = take i' ys `interleave` drop i' ys 11 | where 12 | ys = [Smart j y | (j, y) <- [0 ..] `zip` shrinker x] 13 | 14 | i' = 0 `max` (i - 2) 15 | 16 | [] `interleave` bs = bs 17 | as `interleave` [] = as 18 | (a : as) `interleave` (b : bs) = a : b : (as `interleave` bs) 19 | -------------------------------------------------------------------------------- /quickcheck-dynamic/src/Test/QuickCheck/DynamicLogic/Utils.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.DynamicLogic.Utils where 2 | 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Property 5 | 6 | withSize :: Testable prop => (Int -> prop) -> Property 7 | withSize f = MkProperty . sized $ unProperty . property . f 8 | -------------------------------------------------------------------------------- /quickcheck-dynamic/src/Test/QuickCheck/Extras.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.Extras where 2 | 3 | import Control.Monad.Reader 4 | import Control.Monad.State 5 | import Test.QuickCheck.Monadic 6 | 7 | runPropertyStateT :: Monad m => PropertyM (StateT s m) a -> s -> PropertyM m (a, s) 8 | runPropertyStateT p s0 = MkPropertyM $ \k -> do 9 | m <- unPropertyM (do a <- p; s <- run get; return (a, s)) $ fmap lift . k 10 | return $ evalStateT m s0 11 | 12 | runPropertyReaderT :: Monad m => PropertyM (ReaderT e m) a -> e -> PropertyM m a 13 | runPropertyReaderT p e = MkPropertyM $ \k -> do 14 | m <- unPropertyM p $ fmap lift . k 15 | return $ runReaderT m e 16 | -------------------------------------------------------------------------------- /quickcheck-dynamic/src/Test/QuickCheck/StateModel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE QuantifiedConstraints #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | -- | Model-Based Testing library for use with Haskell QuickCheck. 8 | -- 9 | -- This module provides the basic machinery to define a `StateModel` from which /traces/ can 10 | -- be generated and executed against some /actual/ implementation code to define monadic `Property` 11 | -- to be asserted by QuickCheck. 12 | module Test.QuickCheck.StateModel ( 13 | module Test.QuickCheck.StateModel.Variables, 14 | StateModel (..), 15 | RunModel (..), 16 | PostconditionM (..), 17 | WithUsedVars (..), 18 | Annotated (..), 19 | Step (..), 20 | Polarity (..), 21 | ActionWithPolarity (..), 22 | LookUp, 23 | Actions (..), 24 | pattern Actions, 25 | EnvEntry (..), 26 | pattern (:=?), 27 | Env, 28 | Generic, 29 | IsPerformResult, 30 | Options (..), 31 | monitorPost, 32 | counterexamplePost, 33 | stateAfter, 34 | runActions, 35 | lookUpVar, 36 | lookUpVarMaybe, 37 | viewAtType, 38 | initialAnnotatedState, 39 | computeNextState, 40 | computePrecondition, 41 | computeArbitraryAction, 42 | computeShrinkAction, 43 | generateActionsWithOptions, 44 | shrinkActionsWithOptions, 45 | defaultOptions, 46 | moreActions, 47 | ) where 48 | 49 | import Control.Monad 50 | import Control.Monad.Reader 51 | import Control.Monad.Writer (WriterT, runWriterT, tell) 52 | import Data.Data 53 | import Data.Kind 54 | import Data.List 55 | import Data.Monoid (Endo (..)) 56 | import Data.Set qualified as Set 57 | import Data.Void 58 | import GHC.Generics 59 | import Test.QuickCheck as QC 60 | import Test.QuickCheck.DynamicLogic.SmartShrinking 61 | import Test.QuickCheck.Monadic 62 | import Test.QuickCheck.StateModel.Variables 63 | 64 | -- | The typeclass users implement to define a model against which to validate some implementation. 65 | -- 66 | -- To implement a `StateModel`, user needs to provide at least the following: 67 | -- 68 | -- * A datatype for `Action`s: Each test case is a sequence of `Action`s that's supposed to lead from 69 | -- some `initialState` to some end state, 70 | -- * A generator for traces of `Action`s, the `arbitraryAction` function, 71 | -- * An `initialState`, 72 | -- * A /transition/ function, `nextState`, that "interprets" each `Action` and producing some new `state`. 73 | -- 74 | -- For finer grained control over the testing process, one can also define: 75 | -- 76 | -- * `shrinkAction`: Shrinking is an important part of MBT as it allows QuickCheck engine to look for simpler 77 | -- test cases when something goes wrong which makes troubleshooting easier, 78 | -- * `precondition`: Filters generated `Action` depending on the `state`. When `precondition` is False then 79 | -- the action is /rejected/ and a new one is tried. This is also useful when shrinking a trace 80 | -- in order to ensure that removing some `Action` still produces a valid trace. The `precondition` can be 81 | -- somewhat redundant with the generator's conditions, 82 | -- * `validFailingAction`: Specifies when an action that fails it's `precondition` can still run as what is 83 | -- called a _negative_ action. This means that the action is (1) expected to fail and (2) not expected to 84 | -- change the model state. This is very useful for testing the checks and failure conditions in the SUT 85 | -- are implemented correctly. Should it be necessary to update the model state with e.g. book-keeping for 86 | -- a negative action one can define `failureNextState` - but it is generally recommended to let this be 87 | -- as simple an action as possible. 88 | class 89 | ( forall a. Show (Action state a) 90 | , forall a. HasVariables (Action state a) 91 | , Show state 92 | , HasVariables state 93 | ) => 94 | StateModel state 95 | where 96 | -- | The type of `Action` relevant for this `state`. 97 | -- 98 | -- This is expected to be defined as a GADT where the `a` parameter is instantiated to some 99 | -- observable output from the SUT a given action is expected to produce. For example, here 100 | -- is a fragment of the `Action RegState` (taken from the `Spec.Dynamic.RegistryModel` module) : 101 | -- 102 | -- @ 103 | -- data Action RegState a where 104 | -- Spawn :: Action RegState ThreadId 105 | -- Register :: String -> Var ThreadId -> Action RegState () 106 | -- KillThread :: Var ThreadId -> Action RegState () 107 | -- @ 108 | -- 109 | -- The @Spawn@ action should produce a @ThreadId@, whereas the @KillThread@ action does not return 110 | -- anything. 111 | data Action state a 112 | 113 | -- | Display name for `Action`. 114 | -- This is useful to provide sensible statistics about the distribution of `Action`s run 115 | -- when checking a property. 116 | -- 117 | -- Default implementation uses a poor-man's string manipulation method to extract the 118 | -- constructor name from the value. 119 | actionName :: Action state a -> String 120 | actionName = head . words . show 121 | 122 | -- | Generator for `Action` depending on `state`. 123 | arbitraryAction :: VarContext -> state -> Gen (Any (Action state)) 124 | 125 | -- | Shrinker for `Action`. 126 | -- Defaults to no-op but as usual, defining a good shrinker greatly enhances the usefulness 127 | -- of property-based testing. 128 | shrinkAction :: Typeable a => VarContext -> state -> Action state a -> [Any (Action state)] 129 | shrinkAction _ _ _ = [] 130 | 131 | -- | Initial state of generated traces. 132 | initialState :: state 133 | 134 | -- | Transition function for the model. 135 | -- The `Var a` parameter is useful to keep reference to actual value of type `a` produced 136 | -- by `perform`ing the `Action` inside the `state` so that further actions can use `Lookup` 137 | -- to retrieve that data. This allows the model to be ignorant of those values yet maintain 138 | -- some references that can be compared and looked for. 139 | nextState :: Typeable a => state -> Action state a -> Var a -> state 140 | nextState s _ _ = s 141 | 142 | -- | Transition function for negative actions. Note that most negative testing applications 143 | -- should not require an implementation of this function! 144 | failureNextState :: Typeable a => state -> Action state a -> state 145 | failureNextState s _ = s 146 | 147 | -- | Precondition for filtering generated `Action`. 148 | -- This function is applied before the action is performed, it is useful to refine generators that 149 | -- can produce more values than are useful. 150 | precondition :: state -> Action state a -> Bool 151 | precondition _ _ = True 152 | 153 | -- | Precondition for filtering an `Action` that can meaningfully run but is supposed to fail. 154 | -- An action will run as a _negative_ action if the `precondition` fails and `validFailingAction` succeeds. 155 | -- A negative action should have _no effect_ on the model state. This may not be desierable in all 156 | -- situations - in which case one can override this semantics for book-keeping in `failureNextState`. 157 | validFailingAction :: state -> Action state a -> Bool 158 | validFailingAction _ _ = False 159 | 160 | deriving instance (forall a. Show (Action state a)) => Show (Any (Action state)) 161 | 162 | newtype PostconditionM m a = PostconditionM {runPost :: WriterT (Endo Property, Endo Property) m a} 163 | deriving (Functor, Applicative, Monad) 164 | 165 | instance MonadTrans PostconditionM where 166 | lift = PostconditionM . lift 167 | 168 | evaluatePostCondition :: Monad m => PostconditionM m Bool -> PropertyM m () 169 | evaluatePostCondition post = do 170 | (b, (Endo mon, Endo onFail)) <- run . runWriterT . runPost $ post 171 | monitor mon 172 | unless b $ monitor onFail 173 | assert b 174 | 175 | -- | Apply the property transformation to the property after evaluating 176 | -- the postcondition. Useful for collecting statistics while avoiding 177 | -- duplication between `monitoring` and `postcondition`. 178 | monitorPost :: Monad m => (Property -> Property) -> PostconditionM m () 179 | monitorPost m = PostconditionM $ tell (Endo m, mempty) 180 | 181 | -- | Acts as `Test.QuickCheck.counterexample` if the postcondition fails. 182 | counterexamplePost :: Monad m => String -> PostconditionM m () 183 | counterexamplePost c = PostconditionM $ tell (mempty, Endo $ counterexample c) 184 | 185 | -- | The result required of `perform` depending on the `Error` type. 186 | -- If there are no errors, `Error state = Void`, and 187 | -- so we don't need to specify if the action failed or not. 188 | type family PerformResult state (m :: Type -> Type) a where 189 | PerformResult state m a = EitherIsh (Error state m) a 190 | 191 | type family EitherIsh e a where 192 | EitherIsh Void a = a 193 | EitherIsh e a = Either e a 194 | 195 | class IsPerformResult e a where 196 | performResultToEither :: EitherIsh e a -> Either e a 197 | 198 | instance {-# OVERLAPPING #-} IsPerformResult Void a where 199 | performResultToEither = Right 200 | 201 | instance {-# OVERLAPPABLE #-} (EitherIsh e a ~ Either e a) => IsPerformResult e a where 202 | performResultToEither = id 203 | 204 | class (forall a. Show (Action state a), Monad m) => RunModel state m where 205 | -- | The type of errors that actions can throw. If this is defined as anything 206 | -- other than `Void` `perform` is required to return `Either (Error state) a` 207 | -- instead of `a`. 208 | type Error state m 209 | 210 | type Error state m = Void 211 | 212 | -- | Perform an `Action` in some `state` in the `Monad` `m`. This 213 | -- is the function that's used to exercise the actual stateful 214 | -- implementation, usually through various side-effects as permitted 215 | -- by `m`. It produces a value of type `a`, eg. some observable 216 | -- output from the `Action` that should later be kept in the 217 | -- environment through a `Var a` also passed to the `nextState` 218 | -- function. 219 | -- 220 | -- The `Lookup` parameter provides an /environment/ to lookup `Var 221 | -- a` instances from previous steps. 222 | perform :: Typeable a => state -> Action state a -> LookUp -> m (PerformResult state m a) 223 | 224 | -- | Postcondition on the `a` value produced at some step. 225 | -- The result is `assert`ed and will make the property fail should it be `False`. This is useful 226 | -- to check the implementation produces expected values. 227 | postcondition :: (state, state) -> Action state a -> LookUp -> a -> PostconditionM m Bool 228 | postcondition _ _ _ _ = pure True 229 | 230 | -- | Postcondition on the result of running a _negative_ `Action`. 231 | -- The result is `assert`ed and will make the property fail should it be `False`. This is useful 232 | -- to check the implementation produces e.g. the expected errors or to check that the SUT hasn't 233 | -- been updated during the execution of the negative action. 234 | postconditionOnFailure :: (state, state) -> Action state a -> LookUp -> Either (Error state m) a -> PostconditionM m Bool 235 | postconditionOnFailure _ _ _ _ = pure True 236 | 237 | -- | Allows the user to attach additional information to the `Property` at each step of the process. 238 | -- This function is given the full transition that's been executed, including the start and ending 239 | -- `state`, the `Action`, the current environment to `Lookup` and the value produced by `perform` 240 | -- while executing this step. 241 | monitoring :: (state, state) -> Action state a -> LookUp -> Either (Error state m) a -> Property -> Property 242 | monitoring _ _ _ _ prop = prop 243 | 244 | -- | Allows the user to attach additional information to the `Property` if a positive action fails. 245 | monitoringFailure :: state -> Action state a -> LookUp -> Error state m -> Property -> Property 246 | monitoringFailure _ _ _ _ prop = prop 247 | 248 | type LookUp = forall a. Typeable a => Var a -> a 249 | 250 | type Env = [EnvEntry] 251 | 252 | data EnvEntry where 253 | (:==) :: Typeable a => Var a -> a -> EnvEntry 254 | 255 | infix 5 :== 256 | 257 | pattern (:=?) :: forall a. Typeable a => Var a -> a -> EnvEntry 258 | pattern v :=? val <- (viewAtType -> Just (v, val)) 259 | 260 | viewAtType :: forall a. Typeable a => EnvEntry -> Maybe (Var a, a) 261 | viewAtType ((v :: Var b) :== val) 262 | | Just Refl <- eqT @a @b = Just (v, val) 263 | | otherwise = Nothing 264 | 265 | lookUpVarMaybe :: forall a. Typeable a => Env -> Var a -> Maybe a 266 | lookUpVarMaybe [] _ = Nothing 267 | lookUpVarMaybe (((v' :: Var b) :== a) : env) v = 268 | case eqT @a @b of 269 | Just Refl | v == v' -> Just a 270 | _ -> lookUpVarMaybe env v 271 | 272 | lookUpVar :: Typeable a => Env -> Var a -> a 273 | lookUpVar env v = case lookUpVarMaybe env v of 274 | Nothing -> error $ "Variable " ++ show v ++ " is not bound at type " ++ show (typeRep v) ++ "!" 275 | Just a -> a 276 | 277 | data WithUsedVars a = WithUsedVars VarContext a 278 | 279 | data Polarity 280 | = PosPolarity 281 | | NegPolarity 282 | deriving (Ord, Eq) 283 | 284 | instance Show Polarity where 285 | show PosPolarity = "+" 286 | show NegPolarity = "-" 287 | 288 | data ActionWithPolarity state a = Eq (Action state a) => 289 | ActionWithPolarity 290 | { polarAction :: Action state a 291 | , polarity :: Polarity 292 | } 293 | 294 | instance HasVariables (Action state a) => HasVariables (ActionWithPolarity state a) where 295 | getAllVariables = getAllVariables . polarAction 296 | 297 | deriving instance Eq (Action state a) => Eq (ActionWithPolarity state a) 298 | 299 | data Step state where 300 | (:=) 301 | :: (Typeable a, Eq (Action state a), Show (Action state a)) 302 | => Var a 303 | -> ActionWithPolarity state a 304 | -> Step state 305 | 306 | infix 5 := 307 | 308 | instance (forall a. HasVariables (Action state a)) => HasVariables (Step state) where 309 | getAllVariables (var := act) = Set.insert (Some var) $ getAllVariables (polarAction act) 310 | 311 | funName :: Polarity -> String 312 | funName PosPolarity = "action" 313 | funName _ = "failingAction" 314 | 315 | instance Show (Step state) where 316 | show (var := act) = show var ++ " <- " ++ funName (polarity act) ++ " $ " ++ show (polarAction act) 317 | 318 | instance Show (WithUsedVars (Step state)) where 319 | show (WithUsedVars ctx (var := act)) = 320 | if isWellTyped var ctx 321 | then show var ++ " <- " ++ funName (polarity act) ++ " $ " ++ show (polarAction act) 322 | else funName (polarity act) ++ " $ " ++ show (polarAction act) 323 | 324 | instance Eq (Step state) where 325 | (v := act) == (v' := act') = 326 | unsafeCoerceVar v == v' && Some act == Some act' 327 | 328 | -- Action sequences use Smart shrinking, but this is invisible to 329 | -- client code because the extra Smart constructor is concealed by a 330 | -- pattern synonym. 331 | 332 | -- We also collect a list of names of actions which were generated, 333 | -- but were then rejected by their precondition. 334 | 335 | data Actions state = Actions_ [String] (Smart [Step state]) 336 | deriving (Generic) 337 | 338 | pattern Actions :: [Step state] -> Actions state 339 | pattern Actions as <- 340 | Actions_ _ (Smart _ as) 341 | where 342 | Actions as = Actions_ [] (Smart 0 as) 343 | 344 | {-# COMPLETE Actions #-} 345 | 346 | instance Semigroup (Actions state) where 347 | Actions_ rs (Smart k as) <> Actions_ rs' (Smart _ as') = Actions_ (rs ++ rs') (Smart k (as <> as')) 348 | 349 | instance Eq (Actions state) where 350 | Actions as == Actions as' = as == as' 351 | 352 | instance StateModel state => Show (Actions state) where 353 | show (Actions as) = 354 | let as' = WithUsedVars (usedVariables (Actions as)) <$> as 355 | in intercalate "\n" $ zipWith (++) ("do " : repeat " ") (map show as' ++ ["pure ()"]) 356 | 357 | usedVariables :: forall state. StateModel state => Actions state -> VarContext 358 | usedVariables (Actions as) = go initialAnnotatedState as 359 | where 360 | go :: Annotated state -> [Step state] -> VarContext 361 | go aState [] = allVariables (underlyingState aState) 362 | go aState ((var := act) : steps) = 363 | allVariables (polarAction act) 364 | <> allVariables (underlyingState aState) 365 | <> go (computeNextState aState act var) steps 366 | 367 | instance forall state. StateModel state => Arbitrary (Actions state) where 368 | arbitrary = generateActionsWithOptions defaultOptions 369 | shrink = shrinkActionsWithOptions defaultOptions 370 | 371 | data QCDProperty state = QCDProperty 372 | { runQCDProperty :: Actions state -> Property 373 | , qcdPropertyOptions :: Options state 374 | } 375 | 376 | instance StateModel state => Testable (QCDProperty state) where 377 | property QCDProperty{..} = 378 | forAllShrink 379 | (generateActionsWithOptions qcdPropertyOptions) 380 | (shrinkActionsWithOptions qcdPropertyOptions) 381 | runQCDProperty 382 | 383 | class QCDProp state p | p -> state where 384 | qcdProperty :: p -> QCDProperty state 385 | 386 | instance QCDProp state (QCDProperty state) where 387 | qcdProperty = id 388 | 389 | instance Testable p => QCDProp state (Actions state -> p) where 390 | qcdProperty p = QCDProperty (property . p) defaultOptions 391 | 392 | modifyOptions :: QCDProperty state -> (Options state -> Options state) -> QCDProperty state 393 | modifyOptions p f = 394 | let opts = qcdPropertyOptions p 395 | in p{qcdPropertyOptions = f opts} 396 | 397 | moreActions :: QCDProp state p => Rational -> p -> QCDProperty state 398 | moreActions r p = 399 | modifyOptions (qcdProperty p) $ \opts -> opts{actionLengthMultiplier = actionLengthMultiplier opts * r} 400 | 401 | -- NOTE: indexed on state for forwards compatibility, e.g. when we 402 | -- want to give an explicit initial state 403 | data Options state = Options {actionLengthMultiplier :: Rational} 404 | 405 | defaultOptions :: Options state 406 | defaultOptions = Options{actionLengthMultiplier = 1} 407 | 408 | -- | Generate arbitrary actions with the `GenActionsOptions`. More flexible than using the type-based 409 | -- modifiers. 410 | generateActionsWithOptions :: forall state. StateModel state => Options state -> Gen (Actions state) 411 | generateActionsWithOptions Options{..} = do 412 | (as, rejected) <- arbActions [] [] initialAnnotatedState 1 413 | return $ Actions_ rejected (Smart 0 as) 414 | where 415 | arbActions :: [Step state] -> [String] -> Annotated state -> Int -> Gen ([Step state], [String]) 416 | arbActions steps rejected s step = sized $ \n -> do 417 | let w = round (actionLengthMultiplier * fromIntegral n) `div` 2 + 1 418 | continue <- frequency [(1, pure False), (w, pure True)] 419 | if continue 420 | then do 421 | (mact, rej) <- satisfyPrecondition 422 | case mact of 423 | Just (Some act@ActionWithPolarity{}) -> do 424 | let var = mkVar step 425 | arbActions 426 | ((var := act) : steps) 427 | (rej ++ rejected) 428 | (computeNextState s act var) 429 | (step + 1) 430 | Nothing -> 431 | return (reverse steps, rejected) 432 | else return (reverse steps, rejected) 433 | where 434 | satisfyPrecondition = sized $ \n -> go n (2 * n) [] -- idea copied from suchThatMaybe 435 | go m n rej 436 | | m > n = return (Nothing, rej) 437 | | otherwise = do 438 | a <- resize m $ computeArbitraryAction s 439 | case a of 440 | Some act -> 441 | if computePrecondition s act 442 | then return (Just (Some act), rej) 443 | else go (m + 1) n (actionName (polarAction act) : rej) 444 | 445 | shrinkActionsWithOptions :: forall state. StateModel state => Options state -> Actions state -> [Actions state] 446 | shrinkActionsWithOptions _ (Actions_ rs as) = 447 | map (Actions_ rs) (shrinkSmart (map (prune . map fst) . concatMap customActionsShrinker . shrinkList shrinker . withStates) as) 448 | where 449 | shrinker :: (Step state, Annotated state) -> [(Step state, Annotated state)] 450 | shrinker (v := act, s) = [(unsafeCoerceVar v := act', s) | Some act'@ActionWithPolarity{} <- computeShrinkAction s act] 451 | 452 | customActionsShrinker :: [(Step state, Annotated state)] -> [[(Step state, Annotated state)]] 453 | customActionsShrinker acts = 454 | let usedVars = mconcat [getAllVariables a <> getAllVariables (underlyingState s) | (_ := a, s) <- acts] 455 | binding (v := _, _) = Some v `Set.member` usedVars 456 | -- Remove at most one non-binding action 457 | go [] = [[]] 458 | go (p : ps) 459 | | binding p = map (p :) (go ps) 460 | | otherwise = ps : map (p :) (go ps) 461 | in go acts 462 | 463 | -- Running state models 464 | 465 | data Annotated state = Metadata 466 | { vars :: VarContext 467 | , underlyingState :: state 468 | } 469 | 470 | instance Show state => Show (Annotated state) where 471 | show (Metadata ctx s) = show ctx ++ " |- " ++ show s 472 | 473 | initialAnnotatedState :: StateModel state => Annotated state 474 | initialAnnotatedState = Metadata mempty initialState 475 | 476 | actionWithPolarity :: (StateModel state, Eq (Action state a)) => Annotated state -> Action state a -> ActionWithPolarity state a 477 | actionWithPolarity s a = 478 | let p 479 | | precondition (underlyingState s) a = PosPolarity 480 | | validFailingAction (underlyingState s) a = NegPolarity 481 | | otherwise = PosPolarity 482 | in ActionWithPolarity a p 483 | 484 | computePrecondition :: StateModel state => Annotated state -> ActionWithPolarity state a -> Bool 485 | computePrecondition s (ActionWithPolarity a p) = 486 | let polarPrecondition 487 | | p == PosPolarity = precondition (underlyingState s) a 488 | | otherwise = validFailingAction (underlyingState s) a && not (precondition (underlyingState s) a) 489 | in all (\(Some v) -> v `isWellTyped` vars s) (getAllVariables a) 490 | && polarPrecondition 491 | 492 | computeNextState 493 | :: (StateModel state, Typeable a) 494 | => Annotated state 495 | -> ActionWithPolarity state a 496 | -> Var a 497 | -> Annotated state 498 | computeNextState s a v 499 | | polarity a == PosPolarity = Metadata (extendContext (vars s) v) (nextState (underlyingState s) (polarAction a) v) 500 | | otherwise = Metadata (vars s) (failureNextState (underlyingState s) (polarAction a)) 501 | 502 | computeArbitraryAction 503 | :: StateModel state 504 | => Annotated state 505 | -> Gen (Any (ActionWithPolarity state)) 506 | computeArbitraryAction s = do 507 | Some a <- arbitraryAction (vars s) (underlyingState s) 508 | pure $ Some $ actionWithPolarity s a 509 | 510 | computeShrinkAction 511 | :: forall state a 512 | . (Typeable a, StateModel state) 513 | => Annotated state 514 | -> ActionWithPolarity state a 515 | -> [Any (ActionWithPolarity state)] 516 | computeShrinkAction s (ActionWithPolarity a _) = 517 | [Some (actionWithPolarity s a') | Some a' <- shrinkAction (vars s) (underlyingState s) a] 518 | 519 | prune :: forall state. StateModel state => [Step state] -> [Step state] 520 | prune = loop initialAnnotatedState 521 | where 522 | loop _s [] = [] 523 | loop s ((var := act) : as) 524 | | computePrecondition @state s act = 525 | (var := act) : loop (computeNextState s act var) as 526 | | otherwise = 527 | loop s as 528 | 529 | withStates :: forall state. StateModel state => [Step state] -> [(Step state, Annotated state)] 530 | withStates = loop initialAnnotatedState 531 | where 532 | loop _s [] = [] 533 | loop s ((var := act) : as) = 534 | (var := act, s) : loop (computeNextState @state s act var) as 535 | 536 | stateAfter :: forall state. StateModel state => Actions state -> Annotated state 537 | stateAfter (Actions actions) = loop initialAnnotatedState actions 538 | where 539 | loop s [] = s 540 | loop s ((var := act) : as) = loop (computeNextState @state s act var) as 541 | 542 | runActions 543 | :: forall state m e 544 | . ( StateModel state 545 | , RunModel state m 546 | , e ~ Error state m 547 | , forall a. IsPerformResult e a 548 | ) 549 | => Actions state 550 | -> PropertyM m (Annotated state, Env) 551 | runActions (Actions_ rejected (Smart _ actions)) = do 552 | let bucket = \n -> let (a, b) = go n in show a ++ " - " ++ show b 553 | where 554 | go n 555 | | n < 100 = (d * 10, d * 10 + 9) 556 | | otherwise = let (a, b) = go d in (a * 10, b * 10 + 9) 557 | where 558 | d = div n 10 559 | monitor $ tabulate "# of actions" [show $ bucket $ length actions] 560 | (finalState, env, names, polars) <- runSteps initialAnnotatedState [] actions 561 | monitor $ tabulate "Actions" names 562 | monitor $ tabulate "Action polarity" $ map show polars 563 | unless (null rejected) $ 564 | monitor $ 565 | tabulate "Actions rejected by precondition" rejected 566 | return (finalState, env) 567 | 568 | -- | Core function to execute a sequence of `Step` given some initial `Env`ironment and `Annotated` 569 | -- state. Return the list of action names and polarities to work around 570 | -- https://github.com/nick8325/quickcheck/issues/416 causing repeated calls to tabulate being slow. 571 | runSteps 572 | :: forall state m e 573 | . ( StateModel state 574 | , RunModel state m 575 | , e ~ Error state m 576 | , forall a. IsPerformResult e a 577 | ) 578 | => Annotated state 579 | -> Env 580 | -> [Step state] 581 | -> PropertyM m (Annotated state, Env, [String], [Polarity]) 582 | runSteps s env [] = return (s, reverse env, [], []) 583 | runSteps s env ((v := act) : as) = do 584 | pre $ computePrecondition s act 585 | ret <- run $ performResultToEither <$> perform (underlyingState s) action (lookUpVar env) 586 | let name = show polar ++ actionName action 587 | case (polar, ret) of 588 | (PosPolarity, Left err) -> 589 | positiveActionFailed err 590 | (PosPolarity, Right val) -> do 591 | (s', env') <- positiveActionSucceeded ret val 592 | (s'', env'', names, polars) <- runSteps s' env' as 593 | pure (s'', env'', name : names, polar : polars) 594 | (NegPolarity, _) -> do 595 | (s', env') <- negativeActionResult ret 596 | (s'', env'', names, polars) <- runSteps s' env' as 597 | pure (s'', env'', name : names, polar : polars) 598 | where 599 | polar = polarity act 600 | 601 | action = polarAction act 602 | 603 | positiveActionFailed err = do 604 | monitor $ 605 | monitoringFailure @state @m 606 | (underlyingState s) 607 | action 608 | (lookUpVar env) 609 | err 610 | stop False 611 | 612 | positiveActionSucceeded ret val = do 613 | (s', env', stateTransition) <- computeNewState ret 614 | evaluatePostCondition $ 615 | postcondition 616 | stateTransition 617 | action 618 | (lookUpVar env) 619 | val 620 | pure (s', env') 621 | 622 | negativeActionResult ret = do 623 | (s', env', stateTransition) <- computeNewState ret 624 | evaluatePostCondition $ 625 | postconditionOnFailure 626 | stateTransition 627 | action 628 | (lookUpVar env) 629 | ret 630 | pure (s', env') 631 | 632 | computeNewState ret = do 633 | let var = unsafeCoerceVar v 634 | s' = computeNextState s act var 635 | env' 636 | | Right val <- ret = (var :== val) : env 637 | | otherwise = env 638 | stateTransition = (underlyingState s, underlyingState s') 639 | monitor $ monitoring @state @m stateTransition action (lookUpVar env') ret 640 | pure (s', env', stateTransition) 641 | -------------------------------------------------------------------------------- /quickcheck-dynamic/src/Test/QuickCheck/StateModel/Variables.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | module Test.QuickCheck.StateModel.Variables ( 6 | Var, 7 | Any (..), 8 | HasVariables (..), 9 | HasNoVariables (..), 10 | VarContext, 11 | mkVar, 12 | ctxAtType, 13 | arbitraryVar, 14 | shrinkVar, 15 | extendContext, 16 | isWellTyped, 17 | allVariables, 18 | isEmptyCtx, 19 | unsafeCoerceVar, 20 | unsafeNextVarIndex, 21 | ) where 22 | 23 | import Data.Data 24 | import Data.Kind 25 | import Data.List 26 | import Data.Map (Map) 27 | import Data.Map qualified as Map 28 | import Data.Ord 29 | import Data.Set (Set) 30 | import Data.Set qualified as Set 31 | import GHC.Generics 32 | import GHC.TypeLits 33 | import GHC.Word 34 | import Test.QuickCheck as QC 35 | 36 | -- | A symbolic variable for a value of type `a` 37 | newtype Var a = Var Int 38 | deriving (Eq, Ord, Typeable, Data) 39 | 40 | -- | Create a fresh symbolic variable with given identifier. While 'Var's are 41 | -- usually created by action generators, this function can be used for example 42 | -- to create a 'Var' in the 'initialState' of a 'StateModel'. A good default 43 | -- value for the identifier is '-1' as this will not be generated otherwise. 44 | mkVar :: Int -> Var a 45 | mkVar = Var 46 | 47 | instance Show (Var a) where 48 | show (Var i) = "var" ++ show i 49 | 50 | -- | This type class gives you a way to get all the symbolic variables that 51 | -- appear in a value. 52 | class HasVariables a where 53 | getAllVariables :: a -> Set (Any Var) 54 | 55 | instance HasVariables a => HasVariables (Smart a) where 56 | getAllVariables (Smart _ a) = getAllVariables a 57 | 58 | instance Typeable a => HasVariables (Var a) where 59 | getAllVariables = Set.singleton . Some 60 | 61 | instance (HasVariables k, HasVariables v) => HasVariables (Map k v) where 62 | getAllVariables = getAllVariables . Map.toList 63 | 64 | instance HasVariables a => HasVariables (Set a) where 65 | getAllVariables = getAllVariables . Set.toList 66 | 67 | instance (forall a. HasVariables (f a)) => HasVariables (Any f) where 68 | getAllVariables (Some a) = getAllVariables a 69 | 70 | newtype HasNoVariables a = HasNoVariables a 71 | 72 | deriving via a instance Show a => Show (HasNoVariables a) 73 | deriving via a instance Eq a => Eq (HasNoVariables a) 74 | 75 | instance HasVariables (HasNoVariables a) where 76 | getAllVariables _ = mempty 77 | 78 | deriving via HasNoVariables Integer instance HasVariables Integer 79 | deriving via HasNoVariables Int instance HasVariables Int 80 | deriving via HasNoVariables Char instance HasVariables Char 81 | deriving via HasNoVariables Word8 instance HasVariables Word8 82 | deriving via HasNoVariables Word16 instance HasVariables Word16 83 | deriving via HasNoVariables Word32 instance HasVariables Word32 84 | deriving via HasNoVariables Word64 instance HasVariables Word64 85 | 86 | data Any f where 87 | Some :: (Typeable a, Eq (f a)) => f a -> Any f 88 | 89 | instance Eq (Any f) where 90 | Some (a :: f a) == Some (b :: f b) = 91 | case eqT @a @b of 92 | Just Refl -> a == b 93 | Nothing -> False 94 | 95 | instance (forall a. Ord (f a)) => Ord (Any f) where 96 | compare (Some (a :: f a)) (Some (a' :: f a')) = 97 | case eqT @a @a' of 98 | Just Refl -> compare a a' 99 | Nothing -> compare (typeRep a) (typeRep a') 100 | 101 | newtype VarContext = VarCtx (Set (Any Var)) 102 | deriving (Semigroup, Monoid) via Set (Any Var) 103 | 104 | instance Show VarContext where 105 | show (VarCtx vs) = 106 | "[" ++ intercalate ", " (map showBinding . sortBy (comparing getIdx) $ Set.toList vs) ++ "]" 107 | where 108 | getIdx (Some (Var i)) = i 109 | showBinding :: Any Var -> String 110 | -- The use of typeRep here is on purpose to avoid printing `Var` unnecessarily. 111 | showBinding (Some v) = show v ++ " :: " ++ show (typeRep v) 112 | 113 | isEmptyCtx :: VarContext -> Bool 114 | isEmptyCtx (VarCtx ctx) = null ctx 115 | 116 | isWellTyped :: Typeable a => Var a -> VarContext -> Bool 117 | isWellTyped v (VarCtx ctx) = not (null ctx) && Some v `Set.member` ctx 118 | 119 | -- TODO: check the invariant that no variable index is used 120 | -- twice at different types. This is generally not an issue 121 | -- because lookups take types into account (so it *shouldn't* 122 | -- cause an issue, but it might be good practise to crash 123 | -- if the invariant is violated anyway as it is evidence that 124 | -- something is horribly broken at the use site). 125 | extendContext :: Typeable a => VarContext -> Var a -> VarContext 126 | extendContext (VarCtx ctx) v = VarCtx $ Set.insert (Some v) ctx 127 | 128 | allVariables :: HasVariables a => a -> VarContext 129 | allVariables = VarCtx . getAllVariables 130 | 131 | ctxAtType :: Typeable a => VarContext -> [Var a] 132 | ctxAtType (VarCtx vs) = [v | Some (cast -> Just v) <- Set.toList vs] 133 | 134 | arbitraryVar :: Typeable a => VarContext -> Gen (Var a) 135 | arbitraryVar = elements . ctxAtType 136 | 137 | shrinkVar :: Typeable a => VarContext -> Var a -> [Var a] 138 | shrinkVar ctx v = filter (< v) $ ctxAtType ctx 139 | 140 | unsafeCoerceVar :: Var a -> Var b 141 | unsafeCoerceVar (Var i) = Var i 142 | 143 | unsafeNextVarIndex :: VarContext -> Int 144 | unsafeNextVarIndex (VarCtx vs) = 1 + maximum (0 : [i | Some (Var i) <- Set.toList vs]) 145 | 146 | -- NOTE: This trick is taken from this blog post: 147 | -- https://blog.csongor.co.uk/report-stuck-families/ 148 | data Dummy x 149 | type family Break (c :: Constraint) (rep :: Type -> Type) :: Constraint where 150 | Break _ Dummy = ((), ()) 151 | Break _ _ = () 152 | 153 | instance 154 | {-# OVERLAPPABLE #-} 155 | ( Break 156 | (TypeError ('Text "Missing instance of HasVariables for non-Generic type " ':<>: 'ShowType a)) 157 | (Rep a) 158 | , Generic a 159 | , GenericHasVariables (Rep a) 160 | ) 161 | => HasVariables a 162 | where 163 | getAllVariables = genericGetAllVariables . from 164 | 165 | class GenericHasVariables f where 166 | genericGetAllVariables :: f k -> Set (Any Var) 167 | 168 | instance GenericHasVariables f => GenericHasVariables (M1 i c f) where 169 | genericGetAllVariables = genericGetAllVariables . unM1 170 | 171 | instance HasVariables c => GenericHasVariables (K1 i c) where 172 | genericGetAllVariables = getAllVariables . unK1 173 | 174 | instance GenericHasVariables U1 where 175 | genericGetAllVariables _ = mempty 176 | 177 | instance (GenericHasVariables f, GenericHasVariables g) => GenericHasVariables (f :*: g) where 178 | genericGetAllVariables (x :*: y) = genericGetAllVariables x <> genericGetAllVariables y 179 | 180 | instance (GenericHasVariables f, GenericHasVariables g) => GenericHasVariables (f :+: g) where 181 | genericGetAllVariables (L1 x) = genericGetAllVariables x 182 | genericGetAllVariables (R1 x) = genericGetAllVariables x 183 | -------------------------------------------------------------------------------- /quickcheck-dynamic/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main (main) where 4 | 5 | import Spec.DynamicLogic.RegistryModel qualified 6 | import Test.QuickCheck.DynamicLogic.QuantifySpec qualified 7 | import Test.QuickCheck.StateModelSpec qualified 8 | import Test.Tasty 9 | 10 | main :: IO () 11 | main = defaultMain tests 12 | 13 | tests :: TestTree 14 | tests = 15 | testGroup 16 | "dynamic logic" 17 | [ Spec.DynamicLogic.RegistryModel.tests 18 | , Test.QuickCheck.DynamicLogic.QuantifySpec.tests 19 | , Test.QuickCheck.StateModelSpec.tests 20 | ] 21 | -------------------------------------------------------------------------------- /quickcheck-dynamic/test/Spec/DynamicLogic/Counters.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | 3 | -- | Define several variant models of /counters/ which are useful to 4 | -- test or use examples for various behaviours of the runtime. 5 | module Spec.DynamicLogic.Counters where 6 | 7 | import Control.Monad.Reader 8 | import Data.IORef 9 | import Test.QuickCheck 10 | import Test.QuickCheck.StateModel 11 | 12 | -- A very simple model with a single action that always succeed in 13 | -- predictable way. This model is useful for testing the runtime. 14 | newtype SimpleCounter = SimpleCounter {count :: Int} 15 | deriving (Eq, Show, Generic) 16 | 17 | deriving instance Eq (Action SimpleCounter a) 18 | deriving instance Show (Action SimpleCounter a) 19 | instance HasVariables (Action SimpleCounter a) where 20 | getAllVariables _ = mempty 21 | 22 | instance StateModel SimpleCounter where 23 | data Action SimpleCounter a where 24 | IncSimple :: Action SimpleCounter Int 25 | 26 | arbitraryAction _ _ = pure $ Some IncSimple 27 | 28 | initialState = SimpleCounter 0 29 | 30 | nextState SimpleCounter{count} IncSimple _ = SimpleCounter (count + 1) 31 | 32 | instance RunModel SimpleCounter (ReaderT (IORef Int) IO) where 33 | perform _ IncSimple _ = do 34 | ref <- ask 35 | lift $ atomicModifyIORef' ref (\count -> (succ count, count)) 36 | 37 | -- A very simple model with a single action whose postcondition fails in a 38 | -- predictable way. This model is useful for testing the runtime. 39 | newtype FailingCounter = FailingCounter {failingCount :: Int} 40 | deriving (Eq, Show, Generic) 41 | 42 | deriving instance Eq (Action FailingCounter a) 43 | deriving instance Show (Action FailingCounter a) 44 | instance HasVariables (Action FailingCounter a) where 45 | getAllVariables _ = mempty 46 | 47 | instance StateModel FailingCounter where 48 | data Action FailingCounter a where 49 | Inc' :: Action FailingCounter Int 50 | 51 | arbitraryAction _ _ = pure $ Some Inc' 52 | 53 | initialState = FailingCounter 0 54 | 55 | nextState FailingCounter{failingCount} Inc' _ = FailingCounter (failingCount + 1) 56 | 57 | instance RunModel FailingCounter (ReaderT (IORef Int) IO) where 58 | perform _ Inc' _ = do 59 | ref <- ask 60 | lift $ atomicModifyIORef' ref (\count -> (succ count, count)) 61 | 62 | postcondition (_, FailingCounter{failingCount}) _ _ _ = pure $ failingCount < 4 63 | 64 | -- A generic but simple counter model 65 | data Counter = Counter Int 66 | deriving (Show, Generic) 67 | 68 | deriving instance Show (Action Counter a) 69 | deriving instance Eq (Action Counter a) 70 | instance HasVariables (Action Counter a) where 71 | getAllVariables _ = mempty 72 | 73 | instance StateModel Counter where 74 | data Action Counter a where 75 | Inc :: Action Counter () 76 | Reset :: Action Counter Int 77 | 78 | initialState = Counter 0 79 | 80 | arbitraryAction _ _ = frequency [(5, pure $ Some Inc), (1, pure $ Some Reset)] 81 | 82 | nextState (Counter n) Inc _ = Counter (n + 1) 83 | nextState _ Reset _ = Counter 0 84 | 85 | instance RunModel Counter (ReaderT (IORef Int) IO) where 86 | perform _ Inc _ = do 87 | ref <- ask 88 | lift $ modifyIORef ref succ 89 | perform _ Reset _ = do 90 | ref <- ask 91 | lift $ do 92 | n <- readIORef ref 93 | writeIORef ref 0 94 | pure n 95 | 96 | postcondition (Counter n, _) Reset _ res = pure $ n == res 97 | postcondition _ _ _ _ = pure True 98 | -------------------------------------------------------------------------------- /quickcheck-dynamic/test/Spec/DynamicLogic/Registry.hs: -------------------------------------------------------------------------------- 1 | -- A simple local name service for threads... behaves like the Erlang 2 | -- process registry. 3 | module Spec.DynamicLogic.Registry where 4 | 5 | import Control.Concurrent.STM 6 | import Control.Monad 7 | import GHC.Conc 8 | 9 | type Registry = TVar [(String, ThreadId)] 10 | 11 | isAlive :: ThreadId -> IO Bool 12 | isAlive tid = do 13 | s <- threadStatus tid 14 | return $ s /= ThreadFinished && s /= ThreadDied 15 | 16 | setupRegistry :: IO Registry 17 | setupRegistry = atomically $ newTVar [] 18 | 19 | whereis :: Registry -> String -> IO (Maybe ThreadId) 20 | whereis registry name = do 21 | reg <- readRegistry registry 22 | return $ lookup name reg 23 | 24 | register :: Registry -> String -> ThreadId -> IO () 25 | register registry name tid = do 26 | ok <- isAlive tid 27 | reg <- readRegistry registry 28 | if ok && name `notElem` map fst reg && tid `notElem` map snd reg 29 | then atomically $ do 30 | reg' <- readTVar registry 31 | if name `notElem` map fst reg' && tid `notElem` map snd reg' 32 | then writeTVar registry ((name, tid) : reg') 33 | else error "badarg" 34 | else error "badarg" 35 | 36 | unregister :: Registry -> String -> IO () 37 | unregister registry name = do 38 | reg <- readRegistry registry 39 | when (name `elem` map fst reg) $ do 40 | atomically $ modifyTVar registry $ filter ((/= name) . fst) 41 | 42 | readRegistry :: Registry -> IO [(String, ThreadId)] 43 | readRegistry registry = garbageCollect registry *> atomically (readTVar registry) 44 | 45 | garbageCollect :: Registry -> IO () 46 | garbageCollect registry = do 47 | reg <- atomically $ readTVar registry 48 | garbage <- filterM (fmap not . isAlive) (map snd reg) 49 | atomically $ modifyTVar registry $ filter ((`notElem` garbage) . snd) 50 | return () 51 | -------------------------------------------------------------------------------- /quickcheck-dynamic/test/Spec/DynamicLogic/RegistryModel.hs: -------------------------------------------------------------------------------- 1 | module Spec.DynamicLogic.RegistryModel where 2 | 3 | import Control.Concurrent 4 | import Control.Exception 5 | 6 | import GHC.Generics 7 | 8 | import Control.Monad.Reader 9 | import Data.Either 10 | import Data.List 11 | import Data.Map (Map) 12 | import Data.Map qualified as Map 13 | import Test.QuickCheck 14 | import Test.QuickCheck.Monadic hiding (assert) 15 | import Test.QuickCheck.Monadic qualified as QC 16 | import Test.Tasty hiding (after) 17 | 18 | import Test.Tasty.QuickCheck (testProperty) 19 | 20 | import Spec.DynamicLogic.Registry 21 | import Test.QuickCheck.DynamicLogic 22 | import Test.QuickCheck.Extras 23 | import Test.QuickCheck.StateModel 24 | 25 | data RegState = RegState 26 | { regs :: Map String (Var ThreadId) 27 | , dead :: [Var ThreadId] 28 | } 29 | deriving (Show, Generic) 30 | 31 | deriving instance Show (Action RegState a) 32 | deriving instance Eq (Action RegState a) 33 | 34 | instance HasVariables (Action RegState a) where 35 | getAllVariables (Register _ v) = getAllVariables v 36 | getAllVariables (KillThread v) = getAllVariables v 37 | getAllVariables _ = mempty 38 | 39 | instance StateModel RegState where 40 | data Action RegState a where 41 | Spawn :: Action RegState ThreadId 42 | WhereIs :: String -> Action RegState (Maybe ThreadId) 43 | Register :: String -> Var ThreadId -> Action RegState () 44 | Unregister :: String -> Action RegState () 45 | KillThread :: Var ThreadId -> Action RegState () 46 | 47 | precondition s (Register name tid) = 48 | name `Map.notMember` regs s 49 | && tid `notElem` Map.elems (regs s) 50 | && tid `notElem` dead s 51 | precondition s (Unregister name) = 52 | name `Map.member` regs s 53 | precondition _ _ = True 54 | 55 | validFailingAction _ _ = True 56 | 57 | arbitraryAction ctx s = 58 | let threadIdCtx = ctxAtType @ThreadId ctx 59 | in frequency $ 60 | [ 61 | ( max 1 $ 10 - length threadIdCtx 62 | , return $ Some Spawn 63 | ) 64 | , 65 | ( 2 * Map.size (regs s) 66 | , Some <$> (Unregister <$> probablyRegistered s) 67 | ) 68 | , 69 | ( 10 70 | , Some <$> (WhereIs <$> probablyRegistered s) 71 | ) 72 | ] 73 | ++ [ ( max 1 $ 3 - length (dead s) 74 | , Some <$> (KillThread <$> arbitraryVar ctx) 75 | ) 76 | | not . null $ threadIdCtx 77 | ] 78 | ++ [ ( max 1 $ 10 - Map.size (regs s) 79 | , Some <$> (Register <$> probablyUnregistered s <*> arbitraryVar ctx) 80 | ) 81 | | not . null $ threadIdCtx 82 | ] 83 | 84 | shrinkAction ctx _ (Register name tid) = 85 | [Some (Unregister name)] 86 | ++ [Some (Register name' tid) | name' <- shrinkName name] 87 | ++ [Some (Register name tid') | tid' <- shrinkVar ctx tid] 88 | shrinkAction _ _ (Unregister name) = 89 | Some (WhereIs name) : [Some (Unregister name') | name' <- shrinkName name] 90 | shrinkAction _ _ (WhereIs name) = 91 | [Some (WhereIs name') | name' <- shrinkName name] 92 | shrinkAction _ _ Spawn = [] 93 | shrinkAction ctx _ (KillThread tid) = 94 | [Some (KillThread tid') | tid' <- shrinkVar ctx tid] 95 | 96 | initialState = RegState mempty [] 97 | 98 | nextState s Spawn _ = s 99 | nextState s (Register name tid) _step = s{regs = Map.insert name tid (regs s)} 100 | nextState s (Unregister name) _step = 101 | s{regs = Map.delete name (regs s)} 102 | nextState s (KillThread tid) _ = 103 | s 104 | { dead = tid : dead s 105 | , regs = Map.filter (/= tid) (regs s) 106 | } 107 | nextState s WhereIs{} _ = s 108 | 109 | type RegM = ReaderT Registry IO 110 | 111 | instance RunModel RegState RegM where 112 | type Error RegState RegM = SomeException 113 | 114 | perform _ Spawn _ = do 115 | tid <- lift $ forkIO (threadDelay 10000000) 116 | pure $ Right tid 117 | perform _ (Register name tid) env = do 118 | reg <- ask 119 | lift $ try $ register reg name (env tid) 120 | perform _ (Unregister name) _ = do 121 | reg <- ask 122 | lift $ try $ unregister reg name 123 | perform _ (WhereIs name) _ = do 124 | reg <- ask 125 | res <- lift $ whereis reg name 126 | pure $ Right res 127 | perform _ (KillThread tid) env = do 128 | lift $ killThread (env tid) 129 | lift $ threadDelay 100 130 | pure $ Right () 131 | 132 | postcondition (s, _) (WhereIs name) env mtid = do 133 | pure $ (env <$> Map.lookup name (regs s)) == mtid 134 | postcondition _ _ _ _ = pure True 135 | 136 | postconditionOnFailure (s, _) act@Register{} _ res = do 137 | monitorPost $ 138 | tabulate 139 | "Reason for -Register" 140 | [why s act] 141 | pure $ isLeft res 142 | postconditionOnFailure _s _ _ _ = pure True 143 | 144 | monitoring (_s, s') act@(showDictAction -> ShowDict) _ res = 145 | counterexample (show res ++ " <- " ++ show act ++ "\n -- State: " ++ show s') 146 | . tabulate "Registry size" [show $ Map.size (regs s')] 147 | 148 | data ShowDict a where 149 | ShowDict :: Show a => ShowDict a 150 | 151 | showDictAction :: forall a. Action RegState a -> ShowDict a 152 | showDictAction Spawn{} = ShowDict 153 | showDictAction WhereIs{} = ShowDict 154 | showDictAction Register{} = ShowDict 155 | showDictAction Unregister{} = ShowDict 156 | showDictAction KillThread{} = ShowDict 157 | 158 | instance DynLogicModel RegState where 159 | restricted _ = False 160 | 161 | why :: RegState -> Action RegState a -> String 162 | why s (Register name tid) = 163 | unwords $ 164 | ["name already registered" | name `Map.member` regs s] 165 | ++ ["tid already registered" | tid `elem` Map.elems (regs s)] 166 | ++ ["dead thread" | tid `elem` dead s] 167 | why _ _ = "(impossible)" 168 | 169 | arbitraryName :: Gen String 170 | arbitraryName = elements allNames 171 | 172 | probablyRegistered :: RegState -> Gen String 173 | probablyRegistered s = oneof $ map pure (Map.keys $ regs s) ++ [arbitraryName] 174 | 175 | probablyUnregistered :: RegState -> Gen String 176 | probablyUnregistered s = elements $ allNames ++ (allNames \\ Map.keys (regs s)) 177 | 178 | shrinkName :: String -> [String] 179 | shrinkName name = [n | n <- allNames, n < name] 180 | 181 | allNames :: [String] 182 | allNames = ["a", "b", "c", "d", "e"] 183 | 184 | prop_Registry :: Actions RegState -> Property 185 | prop_Registry s = 186 | monadicIO $ do 187 | monitor $ counterexample "\nExecution\n" 188 | reg <- lift setupRegistry 189 | runPropertyReaderT (runActions s) reg 190 | QC.assert True 191 | 192 | propDL :: DL RegState () -> Property 193 | propDL d = forAllDL d prop_Registry 194 | 195 | -- DL helpers 196 | 197 | unregisterNameAndTid :: String -> Var ThreadId -> DL RegState () 198 | unregisterNameAndTid name tid = do 199 | s <- getModelStateDL 200 | sequence_ 201 | [ action $ Unregister name' 202 | | (name', tid') <- Map.toList $ regs s 203 | , name' == name || tid' == tid 204 | ] 205 | 206 | unregisterTid :: Var ThreadId -> DL RegState () 207 | unregisterTid tid = do 208 | s <- getModelStateDL 209 | sequence_ 210 | [ action $ Unregister name 211 | | (name, tid') <- Map.toList $ regs s 212 | , tid' == tid 213 | ] 214 | 215 | getAlive :: DL RegState [Var ThreadId] 216 | getAlive = do 217 | s <- getModelStateDL 218 | ctx <- getVarContextDL 219 | pure $ ctxAtType @ThreadId ctx \\ dead s 220 | 221 | pickThread :: DL RegState (Var ThreadId) 222 | pickThread = do 223 | tids <- ctxAtType @ThreadId <$> getVarContextDL 224 | forAllQ $ elementsQ tids 225 | 226 | pickAlive :: DL RegState (Var ThreadId) 227 | pickAlive = do 228 | alive <- getAlive 229 | forAllQ $ elementsQ alive 230 | 231 | pickFreshName :: DL RegState String 232 | pickFreshName = do 233 | used <- Map.keys . regs <$> getModelStateDL 234 | forAllQ $ elementsQ (allNames \\ used) 235 | 236 | -- test that the registry never contains more than k processes 237 | 238 | regLimit :: Int -> DL RegState () 239 | regLimit k = do 240 | anyActions_ 241 | assertModel "Too many processes" $ \s -> Map.size (regs s) <= k 242 | 243 | -- test that we can register a pid that is not dead, if we unregister the name first. 244 | 245 | canRegisterAlive :: String -> DL RegState () 246 | canRegisterAlive name = do 247 | tid <- pickAlive 248 | unregisterNameAndTid name tid 249 | action $ Register name tid 250 | pure () 251 | 252 | canRegister :: DL RegState () 253 | canRegister = do 254 | anyActions_ 255 | name <- pickFreshName 256 | canRegisterAlive name 257 | 258 | canRegisterNoUnregister :: DL RegState () 259 | canRegisterNoUnregister = do 260 | anyActions_ 261 | name <- pickFreshName 262 | tid <- pickAlive 263 | action $ Register name tid 264 | pure () 265 | 266 | tests :: TestTree 267 | tests = 268 | testGroup 269 | "registry model example" 270 | [ testProperty "prop_Registry" $ prop_Registry 271 | , testProperty "moreActions 10 $ prop_Registry" $ moreActions 10 prop_Registry 272 | , testProperty "canRegister" $ propDL canRegister 273 | , testProperty "canRegisterNoUnregister" $ expectFailure $ propDL canRegisterNoUnregister 274 | ] 275 | -------------------------------------------------------------------------------- /quickcheck-dynamic/test/Test/QuickCheck/DynamicLogic/QuantifySpec.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.DynamicLogic.QuantifySpec where 2 | 3 | import Test.QuickCheck (Arbitrary (..), Gen, Property) 4 | import Test.QuickCheck.DynamicLogic.Quantify (validQuantification, withGenQ) 5 | import Test.Tasty (TestTree, testGroup) 6 | import Test.Tasty.QuickCheck (testProperty) 7 | 8 | propWithGenQRestrictsValues :: Property 9 | propWithGenQRestrictsValues = 10 | validQuantification $ withGenQ (arbitrary :: Gen Int) ((< 10) . abs) (shrink @Int) 11 | 12 | tests :: TestTree 13 | tests = 14 | testGroup 15 | "Quantification" 16 | [testProperty "withGenQ restricts possible generated values" propWithGenQRestrictsValues] 17 | -------------------------------------------------------------------------------- /quickcheck-dynamic/test/Test/QuickCheck/StateModelSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | 4 | module Test.QuickCheck.StateModelSpec where 5 | 6 | import Control.Monad.Reader (lift) 7 | import Data.IORef (newIORef) 8 | import Data.List (isInfixOf) 9 | import Spec.DynamicLogic.Counters (Counter (..), FailingCounter, SimpleCounter (..)) 10 | import Test.QuickCheck (Property, Result (..), Testable, chatty, checkCoverage, choose, counterexample, cover, noShrinking, property, stdArgs) 11 | import Test.QuickCheck.Extras (runPropertyReaderT) 12 | import Test.QuickCheck.Monadic (assert, monadicIO, monitor, pick) 13 | import Test.QuickCheck.StateModel ( 14 | Actions, 15 | lookUpVarMaybe, 16 | mkVar, 17 | moreActions, 18 | runActions, 19 | underlyingState, 20 | viewAtType, 21 | pattern Actions, 22 | ) 23 | import Test.QuickCheck.Test (test, withState) 24 | import Test.Tasty (TestTree, testGroup) 25 | import Test.Tasty.HUnit (testCase, (@?)) 26 | import Test.Tasty.QuickCheck (testProperty) 27 | 28 | tests :: TestTree 29 | tests = 30 | testGroup 31 | "Running actions" 32 | [ testProperty "simple counter" $ prop_counter 33 | , testProperty "simple_counter_moreActions" $ moreActions 30 prop_counter 34 | , testProperty "returns final state updated from actions" prop_returnsFinalState 35 | , testProperty "environment variables indices are 1-based " prop_variablesIndicesAre1Based 36 | , testCase "prints distribution of actions and polarity" $ do 37 | Success{output} <- captureTerminal prop_returnsFinalState 38 | "100.00% +Inc" `isInfixOf` output @? "Output does not contain '100.00% +Inc'" 39 | "Action polarity" `isInfixOf` output @? "Output does not contain 'Action polarity'" 40 | , testCase "prints counterexample as sequence of steps when postcondition fails" $ do 41 | Failure{output} <- captureTerminal prop_failsOnPostcondition 42 | "do action $ Inc'" `isInfixOf` output @? "Output does not contain \"do action $ Inc'\": " <> output 43 | , testProperty 44 | "moreActions introduces long sequences of actions" 45 | prop_longSequences 46 | ] 47 | 48 | captureTerminal :: Testable p => p -> IO Result 49 | captureTerminal p = 50 | withState stdArgs{chatty = False} $ \st -> 51 | test st (property p) 52 | 53 | prop_counter :: Actions Counter -> Property 54 | prop_counter as = monadicIO $ do 55 | ref <- lift $ newIORef (0 :: Int) 56 | runPropertyReaderT (runActions as) ref 57 | assert True 58 | 59 | prop_returnsFinalState :: Actions SimpleCounter -> Property 60 | prop_returnsFinalState actions@(Actions as) = 61 | monadicIO $ do 62 | ref <- lift $ newIORef (0 :: Int) 63 | (s, _) <- runPropertyReaderT (runActions actions) ref 64 | assert $ count (underlyingState s) == length as 65 | 66 | prop_variablesIndicesAre1Based :: Actions SimpleCounter -> Property 67 | prop_variablesIndicesAre1Based actions@(Actions as) = 68 | noShrinking $ monadicIO $ do 69 | ref <- lift $ newIORef (0 :: Int) 70 | (_, env) <- runPropertyReaderT (runActions actions) ref 71 | act <- pick $ choose (0, length as - 1) 72 | monitor $ 73 | counterexample $ 74 | unlines 75 | [ "Env: " <> show (viewAtType @Int <$> env) 76 | , "Actions: " <> show as 77 | , "Act: " <> show act 78 | ] 79 | assert $ null as || lookUpVarMaybe env (mkVar $ act + 1) == Just act 80 | 81 | prop_failsOnPostcondition :: Actions FailingCounter -> Property 82 | prop_failsOnPostcondition actions = 83 | monadicIO $ do 84 | ref <- lift $ newIORef (0 :: Int) 85 | runPropertyReaderT (runActions actions) ref 86 | assert True 87 | 88 | prop_longSequences :: Property 89 | prop_longSequences = 90 | checkCoverage $ moreActions 10 $ \(Actions steps :: Actions SimpleCounter) -> cover 50 (100 < length steps) "Long sequences" True 91 | --------------------------------------------------------------------------------