├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── CHANGELOG.md ├── COPYING ├── Makefile ├── README.md ├── Setup.lhs ├── checkers.cabal ├── src ├── Control │ └── Monad │ │ └── Extensions.hs └── Test │ └── QuickCheck │ ├── Bottoms.hs │ ├── Checkers.hs │ ├── Classes.hs │ ├── Instances.hs │ ├── Instances │ ├── Array.hs │ ├── Char.hs │ ├── Eq.hs │ ├── List.hs │ ├── Maybe.hs │ ├── Num.hs │ ├── Ord.hs │ └── Tuple.hs │ ├── Later.hs │ └── Utils.hs ├── stack.yaml └── todo.txt /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci '--branches' 'master' 'github' 'checkers.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.15.20230312 12 | # 13 | # REGENDATA ("0.15.20230312",["--branches","master","github","checkers.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-20.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:bionic 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.6.1 36 | compilerKind: ghc 37 | compilerVersion: 9.6.1 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.4.1 41 | compilerKind: ghc 42 | compilerVersion: 9.4.1 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.2.4 46 | compilerKind: ghc 47 | compilerVersion: 9.2.4 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.0.2 51 | compilerKind: ghc 52 | compilerVersion: 9.0.2 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-8.10.7 56 | compilerKind: ghc 57 | compilerVersion: 8.10.7 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-8.8.4 61 | compilerKind: ghc 62 | compilerVersion: 8.8.4 63 | setup-method: hvr-ppa 64 | allow-failure: false 65 | - compiler: ghc-8.6.5 66 | compilerKind: ghc 67 | compilerVersion: 8.6.5 68 | setup-method: hvr-ppa 69 | allow-failure: false 70 | - compiler: ghc-8.4.4 71 | compilerKind: ghc 72 | compilerVersion: 8.4.4 73 | setup-method: hvr-ppa 74 | allow-failure: false 75 | - compiler: ghc-8.2.2 76 | compilerKind: ghc 77 | compilerVersion: 8.2.2 78 | setup-method: hvr-ppa 79 | allow-failure: false 80 | fail-fast: false 81 | steps: 82 | - name: apt 83 | run: | 84 | apt-get update 85 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 86 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 87 | mkdir -p "$HOME/.ghcup/bin" 88 | curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" 89 | chmod a+x "$HOME/.ghcup/bin/ghcup" 90 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 91 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 92 | else 93 | apt-add-repository -y 'ppa:hvr/ghc' 94 | apt-get update 95 | apt-get install -y "$HCNAME" 96 | mkdir -p "$HOME/.ghcup/bin" 97 | curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" 98 | chmod a+x "$HOME/.ghcup/bin/ghcup" 99 | "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 100 | fi 101 | env: 102 | HCKIND: ${{ matrix.compilerKind }} 103 | HCNAME: ${{ matrix.compiler }} 104 | HCVER: ${{ matrix.compilerVersion }} 105 | - name: Set PATH and environment variables 106 | run: | 107 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 108 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 109 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 110 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 111 | HCDIR=/opt/$HCKIND/$HCVER 112 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 113 | HC=$HOME/.ghcup/bin/$HCKIND-$HCVER 114 | echo "HC=$HC" >> "$GITHUB_ENV" 115 | echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" 116 | echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" 117 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 118 | else 119 | HC=$HCDIR/bin/$HCKIND 120 | echo "HC=$HC" >> "$GITHUB_ENV" 121 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 122 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 123 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 124 | fi 125 | 126 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 127 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 128 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 129 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 130 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 131 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 132 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 133 | env: 134 | HCKIND: ${{ matrix.compilerKind }} 135 | HCNAME: ${{ matrix.compiler }} 136 | HCVER: ${{ matrix.compilerVersion }} 137 | - name: env 138 | run: | 139 | env 140 | - name: write cabal config 141 | run: | 142 | mkdir -p $CABAL_DIR 143 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 176 | echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - 177 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 178 | rm -f cabal-plan.xz 179 | chmod a+x $HOME/.cabal/bin/cabal-plan 180 | cabal-plan --version 181 | - name: checkout 182 | uses: actions/checkout@v3 183 | with: 184 | path: source 185 | - name: initial cabal.project for sdist 186 | run: | 187 | touch cabal.project 188 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 189 | cat cabal.project 190 | - name: sdist 191 | run: | 192 | mkdir -p sdist 193 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 194 | - name: unpack 195 | run: | 196 | mkdir -p unpacked 197 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 198 | - name: generate cabal.project 199 | run: | 200 | PKGDIR_checkers="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/checkers-[0-9.]*')" 201 | echo "PKGDIR_checkers=${PKGDIR_checkers}" >> "$GITHUB_ENV" 202 | rm -f cabal.project cabal.project.local 203 | touch cabal.project 204 | touch cabal.project.local 205 | echo "packages: ${PKGDIR_checkers}" >> cabal.project 206 | echo "package checkers" >> cabal.project 207 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 208 | cat >> cabal.project <> cabal.project.local 211 | cat cabal.project 212 | cat cabal.project.local 213 | - name: dump install plan 214 | run: | 215 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 216 | cabal-plan 217 | - name: restore cache 218 | uses: actions/cache/restore@v3 219 | with: 220 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 221 | path: ~/.cabal/store 222 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 223 | - name: install dependencies 224 | run: | 225 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 226 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 227 | - name: build w/o tests 228 | run: | 229 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 230 | - name: build 231 | run: | 232 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 233 | - name: cabal check 234 | run: | 235 | cd ${PKGDIR_checkers} || false 236 | ${CABAL} -vnormal check 237 | - name: haddock 238 | run: | 239 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 240 | - name: unconstrained build 241 | run: | 242 | rm -f cabal.project.local 243 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 244 | - name: save cache 245 | uses: actions/cache/save@v3 246 | if: always() 247 | with: 248 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 249 | path: ~/.cabal/store 250 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | Junk* 3 | Old* 4 | dist 5 | Stuff 6 | TAGS 7 | tags 8 | tarballs 9 | 10 | # Cabal stuff 11 | /.cabal-sandbox 12 | /cabal.sandbox.config 13 | /dist-newstyle 14 | 15 | # Mac OS generates 16 | .DS_Store 17 | 18 | # Where do these files come from? They're not readable. 19 | # For instance, .#Help.page 20 | .#* 21 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## [0.6.0] 2 | 3 | * [Enhance `traversable` checks](https://github.com/haskell-checkers/checkers/pull/61) 4 | 5 | * [Remove redundant constraint from instance CoArbitrary Array](https://github.com/haskell-checkers/checkers/pull/65) 6 | 7 | [0.6.0]: https://github.com/haskell-checkers/checkers/compare/v0.5.7...v0.6.0 8 | 9 | ## [0.5.7] 10 | 11 | * [Add `bifoldable` and `bifoldableBifunctor` tests](https://github.com/haskell-checkers/checkers/pull/62) 12 | 13 | * [Restore `verboseBatch` functionality](https://github.com/haskell-checkers/checkers/pull/59) 14 | 15 | * [Drop support for GHC < 8.2](https://github.com/haskell-checkers/checkers/pull/63) 16 | 17 | [0.5.7]: https://github.com/haskell-checkers/checkers/compare/v0.5.6...v0.5.7 18 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009 Conal Elliott 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The names of the authors may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 25 | 26 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # On code.haskell.org 2 | include ../cho-cabal-make.inc 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | **checkers** is a library for reusable QuickCheck properties, particularly for standard type classes (class laws and [class morphisms](http://conal.net/papers/type-class-morphisms)). 2 | Checkers also has lots of support for randomly generating data values (thanks to Thomas Davie). 3 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /checkers.cabal: -------------------------------------------------------------------------------- 1 | Name: checkers 2 | Version: 0.6.0 3 | Cabal-Version: >= 1.10 4 | Synopsis: Check properties on standard classes and data structures. 5 | Category: Testing 6 | Description: 7 | ''Checkers'' wraps up the expected properties associated with various 8 | standard type classes as QuickCheck properties. Also some morphism 9 | properties. It also provides arbitrary instances and generator combinators 10 | for common data types. 11 | . 12 | © 2008-2013 by Conal Elliott; BSD3 license. 13 | Author: Conal Elliott 14 | Maintainer: conal@conal.net 15 | Copyright: (c) 2008-2013 by Conal Elliott 16 | License: BSD3 17 | License-File: COPYING 18 | Stability: experimental 19 | build-type: Simple 20 | tested-with: GHC==9.6.1, GHC==9.4.1, GHC==9.2.4, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2 21 | homepage: https://github.com/haskell-checkers/checkers 22 | extra-source-files: README.md CHANGELOG.md 23 | 24 | source-repository head 25 | type: git 26 | location: git://github.com/haskell-checkers/checkers.git 27 | 28 | Library 29 | hs-Source-Dirs: src 30 | Extensions: 31 | Build-Depends: base >= 4.10 && < 5, random, QuickCheck>=2.3, array >= 0.1, semigroupoids >= 5 && < 6.1 32 | 33 | Exposed-Modules: 34 | Test.QuickCheck.Utils 35 | Test.QuickCheck.Checkers 36 | Test.QuickCheck.Classes 37 | Test.QuickCheck.Bottoms 38 | Test.QuickCheck.Instances 39 | Test.QuickCheck.Instances.Array 40 | Test.QuickCheck.Instances.Char 41 | Test.QuickCheck.Instances.Eq 42 | Test.QuickCheck.Instances.List 43 | Test.QuickCheck.Instances.Maybe 44 | Test.QuickCheck.Instances.Num 45 | Test.QuickCheck.Instances.Ord 46 | Test.QuickCheck.Instances.Tuple 47 | Test.QuickCheck.Later 48 | Other-modules: 49 | Control.Monad.Extensions 50 | ghc-options: -Wall -Wredundant-constraints 51 | Default-Language: Haskell2010 52 | -------------------------------------------------------------------------------- /src/Control/Monad/Extensions.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Extensions (satisfiesM,if') where 2 | 3 | import Control.Applicative (liftA3) 4 | 5 | satisfiesM :: Monad m => (a -> Bool) -> m a -> m a 6 | satisfiesM p x = x >>= if' p return (const (satisfiesM p x)) 7 | 8 | if' :: Applicative f => f Bool -> f a -> f a -> f a 9 | if' = liftA3 (\ c t e -> if c then t else e) 10 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Bottoms.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.Bottoms (bottom,infiniteComp) where 2 | 3 | import Test.QuickCheck 4 | 5 | import Control.Monad (forever) 6 | import System.IO.Unsafe 7 | import Control.Concurrent 8 | 9 | bottom :: Gen a 10 | bottom = return undefined 11 | 12 | infiniteComp :: Gen a 13 | infiniteComp = return hang 14 | 15 | -- Without using unsafePerformIO, is there a way to define a 16 | -- non-terminating but non-erroring pure value that consume very little 17 | -- resources while not terminating? 18 | 19 | -- | Never yield an answer. Like 'undefined' or 'error "whatever"', but 20 | -- don't raise an error, and don't consume computational resources. 21 | hang :: a 22 | hang = unsafePerformIO hangIO 23 | 24 | -- | Block forever 25 | hangIO :: IO a 26 | hangIO = do -- putStrLn "warning: blocking forever." 27 | -- Any never-terminating computation goes here 28 | -- This one can yield an exception "thread blocked indefinitely" 29 | -- newEmptyMVar >>= takeMVar 30 | -- sjanssen suggests this alternative: 31 | _ <- forever $ threadDelay maxBound 32 | -- forever's return type is (), though it could be fully 33 | -- polymorphic. Until it's fixed, I need the following line. 34 | return undefined 35 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Checkers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances 2 | , FlexibleContexts, TypeSynonymInstances, GeneralizedNewtypeDeriving 3 | , UndecidableInstances, ScopedTypeVariables, DefaultSignatures 4 | , TypeOperators, CPP 5 | #-} 6 | {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} 7 | 8 | ---------------------------------------------------------------------- 9 | -- | 10 | -- Module : Test.QuickCheck.Checkers 11 | -- Copyright : (c) Conal Elliott 2007,2008 12 | -- License : BSD3 13 | -- 14 | -- Maintainer : conal@conal.net 15 | -- Stability : experimental 16 | -- 17 | -- Some QuickCheck helpers 18 | ---------------------------------------------------------------------- 19 | 20 | module Test.QuickCheck.Checkers 21 | ( 22 | -- * Misc 23 | Test, TestBatch, unbatch, checkBatch, quickBatch, verboseBatch 24 | -- , probablisticPureCheck 25 | , Unop, Binop, genR, involution, inverseL, inverse 26 | , FracT, NumT, OrdT, T 27 | -- * Generalized equality 28 | , EqProp(..), eq 29 | , BinRel, reflexive, transitive, symmetric, antiSymmetric 30 | , leftId, rightId, bothId, isAssoc, isCommut, commutes 31 | , MonoidD, monoidD, endoMonoidD, homomorphism 32 | , idempotent, idempotent2, idemElem 33 | -- , funEq, AsFun(..) 34 | -- * Model-based (semantics-based) testing 35 | , Model(..) 36 | , meq, meq1, meq2, meq3, meq4, meq5 37 | , eqModels, denotationFor 38 | , Model1(..) 39 | -- * Some handy testing types 40 | -- , Positive, NonZero(..), NonNegative(..) 41 | -- , suchThat, suchThatMaybe 42 | , arbs, gens 43 | , (.&.) 44 | , arbitrarySatisfying 45 | ) where 46 | 47 | import Data.Function (on) 48 | import Control.Applicative 49 | import Control.Arrow ((***),first) 50 | import qualified Control.Exception as Ex 51 | import Data.List (foldl') 52 | import Data.List.NonEmpty (NonEmpty (..)) 53 | import Data.Monoid hiding (First, Last) 54 | 55 | import Data.Complex 56 | import Data.Proxy 57 | import Data.Ratio 58 | import Data.Functor.Identity 59 | 60 | #if __GLASGOW_HASKELL__ >= 800 61 | import Data.Functor.Compose 62 | import qualified Data.Functor.Product as F 63 | import qualified Data.Functor.Sum as F 64 | #endif 65 | import Data.Semigroup 66 | import GHC.Generics 67 | import System.Random 68 | import Test.QuickCheck hiding (generate) 69 | import Test.QuickCheck.Random (QCGen, newQCGen) 70 | -- import System.IO.Unsafe 71 | 72 | import Test.QuickCheck.Gen (Gen (..)) -- for rand 73 | -- import Test.QuickCheck.Property (Prop(..)) -- for evaluate 74 | 75 | import Test.QuickCheck.Utils 76 | 77 | -- import Test.QuickCheck.Utils 78 | -- import Test.QuickCheck.Instances.Num 79 | -- import Control.Monad.Extensions 80 | 81 | 82 | -- import qualified Data.Stream as S 83 | 84 | 85 | {---------------------------------------------------------- 86 | Misc 87 | ----------------------------------------------------------} 88 | 89 | -- | Named test 90 | type Test = (String,Property) 91 | 92 | -- | Named batch of tests 93 | type TestBatch = (String,[Test]) 94 | 95 | -- | Flatten a test batch for inclusion in another 96 | unbatch :: TestBatch -> [Test] 97 | unbatch (batchName,props) = map (first ((batchName ++ ": ")++)) props 98 | 99 | -- TODO: consider a tree structure so that flattening is unnecessary. 100 | 101 | type QuickCheckRunner = Args -> Property -> IO () 102 | 103 | -- | Run a batch of tests. See 'quickBatch' and 'verboseBatch'. 104 | checkBatch' :: QuickCheckRunner -> Args -> TestBatch -> IO () 105 | checkBatch' runner args (name,tests) = 106 | do putStrLn $ "\n" ++ name ++ ":" 107 | mapM_ pr tests 108 | where 109 | pr (s,p) = do putStr (padTo (width + 4) (" "++s ++ ":")) 110 | Ex.catch (runner args p) 111 | (print :: Ex.SomeException -> IO ()) 112 | width = foldl' max 0 (map (length.fst) tests) 113 | 114 | checkBatch :: Args -> TestBatch -> IO () 115 | checkBatch = checkBatch' quickCheckWith 116 | 117 | padTo :: Int -> String -> String 118 | padTo n = take n . (++ repeat ' ') 119 | 120 | -- | Check a batch tersely. 121 | quickBatch :: TestBatch -> IO () 122 | quickBatch = checkBatch quick' 123 | 124 | -- | Check a batch verbosely. 125 | verboseBatch :: TestBatch -> IO () 126 | verboseBatch = checkBatch' verboseCheckWith quick' 127 | 128 | quick' :: Args 129 | quick' = stdArgs { maxSuccess = 500 } 130 | 131 | {- 132 | 133 | -- TODO: change TestBatch to be hierarchical/recursive, rather than 134 | -- two-level. 135 | 136 | data Batch n t = Test t | Batch [LBatch n t] 137 | type LBatch n t = (n, Batch n t) 138 | 139 | -- | Run a batch of tests. See 'quickBatch' and 'verboseBatch'. 140 | checkL :: Config -> LBatch -> IO () 141 | checkL config = checkL' 0 142 | where 143 | checkL' :: Int -> LBatch -> IO () 144 | ... 145 | -} 146 | 147 | -- | Unary function, handy for type annotations 148 | type Unop a = a -> a 149 | 150 | -- | Binary function, handy for type annotations 151 | type Binop a = a -> a -> a 152 | 153 | -- Testing types 154 | 155 | -- | Token 'Fractional' type for tests 156 | type FracT = Float 157 | -- | Token 'Num' type for tests 158 | type NumT = Int 159 | -- | Token 'Ord' type for tests 160 | type OrdT = Int -- Char -- randomR is broken on Char 161 | -- | Token uninteresting type for tests 162 | type T = Char 163 | 164 | genR :: Random a => (a, a) -> Gen a 165 | genR (lo,hi) = fmap (fst . randomR (lo,hi)) rand 166 | 167 | -- | @f@ is its own inverse. See also 'inverse'. 168 | involution :: (Show a, Arbitrary a, EqProp a) => 169 | (a -> a) -> Property 170 | involution f = f `inverseL` f 171 | 172 | -- | @f@ is a left inverse of @g@. See also 'inverse'. 173 | inverseL :: (EqProp b, Arbitrary b, Show b) => 174 | (a -> b) -> (b -> a) -> Property 175 | f `inverseL` g = f . g =-= id 176 | 177 | -- | @f@ is a left and right inverse of @g@. See also 'inverseL'. 178 | inverse :: ( EqProp a, Arbitrary a, Show a 179 | , EqProp b, Arbitrary b, Show b ) => 180 | (a -> b) -> (b -> a) -> Property 181 | f `inverse` g = f `inverseL` g .&. g `inverseL` f 182 | 183 | 184 | {---------------------------------------------------------- 185 | Generalized equality 186 | ----------------------------------------------------------} 187 | 188 | infix 4 =-= 189 | 190 | -- | Types of values that can be tested for equality, perhaps through 191 | -- random sampling. 192 | class EqProp a where 193 | (=-=) :: a -> a -> Property 194 | default (=-=) :: (Generic a, GEqProp (Rep a)) => a -> a -> Property 195 | (=-=) = geq `on` from 196 | {-# INLINEABLE (=-=) #-} 197 | 198 | class GEqProp g where 199 | geq :: g x -> g x -> Property 200 | 201 | instance GEqProp g => GEqProp (M1 _1 _2 g) where 202 | geq = geq `on` unM1 203 | {-# INLINEABLE geq #-} 204 | 205 | instance (GEqProp g1, GEqProp g2) => GEqProp (g1 :*: g2) where 206 | geq (g1a :*: g1b) (g2a :*: g2b) = geq g1a g2a .&&. geq g1b g2b 207 | {-# INLINEABLE geq #-} 208 | 209 | instance (GEqProp g1, GEqProp g2) => GEqProp (g1 :+: g2) where 210 | geq (L1 g1) (L1 g2) = geq g1 g2 211 | geq (R1 g1) (R1 g2) = geq g1 g2 212 | geq _ _ = property False 213 | {-# INLINEABLE geq #-} 214 | 215 | instance EqProp a => GEqProp (K1 _1 a) where 216 | geq = (=-=) `on` unK1 217 | {-# INLINEABLE geq #-} 218 | 219 | instance GEqProp U1 where 220 | geq U1 U1 = property True 221 | {-# INLINEABLE geq #-} 222 | 223 | instance GEqProp V1 where 224 | geq _ _ = property True 225 | {-# INLINEABLE geq #-} 226 | 227 | -- | For 'Eq' types as 'EqProp' types 228 | eq :: Eq a => a -> a -> Property 229 | a `eq` a' = property (a == a') 230 | 231 | 232 | -- Template: fill in with Eq types for a 233 | -- instance EqProp a where (=-=) = eq 234 | -- E.g., 235 | 236 | instance EqProp () 237 | instance EqProp Bool 238 | instance EqProp Char where (=-=) = eq 239 | instance EqProp Ordering 240 | 241 | -- Numeric 242 | instance EqProp Int where (=-=) = eq 243 | instance EqProp Float where (=-=) = eq 244 | instance EqProp Double where (=-=) = eq 245 | instance EqProp Integer where (=-=) = eq 246 | instance Eq a => EqProp (Complex a) where (=-=) = eq 247 | instance Eq a => EqProp (Ratio a) where (=-=) = eq 248 | 249 | -- Semigroups 250 | instance EqProp a => EqProp (Min a) 251 | instance EqProp a => EqProp (Max a) 252 | instance EqProp a => EqProp (First a) 253 | instance EqProp a => EqProp (Last a) 254 | 255 | -- Monoids 256 | instance EqProp a => EqProp (Dual a) 257 | instance (Show a, Arbitrary a, EqProp a) => EqProp (Endo a) 258 | instance EqProp All 259 | instance EqProp Any 260 | instance EqProp a => EqProp (Sum a) 261 | instance EqProp a => EqProp (Product a) 262 | instance EqProp (f a) => EqProp (Alt f a) 263 | #if __GLASGOW_HASKELL__ >= 806 264 | instance EqProp (f a) => EqProp (Ap f a) 265 | #endif 266 | 267 | -- Lists 268 | instance EqProp a => EqProp [a] 269 | instance EqProp a => EqProp (NonEmpty a) 270 | instance EqProp a => EqProp (ZipList a) 271 | 272 | -- Maybe 273 | instance EqProp a => EqProp (Maybe a) 274 | 275 | -- Pairing 276 | instance (EqProp a, EqProp b) => EqProp (a,b) 277 | instance (EqProp a, EqProp b, EqProp c) => EqProp (a,b,c) 278 | instance (EqProp a, EqProp b, EqProp c, EqProp d) => EqProp (a,b,c,d) 279 | 280 | -- Either 281 | instance (EqProp a, EqProp b) => EqProp (Either a b) 282 | 283 | -- Functors 284 | #if __GLASGOW_HASKELL__ >= 800 285 | instance EqProp (f (g a)) => EqProp (Compose f g a) 286 | instance (EqProp (f a), EqProp (g a)) => EqProp (F.Sum f g a) 287 | instance (EqProp (f a), EqProp (g a)) => EqProp (F.Product f g a) 288 | #endif 289 | instance EqProp a => EqProp (Identity a) 290 | instance EqProp a => EqProp (Const a b) 291 | instance EqProp (Proxy a) 292 | 293 | -- Function equality 294 | instance (Show a, Arbitrary a, EqProp b) => EqProp (a -> b) where 295 | f =-= f' = property (liftA2 (=-=) f f') 296 | -- Alternative definition: 297 | -- instance (Show a, Arbitrary a, EqProp b) => EqProp (a -> b) where 298 | -- f =-= f' = property (probablisticPureCheck defaultConfig 299 | -- (\x -> f x =-= g x)) 300 | 301 | eqModels :: (Model a b, EqProp b) => a -> a -> Property 302 | eqModels = (=-=) `on` model 303 | 304 | 305 | -- | @f `'denotationFor'` g@ proves that @f@ is a model for @g@, ie that 306 | -- @'model' . g '=-=' f@. 307 | denotationFor 308 | :: (Model b b', Arbitrary a, EqProp b', Show a) 309 | => (a -> b') 310 | -> (a -> b) 311 | -> TestBatch 312 | denotationFor f g = 313 | ( "denotation" 314 | , [("eq", model . g =-= f)] 315 | ) 316 | 317 | -- Other types 318 | -- instance EqProp a => EqProp (S.Stream a) where (=-=) = eqModels 319 | 320 | -- Binary relation 321 | type BinRel a = a -> a -> Bool 322 | 323 | -- | Reflexive property: @a `rel` a@ 324 | reflexive :: (Arbitrary a, Show a) => 325 | BinRel a -> Property 326 | reflexive rel = property $ \ a -> a `rel` a 327 | 328 | -- | Transitive property: @a `rel` b && b `rel` c ==> a `rel` c@. 329 | -- Generate @a@ randomly, but use @gen a@ to generate @b@ and @gen b@ to 330 | -- generate @c@. @gen@ ought to satisfy @rel@ fairly often. 331 | transitive :: (Arbitrary a, Show a) => 332 | BinRel a -> (a -> Gen a) -> Property 333 | transitive rel gen = 334 | property $ \ a -> 335 | forAll (gen a) $ \ b -> 336 | forAll (gen b) $ \ c -> 337 | (a `rel` b) && (b `rel` c) ==> (a `rel` c) 338 | 339 | -- | Symmetric property: @a `rel` b ==> b `rel` a@. Generate @a@ 340 | -- randomly, but use @gen a@ to generate @b@. @gen@ ought to satisfy 341 | -- @rel@ fairly often. 342 | symmetric :: (Arbitrary a, Show a) => 343 | BinRel a -> (a -> Gen a) -> Property 344 | symmetric rel gen = 345 | property $ \ a -> 346 | forAll (gen a) $ \ b -> 347 | (a `rel` b) ==> (b `rel` a) 348 | 349 | -- | Antisymmetric property: @(a `rel` b) && (a /= b) ==> not (b `rel` a)@. 350 | -- 351 | -- @since 0.5.0 352 | antiSymmetric :: (Arbitrary a, Show a, Eq a) => 353 | BinRel a -> Property 354 | antiSymmetric rel = 355 | property $ \ a b -> (a `rel` b) && (a /= b) ==> not (b `rel` a) 356 | 357 | -- | Has a given left identity, according to '(=-=)' 358 | leftId :: (Show a, Arbitrary a, EqProp a) => (i -> a -> a) -> i -> Property 359 | leftId op i = (i `op`) =-= id 360 | 361 | -- | Has a given right identity, according to '(=-=)' 362 | rightId :: (Show a, Arbitrary a, EqProp a) => (a -> i -> a) -> i -> Property 363 | rightId op i = (`op` i) =-= id 364 | 365 | -- | Has a given left and right identity, according to '(=-=)' 366 | bothId :: (Show a, Arbitrary a, EqProp a) => (a -> a -> a) -> a -> Property 367 | bothId = (liftA2.liftA2) (.&.) leftId rightId 368 | 369 | -- bothId op i = leftId op i .&. rightId op i 370 | 371 | -- | Associative, according to '(=-=)' 372 | isAssoc :: (EqProp a, Show a, Arbitrary a) => (a -> a -> a) -> Property 373 | isAssoc = isAssociativeBy (=-=) arbitrary 374 | 375 | -- | Commutative, according to '(=-=)' 376 | commutes :: EqProp z => (a -> a -> z) -> a -> a -> Property 377 | commutes (#) a b = a # b =-= b # a 378 | 379 | -- | Commutative, according to '(=-=)' 380 | isCommut :: (EqProp a, Show a, Arbitrary a) => (a -> a -> a) -> Property 381 | isCommut = isCommutableBy (=-=) arbitrary 382 | 383 | -- | Explicit 'Monoid' dictionary. Doesn't have to correspond to an 384 | -- actual 'Monoid' instance, though see 'monoidD'. 385 | data MonoidD a = MonoidD a (a -> a -> a) 386 | 387 | -- | 'Monoid' dictionary built from the 'Monoid' methods. 388 | monoidD :: Monoid a => MonoidD a 389 | monoidD = MonoidD mempty mappend 390 | 391 | -- | Monoid dictionary for an unwrapped endomorphism. See also 'monoidD' 392 | -- and 'Endo'. 393 | endoMonoidD :: MonoidD (a -> a) 394 | endoMonoidD = MonoidD id (.) 395 | 396 | -- | Homomorphism properties with respect to given monoid dictionaries. 397 | -- See also 'monoidMorphism'. 398 | homomorphism :: (EqProp b, Show a, Arbitrary a) => 399 | MonoidD a -> MonoidD b -> (a -> b) -> [(String,Property)] 400 | homomorphism (MonoidD ida opa) (MonoidD idb opb) q = 401 | [ ("identity" , q ida =-= idb) 402 | , ("binop", property $ \ u v -> q (u `opa` v) =-= q u `opb` q v) 403 | ] 404 | 405 | -- | The unary function @f@ is idempotent, i.e., @f . f == f@ 406 | idempotent :: (Show a, Arbitrary a, EqProp a) => 407 | (a -> a) -> Property 408 | idempotent f = idemElem (.) f 409 | 410 | -- | A binary function @op@ is idempotent, i.e., @x `op` x == x@, for all @x@ 411 | idempotent2 :: (Show a, Arbitrary a, EqProp a) => 412 | (a -> a -> a) -> Property 413 | idempotent2 = property . idemElem 414 | 415 | -- | A binary function @op@ is has an idempotent element @x@, i.e., 416 | -- @x `op` x == x@ 417 | idemElem :: EqProp a => (a -> a -> a) -> a -> Property 418 | idemElem op x = x `op` x =-= x 419 | 420 | {- 421 | -- TODO: phase out AsFun, in favor of Model. withArray 422 | 423 | -- | Types that can be modeled as functions. 424 | class AsFun h a b | h -> a b where 425 | asFun :: h -> (a -> b) 426 | 427 | instance AsFun (a->b) a b where asFun = id 428 | 429 | -- | Equality of function-like types 430 | funEq :: (AsFun h a b, EqProp (a -> b)) => h -> h -> Property 431 | h `funEq` h' = asFun h =-= asFun h' 432 | -} 433 | 434 | 435 | {---------------------------------------------------------- 436 | Model-based (semantics-based) testing 437 | ----------------------------------------------------------} 438 | 439 | ---- From bytestring 440 | 441 | class Model a b | a -> b where 442 | model :: a -> b -- get the model from a concrete value 443 | 444 | -- note: bytestring doesn't make the fundep 445 | 446 | ---- Compare representation-level and model-level operations (commuting diagrams) 447 | 448 | meq :: (Model a b, EqProp b) => a -> b -> Property 449 | meq1 :: (Model a b, Model a1 b1, EqProp b) => 450 | (a1 -> a) -> (b1 -> b) -> a1 -> Property 451 | meq2 :: (Model a b, Model a1 b1, Model a2 b2, EqProp b) => 452 | (a1 -> a2 -> a) -> (b1 -> b2 -> b) -> a1 -> a2 -> Property 453 | meq3 :: (Model a b, Model a1 b1, Model a2 b2, Model a3 b3, EqProp b) => 454 | (a1 -> a2 -> a3 -> a) 455 | -> (b1 -> b2 -> b3 -> b) 456 | -> a1 -> a2 -> a3 -> Property 457 | meq4 :: ( Model a b, Model a1 b1, Model a2 b2 458 | , Model a3 b3, Model a4 b4, EqProp b) => 459 | (a1 -> a2 -> a3 -> a4 -> a) 460 | -> (b1 -> b2 -> b3 -> b4 -> b) 461 | -> a1 -> a2 -> a3 -> a4 -> Property 462 | meq5 :: ( Model a b, Model a1 b1, Model a2 b2, Model a3 b3 463 | , Model a4 b4, Model a5 b5, EqProp b) => 464 | (a1 -> a2 -> a3 -> a4 -> a5 -> a) 465 | -> (b1 -> b2 -> b3 -> b4 -> b5 -> b) 466 | -> a1 -> a2 -> a3 -> a4 -> a5 -> Property 467 | 468 | meq a b = 469 | model a =-= b 470 | meq1 f g = \a -> 471 | model (f a) =-= g (model a) 472 | meq2 f g = \a b -> 473 | model (f a b) =-= g (model a) (model b) 474 | meq3 f g = \a b c -> 475 | model (f a b c) =-= g (model a) (model b) (model c) 476 | meq4 f g = \a b c d -> 477 | model (f a b c d) =-= g (model a) (model b) (model c) (model d) 478 | meq5 f g = \a b c d e -> 479 | model (f a b c d e) =-= g (model a) (model b) (model c) (model d) (model e) 480 | 481 | 482 | ---- Some model instances 483 | 484 | instance Model Bool Bool where model = id 485 | instance Model Char Char where model = id 486 | instance Model Int Int where model = id 487 | instance Model Float Float where model = id 488 | instance Model Double Double where model = id 489 | instance Model String String where model = id 490 | 491 | -- These next two require UndecidableInstances 492 | instance (Model a b, Model a' b') => Model (a,a') (b,b') where 493 | model = model *** model 494 | 495 | instance Model b b' => Model (a -> b) (a -> b') where 496 | model f = model . f 497 | 498 | -- instance Model (S.Stream a) (NonNegative Int -> a) where 499 | -- model s (NonNegative i) = s S.!! i 500 | 501 | 502 | -- | Like 'Model' but for unary type constructors. 503 | class Model1 f g | f -> g where 504 | model1 :: forall a. f a -> g a 505 | 506 | 507 | {---------------------------------------------------------- 508 | Some handy testing types 509 | ----------------------------------------------------------} 510 | 511 | -- from QC2, plus tweaks 512 | 513 | -- type Positive a = NonZero (NonNegative a) 514 | 515 | arbitrarySatisfying :: Arbitrary a => (a -> Bool) -> Gen a 516 | arbitrarySatisfying = (arbitrary `suchThat`) 517 | 518 | -- -- | Generates a value that satisfies a predicate. 519 | -- suchThat :: Gen a -> (a -> Bool) -> Gen a 520 | -- gen `suchThat` p = satisfiesM p gen 521 | 522 | -- -- | Tries to generate a value that satisfies a predicate. 523 | -- suchThatMaybe :: Gen a -> (a -> Bool) -> Gen (Maybe a) 524 | -- gen `suchThatMaybe` p = sized (try 0 . max 1) 525 | -- where 526 | -- try _ 0 = return Nothing 527 | -- try k n = do x <- resize (2*k+n) gen 528 | -- if p x then return (Just x) else try (k+1) (n-1) 529 | 530 | -- | Generate n arbitrary values 531 | arbs :: Arbitrary a => Int -> IO [a] 532 | 533 | arbs n = fmap (\ rnd -> generate n rnd (vector n)) newQCGen 534 | 535 | -- | Produce n values from a generator 536 | gens :: Int -> Gen a -> IO [a] 537 | gens n gen = 538 | fmap (\ rnd -> generate 1000 rnd (sequence (replicate n gen))) newQCGen 539 | 540 | -- The next two are from twanvl: 541 | 542 | instance Testable a => Testable [a] where 543 | property [] = property True 544 | property props = property $ \n -> props !! (n `mod` len) 545 | where len = length props 546 | 547 | instance (Testable a, Testable b) => Testable (a,b) where 548 | property = uncurry (.&.) 549 | 550 | {- 551 | probablisticPureCheck :: Testable a => Args -> a -> Bool 552 | probablisticPureCheck args a = unsafePerformIO $ 553 | do rnd <- newStdGen 554 | probablisticPureTests args (evaluate a) rnd 0 0 [] 555 | 556 | 557 | probablisticPureTests :: Args 558 | -> Gen Result 559 | -> StdGen 560 | -> Int 561 | -> Int 562 | -> [[String]] 563 | -> IO Bool 564 | probablisticPureTests args gen rnd0 ntest nfail stamps 565 | | ntest == maxSuccess args = return True 566 | | nfail == maxDiscard args = return True 567 | | otherwise = 568 | case ok result of 569 | Nothing -> 570 | probablisticPureTests args gen rnd1 ntest (nfail+1) stamps 571 | Just True -> 572 | probablisticPureTests args gen rnd1 (ntest+1) nfail 573 | (stamp result:stamps) 574 | Just False -> 575 | return False 576 | where 577 | result = generate (maxSize config ntest) rnd2 gen 578 | (rnd1,rnd2) = split rnd0 579 | 580 | -} 581 | 582 | -- TODO: resurrect probablistic stuff. bob? 583 | 584 | 585 | {-------------------------------------------------------------------- 586 | Copied (& tweaked) from QC1 587 | --------------------------------------------------------------------} 588 | 589 | -- TODO: are there QC2 replacements for these QC1 operations? 590 | 591 | rand :: Gen QCGen 592 | rand = MkGen (\r _ -> r) 593 | 594 | generate :: Int -> QCGen -> Gen a -> a 595 | generate n rnd (MkGen m) = m rnd' size 596 | where 597 | (size, rnd') = randomR (0, n) rnd 598 | 599 | -- evaluate :: Testable a => a -> Gen Result 600 | -- evaluate a = gen where MkProp gen = property a 601 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Classes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, KindSignatures 2 | , Rank2Types, TypeApplications, TypeOperators, CPP 3 | #-} 4 | 5 | ---------------------------------------------------------------------- 6 | -- | 7 | -- Module : Test.QuickCheck.Classes 8 | -- Copyright : (c) Conal Elliott 2008 9 | -- License : BSD3 10 | -- 11 | -- Maintainer : conal@conal.net 12 | -- Stability : experimental 13 | -- 14 | -- Some QuickCheck properties for standard type classes 15 | ---------------------------------------------------------------------- 16 | 17 | module Test.QuickCheck.Classes 18 | ( ordRel, ord, ordMorphism, semanticOrd 19 | , semigroup 20 | , monoid, monoidMorphism, semanticMonoid 21 | , functor, functorMorphism, semanticFunctor, functorMonoid 22 | , apply, applyMorphism, semanticApply 23 | , applicative, applicativeMorphism, semanticApplicative 24 | , bind, bindMorphism, semanticBind, bindApply 25 | , monad, monadMorphism, semanticMonad, monadFunctor 26 | , monadApplicative, arrow, arrowChoice, foldable, foldableFunctor, bifoldable, bifoldableBifunctor, traversable 27 | , monadPlus, monadOr, alt, alternative 28 | ) 29 | where 30 | 31 | import Data.Bifoldable (Bifoldable (..)) 32 | import Data.Bifunctor hiding (first, second) 33 | import Data.Foldable (Foldable(..)) 34 | import Data.Functor.Apply (Apply ((<.>))) 35 | import Data.Functor.Alt (Alt (())) 36 | import Data.Functor.Bind (Bind ((>>-)), apDefault) 37 | import qualified Data.Functor.Bind as B (Bind (join)) 38 | import Data.Functor.Compose (Compose (..)) 39 | import Data.Functor.Identity (Identity (..)) 40 | import Data.List.NonEmpty (NonEmpty(..)) 41 | import Data.Semigroup (Semigroup (..)) 42 | import Data.Monoid (Endo(..), Dual(..), Sum(..), Product(..)) 43 | import Data.Traversable (fmapDefault, foldMapDefault) 44 | import Control.Applicative (Alternative(..)) 45 | import Control.Monad (MonadPlus (..), ap, join) 46 | import Control.Arrow (Arrow,ArrowChoice,first,second,left,right,(>>>),arr) 47 | import Test.QuickCheck 48 | import Text.Show.Functions () 49 | 50 | import Test.QuickCheck.Checkers 51 | import Test.QuickCheck.Instances.Char () 52 | 53 | 54 | -- | Total ordering. 55 | -- 56 | -- @gen a@ ought to generate values @b@ satisfying @a `rel` b@ fairly often. 57 | ordRel :: forall a. (Ord a, Show a, Arbitrary a) => 58 | BinRel a -> (a -> Gen a) -> TestBatch 59 | ordRel rel gen = 60 | ( "ord" 61 | , [ ("reflexive" , reflexive rel ) 62 | , ("transitive" , transitive rel gen) 63 | , ("antiSymmetric", antiSymmetric rel ) 64 | ] 65 | ) 66 | 67 | -- | 'Ord' laws. 68 | -- 69 | -- @gen a@ ought to generate values @b@ satisfying @a `rel` b@ fairly often. 70 | ord :: forall a. (Ord a, Show a, Arbitrary a) => 71 | (a -> Gen a) -> TestBatch 72 | ord gen = 73 | ( "Ord" 74 | , [ ("Reflexivity of (<=)", reflexive le) 75 | , ("Transitivity of (<=)", transitive le gen) 76 | , ("Antisymmetry of (<=)", antiSymmetric le) 77 | , ("x >= y = y <= x", p (\x y -> (x >= y) === (y <= x))) 78 | , ("x < y = x <= y && x /= y", p (\x y -> (x < y) === (x <= y && x /= y))) 79 | , ("x > y = y < x", p (\x y -> (x > y) === (y < x))) 80 | , ("x < y = compare x y == LT", p (\x y -> (x < y) === (compare x y == LT))) 81 | , ("x > y = compare x y == GT", p (\x y -> (x > y) === (compare x y == GT))) 82 | , ("x == y = compare x y == EQ", p (\x y -> (x == y) === (compare x y == EQ))) 83 | , ("min x y == if x <= y then x else y = True", p (\x y -> min x y === if x <= y then x else y)) 84 | , ("max x y == if x >= y then x else y = True", p (\x y -> max x y === if x >= y then x else y)) 85 | ] 86 | ) 87 | where 88 | le :: a -> a -> Bool 89 | le = (<=) 90 | p :: (a -> a -> Property) -> Property 91 | p = property 92 | 93 | -- | 'Ord' morphism properties. @h@ is an 'Ord' morphism iff: 94 | -- 95 | -- > a <= b = h a <= h b 96 | -- > 97 | -- > h (a `min` b) = h a `min` h b 98 | -- > h (a `max` b) = h a `max` h b 99 | ordMorphism :: (Ord a, Ord b, EqProp b, Show a, Arbitrary a) => 100 | (a -> b) -> TestBatch 101 | 102 | ordMorphism h = ( "ord morphism" 103 | , [ ("(<=)", distrib' (<=)) 104 | , ("min" , distrib min ) 105 | , ("max" , distrib max ) 106 | ] 107 | ) 108 | where 109 | distrib :: (forall c. Ord c => c -> c -> c) -> Property 110 | distrib op = property $ \ u v -> h (u `op` v) =-= h u `op` h v 111 | 112 | distrib' :: EqProp d => (forall c. Ord c => c -> c -> d) -> Property 113 | distrib' op = property $ \ u v -> u `op` v =-= h u `op` h v 114 | 115 | -- | The semantic function ('model') for @a@ is an 'ordMorphism'. 116 | semanticOrd :: forall a b. 117 | ( Model a b 118 | , Ord a, Ord b 119 | , Show a 120 | , Arbitrary a 121 | , EqProp b 122 | ) => 123 | a -> TestBatch 124 | semanticOrd = const (first ("semantic " ++) 125 | (ordMorphism (model :: a -> b))) 126 | 127 | 128 | -- | Properties to check that the 'Monoid' 'a' satisfies the monoid 129 | -- properties. The argument value is ignored and is present only for its 130 | -- type. 131 | monoid :: forall a. (Monoid a, Show a, Arbitrary a, EqProp a) => 132 | a -> TestBatch 133 | monoid = const ( "monoid" 134 | , [ ("left identity", leftId mappend (mempty :: a)) 135 | , ("right identity", rightId mappend (mempty :: a)) 136 | , ("associativity" , isAssoc (mappend :: Binop a)) 137 | #if MIN_VERSION_base(4,11,0) 138 | , ("mappend = (<>)", property monoidSemigroupP) 139 | #endif 140 | , ("mconcat", property mconcatP) 141 | ] 142 | ) 143 | where 144 | #if MIN_VERSION_base(4,11,0) 145 | monoidSemigroupP :: a -> a -> Property 146 | monoidSemigroupP x y = mappend x y =-= x <> y 147 | #endif 148 | mconcatP :: [a] -> Property 149 | mconcatP as = mconcat as =-= foldr mappend mempty as 150 | 151 | -- | Properties to check that the 'Semigroup' 'a' satisfies the semigroup 152 | -- properties. The argument value is ignored and is present only for its 153 | -- type. 154 | -- 155 | -- @since 0.5.0 156 | semigroup :: forall a n. 157 | ( Semigroup a, Show a, Arbitrary a, EqProp a 158 | , Integral n, Show n, Arbitrary n) => 159 | (a, n) -> TestBatch 160 | semigroup = const ( "semigroup" 161 | , [("associativity", isAssoc ((<>) :: Binop a)) 162 | ,("sconcat", property sconcatP) 163 | ,("stimes", property stimesP) 164 | ] 165 | ) 166 | where 167 | sconcatP :: a -> [a] -> Property 168 | sconcatP a as = sconcat (a :| as) =-= foldr1 (<>) (a :| as) 169 | stimesP :: Positive n -> a -> Property 170 | stimesP (Positive n) a = stimes n a =-= foldr1 (<>) (replicate (fromIntegral n) a) 171 | 172 | -- | Monoid homomorphism properties. See also 'homomorphism'. 173 | monoidMorphism :: (Monoid a, Monoid b, EqProp b, Show a, Arbitrary a) => 174 | (a -> b) -> TestBatch 175 | monoidMorphism q = ("monoid morphism", homomorphism monoidD monoidD q) 176 | 177 | semanticMonoid :: forall a b. 178 | ( Model a b 179 | , Monoid a, Monoid b 180 | , Show a 181 | , Arbitrary a 182 | , EqProp b 183 | ) => 184 | a -> TestBatch 185 | 186 | -- | The semantic function ('model') for @a@ is a 'monoidMorphism'. 187 | semanticMonoid = const (first ("semantic " ++) 188 | (monoidMorphism (model:: a -> b))) 189 | 190 | functorMonoid :: forall m a b. 191 | ( Functor m 192 | , Monoid (m a) 193 | , Monoid (m b) 194 | , CoArbitrary a 195 | , Arbitrary b 196 | , Arbitrary (m a) 197 | , Show (m a) 198 | , EqProp (m b)) => 199 | m (a,b) -> TestBatch 200 | functorMonoid = const ("functor-monoid" 201 | , [ ( "identity",property identityP ) 202 | , ( "binop", property binopP ) 203 | ] 204 | ) 205 | where 206 | identityP :: (a->b) -> Property 207 | identityP f = (fmap f) (mempty :: m a) =-= (mempty :: m b) 208 | binopP :: (a->b) -> (m a) -> (m a) -> Property 209 | binopP f u v = (fmap f) (u `mappend` v) =-= (fmap f u) `mappend` (fmap f v) 210 | 211 | -- There I have an attempt at doing this. I eventually implemented 212 | -- those semanticMorphisms as their own functions. I'm not too thrilled with 213 | -- that implementation, but it works. 214 | 215 | -- TODO: figure out out to eliminate the redundancy. 216 | 217 | -- | Properties to check that the 'Functor' @m@ satisfies the functor 218 | -- properties. 219 | functor :: forall m a b c. 220 | ( Functor m 221 | , Arbitrary b, Arbitrary c 222 | , CoArbitrary a, CoArbitrary b 223 | , Show (m a), Arbitrary (m a), EqProp (m a), EqProp (m c)) => 224 | m (a,b,c) -> TestBatch 225 | functor = const ( "functor" 226 | , [ ("identity", property identityP) 227 | , ("compose" , property composeP) ] 228 | ) 229 | where 230 | identityP :: Property 231 | composeP :: (b -> c) -> (a -> b) -> Property 232 | 233 | identityP = fmap id =-= (id :: m a -> m a) 234 | composeP g f = fmap g . fmap f =-= (fmap (g.f) :: m a -> m c) 235 | 236 | -- Note the similarity between 'functor' and 'monoidMorphism'. The 237 | -- functor laws say that 'fmap' is a homomorphism w.r.t '(.)': 238 | -- 239 | -- functor = const ("functor", homomorphism endoMonoidD endoMonoidD fmap) 240 | -- 241 | -- However, I don't think the types can work out, since 'fmap' is used at 242 | -- three different types. 243 | 244 | 245 | -- | 'Functor' morphism (natural transformation) properties 246 | functorMorphism :: forall f g. 247 | ( Functor f, Functor g 248 | , Arbitrary (f NumT), Show (f NumT) 249 | , EqProp (g T) 250 | ) => 251 | (forall a. f a -> g a) -> TestBatch 252 | functorMorphism q = ("functor morphism", [("fmap", property fmapP)]) 253 | where 254 | -- fmapP :: (NumT -> T) -> f NumT -> Property 255 | -- fmapP h l = q (fmap h l) =-= fmap h (q l) 256 | fmapP :: (NumT -> T) -> Property 257 | fmapP h = q . fmap h =-= fmap h . q 258 | 259 | -- Note: monomorphism prevent us from saying @commutes (.) q (fmap h)@, 260 | -- since @fmap h@ is used at two different types. 261 | 262 | -- | The semantic function ('model1') for @f@ is a 'functorMorphism'. 263 | semanticFunctor :: forall f g. 264 | ( Model1 f g 265 | , Functor f 266 | , Functor g 267 | , Arbitrary (f NumT) 268 | , Show (f NumT) 269 | , EqProp (g T) 270 | ) => 271 | f () -> TestBatch 272 | semanticFunctor = const (functorMorphism (model1 :: forall b. f b -> g b)) 273 | 274 | 275 | -- | Properties to check that the 'Apply' @m@ satisfies the apply 276 | -- properties 277 | apply :: forall m a b c. 278 | ( Apply m 279 | , CoArbitrary a, Arbitrary b, CoArbitrary b 280 | , Arbitrary c, Arbitrary (m a) 281 | , Arbitrary (m (b -> c)), Show (m (b -> c)) 282 | , Arbitrary (m (a -> b)), Show (m (a -> b)) 283 | , Show (m a) 284 | , EqProp (m c) 285 | ) => 286 | m (a,b,c) -> TestBatch 287 | apply = const ( "apply" 288 | , [ ("associativity", property associativityP) 289 | , ("left" , property leftP) 290 | , ("right" , property rightP) 291 | ] 292 | ) 293 | where 294 | associativityP :: m (b -> c) -> m (a -> b) -> m a -> Property 295 | rightP :: (b -> c) -> m (a -> b) -> m a -> Property 296 | leftP :: (a -> b) -> m (b -> c) -> m a -> Property 297 | 298 | associativityP u v w = ((.) <$> u <.> v <.> w) =-= (u <.> (v <.> w)) 299 | leftP f x y = (x <.> (f <$> y)) =-= ((. f) <$> x <.> y) 300 | rightP f x y = (f <$> (x <.> y)) =-= ((f .) <$> x <.> y) 301 | 302 | 303 | -- | 'Apply' morphism properties 304 | applyMorphism :: forall f g. 305 | ( Apply f, Apply g 306 | , Show (f NumT), Arbitrary (f NumT) 307 | , EqProp (g T) 308 | , Show (f (NumT -> T)) 309 | , Arbitrary (f (NumT -> T)) 310 | ) => 311 | (forall a. f a -> g a) -> TestBatch 312 | applyMorphism q = 313 | ( "apply morphism" 314 | , [ ("apply", property applyP)] ) 315 | where 316 | applyP :: f (NumT->T) -> f NumT -> Property 317 | applyP mf mx = q (mf <.> mx) =-= (q mf <.> q mx) 318 | 319 | 320 | -- | The semantic function ('model1') for @f@ is an 'applyMorphism'. 321 | semanticApply :: forall f g. 322 | ( Model1 f g 323 | , Apply f, Apply g 324 | , Arbitrary (f NumT), Arbitrary (f (NumT -> T)) 325 | , EqProp (g T) 326 | , Show (f NumT), Show (f (NumT -> T)) 327 | ) => 328 | f () -> TestBatch 329 | semanticApply = 330 | const (applyMorphism (model1 :: forall b. f b -> g b)) 331 | 332 | 333 | -- | Properties to check that the 'Applicative' @m@ satisfies the applicative 334 | -- properties 335 | applicative :: forall m a b c. 336 | ( Applicative m 337 | , Arbitrary a, CoArbitrary a, Arbitrary b, Arbitrary (m a) 338 | , Arbitrary (m (b -> c)), Show (m (b -> c)) 339 | , Arbitrary (m (a -> b)), Show (m (a -> b)) 340 | , Show a, Show (m a) 341 | , EqProp (m a), EqProp (m b), EqProp (m c) 342 | ) => 343 | m (a,b,c) -> TestBatch 344 | applicative = const ( "applicative" 345 | , [ ("identity" , property identityP) 346 | , ("composition" , property compositionP) 347 | , ("homomorphism", property homomorphismP) 348 | , ("interchange" , property interchangeP) 349 | , ("functor" , property functorP) 350 | ] 351 | ) 352 | where 353 | identityP :: m a -> Property 354 | compositionP :: m (b -> c) -> m (a -> b) -> m a -> Property 355 | homomorphismP :: (a -> b) -> a -> Property 356 | interchangeP :: m (a -> b) -> a -> Property 357 | functorP :: (a -> b) -> m a -> Property 358 | 359 | identityP v = (pure id <*> v) =-= v 360 | compositionP u v w = (pure (.) <*> u <*> v <*> w) =-= (u <*> (v <*> w)) 361 | homomorphismP f x = (pure f <*> pure x) =-= (pure (f x) :: m b) 362 | interchangeP u y = (u <*> pure y) =-= (pure ($ y) <*> u) 363 | functorP f x = (fmap f x) =-= (pure f <*> x) 364 | 365 | 366 | -- | 'Applicative' morphism properties 367 | applicativeMorphism :: forall f g. 368 | ( Applicative f, Applicative g 369 | , Show (f NumT), Arbitrary (f NumT) 370 | , EqProp (g NumT), EqProp (g T) 371 | , Show (f (NumT -> T)) 372 | , Arbitrary (f (NumT -> T)) 373 | ) => 374 | (forall a. f a -> g a) -> TestBatch 375 | applicativeMorphism q = 376 | ( "applicative morphism" 377 | , [("pure", property pureP), ("apply", property applyP)] ) 378 | where 379 | pureP :: NumT -> Property 380 | applyP :: f (NumT->T) -> f NumT -> Property 381 | 382 | pureP a = q (pure a) =-= pure a 383 | applyP mf mx = q (mf <*> mx) =-= (q mf <*> q mx) 384 | 385 | 386 | -- | The semantic function ('model1') for @f@ is an 'applicativeMorphism'. 387 | semanticApplicative :: forall f g. 388 | ( Model1 f g 389 | , Applicative f, Applicative g 390 | , Arbitrary (f NumT), Arbitrary (f (NumT -> T)) 391 | , EqProp (g NumT), EqProp (g T) 392 | , Show (f NumT), Show (f (NumT -> T)) 393 | ) => 394 | f () -> TestBatch 395 | semanticApplicative = 396 | const (applicativeMorphism (model1 :: forall b. f b -> g b)) 397 | 398 | 399 | -- | Properties to check that the 'bind' @m@ satisfies the bind properties 400 | bind :: forall m a b c. 401 | ( Bind m 402 | , CoArbitrary a, CoArbitrary b 403 | , Arbitrary (m a), EqProp (m a), Show (m a) 404 | , Arbitrary (m b) 405 | , Arbitrary (m c), EqProp (m c) 406 | , Arbitrary (m (m (m a))), Show (m (m (m a))) 407 | ) => 408 | m (a,b,c) -> TestBatch 409 | bind = const ( "bind laws" 410 | , [ ("join associativity", property joinAssocP) 411 | , ("bind associativity", property bindAssocP) 412 | ] 413 | ) 414 | where 415 | bindAssocP :: m a -> (a -> m b) -> (b -> m c) -> Property 416 | joinAssocP :: m (m (m a)) -> Property 417 | 418 | bindAssocP m f g = ((m >>- f) >>- g) =-= (m >>- (\x -> f x >>- g)) 419 | joinAssocP mmma = B.join (B.join mmma) =-= B.join (fmap B.join mmma) 420 | 421 | bindApply :: forall m a b. 422 | ( Bind m 423 | , EqProp (m b) 424 | , Show (m a), Arbitrary (m a) 425 | , Show (m (a -> b)), Arbitrary (m (a -> b))) => 426 | m (a, b) -> TestBatch 427 | bindApply = const ( "bind apply" 428 | , [ ("ap", property apP) ] 429 | ) 430 | where 431 | apP :: m (a -> b) -> m a -> Property 432 | apP f x = (f <.> x) =-= (f `apDefault` x) 433 | 434 | -- | 'bind' morphism properties 435 | bindMorphism :: forall f g. 436 | ( Bind f, Bind g 437 | , Show (f NumT) 438 | , Show (f (f (NumT -> T))) 439 | , Arbitrary (f NumT), Arbitrary (f T) 440 | , Arbitrary (f (f (NumT -> T))) 441 | , EqProp (g T) 442 | , EqProp (g (NumT -> T)) 443 | ) => 444 | (forall a. f a -> g a) -> TestBatch 445 | bindMorphism q = 446 | ( "bind morphism" 447 | , [ ("bind", property bindP), ("join", property joinP) ] ) 448 | where 449 | bindP :: f NumT -> (NumT -> f T) -> Property 450 | joinP :: f (f (NumT->T)) -> Property 451 | 452 | bindP u k = q (u >>- k) =-= (q u >>- q . k) 453 | joinP uu = q (B.join uu) =-= B.join (fmap q (q uu)) 454 | 455 | -- | The semantic function ('model1') for @f@ is a 'bindMorphism'. 456 | semanticBind :: forall f g. 457 | ( Model1 f g 458 | , Bind f, Bind g 459 | , EqProp (g T) 460 | , EqProp (g (NumT -> T)) 461 | , Arbitrary (f T) , Arbitrary (f NumT) 462 | , Arbitrary (f (f (NumT -> T))) 463 | , Show (f (f (NumT -> T))) 464 | , Show (f NumT) 465 | ) => 466 | f () -> TestBatch 467 | semanticBind = const (bindMorphism (model1 :: forall b. f b -> g b)) 468 | 469 | 470 | -- | Properties to check that the 'Monad' @m@ satisfies the monad properties 471 | monad :: forall m a b c. 472 | ( Monad m 473 | , Show a, Arbitrary a, CoArbitrary a, CoArbitrary b 474 | , Arbitrary (m a), EqProp (m a), Show (m a) 475 | , Arbitrary (m b), EqProp (m b) 476 | , Arbitrary (m c), EqProp (m c) 477 | , Show (m (a -> b)), Arbitrary (m (a -> b)) 478 | ) => 479 | m (a,b,c) -> TestBatch 480 | monad = const ( "monad laws" 481 | , [ ("left identity", property leftP) 482 | , ("right identity", property rightP) 483 | , ("associativity" , property assocP) 484 | , ("pure", property pureP) 485 | , ("ap", property apP) 486 | ] 487 | ) 488 | where 489 | leftP :: (a -> m b) -> a -> Property 490 | rightP :: m a -> Property 491 | assocP :: m a -> (a -> m b) -> (b -> m c) -> Property 492 | pureP :: a -> Property 493 | apP :: m (a -> b) -> m a -> Property 494 | 495 | leftP f a = (return a >>= f) =-= f a 496 | rightP m = (m >>= return) =-= m 497 | assocP m f g = ((m >>= f) >>= g) =-= (m >>= (\x -> f x >>= g)) 498 | pureP x = (pure x :: m a) =-= return x 499 | apP f x = (f <*> x) =-= (f `ap` x) 500 | 501 | -- | Law for monads that are also instances of 'Functor'. 502 | -- 503 | -- Note that instances that satisfy 'applicative' and 'monad' 504 | -- are implied to satisfy this property too. 505 | monadFunctor :: forall m a b. 506 | ( Monad m 507 | , Arbitrary b, CoArbitrary a 508 | , Arbitrary (m a), Show (m a), EqProp (m b)) => 509 | m (a, b) -> TestBatch 510 | monadFunctor = const ( "monad functor" 511 | , [("bind return", property bindReturnP)]) 512 | where 513 | bindReturnP :: (a -> b) -> m a -> Property 514 | bindReturnP f xs = fmap f xs =-= (xs >>= return . f) 515 | 516 | -- | Note that 'monad' also contains these properties. 517 | monadApplicative :: forall m a b. 518 | ( Monad m 519 | , EqProp (m a), EqProp (m b) 520 | , Show a, Arbitrary a 521 | , Show (m a), Arbitrary (m a) 522 | , Show (m (a -> b)), Arbitrary (m (a -> b))) => 523 | m (a, b) -> TestBatch 524 | monadApplicative = const ( "monad applicative" 525 | , [ ("pure", property pureP) 526 | , ("ap", property apP) 527 | ] 528 | ) 529 | where 530 | pureP :: a -> Property 531 | apP :: m (a -> b) -> m a -> Property 532 | 533 | pureP x = (pure x :: m a) =-= return x 534 | apP f x = (f <*> x) =-= (f `ap` x) 535 | 536 | -- | 'Monad' morphism properties 537 | 538 | -- | 'Applicative' morphism properties 539 | monadMorphism :: forall f g. 540 | ( Monad f, Monad g 541 | , Show (f NumT) 542 | , Show (f (f (NumT -> T))) 543 | , Arbitrary (f NumT), Arbitrary (f T) 544 | , Arbitrary (f (f (NumT -> T))) 545 | , EqProp (g NumT), EqProp (g T) 546 | , EqProp (g (NumT -> T)) 547 | ) => 548 | (forall a. f a -> g a) -> TestBatch 549 | monadMorphism q = 550 | ( "monad morphism" 551 | , [ ("return", property returnP), ("bind", property bindP), ("join", property joinP) ] ) 552 | where 553 | returnP :: NumT -> Property 554 | bindP :: f NumT -> (NumT -> f T) -> Property 555 | joinP :: f (f (NumT->T)) -> Property 556 | 557 | returnP a = q (return a) =-= return a 558 | bindP u k = q (u >>= k) =-= (q u >>= q . k) 559 | joinP uu = q (join uu) =-= join (fmap q (q uu)) 560 | 561 | -- The join and bind properties are redundant. Pick one. 562 | 563 | -- q (join uu) 564 | -- == q (uu >>= id) 565 | -- == q uu >>= q . id 566 | -- == q uu >>= q 567 | -- == join (fmap q (q uu)) 568 | 569 | -- q (u >>= k) 570 | -- == q (fmap k (join u)) 571 | -- == fmap k (q (join u)) -- if also a functor morphism 572 | -- == fmap k (join (fmap q (q uu))) 573 | -- == fmap k (q u >>= q) 574 | -- == ??? 575 | 576 | -- I'm stuck at the end here. What's missing? 577 | 578 | -- | The semantic function ('model1') for @f@ is a 'monadMorphism'. 579 | semanticMonad :: forall f g. 580 | ( Model1 f g 581 | , Monad f, Monad g 582 | , EqProp (g T) , EqProp (g NumT) 583 | , EqProp (g (NumT -> T)) 584 | , Arbitrary (f T) , Arbitrary (f NumT) 585 | , Arbitrary (f (f (NumT -> T))) 586 | , Show (f (f (NumT -> T))) 587 | , Show (f NumT) 588 | ) => 589 | f () -> TestBatch 590 | semanticMonad = const (monadMorphism (model1 :: forall b. f b -> g b)) 591 | 592 | -- | Laws for MonadPlus instances with left distribution. 593 | monadPlus :: forall m a b. 594 | ( MonadPlus m, Show (m a) 595 | , CoArbitrary a, Arbitrary (m a), Arbitrary (m b) 596 | , EqProp (m a), EqProp (m b)) => 597 | m (a, b) -> TestBatch 598 | monadPlus = const ( "MonadPlus laws" 599 | , [ ("left zero", property leftZeroP) 600 | , ("left identity", leftId mplus (mzero :: m a)) 601 | , ("right identity", rightId mplus (mzero :: m a)) 602 | , ("associativity" , isAssoc (mplus :: Binop (m a))) 603 | , ("left distribution", property leftDistP) 604 | ] 605 | ) 606 | where 607 | leftZeroP :: (a -> m b) -> Property 608 | leftDistP :: m a -> m a -> (a -> m b) -> Property 609 | 610 | leftZeroP k = (mzero >>= k) =-= mzero 611 | leftDistP a b k = (a `mplus` b >>= k) =-= ((a >>= k) `mplus` (b >>= k)) 612 | 613 | -- | Laws for MonadPlus instances with left catch. 614 | monadOr :: forall m a b. 615 | ( MonadPlus m, Show a, Show (m a) 616 | , Arbitrary a, CoArbitrary a, Arbitrary (m a), Arbitrary (m b) 617 | , EqProp (m a), EqProp (m b)) => 618 | m (a, b) -> TestBatch 619 | monadOr = const ( "MonadOr laws" 620 | , [ ("left zero", property leftZeroP) 621 | , ("left identity", leftId mplus (mzero :: m a)) 622 | , ("right identity", rightId mplus (mzero :: m a)) 623 | , ("associativity" , isAssoc (mplus :: Binop (m a))) 624 | , ("left catch", property leftCatchP) 625 | ] 626 | ) 627 | where 628 | leftZeroP :: (a -> m b) -> Property 629 | leftCatchP :: a -> m a -> Property 630 | 631 | leftZeroP k = (mzero >>= k) =-= mzero 632 | leftCatchP a b = return a `mplus` b =-= return a 633 | 634 | -- | Check Alt Semigroup law 635 | alt :: forall f a. ( Alt f, Arbitrary (f a) 636 | , EqProp (f a), Show (f a)) => 637 | f a -> TestBatch 638 | alt = const ( "Alt laws" 639 | , [ ("associativity", isAssoc (() :: Binop (f a))) ] ) 640 | 641 | 642 | -- | Check Alternative Monoid laws 643 | alternative :: forall f a. ( Alternative f, Arbitrary (f a) 644 | , EqProp (f a), Show (f a)) => 645 | f a -> TestBatch 646 | alternative = const ( "Alternative laws" 647 | , [ ("left identity", leftId (<|>) (empty :: f a)) 648 | , ("right identity", rightId (<|>) (empty :: f a)) 649 | , ("associativity", isAssoc ((<|>) :: Binop (f a))) 650 | ] 651 | ) 652 | 653 | 654 | arrow :: forall a b c d e. 655 | ( Arrow a 656 | , Show (a d e), Show (a c d), Show (a b c) 657 | , Arbitrary (a d e), Arbitrary (a c d), Arbitrary (a b c) 658 | , Arbitrary c, Arbitrary d, Arbitrary e 659 | , CoArbitrary b, CoArbitrary c, CoArbitrary d 660 | , EqProp (a b e), EqProp (a b d) 661 | , EqProp (a (b,d) c) 662 | , EqProp (a (b,d) (c,d)), EqProp (a (b,e) (d,e)) 663 | , EqProp (a (b,d) (c,e)) 664 | ) => 665 | a b (c,d,e) -> TestBatch 666 | arrow = const ("arrow laws" 667 | , [ ("associativity" , property assocP) 668 | , ("arr distributes" , property arrDistributesP) 669 | -- TODO: how to define h is onto or one-to-one? 670 | -- , ("extensionality principle" , property extensionalityP) 671 | -- , ("extensionality dual" , property extensionalityDualP) 672 | , ("first works as funs" , property firstAsFunP) 673 | , ("first keeps composition", property firstKeepCompP) 674 | , ("first works as fst" , property firstIsFstP) 675 | , ("second can move" , property secondMovesP) 676 | ] 677 | ) 678 | where 679 | assocP :: a b c -> a c d -> a d e -> Property 680 | assocP f g h = ((f >>> g) >>> h) =-= (f >>> (g >>> h)) 681 | 682 | arrDistributesP :: (b -> c) -> (c -> d) -> Property 683 | arrDistributesP f g = ((arr (f >>> g)) :: a b d) =-= (arr f >>> arr g) 684 | 685 | firstAsFunP :: (b -> c) -> Property 686 | firstAsFunP f = (first (arr f) :: a (b,d) (c,d)) =-= arr (first f) 687 | 688 | firstKeepCompP :: a b c -> a c d -> Property 689 | firstKeepCompP f g = 690 | ((first (f >>> g)) :: (a (b,e) (d,e))) =-= (first f >>> first g) 691 | 692 | firstIsFstP :: a b c -> Property 693 | firstIsFstP f = ((first f :: a (b,d) (c,d)) >>> arr fst) 694 | =-= (arr fst >>> f) 695 | 696 | secondMovesP :: (a b c) -> (d -> e) -> Property 697 | secondMovesP f g = (first f >>> second (arr g)) 698 | =-= ((second (arr g)) >>> first f) 699 | 700 | arrowChoice :: forall a b c d e. 701 | ( ArrowChoice a 702 | , Show (a b c) 703 | , Arbitrary (a b c) 704 | , Arbitrary c, Arbitrary e 705 | , CoArbitrary b, CoArbitrary d 706 | , EqProp (a (Either b d) (Either c e)) 707 | , EqProp (a (Either b d) (Either c d)) 708 | ) => 709 | a b (c,d,e) -> TestBatch 710 | arrowChoice = const ("arrow choice laws" 711 | , [ ("left works as funs", property leftAsFunP) 712 | , ("right can move" , property rightMovesP) 713 | ] 714 | ) 715 | where 716 | leftAsFunP :: (b -> c) -> Property 717 | leftAsFunP f = (left (arr f) :: a (Either b d) (Either c d)) 718 | =-= arr (left f) 719 | 720 | rightMovesP :: (a b c) -> (d -> e) -> Property 721 | rightMovesP f g = (left f >>> right (arr g)) 722 | =-= ((right (arr g)) >>> left f) 723 | 724 | traversable :: forall t a b c m f g. 725 | ( Traversable t, Applicative f, Applicative g, Monoid m 726 | , Arbitrary (t a), Arbitrary (t b), Arbitrary (f b), Arbitrary (g c) 727 | , Arbitrary (t (f (g a))) 728 | , Arbitrary m, Arbitrary b 729 | , CoArbitrary a, CoArbitrary b 730 | , Show (t a), Show (t b), Show (t (f (g a))) 731 | , EqProp (t b), EqProp m, EqProp (f (g (t a))), EqProp (f (g (t c)))) => t (f a, g b, c, m) 732 | -> TestBatch 733 | traversable = const ( "Traversable" 734 | , [ ("identity", property identityP) 735 | , ("composition", property compositionP) 736 | -- , ("naturality", property $ \(f :: f Int -> g Int) -> naturalityP f) 737 | , ("fmap", property fmapP) 738 | , ("foldMap", property foldMapP) 739 | , ("sequenceA identity", property sequenceIdentityP) 740 | , ("sequenceA composition", property sequenceCompositionP) 741 | -- , ("sequenceA naturality", property $ \(f :: f a -> g a) -> sequenceNaturalityP f) 742 | ] 743 | ) 744 | where 745 | identityP :: Property 746 | identityP = traverse @t @_ @b Identity =-= Identity 747 | 748 | compositionP :: (a -> f b) -> (b -> g c) -> Property 749 | compositionP f g = traverse @t (Compose . fmap g . f) =-= Compose . fmap (traverse g) . traverse f 750 | 751 | --FIXME: Does not compile due to rank2 type. 752 | --naturalityP :: (forall x. (f x -> g x)) -> (a -> f b) -> Property 753 | --naturalityP t f = t . traverse @t f =-= traverse (t . f) 754 | 755 | fmapP :: (a -> b) -> t a -> Property 756 | fmapP f x = f `fmap` x =-= f `fmapDefault` x 757 | 758 | foldMapP :: (a -> m) -> t a -> Property 759 | foldMapP f x = f `foldMap` x =-= (f `foldMapDefault` x :: m) 760 | 761 | sequenceIdentityP :: Property 762 | sequenceIdentityP = sequenceA @t @_ @b . fmap Identity =-= Identity 763 | 764 | sequenceCompositionP :: Property 765 | sequenceCompositionP = sequenceA @t @(Compose f g) @a . fmap Compose =-= Compose . fmap sequenceA . sequenceA 766 | 767 | --FIXME: Does not compile due to rank2 type. 768 | --sequenceNaturalityP :: (forall x. (f x -> g x)) -> Property 769 | --sequenceNaturalityP t = t . sequenceA @t @_ @a =-= sequenceA . fmap t 770 | 771 | -- | Note that 'foldable' doesn't check the strictness of 'foldl'', `foldr'' and `foldMap''. 772 | -- 773 | -- @since 0.4.13 774 | 775 | -- The (Arbitrary m) constraint is required with base >= 4.13, where we have an 776 | -- additional property for checking foldMap'. 777 | foldable :: forall t a b m n o. 778 | ( Foldable t 779 | , CoArbitrary a, CoArbitrary b 780 | , Arbitrary a, Arbitrary b, Arbitrary m, Arbitrary o, Arbitrary (t a), Arbitrary (t m), Arbitrary (t n), Arbitrary (t o) 781 | , Monoid m 782 | , Num n 783 | , Ord o 784 | , EqProp m, EqProp n, EqProp b, EqProp o, EqProp a 785 | , Show (t m), Show (t n), Show (t o), Show b, Show (t a), Show o) => 786 | t (a, b, m, n, o) -> TestBatch 787 | foldable = const ( "Foldable" 788 | , [ ("foldr and foldMap", property foldrFoldMapP) 789 | , ("foldl and foldMap", property foldlFoldMapP) 790 | , ("fold and foldMap", property foldFoldMapP) 791 | , ("length", property lengthP) 792 | #if MIN_VERSION_base(4,13,0) 793 | , ("foldMap'", property foldMap'P) 794 | #endif 795 | , ("foldr'", property foldr'P) 796 | , ("foldl'", property foldl'P) 797 | , ("foldr1", property foldr1P) 798 | , ("foldl1", property foldl1P) 799 | , ("toList", property toListP) 800 | , ("null", property nullP) 801 | , ("elem", property elemP) 802 | , ("maximum", property maximumP) 803 | , ("minimum", property minimumP) 804 | , ("sum", property sumP) 805 | , ("product", property productP) 806 | ] 807 | ) 808 | where 809 | foldrFoldMapP :: (a -> b -> b) -> b -> t a -> Property 810 | foldrFoldMapP f z t = foldr f z t =-= appEndo (foldMap (Endo . f) t ) z 811 | foldlFoldMapP :: (b -> a -> b) -> b -> t a -> Property 812 | foldlFoldMapP f z t = foldl f z t =-= appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z 813 | foldFoldMapP :: t m -> Property 814 | foldFoldMapP t = fold t =-= foldMap id t 815 | lengthP :: t a -> Property 816 | lengthP t = length t =-= (getSum . foldMap (Sum . const 1)) t 817 | #if MIN_VERSION_base(4,13,0) 818 | -- TODO: Check strictness 819 | foldMap'P :: (a -> m) -> t a -> Property 820 | foldMap'P f t = foldMap' f t =-= foldl' (\acc a -> acc <> f a) mempty t 821 | #endif 822 | sumP :: t n -> Property 823 | sumP t = sum t =-= (getSum . foldMap Sum) t 824 | productP :: t n -> Property 825 | productP t = product t =-= (getProduct . foldMap Product) t 826 | maximumP :: t o -> Property 827 | maximumP t = not (null t) ==> maximum t =-= maximum (toList t) 828 | minimumP :: t o -> Property 829 | minimumP t = not (null t) ==> minimum t =-= minimum (toList t) 830 | foldr1P :: (a -> a -> a) -> t a -> Property 831 | foldr1P f t = not (null t) ==> foldr1 f t =-= foldr1 f (toList t) 832 | foldl1P :: (a -> a -> a) -> t a -> Property 833 | foldl1P f t = not (null t) ==> foldl1 f t =-= foldl1 f (toList t) 834 | toListP :: t a -> Property 835 | toListP t = toList t =-= foldr (:) [] t 836 | nullP :: t a -> Property 837 | nullP t = null t =-= foldr (const (const False)) True t 838 | -- TODO: Check strictness 839 | foldr'P :: (a -> b -> b) -> b -> t a -> Property 840 | foldr'P f z t = foldr' f z t =-= foldr' f z (toList t) 841 | -- TODO: Check strictness 842 | foldl'P :: (b -> a -> b) -> b -> t a -> Property 843 | foldl'P f z t = foldl' f z t =-= foldl' f z (toList t) 844 | elemP :: o -> t o -> Property 845 | elemP o t = elem o t =-= elem o (toList t) 846 | 847 | -- | @since 0.4.13 848 | foldableFunctor :: forall t a m. 849 | ( Functor t, Foldable t 850 | , CoArbitrary a 851 | , Arbitrary m, Arbitrary (t a) 852 | , EqProp m 853 | , Monoid m 854 | , Show (t a)) => 855 | t (a, m) -> TestBatch 856 | foldableFunctor = const ( "Foldable Functor" 857 | , [ ("foldMap f = fold . fmap f", property foldMapP) ] 858 | ) 859 | where 860 | foldMapP :: (a -> m) -> t a -> Property 861 | foldMapP f t = foldMap f t =-= fold (fmap f t) 862 | 863 | -- | @since 0.5.7 864 | bifoldable :: forall p a b c m. 865 | ( Bifoldable p, Monoid m 866 | , Show (p a b), Show (p m m) 867 | , Arbitrary (p a b), Arbitrary (p m m), Arbitrary m 868 | , CoArbitrary a, CoArbitrary b 869 | , EqProp m, EqProp c, CoArbitrary c, Arbitrary c, Show c) => 870 | p a (b, c, m) -> TestBatch 871 | bifoldable = const ( "Bifoldable" 872 | , [ ("identity", property identityP) 873 | , ("bifoldMap f g ≡ bifoldr (mappend . f) (mappend . g) mempty", property bifoldMapBifoldrP) 874 | , ("bifoldr f g z t ≡ appEndo (bifoldMap (Endo . f) (Endo . g) t) z", property bifoldrBifoldMapP) 875 | ] 876 | ) 877 | where 878 | identityP :: Property 879 | identityP = bifold =-= (bifoldMap id id :: p m m -> m) 880 | 881 | bifoldMapBifoldrP :: (a -> m) -> (b -> m) -> Property 882 | bifoldMapBifoldrP f g = bifoldMap f g =-= (bifoldr (mappend . f) (mappend . g) mempty :: p a b -> m) 883 | 884 | bifoldrBifoldMapP :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> Property 885 | bifoldrBifoldMapP f g z t = bifoldr f g z t =-= appEndo (bifoldMap (Endo . f) (Endo . g) t) z 886 | 887 | -- | @since 0.5.7 888 | bifoldableBifunctor :: forall p a b m. 889 | ( Bifoldable p, Bifunctor p, Monoid m 890 | , Show (p a b) 891 | , Arbitrary (p a b), Arbitrary m, CoArbitrary a, CoArbitrary b 892 | , EqProp m) => 893 | p a (b, m) -> TestBatch 894 | bifoldableBifunctor = const ( "Bifoldable Bifunctor" 895 | , [ ("bifoldMap f g ≡ bifold . bimap f g", property bifoldBimapP) ] 896 | ) 897 | where 898 | bifoldBimapP :: (a -> m) -> (b -> m) -> Property 899 | bifoldBimapP f g = bifoldMap f g =-= (bifold . bimap f g :: p a b -> m) 900 | 901 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Instances.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} 2 | module Test.QuickCheck.Instances 3 | (module Test.QuickCheck.Instances.Char 4 | ,module Test.QuickCheck.Instances.Eq 5 | ,module Test.QuickCheck.Instances.List 6 | ,module Test.QuickCheck.Instances.Maybe 7 | ,module Test.QuickCheck.Instances.Num 8 | ,module Test.QuickCheck.Instances.Ord 9 | ,module Test.QuickCheck.Instances.Tuple 10 | ) where 11 | 12 | import Test.QuickCheck.Instances.Array () 13 | import Test.QuickCheck.Instances.Char 14 | import Test.QuickCheck.Instances.Eq 15 | import Test.QuickCheck.Instances.List 16 | import Test.QuickCheck.Instances.Maybe 17 | import Test.QuickCheck.Instances.Num 18 | import Test.QuickCheck.Instances.Ord 19 | import Test.QuickCheck.Instances.Tuple 20 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Instances/Array.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} 3 | 4 | module Test.QuickCheck.Instances.Array where 5 | 6 | import Test.QuickCheck 7 | import Data.Array 8 | 9 | instance (Ix a, Integral a, Arbitrary b) => Arbitrary (Array a b) where 10 | arbitrary = 11 | (\x -> listArray (0,fromIntegral (length x - 1)) x) <$> arbitrary 12 | 13 | instance (CoArbitrary b) => CoArbitrary (Array a b) where 14 | coarbitrary = coarbitrary . elems 15 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Instances/Char.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.Instances.Char 2 | (nonSpace,whitespace,space,newline 3 | ,lowerAlpha,upperAlpha,numeric 4 | ,parenthesis,bracket,brace 5 | ,operator 6 | ) where 7 | 8 | import Data.Char 9 | import Test.QuickCheck 10 | import Test.QuickCheck.Instances.Eq 11 | 12 | -- instance Arbitrary Char where 13 | -- arbitrary = choose ('\0','\255') 14 | -- coarbitrary = variant . ord 15 | 16 | -- instance Arbitrary Char where 17 | -- arbitrary = choose ('\0','\255') 18 | 19 | -- instance CoArbitrary Char where 20 | -- coarbitrary = variant . ord 21 | 22 | -- Bob: why the `rem` 4 ? 23 | 24 | {- | Generates a 'non space' character, i.e. any ascii except 25 | ' ', '\t', '\n' and '\r'. 26 | -} 27 | nonSpace :: Gen Char 28 | nonSpace = notOneof " \t\n\r" 29 | 30 | {- | Generates any whitespace character, including new lines. 31 | -} 32 | whitespace :: Gen Char 33 | whitespace = oneof [space,newline] 34 | 35 | {- | Generates a whitespace charecter, not a newline. 36 | -} 37 | space :: Gen Char 38 | space = oneof (map return " \t") 39 | 40 | {- | Generates either a '\n' or '\r'. 41 | -} 42 | newline :: Gen Char 43 | newline = oneof (map return "\n\r") 44 | 45 | letters :: String 46 | letters = "abcdefghijklmnopqrstuvwxyz" 47 | 48 | {- | Generates any lower case alpha character. 49 | -} 50 | lowerAlpha :: Gen Char 51 | lowerAlpha = oneof (map return letters) 52 | 53 | {- | Generates any upper case alpha character. 54 | -} 55 | upperAlpha :: Gen Char 56 | upperAlpha = oneof (map (return . toUpper) letters) 57 | 58 | {- | Generates a digit character. 59 | -} 60 | numeric :: Gen Char 61 | numeric = oneof (map return "1234567890") 62 | 63 | {- | Generates one or other of '(' and ')'. 64 | -} 65 | parenthesis :: Gen Char 66 | parenthesis = oneof (map return "()") 67 | 68 | {- | Generates one or other of '[' and ']'. 69 | -} 70 | bracket :: Gen Char 71 | bracket = oneof (map return "[]") 72 | 73 | {- | Generates one or other of '{' and '}'. 74 | -} 75 | brace :: Gen Char 76 | brace = oneof (map return "{}") 77 | 78 | {- | Generates one of '*', '/', '-', '+', '<', '>', '|' and '#'. 79 | -} 80 | operator :: Gen Char 81 | operator = oneof (map return "*/-+<>|#") 82 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Instances/Eq.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.Instances.Eq (notEqualTo, notOneof) where 2 | 3 | import Test.QuickCheck 4 | import Test.QuickCheck.Checkers 5 | import Control.Monad.Extensions 6 | 7 | notEqualTo :: (Eq a) => a -> Gen a -> Gen a 8 | notEqualTo v = satisfiesM (/= v) 9 | 10 | notOneof :: (Eq a,Arbitrary a) => [a] -> Gen a 11 | notOneof es = arbitrarySatisfying (not . (`elem` es)) 12 | 13 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Instances/List.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.Instances.List 2 | (anyList,nonEmpty 3 | ,infiniteList 4 | ,setLength 5 | ,increasing,nondecreasing 6 | ,increasingInf,nondecreasingInf 7 | ,decreasing,nonincreasing 8 | ,decreasingInf,nonincreasingInf 9 | ) where 10 | 11 | import Test.QuickCheck hiding (infiniteList) 12 | import Test.QuickCheck.Instances.Num 13 | import Control.Applicative 14 | 15 | {- | Generates a non-empty list with the contents generated using its 16 | argument. 17 | -} 18 | nonEmpty :: Gen a -> Gen [a] 19 | nonEmpty x = liftA2 (:) x (anyList x) 20 | 21 | {- | Generates any list (possibly empty) with the contents generated using 22 | its argument. 23 | -} 24 | anyList :: Gen a -> Gen [a] 25 | anyList x = frequency [(1, pure []), (4, nonEmpty x)] 26 | 27 | {- | Generates an infinite list with contents generated using its argument 28 | -} 29 | infiniteList :: Gen a -> Gen [a] 30 | infiniteList x = liftA2 (:) x (infiniteList x) 31 | 32 | {- | Generates a list with a set length 33 | -} 34 | setLength :: Int -> Gen a -> Gen [a] 35 | setLength 0 _ = pure [] 36 | setLength n g = (:) <$> g <*> setLength (n-1) g 37 | 38 | sumA :: (Applicative f, Num a) => f a -> f [a] -> f [a] 39 | sumA = liftA2 (scanl (+)) 40 | 41 | monotonic_ :: (Arbitrary a, Num a) => (Gen a -> Gen [a]) -> Gen a -> Gen [a] 42 | monotonic_ listGen gen = sumA arbitrary (listGen gen) 43 | 44 | -- TODO: Generalise this to Ord a. 45 | monotonic :: (Arbitrary a, Num a) => Gen a -> Gen [a] 46 | monotonic gen = monotonic_ anyList gen 47 | 48 | -- | Generate increasing towards infinity 49 | increasing :: (Arbitrary a, Eq a, Num a) => Gen [a] 50 | increasing = monotonic positive 51 | 52 | -- | Generate an infinite list of increasing values 53 | increasingInf :: (Arbitrary a, Eq a, Num a) => Gen [a] 54 | increasingInf = monotonic_ infiniteList positive 55 | 56 | -- | Generate nondecreasing values 57 | nondecreasing :: (Arbitrary a, Num a) => Gen [a] 58 | nondecreasing = monotonic nonNegative 59 | 60 | -- | Generate an infinite list of nondecreasing values 61 | nondecreasingInf :: (Arbitrary a, Num a) => Gen [a] 62 | nondecreasingInf = monotonic_ infiniteList nonNegative 63 | 64 | -- | Generate increasing towards infinity 65 | decreasing :: (Arbitrary a, Eq a, Num a) => Gen [a] 66 | decreasing = monotonic negative 67 | 68 | -- | Generate an infinite list of increasing values 69 | decreasingInf :: (Arbitrary a, Eq a, Num a) => Gen [a] 70 | decreasingInf = monotonic_ infiniteList negative 71 | 72 | -- | Generate nondecreasing values 73 | nonincreasing :: (Arbitrary a, Num a) => Gen [a] 74 | nonincreasing = monotonic nonPositive 75 | 76 | -- | Generate an infinite list of nondecreasing values 77 | nonincreasingInf :: (Arbitrary a, Num a) => Gen [a] 78 | nonincreasingInf = monotonic_ infiniteList nonPositive 79 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Instances/Maybe.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.Instances.Maybe (maybeGen) where 2 | 3 | import Test.QuickCheck 4 | 5 | maybeGen :: Gen a -> Gen (Maybe a) 6 | maybeGen x = oneof [pure Nothing 7 | ,Just <$> x] 8 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Instances/Num.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.Instances.Num 2 | (nonNegative,nonPositive 3 | ,negative,positive 4 | ,nonZero,nonZero_ 5 | ) where 6 | 7 | import Test.QuickCheck 8 | import Control.Monad.Extensions 9 | 10 | nonNegative :: (Num a, Arbitrary a) => Gen a 11 | nonNegative = abs <$> arbitrary 12 | 13 | positive :: (Eq a, Num a, Arbitrary a) => Gen a 14 | positive = nonZero nonNegative 15 | 16 | nonPositive :: (Num a, Arbitrary a) => Gen a 17 | nonPositive = negate <$> nonNegative 18 | 19 | negative :: (Eq a, Num a, Arbitrary a) => Gen a 20 | negative = negate <$> positive 21 | 22 | nonZero :: (Eq a, Num a) => Gen a -> Gen a 23 | nonZero g = 24 | sized (\s -> satisfiesM (/= 0) (if (s == 0) then (resize 1 g) else g)) 25 | 26 | nonZero_ :: (Eq a, Num a, Arbitrary a) => Gen a 27 | nonZero_ = nonZero arbitrary 28 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Instances/Ord.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.Instances.Ord where 2 | 3 | import Test.QuickCheck 4 | import Control.Monad.Extensions 5 | 6 | greaterThan :: (Ord a) => a -> Gen a -> Gen a 7 | greaterThan v = satisfiesM (> v) 8 | 9 | lessThan :: (Ord a) => a -> Gen a -> Gen a 10 | lessThan v = satisfiesM (< v) 11 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Instances/Tuple.hs: -------------------------------------------------------------------------------- 1 | module Test.QuickCheck.Instances.Tuple where 2 | 3 | import Test.QuickCheck 4 | import Control.Monad 5 | 6 | {- | Generates a 2-tuple using its arguments to generate the parts. 7 | -} 8 | (>*<) :: Gen a -> Gen b -> Gen (a,b) 9 | x >*< y = liftM2 (,) x y 10 | 11 | {- | Generates a 3-tuple using its arguments to generate the parts. 12 | -} 13 | (>**<) :: Gen a -> Gen b -> Gen c -> Gen (a,b,c) 14 | (>**<) x y z = liftM3 (,,) x y z 15 | 16 | {- | Generates a 4-tuple using its arguments to generate the parts. 17 | -} 18 | (>***<) :: Gen a -> Gen b -> Gen c -> Gen d -> Gen (a,b,c,d) 19 | (>***<) x y z a = liftM4 (,,,) x y z a 20 | 21 | {- | Generates a 5-tuple using its arguments to generate the parts. 22 | -} 23 | (>****<) :: Gen a -> Gen b -> Gen c -> Gen d -> Gen e -> Gen (a,b,c,d,e) 24 | (>****<) x y z a b= liftM5 (,,,,) x y z a b 25 | 26 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Later.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | ---------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Later 5 | -- Copyright : (c) David Sankel 2008 6 | -- License : BSD3 7 | -- 8 | -- Maintainer : david@sankelsoftware.com 9 | -- Stability : experimental 10 | -- 11 | -- Later. Allows for testing of functions that depend on the order of 12 | -- evaluation. 13 | -- 14 | -- TODO: move this functionality to the testing package for Unamb. 15 | ---------------------------------------------------------------------- 16 | 17 | module Test.QuickCheck.Later 18 | ( isAssocTimes 19 | , isCommutTimes 20 | , delay 21 | , delayForever 22 | ) where 23 | 24 | import Test.QuickCheck.Checkers 25 | import Test.QuickCheck 26 | 27 | import System.Random (Random) 28 | 29 | import System.IO.Unsafe 30 | import Control.Concurrent 31 | import Control.Monad (forever) 32 | 33 | -- Generate a random delay up to given max seconds for a property. 34 | delayP :: (Show t, Num t, System.Random.Random t, Testable b) => t -> (t -> b) -> Property 35 | delayP d = forAll (genR (0,d)) 36 | 37 | -- | Is the given function commutative when restricted to the same value 38 | -- but possibly different times? 39 | isCommutTimes :: (EqProp b, Arbitrary a, Show a) => Double -> (a -> a -> b) -> Property 40 | 41 | isCommutTimes d (#) = 42 | delayP d $ \ t1 -> 43 | delayP d $ \ t2 -> 44 | \ v -> let del = flip delay v in 45 | del t1 # del t2 =-= del t2 # del t1 46 | 47 | -- Note that we delay v by t1 and by t2 twice. 48 | -- 49 | -- TODO: make sure CSE isn't kicking in. Examine the core code. 50 | 51 | -- | Is the given function associative when restricted to the same value 52 | -- but possibly different times? 53 | isAssocTimes :: (EqProp a, Arbitrary a, Show a) => Double -> (a -> a -> a) -> Property 54 | 55 | isAssocTimes d (#) = 56 | delayP d $ \ t1 -> 57 | delayP d $ \ t2 -> 58 | delayP d $ \ t3 -> 59 | \ v -> let del = flip delay v in 60 | (del t1 # del t2) # del t3 =-= del t1 # (del t2 # del t3) 61 | 62 | 63 | -- The value eventually returned by an action. Probably handy elsewhere. 64 | -- TODO: what are the necessary preconditions in order to make this 65 | -- function referentially transparent? 66 | eventually :: IO a -> a 67 | eventually = unsafePerformIO . unsafeInterleaveIO 68 | 69 | -- Why unsafeInterleaveIO? Because ... 70 | 71 | -- | Delay a value's availability by the given duration in seconds. 72 | -- Note that the delay happens only on the first evaluation. 73 | delay :: RealFrac t => t -> a -> a 74 | delay d a = eventually $ threadDelay (round (1.0e6 * d)) >> return a 75 | 76 | -- | A value that is never available. Rerun of @hang@ from unamb, but 77 | -- replicated to avoid mutual dependency. 78 | -- 79 | -- TODO: Remove when this module is moved into the unamb-test package. 80 | delayForever :: a 81 | delayForever = unsafePerformIO $ do _ <- forever (threadDelay maxBound) 82 | return undefined 83 | -------------------------------------------------------------------------------- /src/Test/QuickCheck/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wall #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Test.QuickCheck.Utils 5 | -- Copyright : (c) Andy Gill 2001 6 | -- License : BSD-style (see the file libraries/base/LICENSE) 7 | -- 8 | -- Maintainer : libraries@haskell.org 9 | -- Stability : experimental 10 | -- Portability : portable 11 | -- 12 | -- These are some general purpose utilities for use with QuickCheck. 13 | -- 14 | -- Copied from QuickCheck 1.2.0.0. Doesn't appear in 2.x 15 | ----------------------------------------------------------------------------- 16 | 17 | module Test.QuickCheck.Utils 18 | ( isAssociativeBy 19 | , isAssociative 20 | , isCommutableBy 21 | , isCommutable 22 | , isTotalOrder 23 | ) where 24 | 25 | import Prelude 26 | 27 | import Test.QuickCheck 28 | 29 | isAssociativeBy :: (Show a,Testable prop) 30 | => (a -> a -> prop) -> Gen a -> (a -> a -> a) -> Property 31 | isAssociativeBy (=~=) src (#) = 32 | forAll src $ \ a -> 33 | forAll src $ \ b -> 34 | forAll src $ \ c -> 35 | ((a # b) # c) =~= (a # (b # c)) 36 | 37 | isAssociative :: (Arbitrary a,Show a,Eq a) => (a -> a -> a) -> Property 38 | isAssociative = isAssociativeBy (==) arbitrary 39 | 40 | isCommutableBy :: (Show a,Testable prop) 41 | => (b -> b -> prop) -> Gen a -> (a -> a -> b) -> Property 42 | isCommutableBy (=~=) src (#) = 43 | forAll src $ \ a -> 44 | forAll src $ \ b -> 45 | (a # b) =~= (b # a) 46 | 47 | isCommutable :: (Arbitrary a,Show a,Eq b) => (a -> a -> b) -> Property 48 | isCommutable = isCommutableBy (==) arbitrary 49 | 50 | isTotalOrder :: (Ord a) => a -> a -> Property 51 | isTotalOrder x y = 52 | classify (x > y) "less than" $ 53 | classify (x == y) "equals" $ 54 | classify (x < y) "greater than" $ 55 | x < y || x == y || x > y 56 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | 3 | # resolver: lts-6.35 # ghc-7.10.3 4 | # resolver: lts-9.21 # ghc-8.0.2 5 | # resolver: lts-11.22 # ghc-8.2.2 6 | # resolver: lts-12.19 # ghc-8.4.4 7 | # resolver: lts-13.0 # ghc-8.6.3 8 | # resolver: lts-13.13 # ghc-8.6.4 9 | resolver: lts-14.6 # ghc-8.6.5 10 | -------------------------------------------------------------------------------- /todo.txt: -------------------------------------------------------------------------------- 1 | To-do for Checkers 2 | 3 | + The two-level notion of test batches in Checkers is proving 4 | inconvenient. Change to hierarchical. Example of a hierarchy path: 5 | Data.Reactive, Reactive type, applicative laws, Homomorphism. 6 | 7 | + Rename "Help" to something more descriptive. 8 | 9 | + Generalize monoidMorphism to take a function generator instead of a 10 | single function. Use it to define property that says that 'fmap f' is a 11 | monoid morphism for all f. 12 | --------------------------------------------------------------------------------