├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .travis.yml ├── LICENSE ├── QuickCheck.cabal ├── README ├── Setup.lhs ├── cabal.haskell-ci ├── changelog ├── examples ├── Heap.hs ├── Heap_Program.hs ├── Heap_ProgramAlgebraic.hs ├── Lambda.hs ├── Merge.hs ├── Set.hs └── Simple.hs ├── make-hugs ├── src └── Test │ ├── QuickCheck.hs │ └── QuickCheck │ ├── All.hs │ ├── Arbitrary.hs │ ├── Exception.hs │ ├── Features.hs │ ├── Function.hs │ ├── Gen.hs │ ├── Gen │ ├── Class.hs │ └── Unsafe.hs │ ├── Modifiers.hs │ ├── Monadic.hs │ ├── Poly.hs │ ├── Property.hs │ ├── Random.hs │ ├── Test.hs │ └── Text.hs ├── test-hugs └── tests ├── GCoArbitraryExample.hs ├── GShrinkExample.hs ├── Generators.hs ├── Misc.hs ├── MonadFix.hs ├── ShrinkMap.hs ├── Split.hs ├── Terminal.hs ├── TestRandom.hs └── Weird.hs /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci '--config' 'cabal.haskell-ci' 'github' 'QuickCheck.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.13.20210621 12 | # 13 | # REGENDATA ("0.13.20210621",["--config","cabal.haskell-ci","github","QuickCheck.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-18.04 23 | container: 24 | image: buildpack-deps:bionic 25 | continue-on-error: ${{ matrix.allow-failure }} 26 | strategy: 27 | matrix: 28 | include: 29 | - compiler: ghc-9.0.1 30 | compilerKind: ghc 31 | compilerVersion: 9.0.1 32 | setup-method: hvr-ppa 33 | allow-failure: false 34 | - compiler: ghc-8.10.4 35 | compilerKind: ghc 36 | compilerVersion: 8.10.4 37 | setup-method: hvr-ppa 38 | allow-failure: false 39 | - compiler: ghc-8.10.3 40 | compilerKind: ghc 41 | compilerVersion: 8.10.3 42 | setup-method: hvr-ppa 43 | allow-failure: false 44 | - compiler: ghc-8.10.2 45 | compilerKind: ghc 46 | compilerVersion: 8.10.2 47 | setup-method: hvr-ppa 48 | allow-failure: false 49 | - compiler: ghc-8.10.1 50 | compilerKind: ghc 51 | compilerVersion: 8.10.1 52 | setup-method: hvr-ppa 53 | allow-failure: false 54 | - compiler: ghc-8.8.4 55 | compilerKind: ghc 56 | compilerVersion: 8.8.4 57 | setup-method: hvr-ppa 58 | allow-failure: false 59 | - compiler: ghc-8.8.3 60 | compilerKind: ghc 61 | compilerVersion: 8.8.3 62 | setup-method: hvr-ppa 63 | allow-failure: false 64 | - compiler: ghc-8.8.2 65 | compilerKind: ghc 66 | compilerVersion: 8.8.2 67 | setup-method: hvr-ppa 68 | allow-failure: false 69 | - compiler: ghc-8.8.1 70 | compilerKind: ghc 71 | compilerVersion: 8.8.1 72 | setup-method: hvr-ppa 73 | allow-failure: false 74 | - compiler: ghc-8.6.5 75 | compilerKind: ghc 76 | compilerVersion: 8.6.5 77 | setup-method: hvr-ppa 78 | allow-failure: false 79 | - compiler: ghc-8.6.4 80 | compilerKind: ghc 81 | compilerVersion: 8.6.4 82 | setup-method: hvr-ppa 83 | allow-failure: false 84 | - compiler: ghc-8.6.3 85 | compilerKind: ghc 86 | compilerVersion: 8.6.3 87 | setup-method: hvr-ppa 88 | allow-failure: false 89 | - compiler: ghc-8.6.2 90 | compilerKind: ghc 91 | compilerVersion: 8.6.2 92 | setup-method: hvr-ppa 93 | allow-failure: false 94 | - compiler: ghc-8.6.1 95 | compilerKind: ghc 96 | compilerVersion: 8.6.1 97 | setup-method: hvr-ppa 98 | allow-failure: false 99 | - compiler: ghc-8.4.4 100 | compilerKind: ghc 101 | compilerVersion: 8.4.4 102 | setup-method: hvr-ppa 103 | allow-failure: false 104 | - compiler: ghc-8.4.3 105 | compilerKind: ghc 106 | compilerVersion: 8.4.3 107 | setup-method: hvr-ppa 108 | allow-failure: false 109 | - compiler: ghc-8.4.2 110 | compilerKind: ghc 111 | compilerVersion: 8.4.2 112 | setup-method: hvr-ppa 113 | allow-failure: false 114 | - compiler: ghc-8.4.1 115 | compilerKind: ghc 116 | compilerVersion: 8.4.1 117 | setup-method: hvr-ppa 118 | allow-failure: false 119 | - compiler: ghc-8.2.2 120 | compilerKind: ghc 121 | compilerVersion: 8.2.2 122 | setup-method: hvr-ppa 123 | allow-failure: false 124 | - compiler: ghc-8.0.2 125 | compilerKind: ghc 126 | compilerVersion: 8.0.2 127 | setup-method: hvr-ppa 128 | allow-failure: false 129 | - compiler: ghc-7.10.3 130 | compilerKind: ghc 131 | compilerVersion: 7.10.3 132 | setup-method: hvr-ppa 133 | allow-failure: false 134 | - compiler: ghc-7.8.4 135 | compilerKind: ghc 136 | compilerVersion: 7.8.4 137 | setup-method: hvr-ppa 138 | allow-failure: false 139 | - compiler: ghc-7.6.3 140 | compilerKind: ghc 141 | compilerVersion: 7.6.3 142 | setup-method: hvr-ppa 143 | allow-failure: false 144 | - compiler: ghc-7.4.2 145 | compilerKind: ghc 146 | compilerVersion: 7.4.2 147 | setup-method: hvr-ppa 148 | allow-failure: false 149 | - compiler: ghc-7.4.1 150 | compilerKind: ghc 151 | compilerVersion: 7.4.1 152 | setup-method: hvr-ppa 153 | allow-failure: false 154 | - compiler: ghc-7.2.2 155 | compilerKind: ghc 156 | compilerVersion: 7.2.2 157 | setup-method: hvr-ppa 158 | allow-failure: false 159 | - compiler: ghc-7.0.4 160 | compilerKind: ghc 161 | compilerVersion: 7.0.4 162 | setup-method: hvr-ppa 163 | allow-failure: false 164 | fail-fast: false 165 | steps: 166 | - name: apt 167 | run: | 168 | apt-get update 169 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 170 | apt-add-repository -y 'ppa:hvr/ghc' 171 | apt-get update 172 | apt-get install -y "$HCNAME" cabal-install-3.4 hugs libhugs-time-bundled 173 | env: 174 | HCKIND: ${{ matrix.compilerKind }} 175 | HCNAME: ${{ matrix.compiler }} 176 | HCVER: ${{ matrix.compilerVersion }} 177 | - name: Set PATH and environment variables 178 | run: | 179 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 180 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 181 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 182 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 183 | HCDIR=/opt/$HCKIND/$HCVER 184 | HC=$HCDIR/bin/$HCKIND 185 | echo "HC=$HC" >> "$GITHUB_ENV" 186 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 187 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 188 | echo "CABAL=/opt/cabal/3.4/bin/cabal -vnormal+nowrap" >> "$GITHUB_ENV" 189 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 190 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 191 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 192 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 193 | if [ $((HCNUMVER >= 90200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi 194 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 195 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 196 | env: 197 | HCKIND: ${{ matrix.compilerKind }} 198 | HCNAME: ${{ matrix.compiler }} 199 | HCVER: ${{ matrix.compilerVersion }} 200 | - name: env 201 | run: | 202 | env 203 | - name: write cabal config 204 | run: | 205 | mkdir -p $CABAL_DIR 206 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 246 | echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - 247 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 248 | rm -f cabal-plan.xz 249 | chmod a+x $HOME/.cabal/bin/cabal-plan 250 | cabal-plan --version 251 | - name: checkout 252 | uses: actions/checkout@v2 253 | with: 254 | path: source 255 | - name: initial cabal.project for sdist 256 | run: | 257 | touch cabal.project 258 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 259 | cat cabal.project 260 | - name: sdist 261 | run: | 262 | mkdir -p sdist 263 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 264 | - name: unpack 265 | run: | 266 | mkdir -p unpacked 267 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 268 | - name: generate cabal.project 269 | run: | 270 | PKGDIR_QuickCheck="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/QuickCheck-[0-9.]*')" 271 | echo "PKGDIR_QuickCheck=${PKGDIR_QuickCheck}" >> "$GITHUB_ENV" 272 | rm -f cabal.project cabal.project.local 273 | touch cabal.project 274 | touch cabal.project.local 275 | echo "packages: ${PKGDIR_QuickCheck}" >> cabal.project 276 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package QuickCheck" >> cabal.project ; fi 277 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 278 | cat >> cabal.project <> cabal.project 282 | fi 283 | $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: $_ installed\n" unless /^(QuickCheck)$/; }' >> cabal.project.local 284 | cat cabal.project 285 | cat cabal.project.local 286 | - name: dump install plan 287 | run: | 288 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 289 | cabal-plan 290 | - name: cache 291 | uses: actions/cache@v2 292 | with: 293 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 294 | path: ~/.cabal/store 295 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 296 | - name: install dependencies 297 | run: | 298 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 299 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 300 | - name: build w/o tests 301 | run: | 302 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 303 | - name: build 304 | run: | 305 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 306 | - name: tests 307 | run: | 308 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 309 | - name: haddock 310 | run: | 311 | $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 312 | - name: unconstrained build 313 | run: | 314 | rm -f cabal.project.local 315 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 316 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /dist-newstyle/ 3 | .ghc.environment.* 4 | *.hi 5 | *.o 6 | *~ 7 | \#* 8 | .\#* 9 | *.swp 10 | 11 | quickcheck-hugs/ 12 | hugs.output 13 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci '--config=cabal.haskell-ci' 'QuickCheck.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.10 12 | # 13 | version: ~> 1.0 14 | language: c 15 | os: linux 16 | dist: xenial 17 | git: 18 | # whether to recursively clone submodules 19 | submodules: false 20 | cache: 21 | directories: 22 | - $HOME/.cabal/packages 23 | - $HOME/.cabal/store 24 | - $HOME/.hlint 25 | before_cache: 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 27 | # remove files that are regenerated by 'cabal update' 28 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 29 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 30 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 31 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 32 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 33 | - rm -rfv $CABALHOME/packages/head.hackage 34 | jobs: 35 | include: 36 | - compiler: ghc-8.10.1 37 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 38 | os: linux 39 | - compiler: ghc-8.8.3 40 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 41 | os: linux 42 | - compiler: ghc-8.8.2 43 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.2","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 44 | os: linux 45 | - compiler: ghc-8.8.1 46 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 47 | os: linux 48 | - compiler: ghc-8.6.5 49 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 50 | os: linux 51 | - compiler: ghc-8.6.4 52 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.4","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 53 | os: linux 54 | - compiler: ghc-8.6.3 55 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.3","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 56 | os: linux 57 | - compiler: ghc-8.6.2 58 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.2","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 59 | os: linux 60 | - compiler: ghc-8.6.1 61 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.1","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 62 | os: linux 63 | - compiler: ghc-8.4.4 64 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 65 | os: linux 66 | - compiler: ghc-8.4.3 67 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.3","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 68 | os: linux 69 | - compiler: ghc-8.4.2 70 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.2","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 71 | os: linux 72 | - compiler: ghc-8.4.1 73 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.1","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 74 | os: linux 75 | - compiler: ghc-8.2.2 76 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 77 | os: linux 78 | - compiler: ghc-8.2.1 79 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.1","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 80 | os: linux 81 | - compiler: ghc-8.0.2 82 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 83 | os: linux 84 | - compiler: ghc-8.0.1 85 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.1","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 86 | os: linux 87 | - compiler: ghc-7.10.3 88 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.3","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 89 | os: linux 90 | - compiler: ghc-7.10.2 91 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.2","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 92 | os: linux 93 | - compiler: ghc-7.10.1 94 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.10.1","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 95 | os: linux 96 | - compiler: ghc-7.8.4 97 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.4","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 98 | os: linux 99 | - compiler: ghc-7.8.3 100 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.3","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 101 | os: linux 102 | - compiler: ghc-7.8.2 103 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.2","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 104 | os: linux 105 | - compiler: ghc-7.8.1 106 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.8.1","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 107 | os: linux 108 | - compiler: ghc-7.6.3 109 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.6.3","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 110 | os: linux 111 | - compiler: ghc-7.6.2 112 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.6.2","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 113 | os: linux 114 | - compiler: ghc-7.6.1 115 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.6.1","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 116 | os: linux 117 | - compiler: ghc-7.4.2 118 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.4.2","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 119 | os: linux 120 | - compiler: ghc-7.4.1 121 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.4.1","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 122 | os: linux 123 | - compiler: ghc-7.2.2 124 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.2.2","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 125 | os: linux 126 | - compiler: ghc-7.0.4 127 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-7.0.4","cabal-install-3.2","hugs","libhugs-time-bundled"]}} 128 | os: linux 129 | before_install: 130 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 131 | - WITHCOMPILER="-w $HC" 132 | - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') 133 | - HCPKG="$HC-pkg" 134 | - unset CC 135 | - CABAL=/opt/ghc/bin/cabal 136 | - CABALHOME=$HOME/.cabal 137 | - export PATH="$CABALHOME/bin:$PATH" 138 | - TOP=$(pwd) 139 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 140 | - echo $HCNUMVER 141 | - CABAL="$CABAL -vnormal+nowrap" 142 | - set -o pipefail 143 | - TEST=--enable-tests 144 | - BENCH=--enable-benchmarks 145 | - HEADHACKAGE=false 146 | - rm -f $CABALHOME/config 147 | - | 148 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 149 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 150 | echo "write-ghc-environment-files: always" >> $CABALHOME/config 151 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 152 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 153 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 154 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 155 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 156 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 157 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 158 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 159 | echo "install-dirs user" >> $CABALHOME/config 160 | echo " prefix: $CABALHOME" >> $CABALHOME/config 161 | echo "repository hackage.haskell.org" >> $CABALHOME/config 162 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 163 | install: 164 | - ${CABAL} --version 165 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 166 | - | 167 | echo "program-default-options" >> $CABALHOME/config 168 | echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config 169 | - cat $CABALHOME/config 170 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 171 | - travis_retry ${CABAL} v2-update -v 172 | # Generate cabal.project 173 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 174 | - touch cabal.project 175 | - | 176 | echo "packages: ." >> cabal.project 177 | - if [ $HCNUMVER -ge 80200 ] ; then echo 'package QuickCheck' >> cabal.project ; fi 178 | - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" 179 | - | 180 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(QuickCheck)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 181 | - cat cabal.project || true 182 | - cat cabal.project.local || true 183 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 184 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} 185 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 186 | - rm cabal.project.freeze 187 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all 188 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all 189 | script: 190 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 191 | # Packaging... 192 | - ${CABAL} v2-sdist all 193 | # Unpacking... 194 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 195 | - cd ${DISTDIR} || false 196 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 197 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 198 | - PKGDIR_QuickCheck="$(find . -maxdepth 1 -type d -regex '.*/QuickCheck-[0-9.]*')" 199 | # Generate cabal.project 200 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 201 | - touch cabal.project 202 | - | 203 | echo "packages: ${PKGDIR_QuickCheck}" >> cabal.project 204 | - if [ $HCNUMVER -ge 80200 ] ; then echo 'package QuickCheck' >> cabal.project ; fi 205 | - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" 206 | - | 207 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(QuickCheck)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 208 | - cat cabal.project || true 209 | - cat cabal.project.local || true 210 | # Building... 211 | # this builds all libraries and executables (without tests/benchmarks) 212 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 213 | # Building with tests and benchmarks... 214 | # build & run tests, build benchmarks 215 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all 216 | # Testing... 217 | - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all 218 | # haddock... 219 | - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all 220 | # Building without installed constraints for packages in global-db... 221 | - rm -f cabal.project.local 222 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 223 | # Raw travis commands 224 | - export CABAL 225 | - export HC 226 | - (cd ${PKGDIR_QuickCheck} && sh test-hugs) 227 | 228 | # REGENDATA ("0.10",["--config=cabal.haskell-ci","QuickCheck.cabal"]) 229 | # EOF 230 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | (The following is the 3-clause BSD license.) 2 | 3 | Copyright (c) 2000-2019, Koen Claessen 4 | Copyright (c) 2006-2008, Björn Bringert 5 | Copyright (c) 2009-2019, Nick Smallbone 6 | 7 | Redistribution and use in source and binary forms, with or without 8 | modification, are permitted provided that the following conditions are met: 9 | 10 | - Redistributions of source code must retain the above copyright notice, 11 | this list of conditions and the following disclaimer. 12 | - Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | - Neither the names of the copyright owners nor the names of the 16 | contributors may be used to endorse or promote products derived 17 | from this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /QuickCheck.cabal: -------------------------------------------------------------------------------- 1 | Name: QuickCheck 2 | Version: 2.14.2 3 | Cabal-Version: >= 1.10 4 | Build-type: Simple 5 | License: BSD3 6 | License-file: LICENSE 7 | Copyright: 2000-2019 Koen Claessen, 2006-2008 Björn Bringert, 2009-2019 Nick Smallbone 8 | Author: Koen Claessen 9 | Maintainer: Nick Smallbone 10 | Bug-reports: https://github.com/nick8325/quickcheck/issues 11 | Tested-with: GHC ==7.0.4 || ==7.2.2 || >= 7.4 12 | Homepage: https://github.com/nick8325/quickcheck 13 | Category: Testing 14 | Synopsis: Automatic testing of Haskell programs 15 | Description: 16 | QuickCheck is a library for random testing of program properties. 17 | The programmer provides a specification of the program, in the form of 18 | properties which functions should satisfy, and QuickCheck then tests that the 19 | properties hold in a large number of randomly generated cases. 20 | Specifications are expressed in Haskell, using combinators provided by 21 | QuickCheck. QuickCheck provides combinators to define properties, observe the 22 | distribution of test data, and define test data generators. 23 | . 24 | Most of QuickCheck's functionality is exported by the main "Test.QuickCheck" 25 | module. The main exception is the monadic property testing library in 26 | "Test.QuickCheck.Monadic". 27 | . 28 | If you are new to QuickCheck, you can try looking at the following resources: 29 | . 30 | * The . 31 | It's a bit out-of-date in some details and doesn't cover newer QuickCheck features, 32 | but is still full of good advice. 33 | * , 34 | a detailed tutorial written by a user of QuickCheck. 35 | . 36 | The 37 | companion package provides instances for types in Haskell Platform packages 38 | at the cost of additional dependencies. 39 | 40 | extra-source-files: 41 | README 42 | changelog 43 | examples/Heap.hs 44 | examples/Heap_Program.hs 45 | examples/Heap_ProgramAlgebraic.hs 46 | examples/Lambda.hs 47 | examples/Merge.hs 48 | examples/Set.hs 49 | examples/Simple.hs 50 | make-hugs 51 | test-hugs 52 | 53 | source-repository head 54 | type: git 55 | location: https://github.com/nick8325/quickcheck 56 | 57 | source-repository this 58 | type: git 59 | location: https://github.com/nick8325/quickcheck 60 | tag: 2.14.2 61 | 62 | flag templateHaskell 63 | Description: Build Test.QuickCheck.All, which uses Template Haskell. 64 | Default: True 65 | Manual: True 66 | 67 | flag old-random 68 | Description: Build against a pre-1.2.0 version of the random package. 69 | Default: False 70 | Manual: False 71 | 72 | library 73 | Hs-source-dirs: src 74 | Build-depends: base >=4.3 && <5, containers 75 | Default-language: Haskell2010 76 | 77 | -- New vs old random. 78 | if flag(old-random) 79 | Build-depends: random >= 1.0.0.3 && < 1.2.0 80 | cpp-options: -DOLD_RANDOM 81 | else 82 | Build-depends: random >= 1.2.0 && < 1.3 83 | 84 | -- We always use splitmix directly rather than going through StdGen 85 | -- (it's somewhat more efficient). 86 | -- However, Hugs traps overflow on Word64, so we have to stick 87 | -- with StdGen there. 88 | if impl(hugs) 89 | cpp-options: -DNO_SPLITMIX 90 | else 91 | Build-depends: splitmix >= 0.1 && <0.2 92 | 93 | -- Modules that are always built. 94 | Exposed-Modules: 95 | Test.QuickCheck, 96 | Test.QuickCheck.Arbitrary, 97 | Test.QuickCheck.Gen, 98 | Test.QuickCheck.Gen.Unsafe, 99 | Test.QuickCheck.Monadic, 100 | Test.QuickCheck.Modifiers, 101 | Test.QuickCheck.Property, 102 | Test.QuickCheck.Test, 103 | Test.QuickCheck.Text, 104 | Test.QuickCheck.Poly, 105 | Test.QuickCheck.Random, 106 | Test.QuickCheck.Exception, 107 | Test.QuickCheck.Features 108 | 109 | -- GHC-specific modules. 110 | if impl(ghc) 111 | Exposed-Modules: Test.QuickCheck.Function 112 | Build-depends: transformers >= 0.3, deepseq >= 1.1.0.0 113 | else 114 | cpp-options: -DNO_TRANSFORMERS -DNO_DEEPSEQ 115 | 116 | if impl(ghc) && flag(templateHaskell) && !impl(haste) 117 | Build-depends: template-haskell >= 2.4 118 | if impl(ghc >=8.0) 119 | Other-Extensions: TemplateHaskellQuotes 120 | else 121 | Other-Extensions: TemplateHaskell 122 | Exposed-Modules: Test.QuickCheck.All 123 | else 124 | cpp-options: -DNO_TEMPLATE_HASKELL 125 | 126 | if !impl(ghc >= 7.4) 127 | cpp-options: -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS 128 | 129 | -- The new generics appeared in GHC 7.2... 130 | if impl(ghc < 7.2) 131 | cpp-options: -DNO_GENERICS 132 | -- ...but in 7.2-7.4 it lives in the ghc-prim package. 133 | if impl(ghc >= 7.2) && impl(ghc < 7.6) 134 | Build-depends: ghc-prim 135 | 136 | -- Safe Haskell appeared in GHC 7.2, but GHC.Generics isn't safe until 7.4. 137 | if impl (ghc < 7.4) 138 | cpp-options: -DNO_SAFE_HASKELL 139 | 140 | -- random is explicitly Trustworthy since 1.0.1.0 141 | -- similar constraint for containers 142 | if impl(ghc >= 7.2) 143 | Build-depends: random >=1.0.1.0 144 | if impl(ghc >= 7.4) 145 | Build-depends: containers >=0.4.2.1 146 | 147 | if !impl(ghc >= 7.6) 148 | cpp-options: -DNO_POLYKINDS 149 | 150 | if !impl(ghc >= 8.0) 151 | cpp-options: -DNO_MONADFAIL 152 | 153 | -- Switch off most optional features on non-GHC systems. 154 | if !impl(ghc) 155 | -- If your Haskell compiler can cope without some of these, please 156 | -- send a message to the QuickCheck mailing list! 157 | cpp-options: -DNO_TIMEOUT -DNO_NEWTYPE_DERIVING -DNO_GENERICS 158 | -DNO_TEMPLATE_HASKELL -DNO_SAFE_HASKELL -DNO_TYPEABLE -DNO_GADTS 159 | -DNO_EXTRA_METHODS_IN_APPLICATIVE -DOLD_RANDOM 160 | if !impl(hugs) && !impl(uhc) 161 | cpp-options: -DNO_ST_MONAD -DNO_MULTI_PARAM_TYPE_CLASSES 162 | 163 | -- LANGUAGE pragmas don't have any effect in Hugs. 164 | if impl(hugs) 165 | Default-Extensions: CPP 166 | 167 | if impl(uhc) 168 | -- Cabal under UHC needs pointing out all the dependencies of the 169 | -- random package. 170 | Build-depends: old-time, old-locale 171 | -- Plus some bits of the standard library are missing. 172 | cpp-options: -DNO_FIXED -DNO_EXCEPTIONS 173 | 174 | Test-Suite test-quickcheck 175 | type: exitcode-stdio-1.0 176 | Default-language: Haskell2010 177 | hs-source-dirs: 178 | examples 179 | main-is: Heap.hs 180 | build-depends: base, QuickCheck 181 | if !flag(templateHaskell) || impl(haste) 182 | Buildable: False 183 | 184 | Test-Suite test-quickcheck-gcoarbitrary 185 | type: exitcode-stdio-1.0 186 | Default-language: Haskell2010 187 | hs-source-dirs: tests 188 | main-is: GCoArbitraryExample.hs 189 | build-depends: base, QuickCheck 190 | if !flag(templateHaskell) || !impl(ghc >= 7.2) || impl(haste) 191 | buildable: False 192 | if impl(ghc >= 7.2) && impl(ghc < 7.6) 193 | build-depends: ghc-prim 194 | 195 | Test-Suite test-quickcheck-generators 196 | type: exitcode-stdio-1.0 197 | Default-language: Haskell2010 198 | hs-source-dirs: tests 199 | main-is: Generators.hs 200 | build-depends: base, QuickCheck 201 | if !flag(templateHaskell) || impl(haste) 202 | Buildable: False 203 | 204 | Test-Suite test-quickcheck-gshrink 205 | type: exitcode-stdio-1.0 206 | Default-language: Haskell2010 207 | hs-source-dirs: tests 208 | main-is: GShrinkExample.hs 209 | build-depends: base, QuickCheck 210 | if !flag(templateHaskell) || !impl(ghc >= 7.2) || impl(haste) 211 | buildable: False 212 | if impl(ghc >= 7.2) && impl(ghc < 7.6) 213 | build-depends: ghc-prim 214 | 215 | Test-Suite test-quickcheck-terminal 216 | type: exitcode-stdio-1.0 217 | Default-language: Haskell2010 218 | hs-source-dirs: tests 219 | main-is: Terminal.hs 220 | build-depends: base, process, deepseq >= 1.1.0.0, QuickCheck 221 | if !flag(templateHaskell) || !impl(ghc >= 7.10) || impl(haste) 222 | buildable: False 223 | 224 | Test-Suite test-quickcheck-monadfix 225 | type: exitcode-stdio-1.0 226 | Default-language: Haskell2010 227 | hs-source-dirs: tests 228 | main-is: MonadFix.hs 229 | build-depends: base, QuickCheck 230 | if !flag(templateHaskell) || !impl(ghc >= 7.10) || impl(haste) 231 | buildable: False 232 | 233 | Test-Suite test-quickcheck-split 234 | type: exitcode-stdio-1.0 235 | Default-language: Haskell2010 236 | hs-source-dirs: tests 237 | main-is: Split.hs 238 | build-depends: base, QuickCheck 239 | 240 | Test-Suite test-quickcheck-misc 241 | type: exitcode-stdio-1.0 242 | Default-language: Haskell2010 243 | hs-source-dirs: tests 244 | main-is: Misc.hs 245 | build-depends: base, QuickCheck 246 | if !flag(templateHaskell) || !impl(ghc >= 7.10) || impl(haste) 247 | buildable: False 248 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Roberts fork: this fork contains experimental support for running tests in parallel, and shrinking in parallel. 2 | Only the internal evaluation of a property is changed, so the API of QC remains unchanged. There is a module 3 | `Test.QuickCheck.Features` which I've completely commented out for now, so that will obviously not work. 4 | 5 | In order to try this out yourself, you must follow three steps: 6 | 7 | 1: You need to make sure cabal knows where my fork of QC exists. You do this by either cloning this repository onto your local machine and pointing your `cabal.project` to it. 8 | You do this e.g. by adding the line `packages: *.cabal /QuickCheck.cabal`. You can also optionally point your cabal to this remote repository. You do this by 9 | editing your `cabal.project` to say 10 | ``` 11 | source-repository-package 12 | type: git 13 | location: https://github.com/Rewbert/quickcheck.git 14 | -- optionally also add this to point to a particular commit, otherwise you will always get the freshest master commit 15 | -- tag: 16 | ``` 17 | 18 | 2: You need to add some flags when you compile your code. Specifically, `-threaded -feager-blackholing -rtsopts`. 19 | 20 | 3: Finally, all that is left is to change the call to `quickCheck` with a call to `quickCheckPar`. If you don't want parallel shrinking, you should call `quickCheckParWith (stdArgs { parallelShrinking = False}) property`. 21 | 22 | 4: You also need to pass in the runtime option that actually creates more HECs. You need to either instead of `cabal run executable` do `cabal run executable -- +RTS -N` or `-Nx` where x is a number between 1 and the number of cores you have. You can also ddd another compilation option `-with-rtsopts=-N` or `-with-rtsopts=-Nx` 23 | 24 | As a sanity check of whether you are using my fork or not, if you run `quickCheckPar` with just 1 HEC available, the word `donkey` will be printed. 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | This is QuickCheck 2, a library for random testing of program properties. 35 | 36 | Add `QuickCheck` to your package dependencies to use it in tests or REPL. 37 | 38 | The quickcheck-instances [1] companion package provides instances for types in 39 | Haskell Platform packages at the cost of additional dependencies. 40 | 41 | The make-hugs script makes a Hugs-compatible version of QuickCheck. 42 | It may also be useful for other non-GHC implementations. 43 | 44 | [1]: http://hackage.haskell.org/package/quickcheck-instances 45 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runghc 2 | 3 | > module Main where 4 | 5 | > import Distribution.Simple 6 | 7 | > main :: IO () 8 | > main = defaultMain 9 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | apt: hugs libhugs-time-bundled 2 | -- fails due: impl(haste) 3 | cabal-check: False 4 | 5 | raw-travis: 6 | export CABAL 7 | export HC 8 | (cd ${PKGDIR_QuickCheck} && sh test-hugs) 9 | -------------------------------------------------------------------------------- /changelog: -------------------------------------------------------------------------------- 1 | QuickCheck 2.14.2 (released 2020-11-14) 2 | * Add Arbitrary instances for Tree (thanks to Oleg Grenrus) 3 | * GHC 9.0 compatibility (thanks to Vilem-Benjamin Liepelt) 4 | 5 | QuickCheck 2.14.1 (released 2020-07-05) 6 | * Compatibility with random >= 1.2. 7 | 8 | QuickCheck 2.14 (released 2020-03-28) 9 | * QuickCheck is now much faster at generating test data! 10 | As a result, many properties can now be tested a lot faster; 11 | the examples distributed with QuickCheck run about twice as 12 | fast as before, for example. Of course, your mileage may vary. 13 | 14 | The reason for this is that there are now specialised versions 15 | of the 'choose' combinator for various types. These are: 16 | chooseInt, chooseInteger, chooseBoundedIntegral, and chooseEnum. 17 | These combinators are identical to 'choose' but much faster. 18 | All QuickCheck combinators, with the exception of 'choose' 19 | itself, use the new combinators behind the scenes. 20 | 21 | You should see a speedup without doing anything, but to get a 22 | further speedup, consider replacing any uses of 'choose' in your 23 | own generators with the new combinators. 24 | 25 | We are hoping that future releases of the 'random' library may 26 | speed up 'choose', in which case these combinators may no longer 27 | be needed. 28 | 29 | Thanks to Oleg Grenrus for suggesting to bypass 'choose' for 30 | random number generation, and providing the appropriate 31 | primitive in his 'splitmix' random number library. 32 | 33 | * Smaller changes and bugfixes: 34 | - RecursivelyShrink and GSubterms are exported from 35 | Test.QuickCheck.Test (thanks to Tom Mortiboy). 36 | - Don't generate invalid unicode characters 37 | (thanks to Boris Stepanov). 38 | - When a call to 'within' fails, include the duration of the 39 | timeout in the failure report (thanks to William Rusnack). 40 | - In Gen, avoid splitting the seed in the implementation of 41 | >>, *> and <* (thanks to David Feuer). 42 | - Fix a couple of bugs with shrinking of floating-point 43 | numbers. 44 | - Export functionMapWith, functionEitherWith and 45 | functionPairWith from Test.QuickCheck.Function 46 | (thanks to Oleg Grenrus). 47 | - Remove redundant RealFloat constraint from 48 | Arbitrary/CoArbitrary instances for Complex 49 | (thanks to Bodigrim). 50 | 51 | QuickCheck 2.13.2 (released 2019-06-30) 52 | * Compatibility with GHC 8.8 (thanks to Bodigrim) 53 | * Improve error message when 'frequency' is used with only zero weights 54 | * Add 'functionVoid' combinator (thanks to Oleg Grenrus) 55 | * Tighten bounds for random package (thanks to Oleg Grenrus) 56 | 57 | QuickCheck 2.13.1 (released 2019-03-29) 58 | * A couple of bug fixes 59 | 60 | QuickCheck 2.13 (released 2019-03-26) 61 | * Properties with multiple arguments now shrink better. 62 | Previously, the first argument was shrunk, then the second, and 63 | so on. Now, the arguments are shrunk as a whole, so shrink steps 64 | for different arguments can be interleaved. 65 | 66 | * New features: 67 | - New modifiers Negative and NonPositive 68 | - A Testable instance for Maybe prop (where Nothing means 'discard 69 | the test case') 70 | * Dependencies on C code removed: 71 | - Use splitmix instead of tf-random for random number generation 72 | - Remove dependency on 'erf' package 73 | * Small changes: 74 | - Say 'Falsified' instead of 'Falsifiable' when a property fails 75 | * Compatibility improvements: 76 | - Explicitly derive instance Typeable Args 77 | - Lower bound on deepseq 78 | - A script for building Hugs packages 79 | 80 | QuickCheck 2.12.6 (released 2018-10-02) 81 | * Make arbitrarySizedBoundedIntegral handle huge sizes correctly. 82 | * Add changelog for QuickCheck 2.12.5 :) 83 | 84 | QuickCheck 2.12.5 (released 2018-09-30) 85 | * Export isSuccess from Test.QuickCheck. 86 | * Export CoArbitrary even when generics are disabled (bugfix). 87 | * Fix bug in shrinkDecimal. 88 | * Include Test.QuickCheck.Gen in exposed modules for Haddock. 89 | 90 | QuickCheck 2.12.3, 2.12.4 (released 2018-09-12) 91 | * Shrinking for Float and Decimal now works by reducing the number 92 | of digits in the number. The new function shrinkDecimal 93 | implements this shrinking behaviour. 94 | * Shrinking for Rational now tries to make the numerator and 95 | denominator of the number smaller. Previously it tried to reduce 96 | the magnitude of the number. 97 | 98 | QuickCheck 2.12.2 (released 2018-09-10) 99 | * Fix infinite shrinking loop for fractional types. 100 | * Add SortedList modifier. 101 | 102 | QuickCheck 2.12.1 (released 2018-09-06) 103 | * Fix bug in 'classify'. 104 | 105 | QuickCheck 2.12 (released 2018-09-03) 106 | * Silently breaking changes! 107 | - The Arbitrary instance for Word now generates only small 108 | values, the same as Int 109 | - cover no longer causes a property failure if coverage is 110 | insufficient. It just prints a warning. (But see next item!) 111 | 112 | * Overhaul of label/cover family of combinators: 113 | - New property combinator checkCoverage, which checks coverage 114 | requirements in a statistically sound way, and *does* fail if 115 | they are not met. 116 | - Order of arguments to cover swapped, to make it easier to 117 | switch between classify and cover 118 | - New combinators tabulate and coverTable, for reporting test 119 | case distribution more flexibly than label. 120 | - When label is called multiple times in a property, each call 121 | produces a separate table of frequencies. 122 | 123 | * New functions: 124 | - (=/=): like (/=), but prints a counterexample 125 | (thanks to tom-bop) 126 | - forAllShow/forAllShrinkShow: quantification using an 127 | explicit show function (thanks to Stevan Andjelkovic) 128 | - forAllBlind/forAllShrinkBlind: quantification without 129 | printing anything 130 | - verboseShrinking: see how a counterexample is shrunk 131 | - labelledExamples: given a property which uses label, 132 | generate an example test case for each label 133 | - idempotentIOProperty: a variant of ioProperty which shrinks 134 | better but only works for idempotent I/O actions 135 | 136 | * Other improvements: 137 | - MonadFix Gen instance (thanks to Jon Fowler) 138 | - Rational numbers shrink using continued fractions 139 | (thanks to Justus Sagemüller) 140 | - Function instances for Const, Identity, and the types in 141 | Data.Monoid; instance Functor Fun (thanks to Erik Schnetter 142 | and Xia Li-yao) 143 | - More of Test.QuickCheck.Function is exported from 144 | Test.QuickCheck 145 | - Semantics of .||. changed to improve short-circuiting: 146 | if the left argument's precondition is false, the right 147 | argument is not evaluated and the whole disjunction is 148 | considered to have a false precondition 149 | - Bug fix: suchThatMaybe always increased size to at least 1 150 | 151 | * Miscellaneous API changes: 152 | - Result type has changed a bit: 153 | - InsufficientCovered constructor is gone 154 | - Type of labels has changed 155 | - New fields classes, tables 156 | 157 | QuickCheck 2.11.1 - 2.11.3 (released 2018-01-12) 158 | * Cosmetic fixes. 159 | 160 | QuickCheck 2.11 (released 2018-01-12) 161 | * New features: 162 | - InfiniteList modifier generates infinite lists and shows 163 | only the relevant part. 164 | - applyArbitrary2/3/4 for applying a function to random 165 | arguments. 166 | - Template Haskell function allProperties returns all 167 | properties in a module. 168 | 169 | * Applicative Gen instances do less splitting. 170 | * Property now has a Typeable instance. 171 | * (===) now prints correct output when the property is true. 172 | * Test.QuickCheck now exports Fun constructor. 173 | * verboseCheck output is now slightly less confusing. 174 | 175 | QuickCheck 2.10.1 (released 2017-10-06) 176 | * Arbitrary instances for Foreign.C.Types are available in more 177 | GHC versions. 178 | * Fixed a bug where withMaxSuccess didn't adjust the allowed 179 | number of discarded tests. 180 | * Remove quadratic behaviour in terminal output. 181 | 182 | QuickCheck 2.10 (released 2017-06-15) 183 | * New combinators: 184 | - withMaxSuccess sets the maximum number of test cases for a property. 185 | - shrinkMap/shrinkMapBy are helpers for defining shrink functions. 186 | - total checks that a value is non-crashing. 187 | - suchThatMap is similar to 'suchThat' 188 | but takes a Maybe-returning function instead of a predicate. 189 | - getSize returns the current test case size. 190 | 191 | * Random strings and characters now include Unicode characters by 192 | default. To generate only ASCII characters, use the new 193 | ASCIIString modifier or arbitraryASCIIChar generator. 194 | The following modifiers and generators also control the 195 | kind of strings generated: UnicodeString, PrintableString, 196 | arbitraryUnicodeChar, arbitraryPrintableChar. 197 | 198 | * QuickCheck no longer catches asynchronous exceptions, which 199 | means that pressing ctrl-C will now cancel testing without 200 | printing a counterexample. If you are debugging an infinite loop, 201 | please use the 'within' combinator or 'verboseCheck' instead. 202 | ('within' is better as it allows the counterexample to be 203 | shrunk.) 204 | 205 | * Much of Test.QuickCheck.Function (showable random functions) 206 | is now exported from Test.QuickCheck. 207 | - Test.QuickCheck.Function now defines functions and 208 | pattern synonyms which simplify testing functions of 209 | more than one argument: apply2, apply3, Fn2, Fn3. 210 | 211 | * New typeclasses Arbitrary1 and Arbitrary2 which lift Arbitrary 212 | to unary/binary type constructors, like in Data.Functor.Classes. 213 | 214 | * Some Arbitrary instances have been removed: NonEmpty, Natural. 215 | This is because they resulted in a lot of extra dependencies. 216 | You can now find them in the quickcheck-instances package. 217 | Alternatively, use the NonEmptyList and NonNegative modifiers. 218 | 219 | * New Arbitrary instances for the following types: Proxy, ExitCode, 220 | WrappedMonad, WrappedArrow, QCGen, and the types in 221 | Foreign.C.Types and Data.Functor.{Product,Compose}. 222 | Also a Function instance for Word. 223 | 224 | * The functions in Test.QuickCheck.Monadic which take an argument 225 | of type PropertyM m a now expect that 'a' to be Testable, and test it. 226 | To reduce breakage from this, () is now an instance of Testable which 227 | always succeeds. 228 | - PropertyM now has a MonadFail instance on recent GHCs. 229 | Furthermore, the constraints on some instances were loosened. 230 | 231 | * Miscellaneous API changes: 232 | - Result now returns the counterexample as a list of strings. 233 | See the "failingTestCase" field. 234 | - Args now has a `maxShrinks` argument, the maximum number of 235 | shrinks to try before giving up shrinking. 236 | - The 'labels' field of Result now encodes frequencies as Doubles 237 | rather than Ints. 238 | 239 | * Bugfixes: 240 | - 'Test.QuickCheck.Function', 'Test.QuickCheck.Poly', and 241 | 'Test.QuickCheck.Monadic' are now Safe modules. 242 | - Result.theException and Result.reason were taken from 243 | the pre-shrunk counterexample, not the shrunk one. 244 | - The Testable Property instance improperly used 'again'. 245 | - Gen.>>= is strict in the result of split, fixing a space leak. 246 | - within now gives a better error message on timeout 247 | 248 | * Some more examples and links have been added to the documentation. 249 | 250 | QuickCheck 2.9.2 (released 2016-09-15) 251 | * Fix a bug where some properties were only being tested once 252 | * Make shrinking of floating-point values less aggressive 253 | * Add function chooseAny :: Random a => Gen a 254 | 255 | QuickCheck 2.9.1 (released 2016-07-11) 256 | * 'again' was only used in forAllShrink, not forAll 257 | 258 | QuickCheck 2.9 (released 2016-07-10) 259 | * Arbitrary, CoArbitrary and Function instances for more types 260 | * Generics for automatic Function instances 261 | * A new combinator "again" which undoes the effect of "once" 262 | * Remove "exhaustive" from Testable typeclass; 263 | instead, combinators which are nonexhaustive (such as forAll) 264 | call "again", which should be more robust 265 | 266 | * Drop support for GHC 6.x 267 | 268 | * Fixed bugs: 269 | * arbitrarySizedBoundedIntegral wasn't generating huge integers 270 | * verboseCheck failed with Test.QuickCheck.Function 271 | * label had a space leak 272 | 273 | QuickCheck 2.8.2 (released 2016-01-15) 274 | * GHC 8 support 275 | * Add Arbitrary and CoArbitrary instances for types in 276 | containers package 277 | * Improve speed of shuffle combinator 278 | * Only print to stderr if it's a terminal. 279 | * Small changes: slightly improve documentation, 280 | remove redundant constraints from some functions' types, 281 | small improvements to Test.QuickCheck.All. 282 | 283 | QuickCheck 2.8.1 (released 2015-04-03) 284 | * Fix bug where exceptions thrown printing counterexamples weren't 285 | being caught when terminal output was disabled 286 | * Don't export Test.QuickCheck.Property.result 287 | 288 | QuickCheck 2.8 (released 2015-03-18) 289 | * New features: 290 | * Support for GHC 7.10 291 | * Arbitrary instance for Natural 292 | * New generators shuffle and sublistOf 293 | * Support for generic coarbitrary 294 | * When using the cover combinator, insufficient coverage now 295 | causes the property to fail 296 | 297 | * API changes: 298 | * Test.QuickCheck.Function: new pattern synonym Fn 299 | * genericShrink no longer requires Typeable 300 | * Result has a new constructor InsufficientCoverage 301 | * resize throws an error if the size is negative 302 | 303 | * Bug fixes: 304 | * Fix memory leaks 305 | * Exceptions thrown by callbacks now cause the test to fail 306 | * Fixed a bug where the cover combinator wouldn't give a 307 | warning if coverage was 0% 308 | 309 | QuickCheck 2.7.3 (released 2014-03-24) 310 | * Add annotations for Safe Haskell. 311 | 312 | QuickCheck 2.7.2 (released 2014-03-22) 313 | * Fix bug in cabal file which broke cabal test 314 | 315 | QuickCheck 2.7.1 (released 2014-03-20) 316 | * Fixed bug - the Small modifier didn't work on unsigned types 317 | * Changed arbitrarySizedIntegral to have an Integral constraint 318 | instead of just Num 319 | 320 | QuickCheck 2.7 (released 2014-03-19) 321 | 322 | * New features: 323 | * New genericShrink function provides generic shrinking with GHC. 324 | * New combinator x === y: fails if x /= y, but also prints their values 325 | * New function generate :: Gen a -> IO a for running a generator. 326 | * New combinators infiniteList and infiniteListOf for generating infinite lists. 327 | * Several combinators added to the main Test.QuickCheck module which 328 | were previously languishing in other modules. Of particular interest: 329 | quickCheckAll, ioProperty. 330 | * New combinators delay and capture which can be used (unsafely!) 331 | to reuse the random number seed. Useful for generating 332 | polymorphic (rank-2) values. 333 | * A new Discard data type and a Testable instance for discarding test cases. 334 | * All modifiers now have Functor instances and accessor functions. 335 | * Pressing ctrl-C during shrinking now shows the last failed 336 | test case, rather than the current shrinking candidate. 337 | * Experimental support for UHC. You will need the latest version of Cabal from git. 338 | 339 | * Better distribution of test data: 340 | * The Int generator now only generates fairly small numbers. 341 | * The new Small and Large modifiers control the distribution of integers 342 | (Small generates small numbers, Large from the whole range). 343 | * Floating-point numbers shrink better. 344 | 345 | * Improved random number generation: 346 | * QuickCheck now uses TFGen rather than StdGen on newer versions 347 | of GHC, because StdGen's random numbers aren't always random. 348 | * 'variant' now uses a prefix code. This should prevent some 349 | potential bananaskins with coarbitrary. 350 | 351 | * API changes: 352 | * The Gen monad now uses an abstract type QCGen rather than StdGen. 353 | * The Result type now returns the thrown exception and number 354 | of failed shrink attempts. 355 | * Property is now a newtype rather than Gen Prop as it was before. 356 | * promote is moved into the new module Test.QuickCheck.Gen.Unsafe. 357 | * 'printTestCase' is deprecated - its new name is 'counterexample' 358 | * 'morallyDubiousIOProperty' is deprecated - its new name is 359 | 'ioProperty', no moral judgement involved :) 360 | 361 | QuickCheck 2.6, released 2013-03-07 362 | 363 | * Add convenience Function instances for up to 7-tuples 364 | * Make stderr line buffered to reduce console I/O. 365 | * Return a flag to say whether the test case was interrupted. 366 | 367 | QuickCheck 2.5, released 2012-06-18 368 | 369 | * Replace maxDiscard with maxDiscardRatio 370 | * Remove Testable () instance. 371 | * Added a 'discard' exception that discards the current test case 372 | * Add accessors for modifiers (where it makes sense) 373 | * Rename 'stop' to 'abort' to avoid a name clash 374 | * Added a 'once' combinator 375 | * If a property is of type Bool, only run it once 376 | * Add coarbitraryEnum to Test.QuickCheck module. 377 | * Add 'coarbitrary' helper for Enums. 378 | * Rejiggled the formatting code to support multi-line error messages 379 | * Add instances for Ordering and Fixed. 380 | * Added arbitraryBoundedEnum generator (thanks to Antoine Latter). 381 | * Add verboseCheckAll and polyverboseCheck function for usability. 382 | -------------------------------------------------------------------------------- /examples/Heap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} 2 | module Main where 3 | 4 | -------------------------------------------------------------------------- 5 | -- imports 6 | 7 | import Test.QuickCheck 8 | 9 | import Data.List 10 | ( sort 11 | , (\\) 12 | ) 13 | 14 | import Control.Monad 15 | ( liftM 16 | , liftM2 17 | ) 18 | 19 | -------------------------------------------------------------------------- 20 | -- skew heaps 21 | 22 | data Heap a 23 | = Node a (Heap a) (Heap a) 24 | | Empty 25 | deriving ( Eq, Ord, Show ) 26 | 27 | empty :: Heap a 28 | empty = Empty 29 | 30 | isEmpty :: Heap a -> Bool 31 | isEmpty Empty = True 32 | isEmpty _ = False 33 | 34 | unit :: a -> Heap a 35 | unit x = Node x empty empty 36 | 37 | size :: Heap a -> Int 38 | size Empty = 0 39 | size (Node _ h1 h2) = 1 + size h1 + size h2 40 | 41 | insert :: Ord a => a -> Heap a -> Heap a 42 | insert x h = unit x `merge` h 43 | 44 | removeMin :: Ord a => Heap a -> Maybe (a, Heap a) 45 | removeMin Empty = Nothing 46 | removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) 47 | 48 | merge :: Ord a => Heap a -> Heap a -> Heap a 49 | h1 `merge` Empty = h1 50 | Empty `merge` h2 = h2 51 | h1@(Node x h11 h12) `merge` h2@(Node y h21 h22) 52 | | x <= y = Node x (h12 `merge` h2) h11 53 | | otherwise = Node y (h22 `merge` h1) h21 54 | 55 | fromList :: Ord a => [a] -> Heap a 56 | fromList xs = merging [ unit x | x <- xs ] 57 | where 58 | merging [] = empty 59 | merging [h] = h 60 | merging hs = merging (sweep hs) 61 | 62 | sweep [] = [] 63 | sweep [h] = [h] 64 | sweep (h1:h2:hs) = (h1 `merge` h2) : sweep hs 65 | 66 | toList :: Heap a -> [a] 67 | toList h = toList' [h] 68 | where 69 | toList' [] = [] 70 | toList' (Empty : hs) = toList' hs 71 | toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) 72 | 73 | toSortedList :: Ord a => Heap a -> [a] 74 | toSortedList Empty = [] 75 | toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) 76 | 77 | -------------------------------------------------------------------------- 78 | -- specification 79 | 80 | invariant :: Ord a => Heap a -> Bool 81 | invariant Empty = True 82 | invariant (Node x h1 h2) = x <=? h1 && x <=? h2 && invariant h1 && invariant h2 83 | 84 | (<=?) :: Ord a => a -> Heap a -> Bool 85 | x <=? Empty = True 86 | x <=? Node y _ _ = x <= y 87 | 88 | (==?) :: Ord a => Heap a -> [a] -> Bool 89 | h ==? xs = invariant h && sort (toList h) == sort xs 90 | 91 | -------------------------------------------------------------------------- 92 | -- properties 93 | 94 | prop_Empty = 95 | empty ==? ([] :: [Int]) 96 | 97 | prop_IsEmpty (h :: Heap Int) = 98 | isEmpty h == null (toList h) 99 | 100 | prop_Unit (x :: Int) = 101 | unit x ==? [x] 102 | 103 | prop_Size (h :: Heap Int) = 104 | size h == length (toList h) 105 | 106 | prop_Insert x (h :: Heap Int) = 107 | insert x h ==? (x : toList h) 108 | 109 | prop_RemoveMin (h :: Heap Int) = 110 | cover 80 (size h > 1) "non-trivial" $ 111 | case removeMin h of 112 | Nothing -> h ==? [] 113 | Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x]) 114 | 115 | prop_Merge h1 (h2 :: Heap Int) = 116 | (h1 `merge` h2) ==? (toList h1 ++ toList h2) 117 | 118 | prop_FromList (xs :: [Int]) = 119 | fromList xs ==? xs 120 | 121 | prop_ToSortedList (h :: Heap Int) = 122 | h ==? xs && xs == sort xs 123 | where 124 | xs = toSortedList h 125 | 126 | -------------------------------------------------------------------------- 127 | -- generators 128 | 129 | instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where 130 | arbitrary = sized (arbHeap Nothing) 131 | where 132 | arbHeap mx n = 133 | frequency $ 134 | [ (1, return Empty) ] ++ 135 | [ (7, do my <- arbitrary `suchThatMaybe` ((>= mx) . Just) 136 | case my of 137 | Nothing -> return Empty 138 | Just y -> liftM2 (Node y) arbHeap2 arbHeap2 139 | where arbHeap2 = arbHeap (Just y) (n `div` 2)) 140 | | n > 0 141 | ] 142 | 143 | -------------------------------------------------------------------------- 144 | -- main 145 | 146 | return [] 147 | main = $quickCheckAll 148 | 149 | -------------------------------------------------------------------------- 150 | -- the end. 151 | {- 152 | shrink Empty = [] 153 | shrink (Node x h1 h2) = 154 | [ h1, h2 ] 155 | ++ [ Node x h1' h2 | h1' <- shrink h1, x <=? h1' ] 156 | ++ [ Node x h1 h2' | h2' <- shrink h2, x <=? h2' ] 157 | ++ [ Node x' h1 h2 | x' <- shrink x, x' <=? h1, x' <=? h2 ] 158 | -} 159 | 160 | -- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) 161 | 162 | {- 163 | prop_HeapIsNotSorted (h :: Heap Int) = 164 | expectFailure $ 165 | toList h == toSortedList h 166 | -} 167 | 168 | -------------------------------------------------------------------------------- /examples/Heap_Program.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} 2 | module Main where 3 | 4 | -------------------------------------------------------------------------- 5 | -- imports 6 | 7 | import Test.QuickCheck 8 | import Test.QuickCheck.Poly 9 | 10 | import Data.List 11 | ( sort 12 | , (\\) 13 | ) 14 | 15 | import Control.Monad 16 | ( liftM 17 | , liftM2 18 | ) 19 | 20 | -------------------------------------------------------------------------- 21 | -- skew heaps 22 | 23 | data Heap a 24 | = Node a (Heap a) (Heap a) 25 | | Nil 26 | deriving ( Eq, Ord, Show ) 27 | 28 | empty :: Heap a 29 | empty = Nil 30 | 31 | isEmpty :: Heap a -> Bool 32 | isEmpty Nil = True 33 | isEmpty _ = False 34 | 35 | unit :: a -> Heap a 36 | unit x = Node x empty empty 37 | 38 | size :: Heap a -> Int 39 | size Nil = 0 40 | size (Node _ h1 h2) = 1 + size h1 + size h2 41 | 42 | insert :: Ord a => a -> Heap a -> Heap a 43 | insert x h = unit x `merge` h 44 | 45 | removeMin :: Ord a => Heap a -> Maybe (a, Heap a) 46 | removeMin Nil = Nothing 47 | removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) 48 | 49 | merge :: Ord a => Heap a -> Heap a -> Heap a 50 | h1 `merge` Nil = h1 51 | Nil `merge` h2 = h2 52 | h1@(Node x h11 h12) `merge` h2@(Node y h21 h22) 53 | | x <= y = Node x (h12 `merge` h2) h11 54 | | otherwise = Node y (h22 `merge` h1) h21 55 | 56 | fromList :: Ord a => [a] -> Heap a 57 | fromList xs = merging [ unit x | x <- xs ] 58 | where 59 | merging [] = empty 60 | merging [h] = h 61 | merging hs = merging (sweep hs) 62 | 63 | sweep [] = [] 64 | sweep [h] = [h] 65 | sweep (h1:h2:hs) = (h1 `merge` h2) : sweep hs 66 | 67 | toList :: Heap a -> [a] 68 | toList h = toList' [h] 69 | where 70 | toList' [] = [] 71 | toList' (Nil : hs) = toList' hs 72 | toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) 73 | 74 | toSortedList :: Ord a => Heap a -> [a] 75 | toSortedList Nil = [] 76 | toSortedList (Node x h1 h2) = x : toList (h1 `merge` h2) 77 | 78 | -------------------------------------------------------------------------- 79 | -- heap programs 80 | 81 | data HeapP a 82 | = Empty 83 | | Unit a 84 | | Insert a (HeapP a) 85 | | SafeRemoveMin (HeapP a) 86 | | Merge (HeapP a) (HeapP a) 87 | | FromList [a] 88 | deriving (Show) 89 | 90 | heap :: Ord a => HeapP a -> Heap a 91 | heap Empty = empty 92 | heap (Unit x) = unit x 93 | heap (Insert x p) = insert x (heap p) 94 | heap (SafeRemoveMin p) = case removeMin (heap p) of 95 | Nothing -> empty -- arbitrary choice 96 | Just (_,h) -> h 97 | heap (Merge p q) = heap p `merge` heap q 98 | heap (FromList xs) = fromList xs 99 | 100 | instance Arbitrary a => Arbitrary (HeapP a) where 101 | arbitrary = sized arbHeapP 102 | where 103 | arbHeapP s = 104 | frequency 105 | [ (1, do return Empty) 106 | , (1, do x <- arbitrary 107 | return (Unit x)) 108 | , (s, do x <- arbitrary 109 | p <- arbHeapP s1 110 | return (Insert x p)) 111 | , (s, do p <- arbHeapP s1 112 | return (SafeRemoveMin p)) 113 | , (s, do p <- arbHeapP s2 114 | q <- arbHeapP s2 115 | return (Merge p q)) 116 | , (1, do xs <- arbitrary 117 | return (FromList xs)) 118 | ] 119 | where 120 | s1 = s-1 121 | s2 = s`div`2 122 | 123 | 124 | shrink (Unit x) = [ Unit x' | x' <- shrink x ] 125 | shrink (FromList xs) = [ Unit x | x <- xs ] 126 | ++ [ FromList xs' | xs' <- shrink xs ] 127 | shrink (Insert x p) = [ p ] 128 | ++ [ Insert x p' | p' <- shrink p ] 129 | ++ [ Insert x' p | x' <- shrink x ] 130 | shrink (SafeRemoveMin p) = [ p ] 131 | ++ [ SafeRemoveMin p' | p' <- shrink p ] 132 | shrink (Merge p q) = [ p, q ] 133 | ++ [ Merge p' q | p' <- shrink p ] 134 | ++ [ Merge p q' | q' <- shrink q ] 135 | shrink _ = [] 136 | 137 | data HeapPP a = HeapPP (HeapP a) (Heap a) 138 | deriving (Show) 139 | 140 | instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where 141 | arbitrary = 142 | do p <- arbitrary 143 | return (HeapPP p (heap p)) 144 | 145 | shrink (HeapPP p _) = 146 | [ HeapPP p' (heap p') | p' <- shrink p ] 147 | 148 | -------------------------------------------------------------------------- 149 | -- properties 150 | 151 | (==?) :: Heap OrdA -> [OrdA] -> Bool 152 | h ==? xs = sort (toList h) == sort xs 153 | 154 | prop_Empty = 155 | empty ==? [] 156 | 157 | prop_IsEmpty (HeapPP _ h) = 158 | isEmpty h == null (toList h) 159 | 160 | prop_Unit x = 161 | unit x ==? [x] 162 | 163 | prop_Size (HeapPP _ h) = 164 | size h == length (toList h) 165 | 166 | prop_Insert x (HeapPP _ h) = 167 | insert x h ==? (x : toList h) 168 | 169 | prop_RemoveMin (HeapPP _ h) = 170 | cover 80 (size h > 1) "non-trivial" $ 171 | case removeMin h of 172 | Nothing -> h ==? [] 173 | Just (x,h') -> x == minimum (toList h) && h' ==? (toList h \\ [x]) 174 | 175 | prop_Merge (HeapPP _ h1) (HeapPP _ h2) = 176 | (h1 `merge` h2) ==? (toList h1 ++ toList h2) 177 | 178 | prop_FromList xs = 179 | fromList xs ==? xs 180 | 181 | prop_ToSortedList (HeapPP _ h) = 182 | h ==? xs && xs == sort xs 183 | where 184 | xs = toSortedList h 185 | 186 | -------------------------------------------------------------------------- 187 | -- main 188 | 189 | return [] 190 | main = $(quickCheckAll) 191 | 192 | -------------------------------------------------------------------------- 193 | -- the end. 194 | 195 | -- toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) 196 | 197 | 198 | -------------------------------------------------------------------------------- /examples/Heap_ProgramAlgebraic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell, GADTs #-} 2 | module Main where 3 | 4 | -------------------------------------------------------------------------- 5 | -- imports 6 | 7 | import Test.QuickCheck 8 | import Test.QuickCheck.Poly 9 | 10 | import Data.List 11 | ( sort 12 | , nub 13 | , (\\) 14 | ) 15 | 16 | import Data.Maybe 17 | ( fromJust 18 | ) 19 | 20 | import Control.Monad 21 | ( liftM 22 | , liftM2 23 | ) 24 | 25 | -------------------------------------------------------------------------- 26 | -- skew heaps 27 | 28 | data Heap a 29 | = Node a (Heap a) (Heap a) 30 | | Nil 31 | deriving ( Eq, Ord, Show ) 32 | 33 | empty :: Heap a 34 | empty = Nil 35 | 36 | isEmpty :: Heap a -> Bool 37 | isEmpty Nil = True 38 | isEmpty _ = False 39 | 40 | unit :: a -> Heap a 41 | unit x = Node x empty empty 42 | 43 | size :: Heap a -> Int 44 | size Nil = 0 45 | size (Node _ h1 h2) = 1 + size h1 + size h2 46 | 47 | insert :: Ord a => a -> Heap a -> Heap a 48 | insert x h = unit x `merge` h 49 | 50 | removeMin :: Ord a => Heap a -> Maybe (a, Heap a) 51 | removeMin Nil = Nothing 52 | removeMin (Node x h1 h2) = Just (x, h1 `merge` h2) 53 | 54 | merge :: Ord a => Heap a -> Heap a -> Heap a 55 | h1 `merge` Nil = h1 56 | Nil `merge` h2 = h2 57 | h1@(Node x h11 h12) `merge` h2@(Node y h21 h22) 58 | | x <= y = Node x (h12 `merge` h2) h11 59 | | otherwise = Node y (h22 `merge` h1) h21 60 | 61 | fromList :: Ord a => [a] -> Heap a 62 | fromList xs = merging [ unit x | x <- xs ] [] 63 | where 64 | merging [] [] = empty 65 | merging [p] [] = p 66 | merging (p:q:ps) qs = merging ps ((p`merge`q):qs) 67 | merging ps qs = merging (ps ++ reverse qs) [] 68 | 69 | toList :: Heap a -> [a] 70 | toList h = toList' [h] 71 | where 72 | toList' [] = [] 73 | toList' (Nil : hs) = toList' hs 74 | toList' (Node x h1 h2 : hs) = x : toList' (h1:h2:hs) 75 | 76 | toSortedList :: Ord a => Heap a -> [a] 77 | toSortedList Nil = [] 78 | toSortedList (Node x h1 h2) = x : toSortedList (h1 `merge` h2) 79 | 80 | -------------------------------------------------------------------------- 81 | -- heap programs 82 | 83 | data HeapP a 84 | = Empty 85 | | Unit a 86 | | Insert a (HeapP a) 87 | | SafeRemoveMin (HeapP a) 88 | | Merge (HeapP a) (HeapP a) 89 | | FromList [a] 90 | deriving (Show) 91 | 92 | safeRemoveMin :: Ord a => Heap a -> Heap a 93 | safeRemoveMin h = case removeMin h of 94 | Nothing -> empty -- arbitrary choice 95 | Just (_,h) -> h 96 | 97 | heap :: Ord a => HeapP a -> Heap a 98 | heap Empty = empty 99 | heap (Unit x) = unit x 100 | heap (Insert x p) = insert x (heap p) 101 | heap (SafeRemoveMin p) = safeRemoveMin (heap p) 102 | heap (Merge p q) = heap p `merge` heap q 103 | heap (FromList xs) = fromList xs 104 | 105 | instance (Ord a, Arbitrary a) => Arbitrary (HeapP a) where 106 | arbitrary = sized arbHeapP 107 | where 108 | arbHeapP s = 109 | frequency 110 | [ (1, do return Empty) 111 | , (1, do x <- arbitrary 112 | return (Unit x)) 113 | , (s, do x <- arbitrary 114 | p <- arbHeapP s1 115 | return (Insert x p)) 116 | , (s, do p <- arbHeapP s1 117 | return (SafeRemoveMin p)) 118 | , (s, do p <- arbHeapP s2 119 | q <- arbHeapP s2 120 | return (Merge p q)) 121 | , (1, do xs <- arbitrary 122 | return (FromList xs)) 123 | ] 124 | where 125 | s1 = s-1 126 | s2 = s`div`2 127 | 128 | 129 | shrink Empty = [] 130 | shrink (Unit x) = [ Unit x' | x' <- shrink x ] 131 | shrink (FromList xs) = [ Unit x | x <- xs ] 132 | ++ [ FromList xs' | xs' <- shrink xs ] 133 | shrink p = 134 | [ FromList (toList (heap p)) ] ++ 135 | case p of 136 | Insert x p -> [ p ] 137 | ++ [ Insert x p' | p' <- shrink p ] 138 | ++ [ Insert x' p | x' <- shrink x ] 139 | SafeRemoveMin p -> [ p ] 140 | ++ [ SafeRemoveMin p' | p' <- shrink p ] 141 | Merge p q -> [ p, q ] 142 | ++ [ Merge p' q | p' <- shrink p ] 143 | ++ [ Merge p q' | q' <- shrink q ] 144 | 145 | data HeapPP a = HeapPP (HeapP a) (Heap a) 146 | deriving (Show) 147 | 148 | instance (Ord a, Arbitrary a) => Arbitrary (HeapPP a) where 149 | arbitrary = 150 | do p <- arbitrary 151 | return (HeapPP p (heap p)) 152 | 153 | shrink (HeapPP p _) = 154 | [ HeapPP p' (heap p') | p' <- shrink p ] 155 | 156 | -------------------------------------------------------------------------- 157 | -- properties 158 | 159 | data Context a where 160 | Context :: Eq b => (Heap a -> b) -> Context a 161 | 162 | instance (Ord a, Arbitrary a) => Arbitrary (Context a) where 163 | arbitrary = 164 | do f <- sized arbContext 165 | let vec h = (size h, toSortedList h, isEmpty h) 166 | return (Context (vec . f)) 167 | where 168 | arbContext s = 169 | frequency 170 | [ (1, do return id) 171 | , (s, do x <- arbitrary 172 | f <- arbContext (s-1) 173 | return (insert x . f)) 174 | , (s, do f <- arbContext (s-1) 175 | return (safeRemoveMin . f)) 176 | , (s, do HeapPP _ h <- arbitrary 177 | f <- arbContext (s`div`2) 178 | elements [ (h `merge`) . f, (`merge` h) . f ]) 179 | ] 180 | 181 | instance Show (Context a) where 182 | show _ = "*" 183 | 184 | (=~) :: Heap Char -> Heap Char -> Property 185 | --h1 =~ h2 = sort (toList h1) == sort (toList h2) 186 | --h1 =~ h2 = property (nub (sort (toList h1)) == nub (sort (toList h2))) -- bug! 187 | h1 =~ h2 = property (\(Context c) -> c h1 == c h2) 188 | 189 | {- 190 | The normal form is: 191 | 192 | insert x1 (insert x2 (... empty)...) 193 | 194 | where x1 <= x2 <= ... 195 | -} 196 | 197 | -- heap creating operations 198 | 199 | prop_Unit x = 200 | unit x =~ insert x empty 201 | 202 | prop_RemoveMin_Empty = 203 | removeMin (empty :: Heap OrdA) == Nothing 204 | 205 | prop_RemoveMin_Insert1 x = 206 | removeMin (insert x empty :: Heap OrdA) == Just (x, empty) 207 | 208 | prop_RemoveMin_Insert2 x y (HeapPP _ h) = 209 | removeMin (insert x (insert y h)) ==~ 210 | (insert (max x y) `maph` removeMin (insert (min x y) h)) 211 | where 212 | f `maph` Just (x,h) = Just (x, f h) 213 | f `maph` Nothing = Nothing 214 | 215 | Nothing ==~ Nothing = property True 216 | Just (x,h1) ==~ Just (y,h2) = x==y .&&. h1 =~ h2 217 | 218 | prop_InsertSwap x y (HeapPP _ h) = 219 | insert x (insert y h) =~ insert y (insert x h) 220 | 221 | prop_MergeInsertLeft x (HeapPP _ h1) (HeapPP _ h2) = 222 | (insert x h1 `merge` h2) =~ insert x (h1 `merge` h2) 223 | 224 | prop_MergeInsertRight x (HeapPP _ h1) (HeapPP _ h2) = 225 | (h1 `merge` insert x h2) =~ insert x (h1 `merge` h2) 226 | 227 | -- heap observing operations 228 | 229 | prop_Size_Empty = 230 | size empty == 0 231 | 232 | prop_Size_Insert x (HeapPP _ (h :: Heap OrdA)) = 233 | size (insert x h) == 1 + size h 234 | 235 | prop_ToList_Empty = 236 | toList empty == ([] :: [OrdA]) 237 | 238 | prop_ToList_Insert x (HeapPP _ (h :: Heap OrdA)) = 239 | sort (toList (insert x h)) == sort (x : toList h) 240 | 241 | prop_ToSortedList (HeapPP _ (h :: Heap OrdA)) = 242 | toSortedList h == sort (toList h) 243 | 244 | -------------------------------------------------------------------------- 245 | -- main 246 | 247 | return [] 248 | main = $(quickCheckAll) 249 | 250 | -------------------------------------------------------------------------- 251 | -- the end. 252 | 253 | 254 | 255 | -------------------------------------------------------------------------------- /examples/Lambda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} 2 | module Main where 3 | 4 | -------------------------------------------------------------------------- 5 | -- imports 6 | 7 | import Test.QuickCheck 8 | 9 | import Control.Monad 10 | ( liftM 11 | , liftM2 12 | ) 13 | 14 | import Data.Char 15 | ( toUpper 16 | ) 17 | 18 | import Data.Set (Set) 19 | import qualified Data.Set as Set 20 | 21 | -------------------------------------------------------------------------- 22 | -- types for lambda expressions 23 | 24 | -- variables 25 | 26 | newtype Var = MkVar String 27 | deriving ( Eq, Ord ) 28 | 29 | instance Show Var where 30 | show (MkVar s) = s 31 | 32 | varList :: [Var] 33 | varList = [ MkVar s 34 | | let vs = [ c:v | v <- "" : vs, c <- ['a'..'z'] ] 35 | , s <- vs 36 | ] 37 | 38 | instance Arbitrary Var where 39 | arbitrary = growingElements [ MkVar [c] | c <- ['a'..'z'] ] 40 | 41 | -- constants 42 | 43 | newtype Con = MkCon String 44 | deriving ( Eq, Ord ) 45 | 46 | instance Show Con where 47 | show (MkCon s) = s 48 | 49 | instance Arbitrary Con where 50 | arbitrary = growingElements [ MkCon [c] | c <- ['A'..'Z'] ] 51 | 52 | -- expressions 53 | 54 | data Exp 55 | = Lam Var Exp 56 | | App Exp Exp 57 | | Var Var 58 | | Con Con 59 | deriving ( Eq, Ord ) 60 | 61 | instance Show Exp where 62 | showsPrec n (Lam x t) = showParen (n>0) (showString "\\" . shows x . showString "." . shows t) 63 | showsPrec n (App s t) = showParen (n>1) (showsPrec 1 s . showString " " . showsPrec 2 t) 64 | showsPrec _ (Var x) = shows x 65 | showsPrec _ (Con c) = shows c 66 | 67 | instance Arbitrary Exp where 68 | arbitrary = sized arbExp 69 | where 70 | arbExp n = 71 | frequency $ 72 | [ (2, liftM Var arbitrary) 73 | , (1, liftM Con arbitrary) 74 | ] ++ 75 | concat 76 | [ [ (5, liftM2 Lam arbitrary arbExp1) 77 | , (5, liftM2 App arbExp2 arbExp2) 78 | ] 79 | | n > 0 80 | ] 81 | where 82 | arbExp1 = arbExp (n-1) 83 | arbExp2 = arbExp (n `div` 2) 84 | 85 | shrink (Lam x a) = [ a ] 86 | ++ [ Lam x a' | a' <- shrink a ] 87 | shrink (App a b) = [ a, b ] 88 | ++ [ ab 89 | | Lam x a' <- [a] 90 | , let ab = subst x b a' 91 | , length (show ab) < length (show (App a b)) 92 | ] 93 | ++ [ App a' b | a' <- shrink a ] 94 | ++ [ App a b' | b' <- shrink b ] 95 | shrink (Var x) = [Con (MkCon (map toUpper (show x)))] 96 | shrink _ = [] 97 | 98 | -------------------------------------------------------------------------- 99 | -- functions for lambda expressions 100 | 101 | free :: Exp -> Set Var 102 | free (Lam x a) = Set.delete x (free a) 103 | free (App a b) = free a `Set.union` free b 104 | free (Var x) = Set.singleton x 105 | free (Con _) = Set.empty 106 | 107 | subst :: Var -> Exp -> Exp -> Exp 108 | subst x c (Var y) | x == y = c 109 | subst x b (Lam y a) | x /= y = Lam y (subst x b a) 110 | subst x c (App a b) = App (subst x c a) (subst x c b) 111 | subst x c a = a 112 | 113 | fresh :: Var -> Set Var -> Var 114 | fresh x ys = head (filter (`Set.notMember` ys) (x:varList)) 115 | 116 | rename :: Var -> Var -> Exp -> Exp 117 | rename x y a | x == y = a 118 | | otherwise = subst x (Var y) a 119 | 120 | -- different bugs: 121 | --subst x b (Lam y a) | x /= y = Lam y (subst x b a) -- bug 1 122 | --subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y':_ = (y:varList) \\ free b -- bug 2 123 | --subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y' = (y:varList) \\ (x:free b) -- bug 3 124 | --subst x b (Lam y a) | x /= y = Lam y' (subst x b (rename y y' a)) where y' = fresh y (x:free b) -- bug 4 125 | --subst x c (Lam y a) | x /= y = Lam y' (subst x c (rename y y' a)) where y' = fresh y (x `insert` delete y (free a) `union` free c) 126 | 127 | -------------------------------------------------------------------------- 128 | -- properties for substitutions 129 | 130 | showResult :: (Show a, Testable prop) => a -> (a -> prop) -> Property 131 | showResult x f = 132 | whenFail (putStrLn ("Result: " ++ show x)) $ 133 | f x 134 | 135 | prop_SubstFreeNoVarCapture a x b = 136 | showResult (subst x b a) $ \subst_x_b_a -> 137 | x `Set.member` free_a ==> 138 | free subst_x_b_a == (Set.delete x free_a `Set.union` free b) 139 | where 140 | free_a = free a 141 | 142 | prop_SubstNotFreeSame a x b = 143 | showResult (subst x b a) $ \subst_x_b_a -> 144 | x `Set.notMember` free a ==> 145 | subst_x_b_a == a 146 | 147 | prop_SubstNotFreeSameVars a x b = 148 | showResult (subst x b a) $ \subst_x_b_a -> 149 | x `Set.notMember` free a ==> 150 | free subst_x_b_a == free a 151 | 152 | main1 = 153 | do quickCheck prop_SubstFreeNoVarCapture 154 | quickCheck prop_SubstNotFreeSame 155 | quickCheck prop_SubstNotFreeSameVars 156 | 157 | --expectFailure $ 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | -------------------------------------------------------------------------- 167 | -- eval 168 | 169 | eval :: Exp -> Exp 170 | eval (Var x) = error "eval: free variable" 171 | eval (App a b) = 172 | case eval a of 173 | Lam x a' -> eval (subst x b a') 174 | a' -> App a' (eval b) 175 | eval a = a 176 | 177 | -------------------------------------------------------------------------- 178 | -- closed lambda expressions 179 | 180 | newtype ClosedExp = Closed Exp deriving ( Show ) 181 | 182 | instance Arbitrary ClosedExp where 183 | arbitrary = Closed `fmap` sized (arbExp []) 184 | where 185 | arbExp xs n = 186 | frequency $ 187 | [ (8, liftM Var (elements xs)) 188 | | not (null xs) 189 | ] ++ 190 | [ (2, liftM Con arbitrary) 191 | ] ++ 192 | [ (20, do x <- arbitrary 193 | t <- arbExp (x:xs) n' 194 | return (Lam x t)) 195 | | n > 0 || null xs 196 | ] ++ 197 | [ (20, liftM2 App (arbExp xs n2) (arbExp xs n2)) 198 | | n > 0 199 | ] 200 | where 201 | n' = n-1 202 | n2 = n `div` 2 203 | 204 | shrink (Closed a) = 205 | [ Closed a' | a' <- shrink a, Set.null (free a') ] 206 | 207 | -------------------------------------------------------------------------- 208 | -- properties for closed lambda expressions 209 | 210 | isValue :: Exp -> Bool 211 | isValue (Var _) = False 212 | isValue (App (Lam _ _) _) = False 213 | isValue (App a b) = isValue a && isValue b 214 | isValue _ = True 215 | 216 | prop_ClosedExpIsClosed (Closed a) = 217 | Set.null (free a) 218 | 219 | prop_EvalProducesValue (Closed a) = 220 | within 1000 $ 221 | isValue (eval a) 222 | 223 | main2 = 224 | do quickCheck prop_ClosedExpIsClosed 225 | quickCheck prop_EvalProducesValue 226 | 227 | -- expectFailure $ 228 | 229 | -------------------------------------------------------------------------- 230 | -- main 231 | 232 | main = 233 | do main1 234 | main2 235 | 236 | -------------------------------------------------------------------------- 237 | -- the end. 238 | 239 | {- 240 | instance Arbitrary Exp where 241 | arbitrary = sized (arbExp []) 242 | where 243 | 244 | arbitrary = repair [] `fmap` sized arbExp 245 | where 246 | arbExp n = 247 | frequency $ 248 | [ (1, liftM Var arbitrary) 249 | ] ++ concat 250 | [ [ (3, liftM2 Lam arbitrary (arbExp n')) 251 | , (4, liftM2 App (arbExp n2) (arbExp n2)) 252 | ] 253 | | n > 0 254 | ] 255 | where 256 | n' = n-1 257 | n2 = n `div` 2 258 | 259 | repair xs (Var x) 260 | | x `elem` xs = Var x 261 | | null xs = Lam x (Var x) 262 | | otherwise = Var (xs !! (ord (last (show x)) `mod` length xs)) 263 | repair xs (App a b) = App (repair xs a) (repair xs b) 264 | repair xs (Lam x a) = Lam x (repair (x:xs) a) 265 | 266 | -- lots of clever shrinking added 267 | shrinkRec (Lam x a) = [ a | x `notElem` free a ] 268 | shrinkRec (App a b) = [ a, b ] 269 | ++ [ red 270 | | Lam x a' <- [a] 271 | , let red = subst x b a' 272 | , length (show red) < length (show (App a b)) 273 | ] 274 | shrinkRec (Var x) = [Con (MkCon (map toUpper (show x)))] 275 | shrinkRec _ = [] 276 | 277 | -- types 278 | 279 | data Type 280 | = Base Con 281 | | Type :-> Type 282 | deriving ( Eq, Show ) 283 | 284 | instance Arbitrary Type where 285 | arbitrary = sized arbType 286 | where 287 | arbType n = 288 | frequency $ 289 | [ (1, liftM Base arbitrary) 290 | ] ++ 291 | [ (4, liftM2 (:->) arbType2 arbType2) 292 | | n > 0 293 | ] 294 | where 295 | arbType2 = arbType (n `div` 2) 296 | 297 | newtype WellTypedExp = WellTyped Exp 298 | deriving ( Eq, Show ) 299 | 300 | arbExpWithType n env t = 301 | frequency $ 302 | [ (2, liftM Var (elements xs)) 303 | | let xs = [ x | (x,t') <- env, t == t' ] 304 | , not (null xs) 305 | ] ++ 306 | [ (1, return (Con b)) 307 | | Base b <- [t] 308 | ] ++ 309 | [ (if n > 0 then 5 else 1 310 | , do x <- arbitrary 311 | b <- arbExpWithType n1 ((x,ta):[ xt | xt <- env, fst xt /= x ]) tb 312 | return (Lam x b)) 313 | | ta :-> tb <- [t] 314 | ] ++ 315 | [ (5, do tb <- arbitrary 316 | a <- arbExpWithType n2 env (tb :-> t) 317 | b <- arbExpWithType n2 env tb 318 | return (App a b)) 319 | | n > 0 320 | ] 321 | where 322 | n1 = n-1 323 | n2 = n `div` 2 324 | 325 | instance Arbitrary WellTypedExp where 326 | arbitrary = 327 | do t <- arbitrary 328 | e <- sized (\n -> arbExpWithType n [] t) 329 | return (WellTyped e) 330 | 331 | shrink _ = [] 332 | 333 | newtype OpenExp = Open Exp 334 | deriving ( Eq, Show ) 335 | 336 | instance Arbitrary OpenExp where 337 | arbitrary = Open `fmap` sized arbExp 338 | where 339 | arbExp n = 340 | frequency $ 341 | [ (2, liftM Var arbitrary) 342 | , (1, liftM Con arbitrary) 343 | ] ++ 344 | concat 345 | [ [ (5, liftM2 Lam arbitrary arbExp1) 346 | , (5, liftM2 App arbExp2 arbExp2) 347 | ] 348 | | n > 0 349 | ] 350 | where 351 | arbExp1 = arbExp (n-1) 352 | arbExp2 = arbExp (n `div` 2) 353 | 354 | shrink (Open a) = map Open (shrink a) 355 | 356 | prop_EvalProducesValueWT (WellTyped a) = 357 | isValue (eval a) 358 | 359 | -} 360 | 361 | x = MkVar "x" 362 | y = MkVar "y" 363 | 364 | -------------------------------------------------------------------------------- /examples/Merge.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} 2 | module Main where 3 | 4 | -------------------------------------------------------------------------- 5 | -- imports 6 | 7 | import Test.QuickCheck 8 | 9 | import Data.List 10 | ( sort 11 | ) 12 | 13 | -------------------------------------------------------------------------- 14 | -- merge sort 15 | 16 | msort :: Ord a => [a] -> [a] 17 | msort xs = merging [ [x] | x <- xs ] 18 | 19 | merging :: Ord a => [[a]] -> [a] 20 | merging [] = [] 21 | merging [xs] = xs 22 | merging xss = merging (sweep xss) 23 | 24 | sweep :: Ord a => [[a]] -> [[a]] 25 | sweep [] = [] 26 | sweep [xs] = [xs] 27 | sweep (xs:ys:xss) = merge xs ys : sweep xss 28 | 29 | merge :: Ord a => [a] -> [a] -> [a] 30 | merge xs [] = xs 31 | merge [] ys = ys 32 | merge (x:xs) (y:ys) 33 | | x <= y = x : merge xs (y:ys) 34 | | otherwise = y : merge (x:xs) ys 35 | 36 | -------------------------------------------------------------------------- 37 | -- example properties 38 | 39 | ordered :: Ord a => [a] -> Bool 40 | ordered [] = True 41 | ordered [x] = True 42 | ordered (x:y:xs) = x <= y && ordered (y:xs) 43 | 44 | prop_Merge xs (ys :: [Int]) = 45 | ordered xs && ordered ys ==> 46 | collect (length xs + length ys) $ 47 | ordered (xs `merge` ys) 48 | 49 | -- collect (sort [length xs, length ys]) $ 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | -------------------------------------------------------------------------- 70 | -- quantificiation 71 | 72 | --prop_Merge (Ordered xs) (Ordered (ys :: [Int])) = 73 | -- ordered (xs `merge` ys) 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | -- classify (length xs `min` length ys >= 5) "not trivial" $ 88 | -- cover (length xs `min` length ys >= 5) 70 "not trivial" $ 89 | 90 | {- 91 | shrink (Ordered xs) = 92 | [ Ordered xs' 93 | | xs' <- shrink xs 94 | , ordered xs' 95 | ] 96 | -} 97 | 98 | -------------------------------------------------------------------------- 99 | -- merging 100 | 101 | prop_Merging (xss :: [OrderedList Int]) = 102 | ordered (merging [ xs | Ordered xs <- xss ]) 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | -- mapSize (`div` 2) $ \(xss :: [OrderedList Int]) -> 111 | 112 | return [] 113 | main = $quickCheckAll 114 | 115 | -------------------------------------------------------------------------- 116 | -- the end. 117 | -------------------------------------------------------------------------------- /examples/Set.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} 2 | module Main where 3 | 4 | -------------------------------------------------------------------------- 5 | -- imports 6 | 7 | import Test.QuickCheck 8 | 9 | import Text.Show.Functions 10 | import Data.List 11 | ( sort 12 | , group 13 | , nub 14 | , (\\) 15 | ) 16 | 17 | import Control.Monad 18 | ( liftM 19 | , liftM2 20 | ) 21 | 22 | import Data.Maybe 23 | 24 | --import Text.Show.Functions 25 | 26 | -------------------------------------------------------------------------- 27 | -- binary search trees 28 | 29 | data Set a 30 | = Node a (Set a) (Set a) 31 | | Empty 32 | deriving ( Eq, Ord, Show ) 33 | 34 | empty :: Set a 35 | empty = Empty 36 | 37 | isEmpty :: Set a -> Bool 38 | isEmpty Empty = True 39 | isEmpty _ = False 40 | 41 | unit :: a -> Set a 42 | unit x = Node x empty empty 43 | 44 | size :: Set a -> Int 45 | size Empty = 0 46 | size (Node _ s1 s2) = 1 + size s1 + size s2 47 | 48 | insert :: Ord a => a -> Set a -> Set a 49 | insert x s = s `union` unit x 50 | 51 | merge :: Set a -> Set a -> Set a 52 | s `merge` Empty = s 53 | s `merge` Node x Empty s2 = Node x s s2 54 | s `merge` Node x (Node y s11 s12) s2 = Node y s (Node x (s11 `merge` s12) s2) 55 | 56 | delete :: Ord a => a -> Set a -> Set a 57 | delete x Empty = Empty 58 | delete x (Node x' s1 s2) = 59 | case x `compare` x' of 60 | LT -> Node x' (delete x s1) s2 61 | EQ -> s1 `merge` s2 62 | GT -> Node x' s1 (delete x s2) 63 | 64 | union :: Ord a => Set a -> Set a -> Set a 65 | {- 66 | s1 `union` Empty = s1 67 | Empty `union` s2 = s2 68 | s1@(Node x s11 s12) `union` s2@(Node y s21 s22) = 69 | case x `compare` y of 70 | LT -> Node x s11 (s12 `union` Node y Empty s22) `union` s21 71 | EQ -> Node x (s11 `union` s21) (s12 `union` s22) 72 | --GT -> s11 `union` Node y s21 (Node x Empty s12 `union` s22) 73 | GT -> Node x (s11 `union` Node y s21 Empty) s12 `union` s22 74 | -} 75 | s1 `union` Empty = s1 76 | Empty `union` s2 = s2 77 | Node x s11 s12 `union` s2 = Node x (s11 `union` s21) (s12 `union` s22) 78 | where 79 | (s21,s22) = split x s2 80 | 81 | split :: Ord a => a -> Set a -> (Set a, Set a) 82 | split x Empty = (Empty, Empty) 83 | split x (Node y s1 s2) = 84 | case x `compare` y of 85 | LT -> (s11, Node y s12 s2) 86 | EQ -> (s1, s2) 87 | GT -> (Node y s1 s21, s22) 88 | where 89 | (s11,s12) = split x s1 90 | (s21,s22) = split x s2 91 | 92 | mapp :: (a -> b) -> Set a -> Set b 93 | mapp f Empty = Empty 94 | mapp f (Node x s1 s2) = Node (f x) (mapp f s1) (mapp f s2) 95 | 96 | fromList :: Ord a => [a] -> Set a 97 | --fromList xs = build [ (empty,x) | x <- sort xs ] 98 | fromList xs = build [ (empty,head x) | x <- group (sort xs) ] 99 | where 100 | build [] = empty 101 | build [(s,x)] = attach x s 102 | build sxs = build (sweep sxs) 103 | 104 | sweep [] = [] 105 | sweep [sx] = [sx] 106 | sweep ((s1,x1):(s2,x2):sxs) = (Node x1 s1 s2,x2) : sweep sxs 107 | 108 | attach x Empty = unit x 109 | attach x (Node y s1 s2) = Node y s1 (attach x s2) 110 | 111 | toList :: Set a -> [a] 112 | toList s = toSortedList s 113 | 114 | toSortedList :: Set a -> [a] 115 | toSortedList s = toList' s [] 116 | where 117 | toList' Empty xs = xs 118 | toList' (Node x s1 s2) xs = toList' s1 (x : toList' s2 xs) 119 | 120 | -------------------------------------------------------------------------- 121 | -- generators 122 | 123 | instance (Ord a, Arbitrary a) => Arbitrary (Set a) where 124 | arbitrary = sized (arbSet Nothing Nothing) 125 | where 126 | arbSet mx my n = 127 | frequency $ 128 | [ (1, return Empty) ] ++ 129 | [ (7, do mz <- arbitrary `suchThatMaybe` (isOK mx my) 130 | case mz of 131 | Nothing -> return Empty 132 | Just z -> liftM2 (Node z) (arbSet mx mz n2) 133 | (arbSet mz my n2) 134 | where n2 = n `div` 2) 135 | | n > 0 136 | ] 137 | 138 | isOK mx my z = 139 | maybe True ( ShrinkSub (Set a) 146 | 147 | -------------------------------------------------------------------------- 148 | -- properties 149 | 150 | (.<) :: Ord a => Set a -> a -> Bool 151 | Empty .< x = True 152 | Node y _ s .< x = y < x && s .< x 153 | 154 | (<.) :: Ord a => a -> Set a -> Bool 155 | x <. Empty = True 156 | x <. Node y _ s = x < y && x <. s 157 | 158 | (==?) :: Ord a => Set a -> [a] -> Bool 159 | s ==? xs = invariant s && sort (toList s) == nub (sort xs) 160 | 161 | invariant :: Ord a => Set a -> Bool 162 | invariant Empty = True 163 | invariant (Node x s1 s2) = s1 .< x && x <. s2 && invariant s1 && invariant s2 164 | 165 | prop_Invariant (s :: Set Int) = 166 | invariant s 167 | 168 | prop_Empty = 169 | empty ==? ([] :: [Int]) 170 | 171 | prop_Unit (x :: Int) = 172 | unit x ==? [x] 173 | 174 | prop_Size (s :: Set Int) = 175 | cover 60 (size s >= 15) "large" $ 176 | size s == length (toList s) 177 | 178 | prop_Insert x (s :: Set Int) = 179 | insert x s ==? (x : toList s) 180 | 181 | prop_Delete x (s :: Set Int) = 182 | delete x s ==? (toList s \\ [x]) 183 | 184 | prop_Union s1 (s2 :: Set Int) = 185 | (s1 `union` s2) ==? (toList s1 ++ toList s2) 186 | 187 | prop_Mapp (f :: Int -> Int) (s :: Set Int) = 188 | expectFailure $ 189 | whenFail (putStrLn ("Fun: " ++ show [ (x,f x) | x <- toList s])) $ 190 | mapp f s ==? map f (toList s) 191 | 192 | prop_FromList (xs :: [Int]) = 193 | fromList xs ==? xs 194 | 195 | prop_ToSortedList (s :: Set Int) = 196 | s ==? xs && xs == sort xs 197 | where 198 | xs = toSortedList s 199 | 200 | -- whenFail (putStrLn ("Result: " ++ show (fromList xs))) $ 201 | 202 | prop_FromList' (xs :: [Int]) = 203 | shrinking shrink xs $ \xs' -> 204 | fromList xs ==? xs 205 | 206 | -------------------------------------------------------------------------- 207 | -- main 208 | 209 | return [] 210 | main = $quickCheckAll 211 | 212 | -------------------------------------------------------------------------- 213 | -- the end. 214 | -------------------------------------------------------------------------------- /examples/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} 2 | module Main where 3 | 4 | -------------------------------------------------------------------------- 5 | -- imports 6 | 7 | import Test.QuickCheck 8 | 9 | -------------------------------------------------------------------------- 10 | -- example 1 11 | 12 | allEqual x y z = x == y && y == z 13 | allEqual' x y z = 2*x == y + z 14 | 15 | prop_SimonThompson x y (z :: Int) = 16 | allEqual x y z == allEqual' x y z 17 | 18 | -------------------------------------------------------------------------- 19 | -- example 2 20 | 21 | prop_ReverseReverse :: Eq a => [a] -> Bool 22 | prop_ReverseReverse xs = 23 | reverse (reverse xs) == xs 24 | 25 | prop_Reverse xs = 26 | reverse xs == xs 27 | 28 | -------------------------------------------------------------------------- 29 | -- example 3 30 | 31 | prop_Error (x,y) = 32 | 2*x <= 5*y 33 | 34 | -------------------------------------------------------------------------- 35 | -- main 36 | 37 | return [] 38 | prop_conj = counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) .&&. 39 | counterexample "reverse" $(monomorphic 'prop_Reverse) 40 | prop_disj = counterexample "reverse" $(monomorphic 'prop_Reverse) .||. 41 | counterexample "Simon Thompson" $(monomorphic 'prop_SimonThompson) 42 | return [] 43 | main = $quickCheckAll 44 | 45 | -------------------------------------------------------------------------- 46 | -- the end. 47 | -------------------------------------------------------------------------------- /make-hugs: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -e 4 | 5 | TOPDIR=$(dirname "$0") 6 | TARGETDIR=$TOPDIR/quickcheck-hugs 7 | 8 | find "$TOPDIR/src" -name '*.hs' | while read -r src; do 9 | tgt="$TARGETDIR/$(echo "$src" | sed "s/^$TOPDIR\/src"'//')" 10 | 11 | echo "Processing $src -> $tgt" 12 | 13 | mkdir -p "$(dirname "$tgt")" 14 | # If you want to switch on and off other features, look in 15 | # QuickCheck.cabal to see what's available, or submit a patch 16 | # adding a new -DNO_... flag. 17 | cpphs --noline -DOLD_RANDOM -DNO_SPLITMIX -DNO_TEMPLATE_HASKELL \ 18 | -DNO_CTYPES_CONSTRUCTORS -DNO_FOREIGN_C_USECONDS -DNO_GENERICS \ 19 | -DNO_SAFE_HASKELL -DNO_POLYKINDS -DNO_MONADFAIL -DNO_TIMEOUT \ 20 | -DNO_NEWTYPE_DERIVING -DNO_TYPEABLE -DNO_GADTS -DNO_TRANSFORMERS \ 21 | -DNO_DEEPSEQ -DNO_EXTRA_METHODS_IN_APPLICATIVE \ 22 | "$src" > "$tgt" 23 | done 24 | 25 | echo "A Hugs-compatible version of QuickCheck is now" 26 | echo "available in the quickcheck-hugs directory." 27 | echo "Load it with hugs -98." 28 | -------------------------------------------------------------------------------- /src/Test/QuickCheck.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | The 3 | gives detailed information about using QuickCheck effectively. 4 | You can also try , 5 | a tutorial written by a user of QuickCheck. 6 | 7 | To start using QuickCheck, write down your property as a function returning @Bool@. 8 | For example, to check that reversing a list twice gives back the same list you can write: 9 | 10 | @ 11 | import Test.QuickCheck 12 | 13 | prop_reverse :: [Int] -> Bool 14 | prop_reverse xs = reverse (reverse xs) == xs 15 | @ 16 | 17 | You can then use QuickCheck to test @prop_reverse@ on 100 random lists: 18 | 19 | >>> quickCheck prop_reverse 20 | +++ OK, passed 100 tests. 21 | 22 | To run more tests you can use the 'withMaxSuccess' combinator: 23 | 24 | >>> quickCheck (withMaxSuccess 10000 prop_reverse) 25 | +++ OK, passed 10000 tests. 26 | 27 | To use QuickCheck on your own data types you will need to write 'Arbitrary' 28 | instances for those types. See the 29 | for 30 | details about how to do that. 31 | -} 32 | {-# LANGUAGE CPP #-} 33 | #ifndef NO_SAFE_HASKELL 34 | {-# LANGUAGE Safe #-} 35 | #endif 36 | #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 37 | {-# LANGUAGE PatternSynonyms #-} 38 | #endif 39 | module Test.QuickCheck 40 | ( 41 | -- * Running tests 42 | quickCheck 43 | , Args(..), Result(..) 44 | , stdArgs 45 | , quickCheckWith 46 | , quickCheckWithResult 47 | , quickCheckResult 48 | , isSuccess 49 | -- ** Running tests verbosely 50 | , verboseCheck 51 | , verboseCheckWith 52 | , verboseCheckWithResult 53 | , verboseCheckResult 54 | -- ** Running tests in parallel 55 | {- | After intense labour by Lord Robert von Krook Af Göhteborgh, the internal 56 | testing loop can be instructed to run tests in parallel. Note. Not running properties 57 | in parallel, but the tests of a property. 58 | 59 | As an example, running the property above with 4 HECs 60 | 61 | @ 62 | quickCheckPar $ withMaxSuccess 10000 prop_reverse 63 | +++ OK, passed 10000 tests 64 | tester 0: 2693 tests 65 | tester 1: 2514 tests 66 | tester 2: 2503 tests 67 | tester 3: 2290 tests 68 | @ 69 | 70 | To make use of this functionality, GHC needs the options @-threaded@ and @-rtsopts@. 71 | Furthermore, the runtime options need to specify that more HECs should be used, with 72 | the @-with-rtsopts=-N@ flag. You could optionally specify exactly how many HECs to 73 | use, e.g @-with-rtsopts=-N4@. This is where the API fetches the number of parallel 74 | workers to launch. It will be equal to however many you instruct the RTS to use. 75 | I've found @-feager-blackholing@ to benefit parallel Haskell before. 76 | 77 | Example of an options section in a cabal file 78 | 79 | @ 80 | ghc-options: 81 | -threaded 82 | -rtsopts 83 | -feager-blackholing 84 | -with-rtsopts=-N4 85 | @ 86 | 87 | The parallelism is implemented using @Control.Concurrent@ and @forkIO@. Instead of 88 | running one sequential test loop, quickCheck will spawn n sequential test loops 89 | with @forkIO@. The threads are all assigned an equal share of the desired number of 90 | tests to run, but by default attempt to steal the right to run more tests from 91 | sibling threads if they run out. Please see `rightToWorkSteal`. 92 | 93 | The functions below behave the same as their non-parallel counterparts, with the 94 | exception that they ask the RTS how many schedulers are available, and populate the 95 | @numTesters@ field with that number. E.g @quickCheckPar p@ when you compiled with 96 | @-N4@ is equivalent to @quickCheckWith (stdArgs { numTesters = 4 }) p@. 97 | 98 | -} 99 | , quickCheckPar 100 | , SizeStrategy(..) 101 | , quickCheckParWith 102 | , quickCheckParResult 103 | , quickCheckParWithResult 104 | #ifndef NO_TEMPLATE_HASKELL 105 | -- ** Testing all properties in a module 106 | 107 | -- | These functions test all properties in the current module, using 108 | -- Template Haskell. You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ 109 | -- pragma in your module for any of these to work. 110 | , quickCheckAll 111 | , verboseCheckAll 112 | , forAllProperties 113 | , allProperties 114 | -- ** Testing polymorphic properties 115 | , polyQuickCheck 116 | , polyVerboseCheck 117 | , monomorphic 118 | #endif 119 | 120 | -- * The 'Arbitrary' typeclass: generation of random values 121 | , Arbitrary(..) 122 | -- ** Helper functions for implementing 'shrink' 123 | #ifndef NO_GENERICS 124 | , genericShrink 125 | , subterms 126 | , recursivelyShrink 127 | #endif 128 | , shrinkNothing 129 | , shrinkList 130 | , shrinkMap 131 | , shrinkMapBy 132 | , shrinkIntegral 133 | , shrinkRealFrac 134 | , shrinkDecimal 135 | 136 | -- ** Lifting of 'Arbitrary' to unary and binary type constructors 137 | , Arbitrary1(..) 138 | , arbitrary1 139 | , shrink1 140 | , Arbitrary2(..) 141 | , arbitrary2 142 | , shrink2 143 | 144 | -- * The 'Gen' monad: combinators for building random generators 145 | , Gen 146 | -- ** Generator combinators 147 | , choose 148 | , chooseInt 149 | , chooseInteger 150 | , chooseBoundedIntegral 151 | , chooseEnum 152 | , chooseAny 153 | , oneof 154 | , frequency 155 | , elements 156 | , growingElements 157 | , sized 158 | , getSize 159 | , resize 160 | , scale 161 | , suchThat 162 | , suchThatMap 163 | , suchThatMaybe 164 | , applyArbitrary2 165 | , applyArbitrary3 166 | , applyArbitrary4 167 | -- ** Generators for lists 168 | , listOf 169 | , listOf1 170 | , vectorOf 171 | , vector 172 | , infiniteListOf 173 | , infiniteList 174 | , shuffle 175 | , sublistOf 176 | , orderedList 177 | -- ** Generators for particular types 178 | , arbitrarySizedIntegral 179 | , arbitrarySizedNatural 180 | , arbitrarySizedFractional 181 | , arbitrarySizedBoundedIntegral 182 | , arbitraryBoundedIntegral 183 | , arbitraryBoundedRandom 184 | , arbitraryBoundedEnum 185 | , arbitraryUnicodeChar 186 | , arbitraryASCIIChar 187 | , arbitraryPrintableChar 188 | -- ** Running generators 189 | , generate 190 | -- ** Debugging generators 191 | , sample 192 | , sample' 193 | 194 | #ifndef NO_GADTS 195 | -- * The 'Function' typeclass: generation of random shrinkable, showable functions 196 | 197 | -- | Example of use: 198 | -- 199 | -- >>> :{ 200 | -- >>> let prop :: Fun String Integer -> Bool 201 | -- >>> prop (Fun _ f) = f "monkey" == f "banana" || f "banana" == f "elephant" 202 | -- >>> :} 203 | -- >>> quickCheck prop 204 | -- *** Failed! Falsified (after 3 tests and 134 shrinks): 205 | -- {"elephant"->1, "monkey"->1, _->0} 206 | -- 207 | -- To generate random values of type @'Fun' a b@, 208 | -- you must have an instance @'Function' a@. 209 | -- If your type has a 'Show' instance, you can use 'functionShow' to write the instance; otherwise, 210 | -- use 'functionMap' to give a bijection between your type and a type that is already an instance of 'Function'. 211 | -- See the @'Function' [a]@ instance for an example of the latter. 212 | -- 213 | -- For more information, see the paper \"Shrinking and showing functions\" by Koen Claessen. 214 | , Fun (..) 215 | , applyFun 216 | , applyFun2 217 | , applyFun3 218 | #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 708 219 | , pattern Fn 220 | , pattern Fn2 221 | , pattern Fn3 222 | #endif 223 | , Function (..) 224 | , functionMap 225 | , functionShow 226 | , functionIntegral 227 | , functionRealFrac 228 | , functionBoundedEnum 229 | , functionVoid 230 | #endif 231 | 232 | -- * The 'CoArbitrary' typeclass: generation of functions the old-fashioned way 233 | , CoArbitrary(..) 234 | #ifndef NO_GENERICS 235 | , genericCoarbitrary 236 | #endif 237 | , variant 238 | , coarbitraryIntegral 239 | , coarbitraryReal 240 | , coarbitraryShow 241 | , coarbitraryEnum 242 | , (><) 243 | 244 | -- * Type-level modifiers for changing generator behavior 245 | 246 | -- | These types do things such as restricting the kind of test data that can be generated. 247 | -- They can be pattern-matched on in properties as a stylistic 248 | -- alternative to using explicit quantification. 249 | -- 250 | -- Examples: 251 | -- 252 | -- @ 253 | -- -- Functions cannot be shown (but see 'Function') 254 | -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = 255 | -- takeWhile p xs ++ dropWhile p xs == xs 256 | -- @ 257 | -- 258 | -- @ 259 | -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = 260 | -- take n xs ++ drop n xs == xs 261 | -- @ 262 | -- 263 | -- @ 264 | -- -- cycle does not work for empty lists 265 | -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = 266 | -- take n (cycle xs) == take n (xs ++ cycle xs) 267 | -- @ 268 | -- 269 | -- @ 270 | -- -- Instead of 'forAll' 'orderedList' 271 | -- prop_Sort ('Ordered' (xs :: ['OrdA'])) = 272 | -- sort xs == xs 273 | -- @ 274 | , Blind(..) 275 | , Fixed(..) 276 | , OrderedList(..) 277 | , NonEmptyList(..) 278 | , InfiniteList(..) 279 | , SortedList(..) 280 | , Positive(..) 281 | , Negative(..) 282 | , NonZero(..) 283 | , NonNegative(..) 284 | , NonPositive(..) 285 | , Large(..) 286 | , Small(..) 287 | , Smart(..) 288 | , Shrink2(..) 289 | #ifndef NO_MULTI_PARAM_TYPE_CLASSES 290 | , Shrinking(..) 291 | , ShrinkState(..) 292 | #endif 293 | , ASCIIString(..) 294 | , UnicodeString(..) 295 | , PrintableString(..) 296 | 297 | -- * Property combinators 298 | , Property, Testable(..) 299 | , forAll 300 | , forAllShrink 301 | , forAllShow 302 | , forAllShrinkShow 303 | , forAllBlind 304 | , forAllShrinkBlind 305 | , shrinking 306 | , (==>) 307 | , Discard(..) 308 | , discard 309 | , (===) 310 | , (=/=) 311 | #ifndef NO_DEEPSEQ 312 | , total 313 | #endif 314 | , ioProperty 315 | , idempotentIOProperty 316 | -- ** Controlling property execution 317 | , verbose 318 | , verboseShrinking 319 | , noShrinking 320 | , withMaxSuccess 321 | , within 322 | , discardAfter 323 | , withDiscardRatio 324 | , withMaxSize 325 | , withMaxShrinks 326 | , once 327 | , again 328 | , mapSize 329 | -- ** Conjunction and disjunction 330 | , (.&.) 331 | , (.&&.) 332 | , conjoin 333 | , (.||.) 334 | , disjoin 335 | -- ** What to do on failure 336 | , counterexample 337 | , printTestCase 338 | , whenFail 339 | , whenFail' 340 | , expectFailure 341 | -- * Analysing test case distribution 342 | , label 343 | , collect 344 | , classify 345 | , tabulate 346 | -- ** Checking test case distribution 347 | , cover 348 | , coverTable 349 | , checkCoverage 350 | , checkCoverageWith 351 | , Confidence(..) 352 | , stdConfidence 353 | -- ** Generating example test cases 354 | , labelledExamples 355 | , labelledExamplesWith 356 | , labelledExamplesWithResult 357 | , labelledExamplesResult 358 | ) 359 | where 360 | 361 | -------------------------------------------------------------------------- 362 | -- imports 363 | import Test.QuickCheck.Gen 364 | import Test.QuickCheck.Arbitrary 365 | import Test.QuickCheck.Modifiers 366 | import Test.QuickCheck.Property hiding ( Result(..) ) 367 | import Test.QuickCheck.Test 368 | import Test.QuickCheck.Exception 369 | #ifndef NO_GADTS 370 | import Test.QuickCheck.Function 371 | #endif 372 | import Test.QuickCheck.Features 373 | #ifndef NO_TEMPLATE_HASKELL 374 | import Test.QuickCheck.All 375 | #endif 376 | 377 | -------------------------------------------------------------------------- 378 | -- the end. 379 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/All.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Rank2Types, CPP #-} 2 | #if __GLASGOW_HASKELL__ >= 800 3 | {-# LANGUAGE TemplateHaskellQuotes #-} 4 | #else 5 | {-# LANGUAGE TemplateHaskell #-} 6 | #endif 7 | #ifndef NO_SAFE_HASKELL 8 | {-# LANGUAGE Trustworthy #-} 9 | #endif 10 | 11 | -- | __Note__: the contents of this module are re-exported by 12 | -- "Test.QuickCheck". You do not need to import it directly. 13 | -- 14 | -- Test all properties in the current module, using Template Haskell. 15 | -- You need to have a @{-\# LANGUAGE TemplateHaskell \#-}@ pragma in 16 | -- your module for any of these to work. 17 | module Test.QuickCheck.All( 18 | -- ** Testing all properties in a module 19 | quickCheckAll, 20 | verboseCheckAll, 21 | forAllProperties, 22 | allProperties, 23 | -- ** Testing polymorphic properties 24 | polyQuickCheck, 25 | polyVerboseCheck, 26 | monomorphic) where 27 | 28 | import Language.Haskell.TH 29 | import Test.QuickCheck.Property hiding (Result) 30 | import Test.QuickCheck.Test 31 | import Data.Char 32 | import Data.List (isPrefixOf, nubBy) 33 | import Control.Monad 34 | 35 | import qualified System.IO as S 36 | 37 | -- | Test a polymorphic property, defaulting all type variables to 'Integer'. 38 | -- 39 | -- Invoke as @$('polyQuickCheck' 'prop)@, where @prop@ is a property. 40 | -- Note that just evaluating @'quickCheck' prop@ in GHCi will seem to 41 | -- work, but will silently default all type variables to @()@! 42 | -- 43 | -- @$('polyQuickCheck' \'prop)@ means the same as 44 | -- @'quickCheck' $('monomorphic' \'prop)@. 45 | -- If you want to supply custom arguments to 'polyQuickCheck', 46 | -- you will have to combine 'quickCheckWith' and 'monomorphic' yourself. 47 | -- 48 | -- If you want to use 'polyQuickCheck' in the same file where you defined the 49 | -- property, the same scoping problems pop up as in 'quickCheckAll': 50 | -- see the note there about @return []@. 51 | polyQuickCheck :: Name -> ExpQ 52 | polyQuickCheck x = [| quickCheck |] `appE` monomorphic x 53 | 54 | -- | Test a polymorphic property, defaulting all type variables to 'Integer'. 55 | -- This is just a convenience function that combines 'verboseCheck' and 'monomorphic'. 56 | -- 57 | -- If you want to use 'polyVerboseCheck' in the same file where you defined the 58 | -- property, the same scoping problems pop up as in 'quickCheckAll': 59 | -- see the note there about @return []@. 60 | polyVerboseCheck :: Name -> ExpQ 61 | polyVerboseCheck x = [| verboseCheck |] `appE` monomorphic x 62 | 63 | type Error = forall a. String -> a 64 | 65 | -- | Monomorphise an arbitrary property by defaulting all type variables to 'Integer'. 66 | -- 67 | -- For example, if @f@ has type @'Ord' a => [a] -> [a]@ 68 | -- then @$('monomorphic' 'f)@ has type @['Integer'] -> ['Integer']@. 69 | -- 70 | -- If you want to use 'monomorphic' in the same file where you defined the 71 | -- property, the same scoping problems pop up as in 'quickCheckAll': 72 | -- see the note there about @return []@. 73 | monomorphic :: Name -> ExpQ 74 | monomorphic t = do 75 | ty0 <- fmap infoType (reify t) 76 | let err msg = error $ msg ++ ": " ++ pprint ty0 77 | (polys, ctx, ty) <- deconstructType err ty0 78 | case polys of 79 | [] -> return (expName t) 80 | _ -> do 81 | integer <- [t| Integer |] 82 | ty' <- monomorphiseType err integer ty 83 | return (SigE (expName t) ty') 84 | 85 | expName :: Name -> Exp 86 | expName n = if isVar n then VarE n else ConE n 87 | 88 | -- See section 2.4 of the Haskell 2010 Language Report, plus support for "[]" 89 | isVar :: Name -> Bool 90 | isVar = let isVar' (c:_) = not (isUpper c || c `elem` ":[") 91 | isVar' _ = True 92 | in isVar' . nameBase 93 | 94 | infoType :: Info -> Type 95 | #if MIN_VERSION_template_haskell(2,11,0) 96 | infoType (ClassOpI _ ty _) = ty 97 | infoType (DataConI _ ty _) = ty 98 | infoType (VarI _ ty _) = ty 99 | #else 100 | infoType (ClassOpI _ ty _ _) = ty 101 | infoType (DataConI _ ty _ _) = ty 102 | infoType (VarI _ ty _ _) = ty 103 | #endif 104 | 105 | deconstructType :: Error -> Type -> Q ([Name], Cxt, Type) 106 | deconstructType err (ForallT xs ctx ty) = do 107 | #if MIN_VERSION_template_haskell(2,17,0) 108 | let plain (PlainTV nm _) = return nm 109 | plain (KindedTV nm _ StarT) = return nm 110 | #else 111 | let plain (PlainTV nm) = return nm 112 | # if MIN_VERSION_template_haskell(2,8,0) 113 | plain (KindedTV nm StarT) = return nm 114 | # else 115 | plain (KindedTV nm StarK) = return nm 116 | # endif 117 | #endif 118 | plain _ = err "Higher-kinded type variables in type" 119 | xs' <- mapM plain xs 120 | return (xs', ctx, ty) 121 | deconstructType _ ty = return ([], [], ty) 122 | 123 | monomorphiseType :: Error -> Type -> Type -> TypeQ 124 | monomorphiseType err mono ty@(VarT n) = return mono 125 | monomorphiseType err mono (AppT t1 t2) = liftM2 AppT (monomorphiseType err mono t1) (monomorphiseType err mono t2) 126 | monomorphiseType err mono ty@(ForallT _ _ _) = err $ "Higher-ranked type" 127 | monomorphiseType err mono ty = return ty 128 | 129 | -- | Test all properties in the current module, using a custom 130 | -- 'quickCheck' function. The same caveats as with 'quickCheckAll' 131 | -- apply. 132 | -- 133 | -- @$'forAllProperties'@ has type @('Property' -> 'IO' 'Result') -> 'IO' 'Bool'@. 134 | -- An example invocation is @$'forAllProperties' 'quickCheckResult'@, 135 | -- which does the same thing as @$'quickCheckAll'@. 136 | -- 137 | -- 'forAllProperties' has the same issue with scoping as 'quickCheckAll': 138 | -- see the note there about @return []@. 139 | forAllProperties :: Q Exp -- :: (Property -> IO Result) -> IO Bool 140 | forAllProperties = [| runQuickCheckAll |] `appE` allProperties 141 | 142 | -- | List all properties in the current module. 143 | -- 144 | -- @$'allProperties'@ has type @[('String', 'Property')]@. 145 | -- 146 | -- 'allProperties' has the same issue with scoping as 'quickCheckAll': 147 | -- see the note there about @return []@. 148 | allProperties :: Q Exp 149 | allProperties = do 150 | Loc { loc_filename = filename } <- location 151 | when (filename == "") $ error "don't run this interactively" 152 | ls <- runIO (fmap lines (readUTF8File filename)) 153 | let prefixes = map (takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') . dropWhile (\c -> isSpace c || c == '>')) ls 154 | idents = nubBy (\x y -> snd x == snd y) (filter (("prop_" `isPrefixOf`) . snd) (zip [1..] prefixes)) 155 | #if MIN_VERSION_template_haskell(2,8,0) 156 | warning x = reportWarning ("Name " ++ x ++ " found in source file but was not in scope") 157 | #else 158 | warning x = report False ("Name " ++ x ++ " found in source file but was not in scope") 159 | #endif 160 | quickCheckOne :: (Int, String) -> Q [Exp] 161 | quickCheckOne (l, x) = do 162 | exists <- (warning x >> return False) `recover` (reify (mkName x) >> return True) 163 | if exists 164 | then sequence 165 | [ tupE 166 | [ stringE $ x ++ " from " ++ filename ++ ":" ++ show l 167 | , [| property |] `appE` monomorphic (mkName x) 168 | ] 169 | ] 170 | else return [] 171 | fmap (ListE . concat) (mapM quickCheckOne idents) `sigE` [t| [(String, Property)] |] 172 | 173 | readUTF8File name = S.openFile name S.ReadMode >>= 174 | set_utf8_io_enc >>= 175 | S.hGetContents 176 | 177 | -- Deal with UTF-8 input and output. 178 | set_utf8_io_enc :: S.Handle -> IO S.Handle 179 | #if __GLASGOW_HASKELL__ > 611 180 | -- possibly if MIN_VERSION_base(4,2,0) 181 | set_utf8_io_enc h = do S.hSetEncoding h S.utf8; return h 182 | #else 183 | set_utf8_io_enc h = return h 184 | #endif 185 | 186 | -- | Test all properties in the current module. 187 | -- The name of the property must begin with @prop_@. 188 | -- Polymorphic properties will be defaulted to 'Integer'. 189 | -- Returns 'True' if all tests succeeded, 'False' otherwise. 190 | -- 191 | -- To use 'quickCheckAll', add a definition to your module along 192 | -- the lines of 193 | -- 194 | -- > return [] 195 | -- > runTests = $quickCheckAll 196 | -- 197 | -- and then execute @runTests@. 198 | -- 199 | -- Note: the bizarre @return []@ in the example above is needed on 200 | -- GHC 7.8 and later; without it, 'quickCheckAll' will not be able to find 201 | -- any of the properties. For the curious, the @return []@ is a 202 | -- Template Haskell splice that makes GHC insert the empty list 203 | -- of declarations at that point in the program; GHC typechecks 204 | -- everything before the @return []@ before it starts on the rest 205 | -- of the module, which means that the later call to 'quickCheckAll' 206 | -- can see everything that was defined before the @return []@. Yikes! 207 | quickCheckAll :: Q Exp 208 | quickCheckAll = forAllProperties `appE` [| quickCheckResult |] 209 | 210 | -- | Test all properties in the current module. 211 | -- This is just a convenience function that combines 'quickCheckAll' and 'verbose'. 212 | -- 213 | -- 'verboseCheckAll' has the same issue with scoping as 'quickCheckAll': 214 | -- see the note there about @return []@. 215 | verboseCheckAll :: Q Exp 216 | verboseCheckAll = forAllProperties `appE` [| verboseCheckResult |] 217 | 218 | runQuickCheckAll :: [(String, Property)] -> (Property -> IO Result) -> IO Bool 219 | runQuickCheckAll ps qc = 220 | fmap and . forM ps $ \(xs, p) -> do 221 | putStrLn $ "=== " ++ xs ++ " ===" 222 | r <- qc p 223 | putStrLn "" 224 | return $ case r of 225 | Success { } -> True 226 | Failure { } -> False 227 | NoExpectedFailure { } -> False 228 | GaveUp { } -> False 229 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Exception.hs: -------------------------------------------------------------------------------- 1 | -- | Throwing and catching exceptions. Internal QuickCheck module. 2 | 3 | -- Hide away the nasty implementation-specific ways of catching 4 | -- exceptions behind a nice API. The main trouble is catching ctrl-C. 5 | 6 | {-# OPTIONS_HADDOCK hide #-} 7 | {-# LANGUAGE CPP #-} 8 | module Test.QuickCheck.Exception where 9 | 10 | #if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ < 700) 11 | #define OLD_EXCEPTIONS 12 | #endif 13 | 14 | #if defined(NO_EXCEPTIONS) 15 | #else 16 | import qualified Control.Exception as E 17 | #endif 18 | 19 | #if defined(NO_EXCEPTIONS) 20 | type AnException = () 21 | #elif defined(OLD_EXCEPTIONS) 22 | type AnException = E.Exception 23 | #else 24 | type AnException = E.SomeException 25 | #endif 26 | 27 | #ifdef NO_EXCEPTIONS 28 | tryEvaluate :: a -> IO (Either AnException a) 29 | tryEvaluate x = return (Right x) 30 | 31 | tryEvaluateIO :: IO a -> IO (Either AnException a) 32 | tryEvaluateIO m = fmap Right m 33 | 34 | evaluate :: a -> IO a 35 | evaluate x = x `seq` return x 36 | 37 | isInterrupt :: AnException -> Bool 38 | isInterrupt _ = False 39 | 40 | discard :: a 41 | discard = error "'discard' not supported, since your Haskell system can't catch exceptions" 42 | 43 | isDiscard :: AnException -> Bool 44 | isDiscard _ = False 45 | 46 | finally :: IO a -> IO b -> IO a 47 | finally mx my = do 48 | x <- mx 49 | my 50 | return x 51 | 52 | #else 53 | -------------------------------------------------------------------------- 54 | -- try evaluate 55 | 56 | tryEvaluate :: a -> IO (Either AnException a) 57 | tryEvaluate x = tryEvaluateIO (return x) 58 | 59 | tryEvaluateIO :: IO a -> IO (Either AnException a) 60 | tryEvaluateIO m = E.tryJust notAsync (m >>= E.evaluate) 61 | where 62 | notAsync :: AnException -> Maybe AnException 63 | #if MIN_VERSION_base(4,7,0) 64 | notAsync e = case E.fromException e of 65 | Just (E.SomeAsyncException _) -> Nothing 66 | Nothing -> Just e 67 | #elif !defined(OLD_EXCEPTIONS) 68 | notAsync e = case E.fromException e :: Maybe E.AsyncException of 69 | Just _ -> Nothing 70 | Nothing -> Just e 71 | #else 72 | notAsync e = Just e 73 | #endif 74 | 75 | --tryEvaluateIO m = Right `fmap` m 76 | 77 | evaluate :: a -> IO a 78 | evaluate = E.evaluate 79 | 80 | -- | Test if an exception was a @^C@. 81 | -- QuickCheck won't try to shrink an interrupted test case. 82 | isInterrupt :: AnException -> Bool 83 | 84 | #if defined(OLD_EXCEPTIONS) 85 | isInterrupt _ = False 86 | #else 87 | isInterrupt e = E.fromException e == Just E.UserInterrupt 88 | #endif 89 | 90 | -- | A special error value. If a property evaluates 'discard', it 91 | -- causes QuickCheck to discard the current test case. 92 | -- This can be useful if you want to discard the current test case, 93 | -- but are somewhere you can't use 'Test.QuickCheck.==>', such as inside a 94 | -- generator. 95 | discard :: a 96 | 97 | isDiscard :: AnException -> Bool 98 | (discard, isDiscard) = (E.throw (E.ErrorCall msg), isDiscard) 99 | where 100 | msg = "DISCARD. " ++ 101 | "You should not see this exception, it is internal to QuickCheck." 102 | #if defined(OLD_EXCEPTIONS) 103 | isDiscard (E.ErrorCall msg') = msg' == msg 104 | isDiscard _ = False 105 | #else 106 | isDiscard e = 107 | case E.fromException e of 108 | Just (E.ErrorCall msg') -> msg' == msg 109 | _ -> False 110 | #endif 111 | 112 | finally :: IO a -> IO b -> IO a 113 | finally = E.finally 114 | #endif 115 | 116 | -------------------------------------------------------------------------- 117 | -- the end. 118 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Features.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | module Test.QuickCheck.Features where 3 | 4 | import Test.QuickCheck.Property hiding (Result, reason) 5 | import qualified Test.QuickCheck.Property as P 6 | import Test.QuickCheck.Test 7 | import Test.QuickCheck.Gen 8 | import Test.QuickCheck.Text 9 | import qualified Data.Set as Set 10 | import Data.Set(Set) 11 | import Data.List (intersperse) 12 | import Data.IORef 13 | import Data.Maybe 14 | 15 | features :: [String] -> Set String -> Set String 16 | features labels classes = 17 | Set.fromList labels `Set.union` classes 18 | 19 | -- prop_noNewFeatures :: Testable prop => Set String -> prop -> Property 20 | -- prop_noNewFeatures feats prop = 21 | -- mapResult f prop 22 | -- where 23 | -- f res = 24 | -- case ok res of 25 | -- Just True 26 | -- | not (features (P.labels res) (Set.fromList (P.classes res)) `Set.isSubsetOf` feats) -> 27 | -- res{ok = Just False, P.reason = "New feature found"} 28 | -- _ -> res 29 | 30 | -- | Given a property, which must use 'label', 'collect', 'classify' or 'cover' 31 | -- to associate labels with test cases, find an example test case for each possible label. 32 | -- The example test cases are minimised using shrinking. 33 | -- 34 | -- For example, suppose we test @'Data.List.delete' x xs@ and record the number 35 | -- of times that @x@ occurs in @xs@: 36 | -- 37 | -- > prop_delete :: Int -> [Int] -> Property 38 | -- > prop_delete x xs = 39 | -- > classify (count x xs == 0) "count x xs == 0" $ 40 | -- > classify (count x xs == 1) "count x xs == 1" $ 41 | -- > classify (count x xs >= 2) "count x xs >= 2" $ 42 | -- > counterexample (show (delete x xs)) $ 43 | -- > count x (delete x xs) == max 0 (count x xs-1) 44 | -- > where count x xs = length (filter (== x) xs) 45 | -- 46 | -- 'labelledExamples' generates three example test cases, one for each label: 47 | -- 48 | -- >>> labelledExamples prop_delete 49 | -- *** Found example of count x xs == 0 50 | -- 0 51 | -- [] 52 | -- [] 53 | -- 54 | -- *** Found example of count x xs == 1 55 | -- 0 56 | -- [0] 57 | -- [] 58 | -- 59 | -- *** Found example of count x xs >= 2 60 | -- 5 61 | -- [5,5] 62 | -- [5] 63 | -- 64 | -- +++ OK, passed 100 tests: 65 | -- 78% count x xs == 0 66 | -- 21% count x xs == 1 67 | -- 1% count x xs >= 2 68 | 69 | 70 | labelledExamples :: Testable prop => prop -> IO () 71 | labelledExamples prop = labelledExamplesWith stdArgs prop 72 | 73 | -- | A variant of 'labelledExamples' that takes test arguments. 74 | labelledExamplesWith :: Testable prop => Args -> prop -> IO () 75 | labelledExamplesWith args prop = labelledExamplesWithResult args prop >> return () 76 | 77 | -- | A variant of 'labelledExamples' that returns a result. 78 | labelledExamplesResult :: Testable prop => prop -> IO Result 79 | labelledExamplesResult prop = labelledExamplesWithResult stdArgs prop 80 | 81 | -- | A variant of 'labelledExamples' that takes test arguments and returns a result. 82 | labelledExamplesWithResult :: Testable prop => Args -> prop -> IO Result 83 | labelledExamplesWithResult args prop = undefined -- TODO fix this 84 | -- withState args (\state -> do 85 | -- let 86 | -- loop :: Set String -> State -> IO Result 87 | -- loop feats state = withNullTerminal $ \nullterm -> do 88 | -- res <- test state{terminal = nullterm} (property (prop_noNewFeatures feats prop)) 89 | -- let feats' = features (failingLabels res) (failingClasses res) 90 | -- case res of 91 | -- Failure{reason = "New feature found"} -> do 92 | -- putLine (terminal state) $ 93 | -- "*** Found example of " ++ 94 | -- concat (intersperse ", " (Set.toList (feats' Set.\\ feats))) 95 | -- mapM_ (putLine (terminal state)) (failingTestCase res) 96 | -- putStrLn "" 97 | -- loop (Set.union feats feats') 98 | -- state{randomSeed = usedSeed res, computeSize = computeSize state `at0` usedSize res} 99 | -- _ -> do 100 | -- out <- terminalOutput nullterm 101 | -- putStr out 102 | -- return res 103 | -- at0 f s 0 0 = s 104 | -- at0 f s n d = f n d 105 | -- loop Set.empty state) Nothing 0 106 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifndef NO_ST_MONAD 3 | {-# LANGUAGE Rank2Types #-} 4 | #endif 5 | -- | Test case generation. 6 | -- 7 | -- __Note__: the contents of this module (except for the definition of 8 | -- 'Gen') are re-exported by "Test.QuickCheck". You probably do not 9 | -- need to import it directly. 10 | module Test.QuickCheck.Gen where 11 | 12 | -------------------------------------------------------------------------- 13 | -- imports 14 | 15 | import System.Random 16 | ( Random 17 | , random 18 | , randomR 19 | , split 20 | ) 21 | 22 | import Control.Monad 23 | ( ap 24 | , replicateM 25 | , filterM 26 | ) 27 | 28 | import Control.Monad.Fix 29 | ( MonadFix(..) ) 30 | 31 | import Control.Applicative 32 | ( Applicative(..) ) 33 | 34 | import Test.QuickCheck.Random 35 | import Data.List (sortBy) 36 | import Data.Ord 37 | import Data.Maybe 38 | #ifndef NO_SPLITMIX 39 | import System.Random.SplitMix(bitmaskWithRejection64', nextInteger, nextDouble, nextFloat, SMGen) 40 | #endif 41 | import Data.Word 42 | import Data.Int 43 | import Data.Bits 44 | import Control.Applicative 45 | 46 | -------------------------------------------------------------------------- 47 | -- ** Generator type 48 | 49 | -- | A generator for values of type @a@. 50 | -- 51 | -- The third-party packages 52 | -- 53 | -- and 54 | -- 55 | -- provide monad transformer versions of @Gen@. 56 | newtype Gen a = MkGen{ 57 | unGen :: QCGen -> Int -> a -- ^ Run the generator on a particular seed. 58 | -- If you just want to get a random value out, consider using 'generate'. 59 | } 60 | 61 | instance Functor Gen where 62 | fmap f (MkGen h) = 63 | MkGen (\r n -> f (h r n)) 64 | 65 | instance Applicative Gen where 66 | pure x = 67 | MkGen (\_ _ -> x) 68 | (<*>) = ap 69 | 70 | #ifndef NO_EXTRA_METHODS_IN_APPLICATIVE 71 | -- We don't need to split the seed for these. 72 | _ *> m = m 73 | m <* _ = m 74 | #endif 75 | 76 | instance Monad Gen where 77 | return = pure 78 | 79 | MkGen m >>= k = 80 | MkGen (\r n -> 81 | case split r of 82 | (r1, r2) -> 83 | let MkGen m' = k (m r1 n) 84 | in m' r2 n 85 | ) 86 | 87 | (>>) = (*>) 88 | 89 | instance MonadFix Gen where 90 | mfix f = 91 | MkGen $ \r n -> 92 | let a = unGen (f a) r n 93 | in a 94 | 95 | -------------------------------------------------------------------------- 96 | -- ** Primitive generator combinators 97 | 98 | -- | Modifies a generator using an integer seed. 99 | variant :: Integral n => n -> Gen a -> Gen a 100 | variant k (MkGen g) = MkGen (\r n -> g (integerVariant (toInteger k) $! r) n) 101 | 102 | -- | Used to construct generators that depend on the size parameter. 103 | -- 104 | -- For example, 'listOf', which uses the size parameter as an upper bound on 105 | -- length of lists it generates, can be defined like this: 106 | -- 107 | -- > listOf :: Gen a -> Gen [a] 108 | -- > listOf gen = sized $ \n -> 109 | -- > do k <- choose (0,n) 110 | -- > vectorOf k gen 111 | -- 112 | -- You can also do this using 'getSize'. 113 | sized :: (Int -> Gen a) -> Gen a 114 | sized f = MkGen (\r n -> let MkGen m = f n in m r n) 115 | 116 | -- | Returns the size parameter. Used to construct generators that depend on 117 | -- the size parameter. 118 | -- 119 | -- For example, 'listOf', which uses the size parameter as an upper bound on 120 | -- length of lists it generates, can be defined like this: 121 | -- 122 | -- > listOf :: Gen a -> Gen [a] 123 | -- > listOf gen = do 124 | -- > n <- getSize 125 | -- > k <- choose (0,n) 126 | -- > vectorOf k gen 127 | -- 128 | -- You can also do this using 'sized'. 129 | getSize :: Gen Int 130 | getSize = sized pure 131 | 132 | -- | Overrides the size parameter. Returns a generator which uses 133 | -- the given size instead of the runtime-size parameter. 134 | resize :: Int -> Gen a -> Gen a 135 | resize n _ | n < 0 = error "Test.QuickCheck.resize: negative size" 136 | resize n (MkGen g) = MkGen (\r _ -> g r n) 137 | 138 | -- | Adjust the size parameter, by transforming it with the given 139 | -- function. 140 | scale :: (Int -> Int) -> Gen a -> Gen a 141 | scale f g = sized (\n -> resize (f n) g) 142 | 143 | -- | Generates a random element in the given inclusive range. 144 | -- For integral and enumerated types, the specialised variants of 145 | -- 'choose' below run much quicker. 146 | choose :: Random a => (a,a) -> Gen a 147 | choose rng = MkGen (\r _ -> let (x,_) = randomR rng r in x) 148 | 149 | -- | Generates a random element over the natural range of `a`. 150 | chooseAny :: Random a => Gen a 151 | chooseAny = MkGen (\r _ -> let (x,_) = random r in x) 152 | 153 | -- | A fast implementation of 'choose' for enumerated types. 154 | chooseEnum :: Enum a => (a, a) -> Gen a 155 | chooseEnum (lo, hi) = 156 | fmap toEnum (chooseInt (fromEnum lo, fromEnum hi)) 157 | 158 | -- | A fast implementation of 'choose' for 'Int'. 159 | chooseInt :: (Int, Int) -> Gen Int 160 | chooseInt = chooseBoundedIntegral 161 | 162 | -- Note about INLINEABLE: we specialise chooseBoundedIntegral 163 | -- for each concrete type, so that all the bounds checks get 164 | -- simplified away. 165 | {-# INLINEABLE chooseBoundedIntegral #-} 166 | -- | A fast implementation of 'choose' for bounded integral types. 167 | chooseBoundedIntegral :: (Bounded a, Integral a) => (a, a) -> Gen a 168 | chooseBoundedIntegral (lo, hi) 169 | #ifndef NO_SPLITMIX 170 | | toInteger mn >= toInteger (minBound :: Int64) && 171 | toInteger mx <= toInteger (maxBound :: Int64) = 172 | fmap fromIntegral (chooseInt64 (fromIntegral lo, fromIntegral hi)) 173 | | toInteger mn >= toInteger (minBound :: Word64) && 174 | toInteger mx <= toInteger (maxBound :: Word64) = 175 | fmap fromIntegral (chooseWord64 (fromIntegral lo, fromIntegral hi)) 176 | #endif 177 | | otherwise = 178 | fmap fromInteger (chooseInteger (toInteger lo, toInteger hi)) 179 | #ifndef NO_SPLITMIX 180 | where 181 | mn = minBound `asTypeOf` lo 182 | mx = maxBound `asTypeOf` hi 183 | #endif 184 | 185 | -- | A fast implementation of 'choose' for 'Integer'. 186 | chooseInteger :: (Integer, Integer) -> Gen Integer 187 | #ifdef NO_SPLITMIX 188 | chooseInteger = choose 189 | #else 190 | chooseInteger (lo, hi) 191 | | lo >= toInteger (minBound :: Int64) && lo <= toInteger (maxBound :: Int64) && 192 | hi >= toInteger (minBound :: Int64) && hi <= toInteger (maxBound :: Int64) = 193 | fmap toInteger (chooseInt64 (fromInteger lo, fromInteger hi)) 194 | | lo >= toInteger (minBound :: Word64) && lo <= toInteger (maxBound :: Word64) && 195 | hi >= toInteger (minBound :: Word64) && hi <= toInteger (maxBound :: Word64) = 196 | fmap toInteger (chooseWord64 (fromInteger lo, fromInteger hi)) 197 | | otherwise = MkGen $ \(QCGen g) _ -> fst (nextInteger lo hi g) 198 | 199 | chooseWord64 :: (Word64, Word64) -> Gen Word64 200 | chooseWord64 (lo, hi) 201 | | lo <= hi = chooseWord64' (lo, hi) 202 | | otherwise = chooseWord64' (hi, lo) 203 | where 204 | chooseWord64' :: (Word64, Word64) -> Gen Word64 205 | chooseWord64' (lo, hi) = 206 | fmap (+ lo) (chooseUpTo (hi - lo)) 207 | 208 | chooseInt64 :: (Int64, Int64) -> Gen Int64 209 | chooseInt64 (lo, hi) 210 | | lo <= hi = chooseInt64' (lo, hi) 211 | | otherwise = chooseInt64' (hi, lo) 212 | where 213 | chooseInt64' :: (Int64, Int64) -> Gen Int64 214 | chooseInt64' (lo, hi) = do 215 | w <- chooseUpTo (fromIntegral hi - fromIntegral lo) 216 | return (fromIntegral (w + fromIntegral lo)) 217 | 218 | chooseUpTo :: Word64 -> Gen Word64 219 | chooseUpTo n = 220 | MkGen $ \(QCGen g) _ -> 221 | fst (bitmaskWithRejection64' n g) 222 | #endif 223 | 224 | -- | Run a generator. The size passed to the generator is always 30; 225 | -- if you want another size then you should explicitly use 'resize'. 226 | generate :: Gen a -> IO a 227 | generate (MkGen g) = 228 | do r <- newQCGen 229 | return (g r 30) 230 | 231 | -- | Generates some example values. 232 | sample' :: Gen a -> IO [a] 233 | sample' g = 234 | generate (sequence [ resize n g | n <- [0,2..20] ]) 235 | 236 | -- | Generates some example values and prints them to 'stdout'. 237 | sample :: Show a => Gen a -> IO () 238 | sample g = 239 | do cases <- sample' g 240 | mapM_ print cases 241 | 242 | -------------------------------------------------------------------------- 243 | -- ** Floating point 244 | 245 | -- | Generate 'Double' in 0..1 range 246 | genDouble :: Gen Double 247 | 248 | -- | Generate 'Float' in 0..1 range 249 | genFloat :: Gen Float 250 | 251 | #ifndef NO_SPLITMIX 252 | genDouble = MkGen $ \(QCGen g) _ -> fst (nextDouble g) 253 | genFloat = MkGen $ \(QCGen g) _ -> fst (nextFloat g) 254 | #else 255 | genDouble = choose (0,1) 256 | genFloat = choose (0,1) 257 | #endif 258 | 259 | -------------------------------------------------------------------------- 260 | -- ** Common generator combinators 261 | 262 | -- | Generates a value that satisfies a predicate. 263 | suchThat :: Gen a -> (a -> Bool) -> Gen a 264 | gen `suchThat` p = 265 | do mx <- gen `suchThatMaybe` p 266 | case mx of 267 | Just x -> return x 268 | Nothing -> sized (\n -> resize (n+1) (gen `suchThat` p)) 269 | 270 | -- | Generates a value for which the given function returns a 'Just', and then 271 | -- applies the function. 272 | suchThatMap :: Gen a -> (a -> Maybe b) -> Gen b 273 | gen `suchThatMap` f = 274 | fmap fromJust $ fmap f gen `suchThat` isJust 275 | 276 | -- | Tries to generate a value that satisfies a predicate. 277 | -- If it fails to do so after enough attempts, returns @Nothing@. 278 | suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) 279 | gen `suchThatMaybe` p = sized (\n -> try n (2*n)) 280 | where 281 | try m n 282 | | m > n = return Nothing 283 | | otherwise = do 284 | x <- resize m gen 285 | if p x then return (Just x) else try (m+1) n 286 | 287 | -- | Randomly uses one of the given generators. The input list 288 | -- must be non-empty. 289 | oneof :: [Gen a] -> Gen a 290 | oneof [] = error "QuickCheck.oneof used with empty list" 291 | oneof gs = chooseInt (0,length gs - 1) >>= (gs !!) 292 | 293 | -- | Chooses one of the given generators, with a weighted random distribution. 294 | -- The input list must be non-empty. 295 | frequency :: [(Int, Gen a)] -> Gen a 296 | frequency [] = error "QuickCheck.frequency used with empty list" 297 | frequency xs 298 | | any (< 0) (map fst xs) = 299 | error "QuickCheck.frequency: negative weight" 300 | | all (== 0) (map fst xs) = 301 | error "QuickCheck.frequency: all weights were zero" 302 | frequency xs0 = chooseInt (1, tot) >>= (`pick` xs0) 303 | where 304 | tot = sum (map fst xs0) 305 | 306 | pick n ((k,x):xs) 307 | | n <= k = x 308 | | otherwise = pick (n-k) xs 309 | pick _ _ = error "QuickCheck.pick used with empty list" 310 | 311 | -- | Generates one of the given values. The input list must be non-empty. 312 | elements :: [a] -> Gen a 313 | elements [] = error "QuickCheck.elements used with empty list" 314 | elements xs = (xs !!) `fmap` chooseInt (0, length xs - 1) 315 | 316 | -- | Generates a random subsequence of the given list. 317 | sublistOf :: [a] -> Gen [a] 318 | sublistOf xs = filterM (\_ -> chooseEnum (False, True)) xs 319 | 320 | -- | Generates a random permutation of the given list. 321 | shuffle :: [a] -> Gen [a] 322 | shuffle xs = do 323 | ns <- vectorOf (length xs) (chooseInt (minBound :: Int, maxBound)) 324 | return (map snd (sortBy (comparing fst) (zip ns xs))) 325 | 326 | -- | Takes a list of elements of increasing size, and chooses 327 | -- among an initial segment of the list. The size of this initial 328 | -- segment increases with the size parameter. 329 | -- The input list must be non-empty. 330 | growingElements :: [a] -> Gen a 331 | growingElements [] = error "QuickCheck.growingElements used with empty list" 332 | growingElements xs = sized $ \n -> elements (take (1 `max` size n) xs) 333 | where 334 | k = length xs 335 | mx = 100 336 | log' = round . log . toDouble 337 | size n = (log' n + 1) * k `div` log' mx 338 | toDouble = fromIntegral :: Int -> Double 339 | 340 | {- WAS: 341 | growingElements xs = sized $ \n -> elements (take (1 `max` (n * k `div` 100)) xs) 342 | where 343 | k = length xs 344 | -} 345 | 346 | -- | Generates a list of random length. The maximum length depends on the 347 | -- size parameter. 348 | listOf :: Gen a -> Gen [a] 349 | listOf gen = sized $ \n -> 350 | do k <- chooseInt (0,n) 351 | vectorOf k gen 352 | 353 | -- | Generates a non-empty list of random length. The maximum length 354 | -- depends on the size parameter. 355 | listOf1 :: Gen a -> Gen [a] 356 | listOf1 gen = sized $ \n -> 357 | do k <- chooseInt (1,1 `max` n) 358 | vectorOf k gen 359 | 360 | -- | Generates a list of the given length. 361 | vectorOf :: Int -> Gen a -> Gen [a] 362 | vectorOf = replicateM 363 | 364 | -- | Generates an infinite list. 365 | infiniteListOf :: Gen a -> Gen [a] 366 | infiniteListOf gen = sequence (repeat gen) 367 | 368 | -------------------------------------------------------------------------- 369 | -- the end. 370 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Gen/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | Lift generators into other monads. 3 | module Test.QuickCheck.Gen.Class where 4 | 5 | import Data.Monoid (Monoid) 6 | import Test.QuickCheck.Gen (Gen) 7 | import Control.Monad.Trans.Class (lift) 8 | import qualified Control.Monad.Trans.State.Strict as SS 9 | import qualified Control.Monad.Trans.State.Lazy as LS 10 | import qualified Control.Monad.Trans.Reader as R 11 | import qualified Control.Monad.Trans.Writer.Lazy as LW 12 | import qualified Control.Monad.Trans.Writer.Strict as SW 13 | import qualified Control.Monad.Trans.Identity as I 14 | import qualified Control.Monad.Trans.RWS.Lazy as LRWS 15 | import qualified Control.Monad.Trans.RWS.Strict as SRWS 16 | import qualified Control.Monad.Trans.Except as E 17 | import qualified Control.Monad.Trans.Maybe as M 18 | import qualified Control.Monad.Trans.Cont as C 19 | 20 | -- | A typeclass for lifting a generator into another monad. 21 | class Monad m => MonadGen m where 22 | -- | Lift a generator into the monad. 23 | liftGen :: Gen a -> m a 24 | 25 | instance MonadGen Gen where 26 | liftGen = id 27 | 28 | instance MonadGen m => MonadGen (SS.StateT s m) where 29 | liftGen = lift . liftGen 30 | 31 | instance MonadGen m => MonadGen (LS.StateT s m) where 32 | liftGen = lift . liftGen 33 | 34 | instance MonadGen m => MonadGen (R.ReaderT r m) where 35 | liftGen = lift . liftGen 36 | 37 | instance (MonadGen m, Monoid w) => MonadGen (LW.WriterT w m) where 38 | liftGen = lift . liftGen 39 | 40 | instance (MonadGen m, Monoid w) => MonadGen (SW.WriterT w m) where 41 | liftGen = lift . liftGen 42 | 43 | instance (MonadGen m, Monoid w) => MonadGen (LRWS.RWST r w s m) where 44 | liftGen = lift . liftGen 45 | 46 | instance (MonadGen m, Monoid w) => MonadGen (SRWS.RWST r w s m) where 47 | liftGen = lift . liftGen 48 | 49 | instance MonadGen m => MonadGen (M.MaybeT m) where 50 | liftGen = lift . liftGen 51 | 52 | instance MonadGen m => MonadGen (E.ExceptT e m) where 53 | liftGen = lift . liftGen 54 | 55 | instance MonadGen m => MonadGen (I.IdentityT m) where 56 | liftGen = lift . liftGen 57 | 58 | instance MonadGen m => MonadGen (C.ContT r m) where 59 | liftGen = lift . liftGen 60 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Gen/Unsafe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifndef NO_SAFE_HASKELL 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | #ifndef NO_ST_MONAD 6 | {-# LANGUAGE Rank2Types #-} 7 | #endif 8 | -- | Unsafe combinators for the 'Gen' monad. 9 | -- 10 | -- 'Gen' is only morally a monad: two generators that are supposed 11 | -- to be equal will give the same probability distribution, but they 12 | -- might be different as functions from random number seeds to values. 13 | -- QuickCheck maintains the illusion that a 'Gen' is a probability 14 | -- distribution and does not allow you to distinguish two generators 15 | -- that have the same distribution. 16 | -- 17 | -- The functions in this module allow you to break this illusion by 18 | -- reusing the same random number seed twice. This is unsafe because 19 | -- by applying the same seed to two morally equal generators, you can 20 | -- see whether they are really equal or not. 21 | module Test.QuickCheck.Gen.Unsafe where 22 | 23 | import Test.QuickCheck.Gen 24 | import Control.Monad 25 | 26 | -- | Promotes a monadic generator to a generator of monadic values. 27 | promote :: Monad m => m (Gen a) -> Gen (m a) 28 | promote m = do 29 | eval <- delay 30 | return (liftM eval m) 31 | 32 | -- | Randomly generates a function of type @'Gen' a -> a@, which 33 | -- you can then use to evaluate generators. Mostly useful in 34 | -- implementing 'promote'. 35 | delay :: Gen (Gen a -> a) 36 | delay = MkGen (\r n g -> unGen g r n) 37 | 38 | #ifndef NO_ST_MONAD 39 | -- | A variant of 'delay' that returns a polymorphic evaluation function. 40 | -- Can be used in a pinch to generate polymorphic (rank-2) values: 41 | -- 42 | -- > genSelector :: Gen (a -> a -> a) 43 | -- > genSelector = elements [\x y -> x, \x y -> y] 44 | -- > 45 | -- > data Selector = Selector (forall a. a -> a -> a) 46 | -- > genPolySelector :: Gen Selector 47 | -- > genPolySelector = do 48 | -- > Capture eval <- capture 49 | -- > return (Selector (eval genSelector)) 50 | capture :: Gen Capture 51 | capture = MkGen (\r n -> Capture (\g -> unGen g r n)) 52 | 53 | newtype Capture = Capture (forall a. Gen a -> a) 54 | #endif 55 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Modifiers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifndef NO_SAFE_HASKELL 3 | {-# LANGUAGE Trustworthy #-} 4 | #endif 5 | #ifndef NO_MULTI_PARAM_TYPE_CLASSES 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | #endif 8 | #ifndef NO_NEWTYPE_DERIVING 9 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 10 | #endif 11 | #ifndef NO_TYPEABLE 12 | {-# LANGUAGE DeriveDataTypeable #-} 13 | #endif 14 | -- | Modifiers for test data. 15 | -- 16 | -- These types do things such as restricting the kind of test data that can be generated. 17 | -- They can be pattern-matched on in properties as a stylistic 18 | -- alternative to using explicit quantification. 19 | -- 20 | -- __Note__: the contents of this module are re-exported by 21 | -- "Test.QuickCheck". You do not need to import it directly. 22 | -- 23 | -- Examples: 24 | -- 25 | -- @ 26 | -- -- Functions cannot be shown (but see "Test.QuickCheck.Function") 27 | -- prop_TakeDropWhile ('Blind' p) (xs :: ['A']) = 28 | -- takeWhile p xs ++ dropWhile p xs == xs 29 | -- @ 30 | -- 31 | -- @ 32 | -- prop_TakeDrop ('NonNegative' n) (xs :: ['A']) = 33 | -- take n xs ++ drop n xs == xs 34 | -- @ 35 | -- 36 | -- @ 37 | -- -- cycle does not work for empty lists 38 | -- prop_Cycle ('NonNegative' n) ('NonEmpty' (xs :: ['A'])) = 39 | -- take n (cycle xs) == take n (xs ++ cycle xs) 40 | -- @ 41 | -- 42 | -- @ 43 | -- -- Instead of 'forAll' 'orderedList' 44 | -- prop_Sort ('Ordered' (xs :: ['OrdA'])) = 45 | -- sort xs == xs 46 | -- @ 47 | module Test.QuickCheck.Modifiers 48 | ( 49 | -- ** Type-level modifiers for changing generator behavior 50 | Blind(..) 51 | , Fixed(..) 52 | , OrderedList(..) 53 | , NonEmptyList(..) 54 | , InfiniteList(..) 55 | , SortedList(..) 56 | , Positive(..) 57 | , Negative(..) 58 | , NonZero(..) 59 | , NonNegative(..) 60 | , NonPositive(..) 61 | , Large(..) 62 | , Small(..) 63 | , Smart(..) 64 | , Shrink2(..) 65 | #ifndef NO_MULTI_PARAM_TYPE_CLASSES 66 | , Shrinking(..) 67 | , ShrinkState(..) 68 | #endif 69 | , ASCIIString(..) 70 | , UnicodeString(..) 71 | , PrintableString(..) 72 | ) 73 | where 74 | 75 | -------------------------------------------------------------------------- 76 | -- imports 77 | 78 | import Test.QuickCheck.Gen 79 | import Test.QuickCheck.Arbitrary 80 | import Test.QuickCheck.Exception 81 | 82 | import Data.List 83 | ( sort 84 | ) 85 | import Data.Ix (Ix) 86 | 87 | #ifndef NO_TYPEABLE 88 | import Data.Typeable (Typeable) 89 | #endif 90 | 91 | -------------------------------------------------------------------------- 92 | -- | @Blind x@: as x, but x does not have to be in the 'Show' class. 93 | newtype Blind a = Blind {getBlind :: a} 94 | deriving ( Eq, Ord 95 | #ifndef NO_NEWTYPE_DERIVING 96 | , Num, Integral, Real, Enum 97 | #endif 98 | #ifndef NO_TYPEABLE 99 | , Typeable 100 | #endif 101 | ) 102 | 103 | instance Functor Blind where 104 | fmap f (Blind x) = Blind (f x) 105 | 106 | instance Show (Blind a) where 107 | show _ = "(*)" 108 | 109 | instance Arbitrary a => Arbitrary (Blind a) where 110 | arbitrary = Blind `fmap` arbitrary 111 | 112 | shrink (Blind x) = [ Blind x' | x' <- shrink x ] 113 | 114 | -------------------------------------------------------------------------- 115 | -- | @Fixed x@: as x, but will not be shrunk. 116 | newtype Fixed a = Fixed {getFixed :: a} 117 | deriving ( Eq, Ord, Show, Read 118 | #ifndef NO_NEWTYPE_DERIVING 119 | , Num, Integral, Real, Enum 120 | #endif 121 | #ifndef NO_TYPEABLE 122 | , Typeable 123 | #endif 124 | ) 125 | 126 | instance Functor Fixed where 127 | fmap f (Fixed x) = Fixed (f x) 128 | 129 | instance Arbitrary a => Arbitrary (Fixed a) where 130 | arbitrary = Fixed `fmap` arbitrary 131 | 132 | -- no shrink function 133 | 134 | -------------------------------------------------------------------------- 135 | -- | @Ordered xs@: guarantees that xs is ordered. 136 | newtype OrderedList a = Ordered {getOrdered :: [a]} 137 | deriving ( Eq, Ord, Show, Read 138 | #ifndef NO_TYPEABLE 139 | , Typeable 140 | #endif 141 | ) 142 | 143 | instance Functor OrderedList where 144 | fmap f (Ordered x) = Ordered (map f x) 145 | 146 | instance (Ord a, Arbitrary a) => Arbitrary (OrderedList a) where 147 | arbitrary = Ordered `fmap` orderedList 148 | 149 | shrink (Ordered xs) = 150 | [ Ordered xs' 151 | | xs' <- shrink xs 152 | , sort xs' == xs' 153 | ] 154 | 155 | -------------------------------------------------------------------------- 156 | -- | @NonEmpty xs@: guarantees that xs is non-empty. 157 | newtype NonEmptyList a = NonEmpty {getNonEmpty :: [a]} 158 | deriving ( Eq, Ord, Show, Read 159 | #ifndef NO_TYPEABLE 160 | , Typeable 161 | #endif 162 | ) 163 | 164 | instance Functor NonEmptyList where 165 | fmap f (NonEmpty x) = NonEmpty (map f x) 166 | 167 | instance Arbitrary a => Arbitrary (NonEmptyList a) where 168 | arbitrary = NonEmpty `fmap` (arbitrary `suchThat` (not . null)) 169 | 170 | shrink (NonEmpty xs) = 171 | [ NonEmpty xs' 172 | | xs' <- shrink xs 173 | , not (null xs') 174 | ] 175 | 176 | ---------------------------------------------------------------------- 177 | -- | @InfiniteList xs _@: guarantees that xs is an infinite list. 178 | -- When a counterexample is found, only prints the prefix of xs 179 | -- that was used by the program. 180 | -- 181 | -- Here is a contrived example property: 182 | -- 183 | -- > prop_take_10 :: InfiniteList Char -> Bool 184 | -- > prop_take_10 (InfiniteList xs _) = 185 | -- > or [ x == 'a' | x <- take 10 xs ] 186 | -- 187 | -- In the following counterexample, the list must start with @"bbbbbbbbbb"@ but 188 | -- the remaining (infinite) part can contain anything: 189 | -- 190 | -- >>> quickCheck prop_take_10 191 | -- *** Failed! Falsified (after 1 test and 14 shrinks): 192 | -- "bbbbbbbbbb" ++ ... 193 | data InfiniteList a = 194 | InfiniteList { 195 | getInfiniteList :: [a], 196 | infiniteListInternalData :: InfiniteListInternalData a } 197 | 198 | -- Uses a similar trick to Test.QuickCheck.Function: 199 | -- the Arbitrary instance generates an infinite list, which is 200 | -- reduced to a finite prefix by shrinking. We use discard to 201 | -- check that nothing coming after the finite prefix is used 202 | -- (see infiniteListFromData). 203 | data InfiniteListInternalData a = Infinite [a] | FinitePrefix [a] 204 | 205 | infiniteListFromData :: InfiniteListInternalData a -> InfiniteList a 206 | infiniteListFromData info@(Infinite xs) = InfiniteList xs info 207 | infiniteListFromData info@(FinitePrefix xs) = 208 | InfiniteList (xs ++ discard) info 209 | 210 | instance Show a => Show (InfiniteList a) where 211 | showsPrec _ (InfiniteList _ (Infinite _)) = 212 | ("" ++) 213 | showsPrec n (InfiniteList _ (FinitePrefix xs)) = 214 | (if n > 10 then ('(':) else id) . 215 | showsPrec 0 xs . 216 | (" ++ ..." ++) . 217 | (if n > 10 then (')':) else id) 218 | 219 | instance Arbitrary a => Arbitrary (InfiniteList a) where 220 | arbitrary = fmap infiniteListFromData arbitrary 221 | shrink (InfiniteList _ info) = 222 | map infiniteListFromData (shrink info) 223 | 224 | instance Arbitrary a => Arbitrary (InfiniteListInternalData a) where 225 | arbitrary = fmap Infinite infiniteList 226 | shrink (Infinite xs) = 227 | [FinitePrefix (take n xs) | n <- map (2^) [0..]] 228 | shrink (FinitePrefix xs) = 229 | map FinitePrefix (shrink xs) 230 | 231 | -------------------------------------------------------------------------- 232 | -- | @Sorted xs@: guarantees that xs is sorted. 233 | newtype SortedList a = Sorted {getSorted :: [a]} 234 | deriving ( Eq, Ord, Show, Read 235 | #ifndef NO_TYPEABLE 236 | , Typeable 237 | #endif 238 | ) 239 | 240 | instance Functor SortedList where 241 | fmap f (Sorted x) = Sorted (map f x) 242 | 243 | instance (Arbitrary a, Ord a) => Arbitrary (SortedList a) where 244 | arbitrary = fmap (Sorted . sort) arbitrary 245 | 246 | shrink (Sorted xs) = 247 | [ Sorted xs' 248 | | xs' <- map sort (shrink xs) 249 | ] 250 | 251 | -------------------------------------------------------------------------- 252 | -- | @Positive x@: guarantees that @x \> 0@. 253 | newtype Positive a = Positive {getPositive :: a} 254 | deriving ( Eq, Ord, Show, Read 255 | #ifndef NO_NEWTYPE_DERIVING 256 | , Enum 257 | #endif 258 | #ifndef NO_TYPEABLE 259 | , Typeable 260 | #endif 261 | ) 262 | 263 | instance Functor Positive where 264 | fmap f (Positive x) = Positive (f x) 265 | 266 | instance (Num a, Ord a, Arbitrary a) => Arbitrary (Positive a) where 267 | arbitrary = fmap Positive (fmap abs arbitrary `suchThat` (> 0)) 268 | shrink (Positive x) = [ Positive x' | x' <- shrink x , x' > 0 ] 269 | 270 | -------------------------------------------------------------------------- 271 | -- | @Negative x@: guarantees that @x \< 0@. 272 | newtype Negative a = Negative {getNegative :: a} 273 | deriving ( Eq, Ord, Show, Read 274 | #ifndef NO_NEWTYPE_DERIVING 275 | , Enum 276 | #endif 277 | #ifndef NO_TYPEABLE 278 | , Typeable 279 | #endif 280 | ) 281 | 282 | instance Functor Negative where 283 | fmap f (Negative x) = Negative (f x) 284 | 285 | instance (Num a, Ord a, Arbitrary a) => Arbitrary (Negative a) where 286 | arbitrary = fmap Negative (arbitrary `suchThat` (< 0)) 287 | shrink (Negative x) = [ Negative x' | x' <- shrink x , x' < 0 ] 288 | 289 | -------------------------------------------------------------------------- 290 | -- | @NonZero x@: guarantees that @x \/= 0@. 291 | newtype NonZero a = NonZero {getNonZero :: a} 292 | deriving ( Eq, Ord, Show, Read 293 | #ifndef NO_NEWTYPE_DERIVING 294 | , Enum 295 | #endif 296 | #ifndef NO_TYPEABLE 297 | , Typeable 298 | #endif 299 | ) 300 | 301 | instance Functor NonZero where 302 | fmap f (NonZero x) = NonZero (f x) 303 | 304 | instance (Num a, Eq a, Arbitrary a) => Arbitrary (NonZero a) where 305 | arbitrary = fmap NonZero $ arbitrary `suchThat` (/= 0) 306 | 307 | shrink (NonZero x) = [ NonZero x' | x' <- shrink x, x' /= 0 ] 308 | 309 | -------------------------------------------------------------------------- 310 | -- | @NonNegative x@: guarantees that @x \>= 0@. 311 | newtype NonNegative a = NonNegative {getNonNegative :: a} 312 | deriving ( Eq, Ord, Show, Read 313 | #ifndef NO_NEWTYPE_DERIVING 314 | , Enum 315 | #endif 316 | #ifndef NO_TYPEABLE 317 | , Typeable 318 | #endif 319 | ) 320 | 321 | instance Functor NonNegative where 322 | fmap f (NonNegative x) = NonNegative (f x) 323 | 324 | instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonNegative a) where 325 | arbitrary = fmap NonNegative (fmap abs arbitrary `suchThat` (>= 0)) 326 | shrink (NonNegative x) = [ NonNegative x' | x' <- shrink x , x' >= 0 ] 327 | 328 | -------------------------------------------------------------------------- 329 | -- | @NonPositive x@: guarantees that @x \<= 0@. 330 | newtype NonPositive a = NonPositive {getNonPositive :: a} 331 | deriving ( Eq, Ord, Show, Read 332 | #ifndef NO_NEWTYPE_DERIVING 333 | , Enum 334 | #endif 335 | #ifndef NO_TYPEABLE 336 | , Typeable 337 | #endif 338 | ) 339 | 340 | instance Functor NonPositive where 341 | fmap f (NonPositive x) = NonPositive (f x) 342 | 343 | instance (Num a, Ord a, Arbitrary a) => Arbitrary (NonPositive a) where 344 | arbitrary = fmap NonPositive (arbitrary `suchThat` (<= 0)) 345 | shrink (NonPositive x) = [ NonPositive x' | x' <- shrink x , x' <= 0 ] 346 | 347 | -------------------------------------------------------------------------- 348 | -- | @Large x@: by default, QuickCheck generates 'Int's drawn from a small 349 | -- range. @Large Int@ gives you values drawn from the entire range instead. 350 | newtype Large a = Large {getLarge :: a} 351 | deriving ( Eq, Ord, Show, Read 352 | #ifndef NO_NEWTYPE_DERIVING 353 | , Num, Integral, Real, Enum, Ix 354 | #endif 355 | #ifndef NO_TYPEABLE 356 | , Typeable 357 | #endif 358 | ) 359 | 360 | instance Functor Large where 361 | fmap f (Large x) = Large (f x) 362 | 363 | instance (Integral a, Bounded a) => Arbitrary (Large a) where 364 | arbitrary = fmap Large arbitrarySizedBoundedIntegral 365 | shrink (Large x) = fmap Large (shrinkIntegral x) 366 | 367 | -------------------------------------------------------------------------- 368 | -- | @Small x@: generates values of @x@ drawn from a small range. 369 | -- The opposite of 'Large'. 370 | newtype Small a = Small {getSmall :: a} 371 | deriving ( Eq, Ord, Show, Read 372 | #ifndef NO_NEWTYPE_DERIVING 373 | , Num, Integral, Real, Enum, Ix 374 | #endif 375 | #ifndef NO_TYPEABLE 376 | , Typeable 377 | #endif 378 | ) 379 | 380 | instance Functor Small where 381 | fmap f (Small x) = Small (f x) 382 | 383 | instance Integral a => Arbitrary (Small a) where 384 | arbitrary = fmap Small arbitrarySizedIntegral 385 | shrink (Small x) = map Small (shrinkIntegral x) 386 | 387 | -------------------------------------------------------------------------- 388 | -- | @Shrink2 x@: allows 2 shrinking steps at the same time when shrinking x 389 | newtype Shrink2 a = Shrink2 {getShrink2 :: a} 390 | deriving ( Eq, Ord, Show, Read 391 | #ifndef NO_NEWTYPE_DERIVING 392 | , Num, Integral, Real, Enum 393 | #endif 394 | #ifndef NO_TYPEABLE 395 | , Typeable 396 | #endif 397 | ) 398 | 399 | instance Functor Shrink2 where 400 | fmap f (Shrink2 x) = Shrink2 (f x) 401 | 402 | instance Arbitrary a => Arbitrary (Shrink2 a) where 403 | arbitrary = 404 | Shrink2 `fmap` arbitrary 405 | 406 | shrink (Shrink2 x) = 407 | [ Shrink2 y | y <- shrink_x ] ++ 408 | [ Shrink2 z 409 | | y <- shrink_x 410 | , z <- shrink y 411 | ] 412 | where 413 | shrink_x = shrink x 414 | 415 | -------------------------------------------------------------------------- 416 | -- | @Smart _ x@: tries a different order when shrinking. 417 | data Smart a = 418 | Smart Int a 419 | 420 | instance Functor Smart where 421 | fmap f (Smart n x) = Smart n (f x) 422 | 423 | instance Show a => Show (Smart a) where 424 | showsPrec n (Smart _ x) = showsPrec n x 425 | 426 | instance Arbitrary a => Arbitrary (Smart a) where 427 | arbitrary = 428 | do x <- arbitrary 429 | return (Smart 0 x) 430 | 431 | shrink (Smart i x) = take i' ys `ilv` drop i' ys 432 | where 433 | ys = [ Smart j y | (j,y) <- [0..] `zip` shrink x ] 434 | i' = 0 `max` (i-2) 435 | 436 | [] `ilv` bs = bs 437 | as `ilv` [] = as 438 | (a:as) `ilv` (b:bs) = a : b : (as `ilv` bs) 439 | 440 | {- 441 | shrink (Smart i x) = part0 ++ part2 ++ part1 442 | where 443 | ys = [ Smart i y | (i,y) <- [0..] `zip` shrink x ] 444 | i' = 0 `max` (i-2) 445 | k = i `div` 10 446 | 447 | part0 = take k ys 448 | part1 = take (i'-k) (drop k ys) 449 | part2 = drop i' ys 450 | -} 451 | 452 | -- drop a (drop b xs) == drop (a+b) xs | a,b >= 0 453 | -- take a (take b xs) == take (a `min` b) xs 454 | -- take a xs ++ drop a xs == xs 455 | 456 | -- take k ys ++ take (i'-k) (drop k ys) ++ drop i' ys 457 | -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) 458 | -- == take k ys ++ take (i'-k) (drop k ys) ++ drop (i'-k) (drop k ys) 459 | -- == take k ys ++ drop k ys 460 | -- == ys 461 | 462 | #ifndef NO_MULTI_PARAM_TYPE_CLASSES 463 | -------------------------------------------------------------------------- 464 | -- | @Shrinking _ x@: allows for maintaining a state during shrinking. 465 | data Shrinking s a = 466 | Shrinking s a 467 | 468 | class ShrinkState s a where 469 | shrinkInit :: a -> s 470 | shrinkState :: a -> s -> [(a,s)] 471 | 472 | instance Functor (Shrinking s) where 473 | fmap f (Shrinking s x) = Shrinking s (f x) 474 | 475 | instance Show a => Show (Shrinking s a) where 476 | showsPrec n (Shrinking _ x) = showsPrec n x 477 | 478 | instance (Arbitrary a, ShrinkState s a) => Arbitrary (Shrinking s a) where 479 | arbitrary = 480 | do x <- arbitrary 481 | return (Shrinking (shrinkInit x) x) 482 | 483 | shrink (Shrinking s x) = 484 | [ Shrinking s' x' 485 | | (x',s') <- shrinkState x s 486 | ] 487 | 488 | #endif /* NO_MULTI_PARAM_TYPE_CLASSES */ 489 | 490 | -------------------------------------------------------------------------- 491 | -- | @ASCIIString@: generates an ASCII string. 492 | newtype ASCIIString = ASCIIString {getASCIIString :: String} 493 | deriving ( Eq, Ord, Show, Read 494 | #ifndef NO_TYPEABLE 495 | , Typeable 496 | #endif 497 | ) 498 | 499 | instance Arbitrary ASCIIString where 500 | arbitrary = ASCIIString `fmap` listOf arbitraryASCIIChar 501 | shrink (ASCIIString xs) = ASCIIString `fmap` shrink xs 502 | 503 | -------------------------------------------------------------------------- 504 | -- | @UnicodeString@: generates a unicode String. 505 | -- The string will not contain surrogate pairs. 506 | newtype UnicodeString = UnicodeString {getUnicodeString :: String} 507 | deriving ( Eq, Ord, Show, Read 508 | #ifndef NO_TYPEABLE 509 | , Typeable 510 | #endif 511 | ) 512 | 513 | instance Arbitrary UnicodeString where 514 | arbitrary = UnicodeString `fmap` listOf arbitraryUnicodeChar 515 | shrink (UnicodeString xs) = UnicodeString `fmap` shrink xs 516 | 517 | -------------------------------------------------------------------------- 518 | -- | @PrintableString@: generates a printable unicode String. 519 | -- The string will not contain surrogate pairs. 520 | newtype PrintableString = PrintableString {getPrintableString :: String} 521 | deriving ( Eq, Ord, Show, Read 522 | #ifndef NO_TYPEABLE 523 | , Typeable 524 | #endif 525 | ) 526 | 527 | instance Arbitrary PrintableString where 528 | arbitrary = PrintableString `fmap` listOf arbitraryPrintableChar 529 | shrink (PrintableString xs) = PrintableString `fmap` shrink xs 530 | 531 | -- the end. 532 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Monadic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifndef NO_SAFE_HASKELL 3 | #if !defined(NO_ST_MONAD) && !(MIN_VERSION_base(4,8,0)) 4 | {-# LANGUAGE Trustworthy #-} 5 | #else 6 | {-# LANGUAGE Safe #-} 7 | #endif 8 | #endif 9 | #ifndef NO_ST_MONAD 10 | {-# LANGUAGE Rank2Types #-} 11 | #endif 12 | {-| 13 | Module : Test.QuickCheck.Monadic 14 | 15 | Allows testing of monadic values. Will generally follow this form: 16 | 17 | @ 18 | prop_monadic a b = 'monadicIO' $ do 19 | a\' \<- 'run' (f a) 20 | b\' \<- 'run' (f b) 21 | -- ... 22 | 'assert' someBoolean 23 | @ 24 | 25 | Example using the @FACTOR(1)@ command-line utility: 26 | 27 | @ 28 | import System.Process 29 | import Test.QuickCheck 30 | import Test.QuickCheck.Monadic 31 | 32 | -- $ factor 16 33 | -- 16: 2 2 2 2 34 | factor :: Integer -> IO [Integer] 35 | factor n = parse \`fmap\` 'System.Process.readProcess' \"factor\" [show n] \"\" where 36 | 37 | parse :: String -> [Integer] 38 | parse = map read . tail . words 39 | 40 | prop_factor :: Positive Integer -> Property 41 | prop_factor ('Test.QuickCheck.Modifiers.Positive' n) = 'monadicIO' $ do 42 | factors \<- 'run' (factor n) 43 | 44 | 'assert' (product factors == n) 45 | @ 46 | 47 | >>> quickCheck prop_factor 48 | +++ OK, passed 100 tests. 49 | 50 | See the paper \"\". 51 | -} 52 | module Test.QuickCheck.Monadic ( 53 | -- * Property monad 54 | PropertyM(..) 55 | 56 | -- * Monadic specification combinators 57 | , run 58 | , assert 59 | , assertWith 60 | , pre 61 | , wp 62 | , pick 63 | , forAllM 64 | , monitor 65 | , stop 66 | , graceful 67 | 68 | -- * Run functions 69 | , monadic 70 | , monadic' 71 | , monadicIO 72 | #ifndef NO_ST_MONAD 73 | , monadicST 74 | , runSTGen 75 | #endif 76 | ) where 77 | 78 | -------------------------------------------------------------------------- 79 | -- imports 80 | 81 | import Test.QuickCheck.Gen 82 | import Test.QuickCheck.Gen.Unsafe 83 | import Test.QuickCheck.Property 84 | 85 | import Control.Monad(liftM, liftM2) 86 | 87 | import Control.Monad.ST 88 | import Control.Applicative 89 | import Control.Exception hiding (assert) 90 | import Control.Concurrent 91 | 92 | #ifndef NO_TRANSFORMERS 93 | import Control.Monad.IO.Class 94 | import Control.Monad.Trans.Class 95 | #endif 96 | 97 | #ifndef NO_MONADFAIL 98 | import qualified Control.Monad.Fail as Fail 99 | #endif 100 | 101 | -------------------------------------------------------------------------- 102 | -- type PropertyM 103 | 104 | -- | The property monad is really a monad transformer that can contain 105 | -- monadic computations in the monad @m@ it is parameterized by: 106 | -- 107 | -- * @m@ - the @m@-computations that may be performed within @PropertyM@ 108 | -- 109 | -- Elements of @PropertyM m a@ may mix property operations and @m@-computations. 110 | newtype PropertyM m a = 111 | MkPropertyM { unPropertyM :: (a -> Gen (m Property)) -> Gen (m Property) } 112 | 113 | bind :: PropertyM m a -> (a -> PropertyM m b) -> PropertyM m b 114 | MkPropertyM m `bind` f = MkPropertyM (\k -> m (\a -> unPropertyM (f a) k)) 115 | 116 | fail_ :: Monad m => String -> PropertyM m a 117 | fail_ s = stop (failed { reason = s }) 118 | 119 | instance Functor (PropertyM m) where 120 | fmap f (MkPropertyM m) = MkPropertyM (\k -> m (k . f)) 121 | 122 | instance Applicative (PropertyM m) where 123 | pure x = MkPropertyM (\k -> k x) 124 | mf <*> mx = 125 | mf `bind` \f -> mx `bind` \x -> pure (f x) 126 | 127 | instance Monad m => Monad (PropertyM m) where 128 | return = pure 129 | (>>=) = bind 130 | #if !MIN_VERSION_base(4,13,0) 131 | fail = fail_ 132 | #endif 133 | 134 | #ifndef NO_MONADFAIL 135 | instance Monad m => Fail.MonadFail (PropertyM m) where 136 | fail = fail_ 137 | #endif 138 | 139 | #ifndef NO_TRANSFORMERS 140 | instance MonadTrans PropertyM where 141 | lift = run 142 | 143 | instance MonadIO m => MonadIO (PropertyM m) where 144 | liftIO = run . liftIO 145 | #endif 146 | 147 | stop :: (Testable prop, Monad m) => prop -> PropertyM m a 148 | stop p = MkPropertyM (\_k -> return (return (property p))) 149 | 150 | -- should think about strictness/exceptions here 151 | -- assert :: Testable prop => prop -> PropertyM m () 152 | -- | Allows embedding non-monadic properties into monadic ones. 153 | assert :: Monad m => Bool -> PropertyM m () 154 | assert True = return () 155 | assert False = fail "Assertion failed" 156 | 157 | -- | Like 'assert' but allows caller to specify an explicit message to show on failure. 158 | -- 159 | -- __Example:__ 160 | -- 161 | -- @ 162 | -- do 163 | -- assertWith True "My first predicate." 164 | -- assertWith False "My other predicate." 165 | -- ... 166 | -- @ 167 | -- 168 | -- @ 169 | -- Assertion failed (after 2 tests): 170 | -- Passed: My first predicate 171 | -- Failed: My other predicate 172 | -- @ 173 | assertWith :: Monad m => Bool -> String -> PropertyM m () 174 | assertWith condition msg = do 175 | let prefix = if condition then "Passed: " else "Failed: " 176 | monitor $ counterexample $ prefix ++ msg 177 | assert condition 178 | 179 | -- should think about strictness/exceptions here 180 | -- | Tests preconditions. Unlike 'assert' this does not cause the 181 | -- property to fail, rather it discards them just like using the 182 | -- implication combinator 'Test.QuickCheck.Property.==>'. 183 | -- 184 | -- This allows representing the 185 | -- 186 | -- > {p} x ← e{q} 187 | -- 188 | -- as 189 | -- 190 | -- @ 191 | -- pre p 192 | -- x \<- run e 193 | -- assert q 194 | -- @ 195 | -- 196 | pre :: Monad m => Bool -> PropertyM m () 197 | pre True = return () 198 | pre False = stop rejected 199 | 200 | -- should be called lift? 201 | -- | The lifting operation of the property monad. Allows embedding 202 | -- monadic\/'IO'-actions in properties: 203 | -- 204 | -- @ 205 | -- log :: Int -> IO () 206 | -- 207 | -- prop_foo n = monadicIO $ do 208 | -- run (log n) 209 | -- -- ... 210 | -- @ 211 | run :: Monad m => m a -> PropertyM m a 212 | run m = MkPropertyM (liftM (m >>=) . promote) 213 | 214 | -- | Quantification in a monadic property, fits better with 215 | -- /do-notation/ than 'forAllM'. 216 | -- __Note__: values generated by 'pick' do not shrink. 217 | pick :: (Monad m, Show a) => Gen a -> PropertyM m a 218 | pick gen = MkPropertyM $ \k -> 219 | do a <- gen 220 | mp <- k a 221 | return (do p <- mp 222 | return (forAll (return a) (const p))) 223 | 224 | -- | The 225 | -- 226 | -- > wp(x ← e, p) 227 | -- 228 | -- can be expressed as in code as @wp e (\\x -> p)@. 229 | wp :: Monad m => m a -> (a -> PropertyM m b) -> PropertyM m b 230 | wp m k = run m >>= k 231 | 232 | -- | Quantification in monadic properties to 'pick', with a notation similar to 233 | -- 'forAll'. __Note__: values generated by 'forAllM' do not shrink. 234 | 235 | forAllM :: (Monad m, Show a) => Gen a -> (a -> PropertyM m b) -> PropertyM m b 236 | forAllM gen k = pick gen >>= k 237 | 238 | -- | Allows making observations about the test data: 239 | -- 240 | -- @ 241 | -- monitor ('collect' e) 242 | -- @ 243 | -- 244 | -- collects the distribution of value of @e@. 245 | -- 246 | -- @ 247 | -- monitor ('counterexample' "Failure!") 248 | -- @ 249 | -- 250 | -- Adds @"Failure!"@ to the counterexamples. 251 | monitor :: Monad m => (Property -> Property) -> PropertyM m () 252 | monitor f = MkPropertyM (\k -> (f `liftM`) `fmap` (k ())) 253 | 254 | -- run functions 255 | 256 | monadic :: (Testable a, Monad m) => (m Property -> Property) -> PropertyM m a -> Property 257 | monadic runner m = property (fmap runner (monadic' m)) 258 | 259 | monadic' :: (Testable a, Monad m) => PropertyM m a -> Gen (m Property) 260 | monadic' (MkPropertyM m) = m (\prop -> return (return (property prop))) 261 | 262 | -- | Runs the property monad for 'IO'-computations. 263 | -- 264 | -- @ 265 | -- prop_cat msg = monadicIO $ do 266 | -- (exitCode, stdout, _) \<- run ('System.Process.readProcessWithExitCode' "cat" [] msg) 267 | -- 268 | -- pre ('System.Exit.ExitSuccess' == exitCode) 269 | -- 270 | -- assert (stdout == msg) 271 | -- @ 272 | -- 273 | -- >>> quickCheck prop_cat 274 | -- +++ OK, passed 100 tests. 275 | -- 276 | monadicIO :: Testable a => PropertyM IO a -> Property 277 | monadicIO = monadic ioProperty 278 | 279 | {- | Add a graceful optional termination of an IO action. If your test needs to perform 280 | some IO that, if interrupted by CTRL-C being pressed, needs to do some teardown, this 281 | combinator is for you! 282 | 283 | Example: 284 | 285 | @ 286 | prop_graceful :: Property 287 | prop_graceful = monadicIO $ do 288 | -- first IO action that might leave unwanted artifacts 289 | c1 <- graceful 290 | (do writeFile "firstfile.txt" "hi" 291 | c <- readFile "firstfile.txt" 292 | removeFile "firstfile.txt" 293 | return c) 294 | -- cleanup function only called if ctrl-c pressed 295 | (do b <- doesFileExist "firstfile.txt" 296 | if b then removeFile "firstfile.txt" else return ()) 297 | 298 | -- second IO action that might leave unwanted artifacts 299 | c2 <- graceful 300 | (do writeFile "secondfile.txt" "hi" 301 | c <- readFile "secondfile.txt" 302 | removeFile "secondfile.txt" 303 | return c) 304 | -- cleanup function only called if ctrl-c pressed 305 | (do b <- doesFileExist "secondfile.txt" 306 | if b then removeFile "secondfile.txt" else return ()) 307 | 308 | -- donkey property 309 | assert (c1 == c2) 310 | @ 311 | 312 | -} 313 | graceful :: IO a -> IO () -> PropertyM IO a 314 | -- TODO piggybacking on UserInterrupt here, but this should really be a QC internal exception 315 | -- this was just placed here for my evaluation 316 | -- 317 | -- design of this combinator might have to change 318 | graceful prop ioa = run $ prop `catch` \UserInterrupt -> do 319 | ioa 320 | tid <- myThreadId 321 | throwTo tid UserInterrupt -- defer to default handler 322 | error "this will never evaluate, but will have the correct type!" 323 | 324 | #ifndef NO_ST_MONAD 325 | -- | Runs the property monad for 'ST'-computations. 326 | -- 327 | -- @ 328 | -- -- Your mutable sorting algorithm here 329 | -- sortST :: Ord a => [a] -> 'Control.Monad.ST.ST' s (MVector s a) 330 | -- sortST = 'Data.Vector.thaw' . 'Data.Vector.fromList' . 'Data.List.sort' 331 | -- 332 | -- prop_sortST xs = monadicST $ do 333 | -- sorted \<- run ('Data.Vector.freeze' =<< sortST xs) 334 | -- assert ('Data.Vector.toList' sorted == sort xs) 335 | -- @ 336 | -- 337 | -- >>> quickCheck prop_sortST 338 | -- +++ OK, passed 100 tests. 339 | -- 340 | monadicST :: Testable a => (forall s. PropertyM (ST s) a) -> Property 341 | monadicST m = property (runSTGen (monadic' m)) 342 | 343 | runSTGen :: (forall s. Gen (ST s a)) -> Gen a 344 | runSTGen f = do 345 | Capture eval <- capture 346 | return (runST (eval f)) 347 | #endif 348 | 349 | -------------------------------------------------------------------------- 350 | -- the end. 351 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Poly.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | #ifndef NO_SAFE_HASKELL 3 | {-# LANGUAGE Safe #-} 4 | #endif 5 | -- | Types to help with testing polymorphic properties. 6 | -- 7 | -- Types 'A', 'B' and 'C' are @newtype@ wrappers around 'Integer' that 8 | -- implement 'Eq', 'Show', 'Arbitrary' and 'CoArbitrary'. Types 9 | -- 'OrdA', 'OrdB' and 'OrdC' also implement 'Ord' and 'Num'. 10 | -- 11 | -- See also "Test.QuickCheck.All" for an automatic way of testing 12 | -- polymorphic properties. 13 | module Test.QuickCheck.Poly 14 | ( A(..), B(..), C(..) 15 | , OrdA(..), OrdB(..), OrdC(..) 16 | ) 17 | where 18 | 19 | -------------------------------------------------------------------------- 20 | -- imports 21 | 22 | import Test.QuickCheck.Arbitrary 23 | 24 | -------------------------------------------------------------------------- 25 | -- polymorphic A, B, C (in Eq) 26 | 27 | -- A 28 | 29 | newtype A = A{ unA :: Integer } 30 | deriving ( Eq ) 31 | 32 | instance Show A where 33 | showsPrec n (A x) = showsPrec n x 34 | 35 | instance Arbitrary A where 36 | arbitrary = (A . (+1) . abs) `fmap` arbitrary 37 | shrink (A x) = [ A x' | x' <- shrink x, x' > 0 ] 38 | 39 | instance CoArbitrary A where 40 | coarbitrary = coarbitrary . unA 41 | 42 | -- B 43 | 44 | newtype B = B{ unB :: Integer } 45 | deriving ( Eq ) 46 | 47 | instance Show B where 48 | showsPrec n (B x) = showsPrec n x 49 | 50 | instance Arbitrary B where 51 | arbitrary = (B . (+1) . abs) `fmap` arbitrary 52 | shrink (B x) = [ B x' | x' <- shrink x, x' > 0 ] 53 | 54 | instance CoArbitrary B where 55 | coarbitrary = coarbitrary . unB 56 | 57 | -- C 58 | 59 | newtype C = C{ unC :: Integer } 60 | deriving ( Eq ) 61 | 62 | instance Show C where 63 | showsPrec n (C x) = showsPrec n x 64 | 65 | instance Arbitrary C where 66 | arbitrary = (C . (+1) . abs) `fmap` arbitrary 67 | shrink (C x) = [ C x' | x' <- shrink x, x' > 0 ] 68 | 69 | instance CoArbitrary C where 70 | coarbitrary = coarbitrary . unC 71 | 72 | -------------------------------------------------------------------------- 73 | -- polymorphic OrdA, OrdB, OrdC (in Eq, Ord) 74 | 75 | -- OrdA 76 | 77 | newtype OrdA = OrdA{ unOrdA :: Integer } 78 | deriving ( Eq, Ord ) 79 | 80 | liftOrdA 81 | :: (Integer -> Integer) 82 | -> OrdA -> OrdA 83 | liftOrdA f (OrdA x) = OrdA (f x) 84 | 85 | liftOrdA2 86 | :: (Integer -> Integer -> Integer) 87 | -> OrdA -> OrdA -> OrdA 88 | liftOrdA2 f (OrdA x) (OrdA y) = OrdA (f x y) 89 | 90 | instance Num OrdA where 91 | (+) = liftOrdA2 (+) 92 | (*) = liftOrdA2 (*) 93 | (-) = liftOrdA2 (-) 94 | negate = liftOrdA negate 95 | abs = liftOrdA abs 96 | signum = liftOrdA signum 97 | fromInteger = OrdA . fromInteger 98 | 99 | 100 | instance Show OrdA where 101 | showsPrec n (OrdA x) = showsPrec n x 102 | 103 | instance Arbitrary OrdA where 104 | arbitrary = (OrdA . (+1) . abs) `fmap` arbitrary 105 | shrink (OrdA x) = [ OrdA x' | x' <- shrink x, x' > 0 ] 106 | 107 | instance CoArbitrary OrdA where 108 | coarbitrary = coarbitrary . unOrdA 109 | 110 | -- OrdB 111 | 112 | newtype OrdB = OrdB{ unOrdB :: Integer } 113 | deriving ( Eq, Ord ) 114 | 115 | liftOrdB 116 | :: (Integer -> Integer) 117 | -> OrdB -> OrdB 118 | liftOrdB f (OrdB x) = OrdB (f x) 119 | 120 | liftOrdB2 121 | :: (Integer -> Integer -> Integer) 122 | -> OrdB -> OrdB -> OrdB 123 | liftOrdB2 f (OrdB x) (OrdB y) = OrdB (f x y) 124 | 125 | instance Num OrdB where 126 | (+) = liftOrdB2 (+) 127 | (*) = liftOrdB2 (*) 128 | (-) = liftOrdB2 (-) 129 | negate = liftOrdB negate 130 | abs = liftOrdB abs 131 | signum = liftOrdB signum 132 | fromInteger = OrdB . fromInteger 133 | 134 | instance Show OrdB where 135 | showsPrec n (OrdB x) = showsPrec n x 136 | 137 | instance Arbitrary OrdB where 138 | arbitrary = (OrdB . (+1) . abs) `fmap` arbitrary 139 | shrink (OrdB x) = [ OrdB x' | x' <- shrink x, x' > 0 ] 140 | 141 | instance CoArbitrary OrdB where 142 | coarbitrary = coarbitrary . unOrdB 143 | 144 | -- OrdC 145 | 146 | newtype OrdC = OrdC{ unOrdC :: Integer } 147 | deriving ( Eq, Ord ) 148 | 149 | liftOrdC 150 | :: (Integer -> Integer) 151 | -> OrdC -> OrdC 152 | liftOrdC f (OrdC x) = OrdC (f x) 153 | 154 | liftOrdC2 155 | :: (Integer -> Integer -> Integer) 156 | -> OrdC -> OrdC -> OrdC 157 | liftOrdC2 f (OrdC x) (OrdC y) = OrdC (f x y) 158 | 159 | instance Num OrdC where 160 | (+) = liftOrdC2 (+) 161 | (*) = liftOrdC2 (*) 162 | (-) = liftOrdC2 (-) 163 | negate = liftOrdC negate 164 | abs = liftOrdC abs 165 | signum = liftOrdC signum 166 | fromInteger = OrdC . fromInteger 167 | 168 | instance Show OrdC where 169 | showsPrec n (OrdC x) = showsPrec n x 170 | 171 | instance Arbitrary OrdC where 172 | arbitrary = (OrdC . (+1) . abs) `fmap` arbitrary 173 | shrink (OrdC x) = [ OrdC x' | x' <- shrink x, x' > 0 ] 174 | 175 | instance CoArbitrary OrdC where 176 | coarbitrary = coarbitrary . unOrdC 177 | 178 | -------------------------------------------------------------------------- 179 | -- the end. 180 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Random.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -- | A wrapper around the system random number generator. Internal QuickCheck module. 3 | {-# LANGUAGE CPP #-} 4 | #ifndef NO_SAFE_HASKELL 5 | {-# LANGUAGE Trustworthy #-} 6 | #endif 7 | module Test.QuickCheck.Random where 8 | 9 | import System.Random 10 | #ifndef NO_SPLITMIX 11 | import System.Random.SplitMix 12 | #endif 13 | import Data.Bits 14 | 15 | -- | The "standard" QuickCheck random number generator. 16 | -- A wrapper around either 'SMGen' on GHC, or 'StdGen' 17 | -- on other Haskell systems. 18 | #ifdef NO_SPLITMIX 19 | newtype QCGen = QCGen StdGen 20 | #else 21 | newtype QCGen = QCGen SMGen 22 | #endif 23 | 24 | instance Show QCGen where 25 | showsPrec n (QCGen g) s = showsPrec n g s 26 | instance Read QCGen where 27 | readsPrec n xs = [(QCGen g, ys) | (g, ys) <- readsPrec n xs] 28 | 29 | instance RandomGen QCGen where 30 | #ifdef NO_SPLITMIX 31 | split (QCGen g) = 32 | case split g of 33 | (g1, g2) -> (QCGen g1, QCGen g2) 34 | genRange (QCGen g) = genRange g 35 | next = wrapQCGen next 36 | #else 37 | split (QCGen g) = 38 | case splitSMGen g of 39 | (g1, g2) -> (QCGen g1, QCGen g2) 40 | genRange _ = (minBound, maxBound) 41 | next = wrapQCGen nextInt 42 | 43 | #ifndef OLD_RANDOM 44 | genWord8 = wrapQCGen genWord8 45 | genWord16 = wrapQCGen genWord16 46 | genWord32 = wrapQCGen genWord32 47 | genWord64 = wrapQCGen genWord64 48 | genWord32R r = wrapQCGen (genWord32R r) 49 | genWord64R r = wrapQCGen (genWord64R r) 50 | genShortByteString n = wrapQCGen (genShortByteString n) 51 | #endif 52 | #endif 53 | 54 | {-# INLINE wrapQCGen #-} 55 | #ifdef NO_SPLITMIX 56 | wrapQCGen :: (StdGen -> (a, StdGen)) -> (QCGen -> (a, QCGen)) 57 | #else 58 | wrapQCGen :: (SMGen -> (a, SMGen)) -> (QCGen -> (a, QCGen)) 59 | #endif 60 | wrapQCGen f (QCGen g) = 61 | case f g of 62 | (x, g') -> (x, QCGen g') 63 | 64 | newQCGen :: IO QCGen 65 | #ifdef NO_SPLITMIX 66 | newQCGen = fmap QCGen newStdGen 67 | #else 68 | newQCGen = fmap QCGen newSMGen 69 | #endif 70 | 71 | mkQCGen :: Int -> QCGen 72 | #ifdef NO_SPLITMIX 73 | mkQCGen n = QCGen (mkStdGen n) 74 | #else 75 | mkQCGen n = QCGen (mkSMGen (fromIntegral n)) 76 | #endif 77 | 78 | -- Parameterised in order to make this code testable. 79 | class Splittable a where 80 | left, right :: a -> a 81 | 82 | instance Splittable QCGen where 83 | left = fst . split 84 | right = snd . split 85 | 86 | -- The logic behind 'variant'. Given a random number seed, and an integer, uses 87 | -- splitting to transform the seed according to the integer. We use a 88 | -- prefix-free code so that calls to integerVariant n g for different values of 89 | -- n are guaranteed to return independent seeds. 90 | {-# INLINE integerVariant #-} 91 | integerVariant :: Splittable a => Integer -> a -> a 92 | integerVariant n g 93 | -- Use one bit to encode the sign, then use Elias gamma coding 94 | -- (https://en.wikipedia.org/wiki/Elias_gamma_coding) to do the rest. 95 | -- Actually, the first bit encodes whether n >= 1 or not; 96 | -- this has the advantage that both 0 and 1 get short codes. 97 | | n >= 1 = gamma n $! left g 98 | | otherwise = gamma (1-n) $! right g 99 | where 100 | gamma n = 101 | encode k . zeroes k 102 | where 103 | k = ilog2 n 104 | 105 | encode (-1) g = g 106 | encode k g 107 | | testBit n k = 108 | encode (k-1) $! right g 109 | | otherwise = 110 | encode (k-1) $! left g 111 | 112 | zeroes 0 g = g 113 | zeroes k g = zeroes (k-1) $! left g 114 | 115 | ilog2 1 = 0 116 | ilog2 n = 1 + ilog2 (n `div` 2) 117 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Text.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK hide #-} 2 | -- | Terminal control and text helper functions. Internal QuickCheck module. 3 | module Test.QuickCheck.Text 4 | ( Str(..) 5 | , ranges 6 | 7 | , number 8 | , short 9 | , showErr 10 | , oneLine 11 | , isOneLine 12 | , bold 13 | , ljust, rjust, centre, lpercent, rpercent, lpercentage, rpercentage 14 | , drawTable, Cell(..) 15 | , paragraphs 16 | 17 | , newTerminal 18 | , withStdioTerminal 19 | , withHandleTerminal 20 | , withNullTerminal 21 | , withBuffering 22 | , terminalOutput 23 | , handle 24 | , Terminal 25 | , putTemp 26 | , clearTemp 27 | , putPart 28 | , putLine 29 | ) 30 | where 31 | 32 | -------------------------------------------------------------------------- 33 | -- imports 34 | 35 | import System.IO 36 | ( hFlush 37 | , hPutStr 38 | , stdout 39 | , stderr 40 | , Handle 41 | , BufferMode (..) 42 | , hGetBuffering 43 | , hSetBuffering 44 | , hIsTerminalDevice 45 | ) 46 | 47 | import Data.IORef 48 | import Data.List (intersperse, transpose) 49 | import Text.Printf 50 | import Test.QuickCheck.Exception 51 | 52 | -------------------------------------------------------------------------- 53 | -- literal string 54 | 55 | newtype Str = MkStr String 56 | 57 | instance Show Str where 58 | show (MkStr s) = s 59 | 60 | ranges :: (Show a, Integral a) => a -> a -> Str 61 | ranges k n = MkStr (show n' ++ " -- " ++ show (n'+k-1)) 62 | where 63 | n' = k * (n `div` k) 64 | 65 | -------------------------------------------------------------------------- 66 | -- formatting 67 | 68 | number :: Int -> String -> String 69 | number n s = show n ++ " " ++ s ++ if n == 1 then "" else "s" 70 | 71 | short :: Int -> String -> String 72 | short n s 73 | | n < k = take (n-2-i) s ++ ".." ++ drop (k-i) s 74 | | otherwise = s 75 | where 76 | k = length s 77 | i = if n >= 5 then 3 else 0 78 | 79 | showErr :: Show a => a -> String 80 | showErr = unwords . words . show 81 | 82 | oneLine :: String -> String 83 | oneLine = unwords . words 84 | 85 | isOneLine :: String -> Bool 86 | isOneLine xs = '\n' `notElem` xs 87 | 88 | ljust n xs = xs ++ replicate (n - length xs) ' ' 89 | rjust n xs = replicate (n - length xs) ' ' ++ xs 90 | centre n xs = 91 | ljust n $ 92 | replicate ((n - length xs) `div` 2) ' ' ++ xs 93 | 94 | lpercent, rpercent :: (Integral a, Integral b) => a -> b -> String 95 | lpercent n k = 96 | lpercentage (fromIntegral n / fromIntegral k) k 97 | 98 | rpercent n k = 99 | rpercentage (fromIntegral n / fromIntegral k) k 100 | 101 | lpercentage, rpercentage :: Integral a => Double -> a -> String 102 | lpercentage p n = 103 | printf "%.*f" places (100*p) ++ "%" 104 | where 105 | -- Show no decimal places if k <= 100, 106 | -- one decimal place if k <= 1000, 107 | -- two decimal places if k <= 10000, and so on. 108 | places :: Integer 109 | places = 110 | ceiling (logBase 10 (fromIntegral n) - 2 :: Double) `max` 0 111 | 112 | rpercentage p n = padding ++ lpercentage p n 113 | where 114 | padding = if p < 0.1 then " " else "" 115 | 116 | data Cell = LJust String | RJust String | Centred String deriving Show 117 | 118 | text :: Cell -> String 119 | text (LJust xs) = xs 120 | text (RJust xs) = xs 121 | text (Centred xs) = xs 122 | 123 | -- Flatten a table into a list of rows 124 | flattenRows :: [[Cell]] -> [String] 125 | flattenRows rows = map row rows 126 | where 127 | cols = transpose rows 128 | widths = map (maximum . map (length . text)) cols 129 | 130 | row cells = concat (intersperse " " (zipWith cell widths cells)) 131 | cell n (LJust xs) = ljust n xs 132 | cell n (RJust xs) = rjust n xs 133 | cell n (Centred xs) = centre n xs 134 | 135 | -- Draw a table given a header and contents 136 | drawTable :: [String] -> [[Cell]] -> [String] 137 | drawTable headers table = 138 | [line] ++ 139 | [border '|' ' ' header | header <- headers] ++ 140 | [line | not (null headers) && not (null rows)] ++ 141 | [border '|' ' ' row | row <- rows] ++ 142 | [line] 143 | where 144 | rows = flattenRows table 145 | 146 | headerwidth = maximum (0:map length headers) 147 | bodywidth = maximum (0:map length rows) 148 | width = max headerwidth bodywidth 149 | 150 | line = border '+' '-' $ replicate width '-' 151 | border x y xs = [x, y] ++ centre width xs ++ [y, x] 152 | 153 | paragraphs :: [[String]] -> [String] 154 | paragraphs = concat . intersperse [""] . filter (not . null) 155 | 156 | bold :: String -> String 157 | -- not portable: 158 | --bold s = "\ESC[1m" ++ s ++ "\ESC[0m" 159 | bold s = s -- for now 160 | 161 | -------------------------------------------------------------------------- 162 | -- putting strings 163 | 164 | data Terminal 165 | = MkTerminal (IORef ShowS) (IORef Int) (String -> IO ()) (String -> IO ()) 166 | 167 | newTerminal :: (String -> IO ()) -> (String -> IO ()) -> IO Terminal 168 | newTerminal out err = 169 | do res <- newIORef (showString "") 170 | tmp <- newIORef 0 171 | return (MkTerminal res tmp out err) 172 | 173 | withBuffering :: IO a -> IO a 174 | withBuffering action = do 175 | mode <- hGetBuffering stderr 176 | -- By default stderr is unbuffered. This is very slow, hence we explicitly 177 | -- enable line buffering. 178 | hSetBuffering stderr LineBuffering 179 | action `finally` hSetBuffering stderr mode 180 | 181 | withHandleTerminal :: Handle -> Maybe Handle -> (Terminal -> IO a) -> IO a 182 | withHandleTerminal outh merrh action = do 183 | let 184 | err = 185 | case merrh of 186 | Nothing -> const (return ()) 187 | Just errh -> handle errh 188 | newTerminal (handle outh) err >>= action 189 | 190 | withStdioTerminal :: (Terminal -> IO a) -> IO a 191 | withStdioTerminal action = do 192 | isatty <- hIsTerminalDevice stderr 193 | if isatty then 194 | withBuffering (withHandleTerminal stdout (Just stderr) action) 195 | else 196 | withBuffering (withHandleTerminal stdout Nothing action) 197 | 198 | withNullTerminal :: (Terminal -> IO a) -> IO a 199 | withNullTerminal action = 200 | newTerminal (const (return ())) (const (return ())) >>= action 201 | 202 | terminalOutput :: Terminal -> IO String 203 | terminalOutput (MkTerminal res _ _ _) = fmap ($ "") (readIORef res) 204 | 205 | handle :: Handle -> String -> IO () 206 | handle h s = do 207 | hPutStr h s 208 | hFlush h 209 | 210 | putPart, putTemp, putLine :: Terminal -> String -> IO () 211 | putPart tm@(MkTerminal res _ out _) s = 212 | do putTemp tm "" 213 | force s 214 | out s 215 | modifyIORef res (. showString s) 216 | where 217 | force :: [a] -> IO () 218 | force = evaluate . seqList 219 | 220 | seqList :: [a] -> () 221 | seqList [] = () 222 | seqList (x:xs) = x `seq` seqList xs 223 | 224 | putLine tm s = putPart tm (s ++ "\n") 225 | 226 | putTemp tm@(MkTerminal _ tmp _ err) s = 227 | do n <- readIORef tmp 228 | err $ 229 | replicate n ' ' ++ replicate n '\b' ++ 230 | s ++ [ '\b' | _ <- s ] 231 | writeIORef tmp (length s) 232 | 233 | clearTemp tm@(MkTerminal _ tmp _ err) = 234 | do n <- readIORef tmp 235 | err $ 236 | replicate n ' ' ++ replicate n '\b' 237 | -------------------------------------------------------------------------- 238 | -- the end. 239 | -------------------------------------------------------------------------------- /test-hugs: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | CABAL=${CABAL:-cabal} 6 | HC=${HC:-ghc} 7 | 8 | # Install cpphs if it is not in path 9 | command -v cpphs || ${CABAL} v2-install --ignore-project --with-compiler "$HC" cpphs 10 | 11 | # Regenerate quickcheck-hugs 12 | sh make-hugs 13 | find quickcheck-hugs 14 | 15 | die() { 16 | echo "TEST FAILED" 17 | exit 1 18 | } 19 | 20 | dotest() { 21 | echo "$2" | hugs -98 -Pquickcheck-hugs: -p'> ' "$1" | tee hugs.output 22 | grep "$3" hugs.output || die 23 | } 24 | 25 | # Simple tests 26 | dotest Test.QuickCheck 'quickCheck $ \xs -> reverse (reverse xs) === (xs :: [Int])' "OK, passed 100 tests." 27 | -------------------------------------------------------------------------------- /tests/GCoArbitraryExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TemplateHaskell #-} 2 | 3 | module Main where 4 | 5 | import GHC.Generics (Generic) 6 | import Test.QuickCheck 7 | import Test.QuickCheck.Function 8 | 9 | data D a = C1 a | C2 deriving (Eq, Show, Read, Generic) 10 | 11 | 12 | instance Arbitrary a => Arbitrary (D a) where arbitrary = error "not implemented" 13 | instance CoArbitrary a => CoArbitrary (D a) 14 | 15 | instance (Show a, Read a) => Function (D a) where 16 | function = functionShow 17 | 18 | prop_coarbitrary (Fun _ f) = 19 | expectFailure $ 20 | withMaxSuccess 1000 $ 21 | f (C1 (2::Int)) `elem` [0, 1 :: Int] 22 | 23 | return [] 24 | main = do True <- $quickCheckAll; return () 25 | -------------------------------------------------------------------------------- /tests/GShrinkExample.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric, ScopedTypeVariables, TemplateHaskell #-} 2 | 3 | module Main where 4 | 5 | import GHC.Generics (Generic) 6 | import Test.QuickCheck 7 | 8 | data Nat = Z | S Nat deriving (Eq, Show, Generic) 9 | 10 | 11 | instance Arbitrary Nat where arbitrary = error "not implemented" 12 | 13 | prop_shrink = 14 | genericShrink (S (S Z)) === [S Z] .&&. 15 | genericShrink [0::Int] === [[]] 16 | 17 | return [] 18 | 19 | main :: IO () 20 | main = do True <- $quickCheckAll; return () 21 | -------------------------------------------------------------------------------- /tests/Generators.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, Rank2Types, NoMonomorphismRestriction #-} 2 | import Test.QuickCheck 3 | import Test.QuickCheck.Gen.Unsafe 4 | import Data.List (inits, sort, nub) 5 | import Data.Int 6 | import Data.Word 7 | import Data.Version 8 | import System.Exit 9 | import Data.Complex 10 | import Text.ParserCombinators.ReadP (readP_to_S) 11 | 12 | newtype Path a = Path [a] deriving (Show, Functor) 13 | 14 | instance Arbitrary a => Arbitrary (Path a) where 15 | arbitrary = do 16 | x <- arbitrary 17 | fmap Path (pathFrom 100 x) 18 | where 19 | pathFrom n x = 20 | fmap (x:) $ 21 | case shrink x of 22 | [] -> return [] 23 | _ | n == 0 -> return [] 24 | ys -> oneof [pathFrom (n-1) y | y <- ys] 25 | 26 | shrink (Path xs) = map Path [ ys | ys <- inits xs, length ys > 0 && length ys < length xs ] 27 | 28 | path :: (a -> Bool) -> Path a -> Bool 29 | path p (Path xs) = all p xs 30 | 31 | somePath :: (a -> Bool) -> Path a -> Property 32 | somePath p = expectFailure . withMaxSuccess 1000 . path (not . p) 33 | 34 | newtype Extremal a = Extremal { getExtremal :: a } deriving (Show, Eq, Ord, Num, Enum, Real, Integral) 35 | 36 | instance (Arbitrary a, Bounded a) => Arbitrary (Extremal a) where 37 | arbitrary = 38 | fmap Extremal $ 39 | frequency 40 | [(1, return minBound), 41 | (1, return maxBound), 42 | (8, arbitrary)] 43 | shrink (Extremal x) = map Extremal (shrink x) 44 | 45 | smallProp :: Integral a => Path a -> Bool 46 | smallProp = path (\x -> (x >= -100 || -100 `asTypeOf` x >= 0) && x <= 100) 47 | 48 | largeProp :: Integral a => Path a -> Property 49 | largeProp = somePath (\x -> x < -1000000 || x > 1000000) 50 | 51 | prop_int :: Path Int -> Bool 52 | prop_int = smallProp 53 | 54 | prop_int32 :: Path Int32 -> Property 55 | prop_int32 = largeProp 56 | 57 | prop_word :: Path Word -> Property 58 | prop_word = largeProp 59 | 60 | prop_word32 :: Path Word32 -> Property 61 | prop_word32 = largeProp 62 | 63 | prop_integer :: Path Integer -> Bool 64 | prop_integer = smallProp 65 | 66 | prop_small :: Path (Small Int) -> Bool 67 | prop_small = smallProp 68 | 69 | prop_large :: Path (Large Int) -> Property 70 | prop_large = largeProp 71 | 72 | prop_smallWord :: Path (Small Word) -> Bool 73 | prop_smallWord = smallProp 74 | 75 | prop_largeWord :: Path (Large Word) -> Property 76 | prop_largeWord = largeProp 77 | 78 | data Choice a b = Choice a b deriving Show 79 | instance (Arbitrary a, Arbitrary b) => Arbitrary (Choice a b) where 80 | arbitrary = do 81 | Capture eval <- capture 82 | return (Choice (eval arbitrary) (eval arbitrary)) 83 | 84 | idemProp :: (Eq a, Arbitrary a, Arbitrary b) => (b -> a) -> Choice a b -> Bool 85 | idemProp f (Choice x y) = x == f y 86 | 87 | prop_fixed_length :: Arbitrary a => Path (Fixed a) -> Bool 88 | prop_fixed_length (Path xs) = length xs == 1 89 | 90 | prop_fixed_idem = idemProp getFixed 91 | prop_blind_idem = idemProp getBlind 92 | 93 | prop_ordered_list = path (\(Ordered xs) -> sort xs == xs) 94 | prop_nonempty_list = path (\(NonEmpty xs) -> not (null xs)) 95 | 96 | pathInt, somePathInt :: 97 | (Arbitrary (f (Extremal Int)), Show (f (Extremal Int)), 98 | Arbitrary (f Integer), Show (f Integer), 99 | Arbitrary (f (Extremal Int8)), Show (f (Extremal Int8)), 100 | Arbitrary (f (Extremal Int16)), Show (f (Extremal Int16)), 101 | Arbitrary (f (Extremal Int32)), Show (f (Extremal Int32)), 102 | Arbitrary (f (Extremal Int64)), Show (f (Extremal Int64)), 103 | Arbitrary (f (Extremal Word)), Show (f (Extremal Word)), 104 | Arbitrary (f (Extremal Word8)), Show (f (Extremal Word8)), 105 | Arbitrary (f (Extremal Word16)), Show (f (Extremal Word16)), 106 | Arbitrary (f (Extremal Word32)), Show (f (Extremal Word32)), 107 | Arbitrary (f (Extremal Word64)), Show (f (Extremal Word64))) => 108 | Bool -> (forall a. f a -> a) -> (forall a. Integral a => a -> Bool) -> Property 109 | pathInt word f p = 110 | conjoin 111 | [counterexample "Int" (path ((p :: Int -> Bool) . getExtremal . f)), 112 | counterexample "Integer" (path ((p :: Integer -> Bool) . f)), 113 | counterexample "Int8" (path ((p :: Int8 -> Bool) . getExtremal . f)), 114 | counterexample "Int16" (path ((p :: Int16 -> Bool) . getExtremal . f)), 115 | counterexample "Int32" (path ((p :: Int32 -> Bool) . getExtremal . f)), 116 | counterexample "Int64" (path ((p :: Int64 -> Bool) . getExtremal . f)), 117 | counterexample "Word" (not word .||. path ((p :: Word -> Bool) . getExtremal . f)), 118 | counterexample "Word8" (not word .||. path ((p :: Word8 -> Bool) . getExtremal . f)), 119 | counterexample "Word16" (not word .||. path ((p :: Word16 -> Bool) . getExtremal . f)), 120 | counterexample "Word32" (not word .||. path ((p :: Word32 -> Bool) . getExtremal . f)), 121 | counterexample "Word64" (not word .||. path ((p :: Word64 -> Bool) . getExtremal . f))] 122 | somePathInt word f p = expectFailure (pathInt word f (not . p)) 123 | 124 | prop_positive = pathInt True getPositive (> 0) 125 | prop_positive_bound = somePathInt True getPositive (== 1) 126 | 127 | prop_nonzero = pathInt True getNonZero (/= 0) 128 | prop_nonzero_bound_1 = somePathInt True getNonZero (== 1) 129 | prop_nonzero_bound_2 = somePathInt True getNonZero (== -1) 130 | 131 | prop_nonnegative = pathInt True getNonNegative (>= 0) 132 | prop_nonnegative_bound = somePathInt True getNonNegative (== 0) 133 | 134 | prop_negative = pathInt False getNegative (< 0) 135 | prop_negative_bound = somePathInt False getNegative (== -1) 136 | 137 | prop_nonpositive = pathInt True getNonPositive (<= 0) 138 | prop_nonpositive_bound = somePathInt True getNonPositive (== 0) 139 | 140 | reachesBound :: (Bounded a, Integral a, Arbitrary a) => 141 | a -> Property 142 | reachesBound x = withMaxSuccess 1000 (expectFailure (x < 3 * (maxBound `div` 4))) 143 | 144 | prop_reachesBound_Int8 = reachesBound :: Int8 -> Property 145 | prop_reachesBound_Int16 = reachesBound :: Int16 -> Property 146 | prop_reachesBound_Int32 = reachesBound :: Int32 -> Property 147 | prop_reachesBound_Int64 = reachesBound :: Int64 -> Property 148 | prop_reachesBound_Word8 = reachesBound :: Word8 -> Property 149 | prop_reachesBound_Word16 = reachesBound :: Word16 -> Property 150 | prop_reachesBound_Word32 = reachesBound :: Word32 -> Property 151 | prop_reachesBound_Word64 = reachesBound :: Word64 -> Property 152 | 153 | -- Shrinking should not loop. 154 | noShrinkingLoop :: (Eq a, Arbitrary a) => Path a -> Bool 155 | noShrinkingLoop (Path (x:xs)) = x `notElem` xs 156 | 157 | prop_no_shrinking_loop_Unit = noShrinkingLoop :: Path () -> Bool 158 | prop_no_shrinking_loop_Bool = noShrinkingLoop :: Path Bool -> Bool 159 | prop_no_shrinking_loop_Ordering = noShrinkingLoop :: Path Ordering -> Bool 160 | prop_no_shrinking_loop_Maybe = noShrinkingLoop :: Path (Maybe Int) -> Bool 161 | prop_no_shrinking_loop_Either = noShrinkingLoop :: Path (Either Int Int) -> Bool 162 | prop_no_shrinking_loop_List = noShrinkingLoop :: Path [Int] -> Bool 163 | prop_no_shrinking_loop_Ratio = noShrinkingLoop :: Path Rational -> Bool 164 | prop_no_shrinking_loop_Complex = noShrinkingLoop :: Path (Complex Double) -> Bool 165 | prop_no_shrinking_loop_Fixed = noShrinkingLoop :: Path (Fixed Int) -> Bool 166 | prop_no_shrinking_loop_Pair = noShrinkingLoop :: Path (Int, Int) -> Bool 167 | prop_no_shrinking_loop_Triple = noShrinkingLoop :: Path (Int, Int, Int) -> Bool 168 | prop_no_shrinking_loop_Integer = noShrinkingLoop :: Path Integer -> Bool 169 | prop_no_shrinking_loop_Int = noShrinkingLoop :: Path Int -> Bool 170 | prop_no_shrinking_loop_Int8 = noShrinkingLoop :: Path Int8 -> Bool 171 | prop_no_shrinking_loop_Int16 = noShrinkingLoop :: Path Int16 -> Bool 172 | prop_no_shrinking_loop_Int32 = noShrinkingLoop :: Path Int32 -> Bool 173 | prop_no_shrinking_loop_Int64 = noShrinkingLoop :: Path Int64 -> Bool 174 | prop_no_shrinking_loop_Word = noShrinkingLoop :: Path Word -> Bool 175 | prop_no_shrinking_loop_Word8 = noShrinkingLoop :: Path Word8 -> Bool 176 | prop_no_shrinking_loop_Word16 = noShrinkingLoop :: Path Word16 -> Bool 177 | prop_no_shrinking_loop_Word32 = noShrinkingLoop :: Path Word32 -> Bool 178 | prop_no_shrinking_loop_Word64 = noShrinkingLoop :: Path Word64 -> Bool 179 | prop_no_shrinking_loop_Char = noShrinkingLoop :: Path Char -> Bool 180 | prop_no_shrinking_loop_Float = noShrinkingLoop :: Path Float -> Bool 181 | prop_no_shrinking_loop_Double = noShrinkingLoop :: Path Double -> Bool 182 | prop_no_shrinking_loop_Version = noShrinkingLoop :: Path Version -> Bool 183 | prop_no_shrinking_loop_ExitCode = noShrinkingLoop :: Path ExitCode -> Bool 184 | 185 | -- Check that shrinking a Double always produces a shrinking candidate. 186 | prop_shrink_candidate_double :: Property 187 | prop_shrink_candidate_double = 188 | forAllShrink gen shrink $ \x -> 189 | x > 0 ==> 190 | not (null (shrink x)) 191 | where 192 | gen :: Gen Double 193 | gen = oneof [arbitrary, fmap fromInteger arbitrary] 194 | 195 | -- Bad shrink: infinite list 196 | -- 197 | -- remove unexpectedFailure in prop_B1, shrinking should not loop forever. 198 | data B1 = B1 Int deriving (Eq, Show) 199 | 200 | instance Arbitrary B1 where 201 | arbitrary = fmap B1 arbitrary 202 | shrink x = x : shrink x 203 | 204 | prop_B1 :: B1 -> Property 205 | prop_B1 (B1 n) = expectFailure $ n === n + 1 206 | 207 | -- Double properties: 208 | 209 | -- We occasionaly generate duplicates. 210 | prop_double_duplicate_list :: [Double] -> Property 211 | prop_double_duplicate_list xs = expectFailure $ nub xs === xs where 212 | sorted = sort xs 213 | 214 | -- And enough numbers to show basic IEEE pit falls. 215 | prop_double_assoc :: Double -> Double -> Double -> Property 216 | prop_double_assoc x y z = expectFailure $ x + (y + z) === (x + y) + z 217 | 218 | 219 | return [] 220 | main = do True <- $forAllProperties (quickCheckWithResult stdArgs { maxShrinks = 10000 }); return () 221 | -------------------------------------------------------------------------------- /tests/Misc.hs: -------------------------------------------------------------------------------- 1 | -- Miscellaneous tests. 2 | 3 | {-# LANGUAGE TemplateHaskell #-} 4 | import Test.QuickCheck 5 | import Test.QuickCheck.Random 6 | 7 | prop_verbose :: Blind (Int -> Int -> Bool) -> Property 8 | prop_verbose (Blind p) = 9 | forAll (mkQCGen <$> arbitrary) $ \g -> 10 | ioProperty $ do 11 | res1 <- quickCheckWithResult stdArgs{replay = Just (g, 100), chatty = False} p 12 | res2 <- quickCheckWithResult stdArgs{replay = Just (g, 100), chatty = False} (verbose p) 13 | return $ 14 | numTests res1 === numTests res2 .&&. 15 | failingTestCase res1 === failingTestCase res2 16 | 17 | prop_failingTestCase :: Blind (Int -> Int -> Int -> Bool) -> Property 18 | prop_failingTestCase (Blind p) = ioProperty $ do 19 | res <- quickCheckWithResult stdArgs{chatty = False} p 20 | let [x, y, z] = failingTestCase res 21 | return (not (p (read x) (read y) (read z))) 22 | 23 | return [] 24 | main = do 25 | True <- $quickCheckAll 26 | return () 27 | -------------------------------------------------------------------------------- /tests/MonadFix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, RecursiveDo #-} 2 | import Test.QuickCheck 3 | import Control.Monad.Fix 4 | 5 | -- A simple (not complete) test for the MonadFix instance. 6 | cyclicList :: Gen [Int] 7 | cyclicList = do 8 | rec xs <- fmap (:ys) arbitrary 9 | ys <- fmap (:xs) arbitrary 10 | return xs 11 | 12 | prop_cyclic :: Property 13 | prop_cyclic = 14 | forAll (Blind <$> cyclicList) $ \(Blind xs) -> 15 | -- repeats with period 2 16 | and $ take 100 $ zipWith (==) xs (drop 2 xs) 17 | 18 | prop_period2 :: Property 19 | prop_period2 = 20 | expectFailure $ 21 | forAll (Blind <$> cyclicList) $ \(Blind xs) -> 22 | -- does not always repeat with period 1 23 | and $ take 100 $ zipWith (==) xs (drop 1 xs) 24 | 25 | return [] 26 | main = do True <- $quickCheckAll; return () 27 | -------------------------------------------------------------------------------- /tests/ShrinkMap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} 2 | import Test.QuickCheck 3 | import Data.List 4 | 5 | shrinkOrderedList :: (Ord a, Arbitrary a) => [a] -> [[a]] 6 | shrinkOrderedList = shrinkMap sort id 7 | 8 | prop_shrinkOrderedList :: [Int] -> Bool 9 | prop_shrinkOrderedList xs = all isSorted (shrinkOrderedList xs) 10 | where isSorted x = x == sort x 11 | 12 | return [] 13 | 14 | main = do True <- $quickCheckAll; return () 15 | -------------------------------------------------------------------------------- /tests/Split.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | import Test.QuickCheck.Random 3 | import Data.List (group, isPrefixOf, sort) 4 | 5 | -- This type allows us to run integerVariant and get a list of bits out. 6 | newtype Splits = Splits { unSplits :: [Bool] } deriving (Eq, Ord, Show) 7 | 8 | instance Splittable Splits where 9 | left (Splits xs) = Splits (xs ++ [False]) 10 | right (Splits xs) = Splits (xs ++ [True]) 11 | 12 | -- Check that integerVariant gives a prefix-free code, 13 | -- i.e., if m /= n then integerVariant m is not a prefix of integerVariant n. 14 | prop_split_prefix :: Property 15 | prop_split_prefix = 16 | once $ forAllShrink (return [-10000..10000]) shrink $ \ns -> 17 | map head (group (sort ns)) == sort ns ==> -- no duplicates 18 | let 19 | codes :: [Splits] 20 | codes = sort [integerVariant n (Splits []) | n <- ns] 21 | 22 | ok (Splits xs) (Splits ys) = not (xs `isPrefixOf` ys) 23 | in 24 | -- After sorting, any prefix will end up immediately before 25 | -- one of its suffixes 26 | and (zipWith ok codes (drop 1 codes)) 27 | 28 | main = do Success{} <- quickCheckResult prop_split_prefix; return () 29 | -------------------------------------------------------------------------------- /tests/Terminal.hs: -------------------------------------------------------------------------------- 1 | -- Check that the terminal output works correctly. 2 | {-# LANGUAGE TemplateHaskell, DeriveGeneric #-} 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Text 5 | import System.Process 6 | import System.IO 7 | import Control.Exception 8 | import GHC.Generics 9 | import Control.DeepSeq 10 | 11 | data Command = 12 | PutPart String 13 | | PutLine String 14 | | PutTemp String 15 | deriving (Eq, Ord, Show, Generic) 16 | 17 | instance Arbitrary Command where 18 | arbitrary = 19 | oneof [ 20 | PutPart <$> line, 21 | PutLine <$> line, 22 | PutTemp <$> line] 23 | where 24 | line = filter (/= '\n') <$> arbitrary 25 | shrink = genericShrink 26 | 27 | exec :: Terminal -> Command -> IO () 28 | exec tm (PutPart xs) = putPart tm xs 29 | exec tm (PutLine xs) = putLine tm xs 30 | exec tm (PutTemp xs) = putTemp tm xs 31 | 32 | eval :: [Command] -> String 33 | eval = concatMap eval1 34 | where 35 | eval1 (PutPart xs) = xs 36 | eval1 (PutLine xs) = xs ++ "\n" 37 | -- PutTemp only has an effect on stderr 38 | eval1 (PutTemp xs) = "" 39 | 40 | -- Evaluate the result of printing a given string, taking backspace 41 | -- characters into account. 42 | format :: String -> String 43 | format xs = format1 [] [] xs 44 | where 45 | -- Arguments: text before the cursor (in reverse order), 46 | -- text after the cursor, text to print 47 | format1 xs ys [] = line xs ys 48 | -- \n emits a new line 49 | format1 xs ys ('\n':zs) = line xs ys ++ "\n" ++ format1 [] [] zs 50 | -- \b moves the cursor to the left 51 | format1 (x:xs) ys ('\b':zs) = format1 xs (x:xs) zs 52 | -- beginning of line: \b ignored 53 | format1 [] ys ('\b':zs) = format1 [] ys zs 54 | -- Normal printing puts the character before the cursor, 55 | -- and overwrites the next character after the cursor 56 | format1 xs ys (z:zs) = format1 (z:xs) (drop 1 ys) zs 57 | 58 | line xs ys = reverse xs ++ ys 59 | 60 | -- Check that the terminal satisfies the following properties: 61 | -- * The text written to stdout matches what's returned by terminalOutput 62 | -- * The output agrees with the model implementation 'eval' 63 | -- * Anything written to stderr (presumably by putTemp) is erased 64 | prop_terminal :: [Command] -> Property 65 | prop_terminal cmds = 66 | withMaxSuccess 1000 $ ioProperty $ 67 | withPipe $ \stdout_read stdout_write -> 68 | withPipe $ \stderr_read stderr_write -> do 69 | out <- withHandleTerminal stdout_write (Just stderr_write) $ \tm -> do 70 | mapM_ (exec tm) (cmds ++ [PutPart ""]) 71 | terminalOutput tm 72 | stdout <- stdout_read 73 | stderr <- stderr_read 74 | return $ conjoin [ 75 | counterexample "output == terminalOutput" $ stdout === out, 76 | counterexample "output == model" $ out === eval cmds, 77 | counterexample "putTemp erased" $ all (== ' ') (format stderr) ] 78 | where 79 | withPipe :: (IO String -> Handle -> IO a) -> IO a 80 | withPipe action = do 81 | (readh, writeh) <- createPipe 82 | hSetEncoding readh utf8 83 | hSetEncoding writeh utf8 84 | let 85 | read = do 86 | hClose writeh 87 | contents <- hGetContents readh 88 | return $!! contents 89 | action read writeh `finally` do 90 | hClose readh 91 | hClose writeh 92 | 93 | return [] 94 | main = do True <- $quickCheckAll; return () 95 | -------------------------------------------------------------------------------- /tests/TestRandom.hs: -------------------------------------------------------------------------------- 1 | -- Checking the quality of the random number generator, 2 | -- in particular that splitting works OK. 3 | -- Disabled by default as it's expensive and not testing QuickCheck as such. 4 | {-# LANGUAGE BangPatterns #-} 5 | import System.Random 6 | import Test.QuickCheck.Random 7 | import Control.Monad 8 | import Data.List 9 | import Data.Maybe 10 | 11 | -- A path is a sequence of splits - false represents the left path, 12 | -- true represents the right path. 13 | type Path = [Bool] 14 | 15 | splits :: RandomGen a => Path -> a -> a 16 | splits [] g = g 17 | splits (False:xs) g = splits xs (fst (split g)) 18 | splits (True:xs) g = splits xs (snd (split g)) 19 | 20 | -- The properties we want to *falsify* are: 21 | -- * two paths always generate the same result 22 | -- * two paths always generate a different result 23 | data Prop = Equal Path Path | Different Path Path 24 | deriving Show 25 | 26 | paths :: Int -> [Path] 27 | paths n = concat [sequence (replicate m [False, True]) | m <- [0..n]] 28 | 29 | props :: Bool -> Int -> [Prop] 30 | props bounded n 31 | | bounded = map (uncurry Equal) pairs ++ map (uncurry Different) pairs 32 | | otherwise = map (uncurry Equal) pairs 33 | where 34 | ps = paths n 35 | pairs = [(p, q) | p <- ps, q <- ps, p < q] 36 | 37 | supply :: RandomGen a => a -> [a] 38 | supply = unfoldr (Just . split) 39 | 40 | -- Generate the properties to check. 41 | -- Parameters: 42 | -- d = maximum depth of split, 43 | -- k1 = range of number for first value 44 | -- k2 = range of number for second value 45 | check :: RandomGen a => Int -> Maybe (Int, Int) -> [a] -> [Prop] 46 | check d mk gs = 47 | foldr filt (props (isJust mk) d) gs 48 | where 49 | filt g props = filter (eval g) props 50 | sample1 g = 51 | case mk of 52 | Just (k1, _) -> fst (randomR (0, k1) g) 53 | Nothing -> fst (next g) 54 | sample2 g = 55 | case mk of 56 | Just (_, k2) -> fst (randomR (0, k2) g) 57 | Nothing -> fst (next g) 58 | eval g (Equal xs ys) = 59 | sample1 (splits xs g) == sample2 (splits ys g) 60 | eval g (Different xs ys) = 61 | sample1 (splits xs g) /= sample2 (splits ys g) 62 | 63 | -- First parameter: depth of splits to try 64 | -- Second parameter: range of random numbers to generate 65 | checkUpTo :: RandomGen a => Int -> Int -> [a] -> [(Int, Maybe (Int, Int), Prop)] 66 | checkUpTo d k gs = 67 | [(d', Nothing, prop)|d' <- [0..d], prop <- check d' Nothing gs] ++ 68 | [(d', Just (k1', k2'), prop)| d' <- [0..d], k1' <- [1..k], k2' <- [1..k], prop <- check d' (Just (k1', k2')) gs] 69 | 70 | main = do 71 | let gs = map mkQCGen [0..10000] 72 | let ![] = checkUpTo 6 20 gs 73 | return () 74 | -------------------------------------------------------------------------------- /tests/Weird.hs: -------------------------------------------------------------------------------- 1 | -- Lots of weird examples to test strange corner cases of QuickCheck, 2 | -- especially exception handling and ctrl-C handling. 3 | 4 | {-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} 5 | module Main where 6 | 7 | import Test.QuickCheck 8 | import Test.QuickCheck.Property 9 | import Test.QuickCheck.Function 10 | import Test.QuickCheck.All 11 | 12 | prop = callback (PostTest Counterexample (\_ _ -> putStrLn "\n\n\napa\n\n\n")) f 13 | where f :: Int -> Bool 14 | f _ = undefined 15 | 16 | prop2 (Fun _ f :: Fun Int Int) (Fun _ g :: Fun Int Int) x = f (g x) == g (f x) 17 | 18 | fibs = 0:1:zipWith (+) fibs (tail fibs) 19 | 20 | prop3 n = n >= 0 && n <= 100000 ==> 1000000 `within` (fibs!!(n+50000) + fibs!!(n+50001) == fibs!!(n+50002)) 21 | prop4, prop5, prop6 :: Int -> Property 22 | prop4 _ = within 1000000 (loop :: Property) 23 | prop5 _ = within 1000000 (loop :: Test.QuickCheck.Property.Result) 24 | prop6 _ = within 1000000 (loop :: Bool) 25 | 26 | revrev (xs :: [Int]) = within 1000 (reverse (reverse xs) == xs) 27 | 28 | undef (n :: Int) = undefined :: Bool 29 | undef2 (n :: Int) = undefined :: Property 30 | undef25 (n :: Int) = MkProperty (return undefined) :: Property 31 | undef21 (n :: Int) = MkProperty (return (MkProp (MkRose undefined []))) :: Property -- note: this example is bad because we construct a rose tree without protecting the result 32 | undef22 (n :: Int) = undefined :: Test.QuickCheck.Property.Result 33 | undef3 (n :: Int) = undefined :: Property 34 | undef4 (n :: Int) = collect "" (undefined :: Property) 35 | undef5 (n :: Int) = collect (undefined :: String) (undefined :: Property) 36 | 37 | data A = A deriving (Eq, Ord, Show) 38 | instance Arbitrary A where 39 | arbitrary = return A 40 | shrink = undefined 41 | 42 | test :: Int -> A -> Bool 43 | test _ _ = False 44 | 45 | loop = loop 46 | 47 | prop_loop (n :: Int) (m :: Int) = prop_loop n m :: Bool 48 | 49 | data B = B deriving (Eq, Ord, Show) 50 | instance Arbitrary B where 51 | arbitrary = return loop 52 | shrink = loop 53 | 54 | prop_loop2 (x :: B) = prop_loop2 x :: Bool 55 | 56 | prop_forevershrink = 57 | forAllShrink arbitrary shrink $ \n -> if n == (0 :: Int) then prop_forevershrink else error "fail" 58 | 59 | untestable n = (odd n ==> True) .&&. (even n ==> True) 60 | nearlyUntestable n = (odd n ==> True) .&&. (even n || n `mod` 6 == 1 ==> True) 61 | 62 | data C = C1 | C2 | C3 deriving (Eq, Ord, Show) 63 | instance Arbitrary C where 64 | arbitrary = return C1 65 | shrink C1 = [C2] 66 | shrink _ = [C3] 67 | 68 | -- Also check that quickCheckAll accepts primes in property names 69 | prop_forevershrink2' C1 = False 70 | prop_forevershrink2' C2 = False 71 | prop_forevershrink2' C3 = prop_forevershrink2' C3 72 | 73 | -- Test automatic monomorphism 74 | prop_poly :: [a] -> Bool 75 | prop_poly a = length a >= 0 76 | 77 | -- See if monomorphic accepts constructor names 78 | dummyRun = quickCheck $(monomorphic 'True) 79 | monoNil = $(monomorphic '[]) 80 | monoCons = $(monomorphic '(:)) 81 | 82 | return [] 83 | main = do True <- $quickCheckAll; return () -- UTF8 test: Привет! 84 | --------------------------------------------------------------------------------