├── .github └── workflows │ └── build.yml ├── .gitignore ├── CREDITS.md ├── LICENSE ├── Makefile ├── README.md ├── Setup.hs ├── TODO.md ├── bench ├── AVLTree.hs ├── Digraph.hs ├── Heap.hs ├── Set.hs ├── avltrees.hs ├── bools.hs ├── digraphs.hs ├── haskell-src-exts.hs ├── haskell-src.hs ├── heaps.hs ├── id.hs ├── list.hs ├── mergeheaps.hs ├── pretty.hs ├── sets.hs ├── setsofsets.hs ├── sieve.hs ├── sorting.hs └── spring.hs ├── doc ├── fitspec.svg ├── modules.md └── tutorial-property-creation.md ├── eg ├── Makefile ├── alga.hs ├── negation.hs └── sorting.hs ├── fitspec.cabal ├── mk ├── depend.mk ├── ghcdeps ├── haddock-i ├── haskell.mk └── install-on ├── src └── Test │ ├── FitSpec.hs │ └── FitSpec │ ├── Derive.hs │ ├── Dot.hs │ ├── Engine.hs │ ├── Main.hs │ ├── Mutable.hs │ ├── Mutable │ └── Tuples.hs │ ├── PrettyPrint.hs │ ├── Report.hs │ ├── ShowMutable.hs │ ├── ShowMutable │ └── Tuples.hs │ ├── TestTypes.hs │ └── Utils.hs ├── stack.yaml └── test ├── derive.hs ├── mutate.hs ├── sdist ├── showmutable.hs └── utils.hs /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | # Builds and tests this Haskell project on "GitHub Actions" 2 | # 3 | # 2021-2024 Rudy Matela 4 | # 5 | # some docs: https://github.com/haskell-actions/setup 6 | # 7 | # The official haskell docker image: https://hub.docker.com/_/haskell 8 | name: build 9 | on: [push] 10 | jobs: 11 | build-and-test: 12 | runs-on: ubuntu-latest 13 | steps: 14 | - run: git --version 15 | - run: make --version 16 | - run: ghc --version 17 | - run: cabal --version 18 | 19 | - name: Check out repository 20 | uses: actions/checkout@v3 21 | 22 | # check out needs to happen before cache so that hashing works 23 | - name: Cache hash 24 | run: echo Cache hash = ${{ hashFiles('*.cabal') }} 25 | 26 | - name: Cache cabal (source) packages 27 | uses: actions/cache@v3 28 | with: 29 | path: | 30 | ~/.cabal/packages 31 | ~/.cache/cabal 32 | key: v1-${{ runner.os }}-cabal-packages-${{ hashFiles('*.cabal') }} 33 | restore-keys: v1-${{ runner.os }}-cabal-packages- 34 | 35 | - name: Cache installed cabal packages 36 | uses: actions/cache@v3 37 | with: 38 | path: | 39 | ~/.cabal 40 | !~/.cabal/packages 41 | ~/.config/cabal 42 | ~/.local/state/cabal 43 | ~/.ghc 44 | key: v1-${{ runner.os }}-cabal-ghc-latest-${{ hashFiles('*.cabal') }} 45 | restore-keys: v1-${{ runner.os }}-cabal-ghc-latest-${{ hashFiles('*.cabal') }} 46 | # restore with exact match has some versions of cabal have trouble updating 47 | 48 | - run: haddock --version || sudo apt-get install ghc-haddock 49 | # blank line 50 | # blank line for alignment with matrix scripts 51 | 52 | - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true 53 | 54 | - run: ghc-pkg list 55 | - run: make install-dependencies 56 | - run: ghc-pkg list 57 | 58 | - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true 59 | 60 | - run: make 61 | - run: make test 62 | - run: make haddock 63 | - run: make test-sdist 64 | - run: make test-via-cabal 65 | 66 | 67 | test-with-ghc: 68 | strategy: 69 | max-parallel: 6 70 | matrix: 71 | # starting with 9.10, docker/_/haskell requires -bullseye as suffix 72 | ghc: 73 | - '9.10-bullseye' 74 | - '9.8' 75 | - '9.6' 76 | - '9.4' 77 | - '9.2' 78 | - '9.0' 79 | - '8.8' 80 | runs-on: ubuntu-latest 81 | needs: build-and-test 82 | container: haskell:${{ matrix.ghc }} 83 | steps: 84 | - run: git --version || true # git is missing in some images 85 | - run: make --version || true # make is missing in some images 86 | - run: ghc --version 87 | - run: cabal --version 88 | 89 | - name: Check out repository 90 | uses: actions/checkout@v3 91 | 92 | # check out needs to happen before cache so that hashing works 93 | - name: Cache hash 94 | run: echo Cache hash = ${{ hashFiles('*.cabal') }} 95 | 96 | - name: Cache cabal (source) packages 97 | uses: actions/cache@v3 98 | with: 99 | path: | 100 | ~/.cabal/packages 101 | ~/.cache/cabal 102 | key: v1-${{ runner.os }}-cabal-packages-${{ hashFiles('*.cabal') }} 103 | restore-keys: v1-${{ runner.os }}-cabal-packages- 104 | 105 | - name: Cache installed cabal packages 106 | uses: actions/cache@v3 107 | with: 108 | path: | 109 | ~/.cabal 110 | !~/.cabal/packages 111 | ~/.config/cabal 112 | ~/.local/state/cabal 113 | ~/.ghc 114 | key: v1-${{ runner.os }}-cabal-ghc-${{ matrix.ghc }}-${{ hashFiles('*.cabal') }} 115 | restore-keys: v1-${{ runner.os }}-cabal-ghc-${{ matrix.ghc }}-${{ hashFiles('*.cabal') }} 116 | # restore with exact match has some versions of cabal have trouble updating 117 | 118 | - run: make --version || rm /etc/apt/sources.list.d/*.list # faster update 119 | - run: make --version || apt-get update 120 | - run: make --version || apt-get install make 121 | 122 | - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true 123 | 124 | - run: ghc-pkg list 125 | - run: make install-dependencies 126 | - run: ghc-pkg list 127 | 128 | - run: du -hd3 ~/.ghc ~/.cabal ~/.config/cabal ~/.cache/cabal ~/.local/state/cabal || true 129 | 130 | - run: make 131 | - run: make test 132 | - run: make haddock 133 | - run: make test-sdist 134 | - run: make test-via-cabal 135 | 136 | test-with-stack: 137 | runs-on: ubuntu-latest 138 | needs: build-and-test 139 | steps: 140 | - name: Check out repository 141 | uses: actions/checkout@v3 142 | 143 | # check out needs to happen before cache so that hashing works 144 | - name: Cache hash 145 | run: echo Cache hash = ${{ hashFiles('stack.yaml') }} 146 | 147 | - name: Cache stack folder 148 | uses: actions/cache@v3 149 | with: 150 | path: ~/.stack 151 | key: v1-${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }} 152 | restore-keys: v1-${{ runner.os }}-stack- 153 | 154 | - name: Cache ghcup folder 155 | uses: actions/cache@v3 156 | with: 157 | path: | 158 | ~/.ghcup 159 | /usr/local/.ghcup/bin 160 | /usr/local/.ghcup/db 161 | /usr/local/.ghcup/ghc/9.4.8 162 | key: v1-${{ runner.os }}-ghcup-${{ hashFiles('stack.yaml') }} 163 | restore-keys: v1-${{ runner.os }}-ghcup- 164 | 165 | - name: Setup Haskell's GHC and Cabal as required by current Stackage LTS 166 | uses: haskell-actions/setup@v2 167 | with: # lts-21.25 168 | ghc-version: '9.4.8' 169 | cabal-version: '3.8' 170 | 171 | - run: du -hd2 ~/.stack ~/.ghcup /usr/local/.ghcup || true 172 | 173 | - run: stack --version 174 | 175 | - run: make test-via-stack 176 | 177 | - run: du -hd2 ~/.stack ~/.ghcup /usr/local/.ghcup || true 178 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # cabal stuff 2 | **/dist 3 | dist-newstyle 4 | **/cabal.sandbox.config 5 | **/.cabal-sandbox 6 | .stack-work 7 | stack.yaml.lock 8 | mk/toplibs 9 | 10 | # vim stuff 11 | **.swp 12 | **.swo 13 | 14 | # ctags stuff 15 | **/TAGS 16 | **/tags 17 | 18 | # ghc object (when compiled directly) 19 | **/*.o 20 | **/*.hi 21 | **/*.dyn_o 22 | **/*.dyn_hi 23 | 24 | # benchmark binaries 25 | bench/avltrees 26 | bench/bools 27 | bench/heaps 28 | bench/mergeheaps 29 | bench/id 30 | bench/list 31 | bench/pretty 32 | bench/sets 33 | bench/setsofsets 34 | bench/sieve 35 | bench/sorting 36 | bench/spring 37 | bench/digraphs 38 | bench/haskell-src 39 | bench/haskell-src-exts 40 | eg/sorting 41 | eg/negation 42 | eg/alga 43 | 44 | # test binaries 45 | test/mutate 46 | test/showmutable 47 | test/derive 48 | test/utils 49 | 50 | # Haddock 51 | doc/**/*.html 52 | doc/**/*.css 53 | doc/**/*.js 54 | doc/**/*.png 55 | doc/**/*.gif 56 | doc/**/*.json 57 | -------------------------------------------------------------------------------- /CREDITS.md: -------------------------------------------------------------------------------- 1 | Credits 2 | ======= 3 | 4 | Rudy Matela: 5 | original implementation of FitSpec. 6 | 7 | Colin Runciman: 8 | improvements in library interface and code; 9 | set and digraph examples; 10 | the name "FitSpec". 11 | 12 | Thanks to: 13 | 14 | * Jonas Duregård 15 | for presenting a black-box mutation testing technique at HIW2014 16 | inspiring me (Rudy) to start working on it 17 | (cf. https://www.youtube.com/watch?v=ROKxri62WYQ); 18 | for discussions; 19 | for an alternative way to enumerate mutants (see patterns folder). 20 | 21 | * Nick Smallbone 22 | for the "Heap" example (adapted from the QuickSpec tool package). 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2017, Rudy Matela 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Rudy Matela nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for FitSpec 2 | # 3 | # Copyright: (c) 2015-2020 Rudy Matela 4 | # License: 3-Clause BSD (see the file LICENSE) 5 | # Maintainer: Rudy Matela 6 | # 7 | # This is faster than Cabal: 8 | # 9 | # Time Scratch Already compiled 10 | # Makefile 14s 0s 11 | # Cabal 90s 1s 12 | # 13 | # Cabal tries to "sandbox" the build of every benchmark program 14 | # rebuilding everything for each of those. 15 | 16 | # Misc variables 17 | GHCIMPORTDIRS = src:bench 18 | GHCFLAGS = -v0 -O2 \ 19 | $(shell grep -q "Arch Linux" /etc/lsb-release && echo -dynamic -package leancheck -package cmdargs) 20 | CABALOPTS= 21 | BENCHS = \ 22 | bench/avltrees \ 23 | bench/bools \ 24 | bench/digraphs \ 25 | bench/heaps \ 26 | bench/id \ 27 | bench/list \ 28 | bench/mergeheaps \ 29 | bench/pretty \ 30 | bench/sets \ 31 | bench/setsofsets \ 32 | bench/sieve \ 33 | bench/sorting \ 34 | bench/spring 35 | EXTRA_BENCHS = $(BENCHS) \ 36 | bench/haskell-src \ 37 | bench/haskell-src-exts 38 | EGS = \ 39 | eg/sorting \ 40 | eg/negation 41 | EXTRA_EGS = $(EGS) \ 42 | eg/alga 43 | TESTS = \ 44 | test/derive \ 45 | test/mutate \ 46 | test/showmutable \ 47 | test/utils 48 | LIST_ALL_HSS = find \( -path "./dist*" -o -path "./.stack-work" -o -path "./Setup.hs" -o -name "haskell-src*.hs" \) -prune \ 49 | -o -name "*.*hs" -print 50 | HADDOCKFLAGS = $(shell grep -q "Arch Linux" /etc/lsb-release && echo --optghc=-dynamic) 51 | LIB_DEPS = base $(INSTALL_DEPS) 52 | INSTALL_DEPS = leancheck cmdargs template-haskell pretty 53 | 54 | all: mk/toplibs 55 | 56 | benchs: $(BENCHS) all 57 | 58 | egs: $(EGS) all 59 | 60 | ghci: Test/FitSpec.ghci 61 | 62 | test: all benchs egs $(TESTS) 63 | ./test/mutate 64 | ./test/showmutable 65 | ./test/derive 66 | ./test/utils 67 | 68 | test-with-extra-deps: all $(EXTRA_BENCHS) $(EXTRA_EGS) $(TESTS) 69 | ./test/mutate 70 | ./test/showmutable 71 | ./test/derive 72 | ./test/utils 73 | 74 | test-via-cabal: 75 | cabal configure --enable-tests --enable-benchmarks --ghc-options="$(GHCFLAGS) -O0" 76 | cabal build 77 | cabal test mutate 78 | 79 | test-via-stack: 80 | stack test fitspec:test:mutate --ghc-options="$(GHCFLAGS) -O0" --system-ghc --no-install-ghc --no-terminal 81 | 82 | test-sdist: 83 | ./test/sdist 84 | 85 | legacy-test: 86 | make clean && make test -j8 GHC=ghc-8.2 GHCFLAGS="-Werror -dynamic" 87 | make clean && make test -j8 GHC=ghc-8.0 GHCFLAGS="-Werror -dynamic" 88 | make clean && make test -j8 GHC=ghc-7.10 GHCFLAGS="-Werror -dynamic" 89 | make clean && make test -j8 GHC=ghc-7.8 GHCFLAGS="-Werror -dynamic" 90 | make clean && make test -j8 91 | 92 | legacy-test-via-cabal: 93 | cabal-ghc-8.2 configure --enable-tests --enable-benchmarks --ghc-option=-dynamic && cabal-ghc-8.2 build && cabal-ghc-8.2 test 94 | cabal-ghc-8.0 configure --enable-tests --enable-benchmarks --ghc-option=-dynamic && cabal-ghc-8.0 build && cabal-ghc-8.0 test 95 | cabal-ghc-7.10 configure --enable-tests --enable-benchmarks --ghc-option=-dynamic && cabal-ghc-7.10 build && cabal-ghc-7.10 test 96 | cabal-ghc-7.8 configure --enable-tests --enable-benchmarks --ghc-option=-dynamic && cabal-ghc-7.8 build && cabal-ghc-7.8 test 97 | cabal clean 98 | 99 | prepare-legacy-test-via-cabal: 100 | rm -rf .cabal-sandbox cabal.sandbox.config 101 | cabal sandbox init 102 | cabal install --only-dependencies --enable-tests --enable-benchmarks --enable-documentation 103 | cabal-ghc-8.2 install --only-dependencies --enable-tests --enable-benchmarks 104 | cabal-ghc-8.0 install --only-dependencies --enable-tests --enable-benchmarks 105 | cabal-ghc-7.10 install --only-dependencies --enable-tests --enable-benchmarks 106 | cabal-ghc-7.8 install --only-dependencies --enable-tests --enable-benchmarks 107 | 108 | clean: clean-hi-o clean-haddock 109 | rm -f $(TESTS) $(BENCHS) $(EGS) {eg,bench}/*.{hi,o,dyn_hi,dyn_o} TAGS tags mk/toplibs 110 | 111 | # Debug: just list all source files compiled normally 112 | list-hs: 113 | $(LISTHS) 114 | 115 | list-libs: 116 | $(LISTLIBS) 117 | 118 | hlint: 119 | hlint \ 120 | --ignore "Use import/export shortcut" \ 121 | --ignore "Use first" \ 122 | --ignore "Use second" \ 123 | --ignore "Use ***" \ 124 | FitSpec.hs FitSpec bench tests 125 | 126 | mk/toplibs: src/Test/FitSpec.o bench/Set.o 127 | touch mk/toplibs 128 | 129 | bench/avltrees: bench/AVLTree.o 130 | 131 | bench/heaps: bench/Heap.o 132 | 133 | bench/digraphs: bench/Digraph.o 134 | 135 | include mk/haskell.mk 136 | # NOTE: 137 | # 138 | # To run make depend, you may need to pass -package now to expose a package: 139 | # 140 | # make depend GHCFLAGS="-package haskell-src-exts" 141 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | FitSpec 2 | ======= 3 | 4 | [![FitSpec Build Status][build-status]][build-log] 5 | [![FitSpec on Hackage][hackage-version]][fitspec-on-hackage] 6 | [![FitSpec on Stackage LTS][stackage-lts-badge]][fitspec-on-stackage-lts] 7 | [![FitSpec on Stackage Nightly][stackage-nightly-badge]][fitspec-on-stackage-nightly] 8 | 9 | ![FitSpec logo][fitspec-logo] 10 | 11 | FitSpec provides automated assistance in the task of refining test properties 12 | for [Haskell] functions. FitSpec tests mutant variations of functions under 13 | test against a given property set, recording any surviving mutants that pass 14 | all tests. FitSpec then reports: 15 | 16 | * *surviving mutants:* 17 | indicating incompleteness of properties, 18 | prompting the user to amend a property or to add a new one; 19 | * *conjectures:* 20 | indicating redundancy in the property set, 21 | prompting the user to remove properties so to reduce the cost of testing. 22 | 23 | Installing FitSpec 24 | ------------------ 25 | 26 | To install the [latest FitSpec version from Hackage], just: 27 | 28 | $ cabal install fitspec 29 | 30 | Pre-requisites are [cmdargs] and [leancheck]. 31 | They should be automatically resolved and installed by [Cabal]. 32 | 33 | Starting from Cabal v3.0, you need to pass `--lib` as an argument to 34 | `cabal install`: 35 | 36 | $ cabal install fitspec --lib 37 | 38 | 39 | Using FitSpec 40 | ------------- 41 | 42 | As an example, consider the following properties describing a `sort` function: 43 | 44 | prop_ordered xs = ordered (sort xs) 45 | prop_length xs = length (sort xs) == length xs 46 | prop_elem x xs = elem x (sort xs) == elem x xs 47 | prop_notElem x xs = notElem x (sort xs) == notElem x xs 48 | prop_min x xs = head (sort (x:xs)) == minimum (x:xs) 49 | 50 | We provide the above properties to FitSpec in the following program: 51 | 52 | import Test.FitSpec 53 | import Data.List 54 | 55 | properties sort = 56 | [ property $ \xs -> ordered (sort xs) 57 | , property $ \xs -> length (sort xs) == length xs 58 | , property $ \x xs -> elem x (sort xs) == elem x xs 59 | , property $ \x xs -> notElem x (sort xs) == notElem x xs 60 | , property $ \x xs -> head (sort (x:xs)) == minimum (x:xs) 61 | ] 62 | where 63 | ordered (x:y:xs) = x <= y && ordered (y:xs) 64 | ordered _ = True 65 | 66 | main = mainWith args { names = ["sort xs"] 67 | , nMutants = 4000 68 | , nTests = 4000 69 | , timeout = 0 70 | } 71 | (sort::[Word2]->[Word2]) 72 | properties 73 | 74 | The above program reports, after a few seconds, that our property set is 75 | apparently *neither minimal nor complete*. 76 | 77 | $ ./fitspec-sort 78 | Apparent incomplete and non-minimal specification based on 79 | 4000 test cases for each of properties 1, 2, 3, 4 and 5 80 | for each of 4000 mutant variations. 81 | 82 | 3 survivors (99% killed), smallest: 83 | \xs -> case xs of 84 | [0,0,1] -> [0,1,1] 85 | _ -> sort xs 86 | 87 | apparent minimal property subsets: {1,2,3} {1,2,4} 88 | conjectures: {3} = {4} 96% killed (weak) 89 | {1,3} ==> {5} 98% killed (weak) 90 | 91 | *Completeness:* Of 4000 mutants, 3 survive testing against our 5 properties. 92 | The surviving mutant is clearly not a valid implementation of `sort`, but 93 | indeed satisfies those properties. As a specification, the property set is 94 | *incomplete* as it omits to require that sorting preserves the number of 95 | occurrences of each element value: `\x xs -> count x (sort xs) == count x xs` 96 | 97 | *Minimality:* 98 | So far as testing has revealed, properties 3 and 4 are equivalent and property 99 | 5 follows from 1 and 3 (conjectures). It is *up to the user* to check whether 100 | these conjectures are true. Indeed they are, so in future testing we could 101 | safely omit properties 4 and 5. 102 | 103 | *Refinement:* If we omit redundant properties, and add a property to kill the 104 | surviving mutant, our refined properties are: 105 | 106 | properties sort = 107 | [ \xs -> ordered (sort xs) 108 | , \xs -> length (sort xs) == length xs 109 | , \x xs -> elem x (sort xs) == elem x xs 110 | , \x xs -> count x (sort xs) == count x xs 111 | ] 112 | 113 | (The implementation of `count` is left as an exercise to the reader.) 114 | 115 | FitSpec now reports: 116 | 117 | Apparent complete but non-minimal specification based on 118 | 4000 test cases for each of properties 1, 2, 3 and 4 119 | for each of 4000 mutant variations. 120 | 121 | 0 survivors (100% killed). 122 | 123 | apparent minimal property subsets: {1,4} 124 | conjectures: {4} ==> {2,3} 99% killed (weak) 125 | 126 | As reported, properties 2 and 3 are implied by property 4, since that is true, 127 | we can safely remove properties 2 and 3 to arrive at a minimal and complete 128 | propety set. 129 | 130 | 131 | ### User-defined datatypes 132 | 133 | If you want to use FitSpec to analyse functions over user-defined datatypes, 134 | those datatypes should be made instances of the [Listable], [Mutable] and 135 | [ShowMutable] typeclasses. Check the Haddock documentation of each class for 136 | how to define instances manually. If datatypes do not follow a data invariant, 137 | instances can be automatically derived using [TH] by: 138 | 139 | deriveMutable ''DataType 140 | 141 | 142 | More documentation 143 | ------------------ 144 | 145 | For more examples, see the [eg](eg) and [bench](bench) folders. 146 | 147 | For further documentation, consult the [doc](doc) folder and [FitSpec API] 148 | documentation on Hackage. 149 | 150 | FitSpec has been subject to a paper, see the 151 | [FitSpec paper on Haskell Symposium 2016](https://matela.com.br/fitspec.pdf). 152 | FitSpec is also subject to a chapter in a [PhD Thesis (2017)]. 153 | 154 | [Listable]: https://hackage.haskell.org/package/leancheck/docs/Test-LeanCheck.html#t:Listable 155 | [Mutable]: https://hackage.haskell.org/package/fitspec/docs/Test-FitSpec.html#t:Mutable 156 | [ShowMutable]: https://hackage.haskell.org/package/fitspec/docs/Test-FitSpec.html#t:ShowMutable 157 | [FitSpec API]: https://hackage.haskell.org/package/fitspec/docs/Test-FitSpec.html 158 | 159 | [leancheck]: https://hackage.haskell.org/package/leancheck 160 | [cmdargs]: https://hackage.haskell.org/package/cmdargs 161 | [pretty]: https://hackage.haskell.org/package/pretty 162 | 163 | [TH]: https://wiki.haskell.org/Template_Haskell 164 | [Cabal]: https://www.haskell.org/cabal 165 | [Haskell]: https://www.haskell.org/ 166 | [PhD Thesis (2017)]: https://matela.com.br/thesis-rudy.pdf 167 | 168 | [fitspec-logo]: https://github.com/rudymatela/fitspec/raw/master/doc/fitspec.svg?sanitize=true 169 | 170 | [build-log]: https://github.com/rudymatela/fitspec/actions/workflows/build.yml 171 | [build-status]: https://github.com/rudymatela/fitspec/actions/workflows/build.yml/badge.svg 172 | [hackage-version]: https://img.shields.io/hackage/v/fitspec.svg 173 | [fitspec-on-hackage]: https://hackage.haskell.org/package/fitspec 174 | [latest FitSpec version from Hackage]: https://hackage.haskell.org/package/fitspec 175 | [stackage-lts-badge]: https://stackage.org/package/fitspec/badge/lts 176 | [stackage-nightly-badge]: https://stackage.org/package/fitspec/badge/nightly 177 | [fitspec-on-stackage]: https://stackage.org/package/fitspec 178 | [fitspec-on-stackage-lts]: https://stackage.org/lts/package/fitspec 179 | [fitspec-on-stackage-nightly]: https://stackage.org/nightly/package/fitspec 180 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | TO DO list for FitSpec 2 | ====================== 3 | 4 | misc 5 | ---- 6 | 7 | * parameterize number of tests in test programs and add slow-test target 8 | 9 | * add diff test for IO functions (diff w/ model output and exit status) 10 | 11 | * implement `toplibs` hack (from LeanCheck and Speculate); 12 | 13 | documentation 14 | ------------- 15 | 16 | * add second simple/minimal example in eg 17 | (unbalanced binary search tree? stack?); 18 | 19 | * write detailed install instructions on INSTALL.md 20 | (cabal install, cabal from sandbox, source include) 21 | -------------------------------------------------------------------------------- /bench/AVLTree.hs: -------------------------------------------------------------------------------- 1 | module AVLTree 2 | ( 3 | -- | * External API 4 | empty 5 | , insert 6 | , remove 7 | , find 8 | , preOrder 9 | , inOrder 10 | , postOrder 11 | , flatten 12 | , height 13 | , nElem 14 | , isEmpty 15 | , fromList 16 | 17 | , leaf 18 | , (//) 19 | , (\\) 20 | , (-/) 21 | , (\-) 22 | 23 | -- | * Internal API 24 | , Tree(..) 25 | , node 26 | , bf 27 | , v 28 | , l 29 | , r 30 | , rotatell 31 | , rotaterr 32 | , rotatelr 33 | , rotaterl 34 | , balance 35 | , same 36 | , removeRoot 37 | , removeGreatest 38 | ) 39 | where 40 | 41 | -- | Tree definition 42 | data Tree a = Empty | 43 | Node Int (Tree a) a (Tree a) 44 | 45 | -- | Smart node constructor that infers height from given subtrees 46 | node :: Tree a -> a -> Tree a -> Tree a 47 | node lst x rst = Node (max (height lst) (height rst) + 1) lst x rst 48 | 49 | -- | Smart node constructor for leafs 50 | leaf :: a -> Tree a 51 | leaf x = node empty x empty 52 | 53 | empty :: Tree a 54 | empty = Empty 55 | 56 | -- | Left infix tree constructor 57 | (//) :: Tree a -> a -> (Tree a -> Tree a) 58 | (//) = node 59 | infix 6 // 60 | 61 | -- | Left infix tree constructor (leaf value) 62 | (-/) :: a -> a -> (Tree a -> Tree a) 63 | x -/ y = node (leaf x) y 64 | infix 6 -/ 65 | 66 | -- | Right infix tree constructor 67 | (\\) :: (Tree a -> Tree a) -> Tree a -> Tree a 68 | (\\) = ($) 69 | infix 5 \\ 70 | 71 | -- | Right infix tree constructor (leaf value) 72 | (\-) :: (Tree a -> Tree a) -> a -> Tree a 73 | ctx \- x = ctx (leaf x) 74 | infix 5 \- 75 | 76 | 77 | -- | Shows tree in format (1-/2\-3)//4\\(empty//5\-7) 78 | instance (Show a) => Show (Tree a) where 79 | showsPrec _ Empty = showString "empty" 80 | showsPrec d (Node _ Empty x Empty) = showParen (d>9) $ showString "leaf " . showsPrec 10 x 81 | showsPrec d (Node _ lst x rst) = showParen (d>4) $ left . showsPrec 7 x . right 82 | where left | isLeaf lst = showsPrec 7 (v lst) . showString "-/" 83 | | otherwise = showsPrec 6 lst . showString "//" 84 | right | isLeaf rst = showString "\\-" . showsPrec 7 (v rst) 85 | | otherwise = showString "\\\\" . showsPrec 6 rst 86 | 87 | -- | Two trees are equal if they hold the same elements. To check for equality also on the structure of the tree, use "same" 88 | instance (Eq a) => Eq (Tree a) where 89 | t == u = flatten t == flatten u 90 | 91 | instance (Ord a) => Ord (Tree a) where 92 | t `compare` u = flatten t `compare` flatten u 93 | 94 | -- | The function should map values keeping ordering, otherwise you'll get a 95 | -- problematic AVL. The resulting AVL can only be manipulated by 'insert' and 96 | -- 'delete' if it follows the 'Invariants.ordered'. 97 | instance Functor Tree where 98 | fmap _ Empty = Empty 99 | fmap f (Node h lst x rst) = Node h (fmap f lst) (f x) (fmap f rst) 100 | 101 | 102 | -- | Two trees are **same** if their *values* and *structure* is the same. 103 | -- Every **same** pair of 'Tree's is '==', not every '==' pair of 'Tree's is 104 | -- **same** 105 | infix 4 `same` 106 | same :: Eq a => Tree a -> Tree a -> Bool 107 | Empty `same` Empty = True 108 | (Node _ tlst x trst) `same` (Node _ ulst y urst) = x == y && tlst `same` ulst && trst `same` urst 109 | _ `same` _ = False 110 | 111 | 112 | insert :: Ord a => a -> Tree a -> Tree a 113 | insert x Empty = node Empty x Empty 114 | insert x t@(Node _ lt y gt) = balance u 115 | where u = case x `compare` y of 116 | EQ -> t 117 | LT -> node (insert x lt) y gt 118 | GT -> node lt y (insert x gt) 119 | 120 | 121 | remove :: Ord a => a -> Tree a -> Tree a 122 | remove _ Empty = Empty -- no-op 123 | remove x t@(Node _ lst y rst) = balance $ 124 | case x `compare` y of 125 | EQ -> removeRoot t 126 | LT -> remove x lst 127 | GT -> remove x rst 128 | 129 | 130 | removeRoot :: Tree a -> Tree a 131 | removeRoot Empty = Empty 132 | removeRoot (Node _ Empty _ Empty) = Empty 133 | removeRoot (Node _ lst _ Empty) = lst 134 | removeRoot (Node _ Empty _ rst) = rst 135 | removeRoot (Node _ lst _ rst) = balance (node nlst y rst) 136 | where 137 | (y, nlst) = removeGreatest lst 138 | 139 | 140 | removeGreatest :: Tree a -> (a, Tree a) 141 | removeGreatest Empty = errorEmptyTree "removeGreatest" 142 | removeGreatest (Node _ lst x Empty) = (x, lst) 143 | removeGreatest (Node _ lst x rst) = (y, balance (node lst x nrst)) 144 | where 145 | (y, nrst) = removeGreatest rst 146 | 147 | 148 | find :: Ord a => a -> Tree a -> Maybe a 149 | find _ Empty = Nothing 150 | find x (Node _ lt y gt) = 151 | case x `compare` y of 152 | EQ -> Just y 153 | LT -> find x lt 154 | GT -> find x gt 155 | 156 | 157 | preOrder :: Tree a -> [a] 158 | preOrder Empty = [] 159 | preOrder (Node _ lst x rst) = [x] ++ preOrder lst ++ preOrder rst 160 | 161 | inOrder :: Tree a -> [a] 162 | inOrder Empty = [] 163 | inOrder (Node _ lst x rst) = inOrder lst ++ [x] ++ inOrder rst 164 | 165 | postOrder :: Tree a -> [a] 166 | postOrder Empty = [] 167 | postOrder (Node _ lst x rst) = postOrder lst ++ postOrder rst ++ [x] 168 | 169 | -- | Alias for inOrder 170 | flatten :: Tree a -> [a] 171 | flatten = inOrder 172 | 173 | fromList :: Ord a => [a] -> Tree a 174 | fromList = foldr insert empty 175 | 176 | 177 | -- | Height of a Tree 178 | height :: Tree a -> Int 179 | height Empty = -1 180 | height (Node h _ _ _) = h 181 | 182 | -- | Number of values stored in the tree. Note: this is slow, as it actually 183 | -- evaluates the whole "spine" of the tree. 184 | nElem :: Tree a -> Int 185 | nElem Empty = 0 186 | nElem (Node _ lt _ gt) = nElem lt + nElem gt + 1 187 | 188 | isEmpty :: Tree a -> Bool 189 | isEmpty Empty = True 190 | isEmpty _ = False 191 | 192 | isLeaf :: Tree a -> Bool 193 | isLeaf (Node _ Empty _ Empty) = True 194 | isLeaf _ = False 195 | 196 | -- | Balancing factor of a Tree 197 | bf :: Tree a -> Int 198 | bf Empty = 0 199 | bf (Node _ lt _ gt) = height lt - height gt 200 | 201 | -- | Value of a node (root) 202 | v :: Tree a -> a 203 | v (Node _ _ x _) = x 204 | v Empty = errorEmptyTree "v" 205 | 206 | -- | Left subtree 207 | l :: Tree a -> Tree a 208 | l (Node _ lst _ _) = lst 209 | l Empty = errorEmptyTree "l" 210 | 211 | -- | Right subtree 212 | r :: Tree a -> Tree a 213 | r (Node _ _ _ rst) = rst 214 | r Empty = errorEmptyTree "r" 215 | 216 | rotatell :: Tree a -> Tree a 217 | rotatell (Node _ (Node _ llst y lrst) x rst) = node llst y (node lrst x rst) 218 | rotatell _ = errorEmptySubtree "rotatell" 219 | 220 | rotaterr :: Tree a -> Tree a 221 | rotaterr (Node _ lst x (Node _ rlst y rrst)) = node (node lst x rlst) y rrst 222 | rotaterr _ = errorEmptySubtree "rotaterr" 223 | 224 | rotatelr :: Tree a -> Tree a 225 | rotatelr (Node _ lst x rst) = rotatell (node (rotaterr lst) x rst) 226 | rotatelr _ = errorEmptySubtree "rotatelr" 227 | 228 | rotaterl :: Tree a -> Tree a 229 | rotaterl (Node _ lst x rst) = rotaterr (node lst x (rotatell rst)) 230 | rotaterl _ = errorEmptySubtree "rotaterl" 231 | 232 | balance :: Tree a -> Tree a 233 | balance t | bf t > 1 = if bf (l t) == (-1) 234 | then rotatelr t 235 | else rotatell t 236 | | bf t < -1 = if bf (r t) == 1 237 | then rotaterl t 238 | else rotaterr t 239 | | otherwise = t 240 | 241 | 242 | errorEmptyTree :: String -> a 243 | errorEmptyTree fun = err fun "empty tree (trying to balance non-AVL tree?)" 244 | 245 | errorEmptySubtree :: String -> a 246 | errorEmptySubtree fun = err fun "empty subtree (trying to balance non-AVL tree?)" 247 | 248 | err :: String -> String -> a 249 | err fun msg = error ("AVLTree.Internals." ++ fun ++ ": " ++ msg) 250 | 251 | -------------------------------------------------------------------------------- /bench/Digraph.hs: -------------------------------------------------------------------------------- 1 | -- A small library of functions on directed graphs 2 | -- using a simple list-of-successors representation. 3 | -- Colin Runciman, May 2015 4 | 5 | module Digraph (Digraph(..), okDigraph, strictOrder, 6 | sources, targets, nodes, preds, succs, 7 | isNode, isEdge, isPath, 8 | emptyDigraph, addNode, addEdge, assoc1toNdigraph, 9 | transitiveClosure, topoSort, 10 | insert, union, diff, cycles, subgraph, maxDagFrom) where 11 | 12 | import GHC.Exts (groupWith) 13 | import Data.List (partition,(\\),sort) 14 | import Data.Maybe (isJust,fromJust) 15 | import Control.Monad (guard) 16 | 17 | data Digraph a = D {nodeSuccs :: [(a,[a])]} deriving (Eq, Show) 18 | -- Data invariant: in a digraph pair-list [...(source,targets)...]: 19 | -- (1) pairs are listed in strictly increasing source order 20 | -- (2) each list of targets is in strictly increasing order 21 | -- (3) every element in a list of targets must itself be 22 | -- listed as a "source", though perhaps with [] targets 23 | 24 | okDigraph :: (Ord a, Eq a) => Digraph a -> Bool 25 | okDigraph (D d) = 26 | strictOrder ss && all goodTargetList tss 27 | where 28 | ss = map fst d 29 | tss = map snd d 30 | goodTargetList ts = strictOrder ts && 31 | all (`elemOrd` ss) ts 32 | 33 | strictOrder :: (Ord a, Eq a) => [a] -> Bool 34 | strictOrder (x:y:etc) = x < y && strictOrder (y:etc) 35 | strictOrder _ = True 36 | 37 | nodes :: Digraph a -> [a] 38 | nodes (D d) = [s | (s,_) <- d] 39 | 40 | sources :: Digraph a -> [a] 41 | sources (D d) = [s | (s,ts) <- d, not (null ts)] 42 | 43 | targets :: (Ord a, Eq a) => Digraph a -> [a] 44 | targets (D d) = foldr union [] (map snd d) 45 | 46 | preds :: (Ord a, Eq a) => a -> Digraph a -> [a] 47 | preds t (D d) = [s | (s,ts) <- d, t `elemOrd` ts] 48 | 49 | succs :: (Ord a, Eq a) => a -> Digraph a -> [a] 50 | succs s (D d) = case lookup s d of 51 | Just ns -> ns 52 | Nothing -> [] 53 | 54 | isNode :: (Ord a, Eq a) => a -> Digraph a -> Bool 55 | isNode n (D d) = isJust (lookup n d) 56 | 57 | isEdge :: (Ord a, Eq a) => a -> a -> Digraph a -> Bool 58 | isEdge s t (D d) = case lookup s d of 59 | Just ns -> t `elemOrd` ns 60 | Nothing -> False 61 | 62 | isPath :: (Ord a, Eq a) => a -> a -> Digraph a -> Bool 63 | isPath s t d = t `elemOrd` closeInto d [] [s] 64 | 65 | emptyDigraph :: Digraph a 66 | emptyDigraph = D [] 67 | 68 | addNode :: (Ord a, Eq a) => a -> Digraph a -> Digraph a 69 | addNode s (D d) = 70 | let (these,those) = span ((< s) . fst) d in 71 | D $ these ++ 72 | case those of 73 | [] -> [(s,[])] 74 | (sd,tsd):etc -> if s == sd then error "addNode: already present" 75 | else (s,[]) : those 76 | 77 | addEdge :: (Ord a, Eq a) => a -> a -> Digraph a -> Digraph a 78 | addEdge s t (D d) = 79 | let (these,those) = span ((< s) . fst) d in 80 | D $ these ++ 81 | case those of 82 | [] -> [(s,[t])] 83 | (sd,tsd):etc -> if s == sd then 84 | if t `elemOrd` tsd then error "addEdge: already present" 85 | else (s,insert t tsd) : etc 86 | else (s,[t]) : those 87 | 88 | -- The function assoc1toNdigraph derives a digraph from an association list 89 | -- pairing single sources with lists of targets. Sorting is applied to 90 | -- outer and inner lists, so there is no ordering requirement on the argument. 91 | -- If there is more than one pair with the same source, target lists are merged. 92 | -- If the same value appears more than once in a target list, duplicates are removed. 93 | -- If any target does not occur as a source, it is added, with an empty target list. 94 | assoc1toNdigraph :: (Ord a, Eq a) => [(a,[a])] -> Digraph a 95 | assoc1toNdigraph stss = D $ addMissingSources $ mergeAndSortTargets $ sort stss 96 | where 97 | mergeAndSortTargets [] = [] 98 | mergeAndSortTargets [(s,ts)] = [(s, nubOrd $ sort ts)] 99 | mergeAndSortTargets ((s0,ts0):(s1,ts1):etc) = 100 | if s0 == s1 then mergeAndSortTargets ((s0,ts0++ts1):etc) 101 | else (s0,nubOrd $ sort ts0) : mergeAndSortTargets ((s1,ts1):etc) 102 | addMissingSources stss = 103 | union [(s,[]) | s <- missingSources] stss 104 | where 105 | missingSources = allTargets `diff` map fst stss 106 | allTargets = foldr union [] (map snd stss) 107 | 108 | transitiveClosure :: (Ord a, Eq a) => Digraph a -> Digraph a 109 | transitiveClosure d = D $ map (close d) (nodeSuccs d) 110 | 111 | close :: (Ord a, Eq a) => Digraph a -> (a,[a]) -> (a,[a]) 112 | close d (s,ts) = (s, closeInto d [] ts) 113 | 114 | closeInto :: (Ord a, Eq a) => Digraph a -> [a] -> [a] -> [a] 115 | closeInto d clo [] = clo 116 | closeInto d clo (t:ts) = 117 | case lookup t (nodeSuccs d) of 118 | Nothing -> closeInto d clo ts 119 | Just tsuccs -> closeInto d clo' (union (diff tsuccs clo') ts) 120 | where 121 | clo' = insert t clo 122 | 123 | -- auxiliary functions for ordered list processing 124 | 125 | nubOrd :: (Ord a, Eq a) => [a] -> [a] 126 | nubOrd [] = [] 127 | nubOrd [x] = [x] 128 | nubOrd (x:y:etc) = if x==y then nubOrd (y:etc) else x : nubOrd (y:etc) 129 | 130 | elemOrd :: Ord a => a -> [a] -> Bool 131 | elemOrd x ys = null (diff [x] ys) 132 | 133 | insert :: Ord a => a -> [a] -> [a] 134 | insert x ys = union [x] ys 135 | 136 | union :: Ord a => [a] -> [a] -> [a] 137 | union [] ys = ys 138 | union (x:xs) [] = x:xs 139 | union (x:xs) (y:ys) = case compare x y of 140 | LT -> x : union xs (y:ys) 141 | EQ -> union xs (y:ys) 142 | GT -> y : union (x:xs) ys 143 | 144 | diff :: Ord a => [a] -> [a] -> [a] 145 | diff [] ys = [] 146 | diff (x:xs) [] = x:xs 147 | diff (x:xs) (y:ys) = case compare x y of 148 | LT -> x : diff xs (y:ys) 149 | EQ -> diff xs ys 150 | GT -> diff (x:xs) ys 151 | 152 | -- The result of cycles lists disjoint maximal subsets of nodes in 153 | -- each of which there is a cycle passing through all nodes. 154 | cycles:: (Ord a, Eq a) => Digraph a -> [[a]] 155 | cycles d = 156 | let d' = transitiveClosure d 157 | cycleNodes = filter (hasLoop d') (sources d') 158 | in 159 | map (sources . D) $ groupWith snd $ nodeSuccs $ subgraph cycleNodes d' 160 | 161 | hasLoop :: Eq a => Digraph a -> a -> Bool 162 | hasLoop d s = 163 | case lookup s (nodeSuccs d) of 164 | Nothing -> False 165 | Just ts -> elem s ts 166 | 167 | subgraph :: Eq a => [a] -> Digraph a -> Digraph a 168 | subgraph ns d = D $ [(s,filter (`elem` ns) ts) | (s,ts) <- nodeSuccs d, elem s ns] 169 | 170 | -- The result of topoSort d, where d is an acyclic digraph, lists all nodes 171 | -- in an order where each node precedes all its digraph successors; 172 | -- the result is Nothing if d has a cycle. 173 | topoSort :: (Ord a, Eq a) => Digraph a -> Maybe [a] 174 | topoSort (D []) = Just [] 175 | topoSort d = do 176 | guard (not $ null maxima) 177 | ns <- topoSort (D nodesuccs') 178 | return $ ns ++ maxima 179 | where 180 | (these,those) = partition (null.snd) (nodeSuccs d) 181 | maxima = nodes (D these) 182 | nodesuccs' = [(s,ts \\ maxima) | (s,ts) <- those] 183 | 184 | -- The result of maxDAGfrom s d is a subgraph of d which is a maximal 185 | -- DAG rooted at node s. 186 | maxDagFrom :: (Ord a, Eq a) => a -> Digraph a -> Digraph a 187 | maxDagFrom s d = md [] [s] (removeAllEdges d) (removeLoops d) 188 | 189 | -- In a call md done todo dag d, done is an ordered list of nodes already 190 | -- visited, todo is a disjoint ordered list of nodes to be visited, dag is 191 | -- the dag so far, and d is the full loop-free digraph. 192 | md :: (Ord a, Eq a) => [a] -> [a] -> Digraph a -> Digraph a -> Digraph a 193 | md _ [] dag d = dag 194 | md done (s:ss) dag d = 195 | case lookup s (nodeSuccs d) of 196 | Nothing -> md done' ss dag d 197 | Just ts -> md done' (union (diff ts done) ss) dag' d 198 | where 199 | dag' = foldr (uncurry addEdgeIfAcyclic) dag [(s,t) | t <- ts] 200 | where 201 | done' = insert s done 202 | 203 | addEdgeIfAcyclic :: (Ord a, Eq a) => a -> a -> Digraph a -> Digraph a 204 | addEdgeIfAcyclic s t d = if isPath t s d then d else addEdge s t d 205 | 206 | removeLoops :: (Ord a, Eq a) => Digraph a -> Digraph a 207 | removeLoops d = D $ [(s, diff ts [s]) | (s, ts) <- nodeSuccs d] 208 | 209 | removeAllEdges :: (Ord a, Eq a) => Digraph a -> Digraph a 210 | removeAllEdges d = D $ [(s, []) | (s, _) <- nodeSuccs d] 211 | 212 | -------------------------------------------------------------------------------- /bench/Heap.hs: -------------------------------------------------------------------------------- 1 | -- Heap code from QuickSpec examples. 2 | -- https://github.com/nick8325/quickspec/blob/0.9.6/examples/Heaps.hs 3 | -- 4 | -- Copyright (c) 2009-2014, Nick Smallbone 5 | -- https://github.com/nick8325/quickspec/blob/0.9.6/LICENSE (BSD3 license) 6 | module Heap where 7 | 8 | data Heap a = Nil | Branch Int a (Heap a) (Heap a) deriving Show 9 | 10 | instance Ord a => Eq (Heap a) where 11 | h1 == h2 = toList h1 == toList h2 12 | 13 | instance Ord a => Ord (Heap a) where 14 | h1 `compare` h2 = toList h1 `compare` toList h2 15 | 16 | toList :: Ord a => Heap a -> [a] 17 | toList Nil = [] 18 | toList h = findMin h : toList (deleteMin h) 19 | 20 | fromList :: Ord a => [a] -> Heap a 21 | fromList = foldr insert Nil 22 | 23 | null :: Heap a -> Bool 24 | null Nil = True 25 | null _ = False 26 | 27 | findMin :: Heap a -> a 28 | findMin (Branch _ x _ _) = x 29 | 30 | insert :: Ord a => a -> Heap a -> Heap a 31 | insert x h = merge h (branch x Nil Nil) 32 | 33 | deleteMin :: Ord a => Heap a -> Heap a 34 | deleteMin (Branch _ _ l r) = merge l r 35 | 36 | branch :: Ord a => a -> Heap a -> Heap a -> Heap a 37 | branch x l r | npl l <= npl r = Branch (npl l + 1) x l r 38 | | otherwise = Branch (npl r + 1) x r l 39 | 40 | merge :: Ord a => Heap a -> Heap a -> Heap a 41 | merge Nil h = h 42 | merge h Nil = h 43 | merge h1@(Branch _ x1 l1 r1) h2@(Branch _ x2 l2 r2) 44 | | x1 <= x2 = branch x1 (merge l1 h2) r1 45 | | otherwise = merge h2 h1 46 | 47 | npl :: Heap a -> Int 48 | npl Nil = 0 49 | npl (Branch n _ _ _) = n 50 | -------------------------------------------------------------------------------- /bench/Set.hs: -------------------------------------------------------------------------------- 1 | -- A list-based library for programming with sets. 2 | -- Colin Runciman, June 2007 to April 2008. 3 | 4 | module Set (Set, elemList, set, emptyS, singleS, pairS, insertS, deleteS, 5 | sizeS, sizeAtMostS, sizeExactlyS, sizeAtLeastS, 6 | isEmptyS, nonEmptyS, minS, choiceS, (<~), 7 | (\/), (/\), (\\), unionS, interS, subS, disjointS, 8 | elemSubsetsOf, powerS, partitionsS, subsetPartitionsS, 9 | (<|), allS, anyS, exactly, forAll, thereExists, forExactly, 10 | minimalS, mapS, mapMonoS, unionMapS, regular) where 11 | 12 | import Data.List (nub, sort, intersperse) 13 | 14 | infixl 7 /\ 15 | infixl 6 \/ 16 | infixr 5 `elemSubsetsOf`, `subsetPartitionsS`, <| 17 | infix 4 <~, `subS` 18 | 19 | data Set a = S {elemList :: [a]} 20 | 21 | instance (Ord a, Eq a) => Eq (Set a) 22 | where 23 | S xs == S ys = xs == ys 24 | 25 | instance Ord a => Ord (Set a) 26 | where 27 | compare (S xs) (S ys) = compare xs ys 28 | 29 | instance (Ord a, Show a) => Show (Set a) 30 | where 31 | show (S xs) = 32 | "{"++concat (intersperse "," (map show xs))++"}" 33 | 34 | set :: Ord a => [a] -> Set a 35 | set = S . nub . sort 36 | 37 | emptyS :: Ord a => Set a 38 | emptyS = S [] 39 | 40 | singleS :: Ord a => a -> Set a 41 | singleS e = S [e] 42 | 43 | pairS :: Ord a => a -> a -> Set a 44 | pairS e1 e2 = set [e1,e2] 45 | 46 | insertS :: Ord a => a -> Set a -> Set a 47 | insertS e = S . insertList e . elemList 48 | where 49 | insertList e [] = [e] 50 | insertList e xs@(x:xs') = case compare e x of 51 | LT -> e : xs 52 | EQ -> xs 53 | GT -> x : insertList e xs' 54 | 55 | deleteS :: Ord a => a -> Set a -> Set a 56 | deleteS e = S . deleteList e . elemList 57 | where 58 | deleteList e [] = [] 59 | deleteList e xs@(x:xs') = case compare e x of 60 | LT -> xs 61 | EQ -> xs' 62 | GT -> x : deleteList e xs' 63 | 64 | sizeS :: Ord a => Set a -> Int 65 | sizeS = length . elemList 66 | 67 | sizeExactlyS :: Ord a => Int -> Set a -> Bool 68 | sizeExactlyS n = lengthExactly n . elemList 69 | where 70 | lengthExactly 0 xs = null xs 71 | lengthExactly n [] = False 72 | lengthExactly n (x:xs) = lengthExactly (n-1) xs 73 | 74 | sizeAtLeastS :: Ord a => Int -> Set a -> Bool 75 | sizeAtLeastS n = lengthAtLeast n . elemList 76 | where 77 | lengthAtLeast 0 xs = True 78 | lengthAtLeast n [] = False 79 | lengthAtLeast n (x:xs) = lengthAtLeast (n-1) xs 80 | 81 | sizeAtMostS :: Ord a => Int -> Set a -> Bool 82 | sizeAtMostS n = lengthAtMost n . elemList 83 | where 84 | lengthAtMost 0 xs = null xs 85 | lengthAtMost n [] = True 86 | lengthAtMost n (x:xs) = lengthAtMost (n-1) xs 87 | 88 | isEmptyS :: Ord a => Set a -> Bool 89 | isEmptyS = null . elemList 90 | 91 | nonEmptyS :: Ord a => Set a -> Bool 92 | nonEmptyS = not . isEmptyS 93 | 94 | minS :: Ord a => Set a -> a 95 | minS = head . elemList 96 | 97 | choiceS :: Ord a => Set a -> Set (a, Set a) 98 | choiceS = S . choice . elemList 99 | where 100 | choice xs = [(x, S (xs1++xs2)) | (xs1,x:xs2) <- splits xs] 101 | 102 | splits :: [a] -> [([a],[a])] 103 | splits [] = [([],[])] 104 | splits (x:xs) = ([],x:xs) : [(x:xs1, xs2) | (xs1,xs2) <- splits xs] 105 | 106 | (<~) :: Ord a => a -> Set a -> Bool 107 | (<~) e = ordElem e . elemList 108 | where 109 | ordElem e [] = False 110 | ordElem e (x:xs) = case compare e x of 111 | LT -> False 112 | EQ -> True 113 | GT -> ordElem e xs 114 | 115 | (\/) :: Ord a => Set a -> Set a -> Set a 116 | S xs \/ S ys = S (join xs ys) 117 | where 118 | join [] ys = ys 119 | join xs [] = xs 120 | join xs@(x:xs') ys@(y:ys') = 121 | case compare x y of 122 | LT -> x : join xs' ys 123 | EQ -> x : join xs' ys' 124 | GT -> y : join xs ys' 125 | 126 | (/\) :: Ord a => Set a -> Set a -> Set a 127 | S xs /\ S ys = S (meet xs ys) 128 | 129 | meet [] _ = [] 130 | meet _ [] = [] 131 | meet xs@(x:xs') ys@(y:ys') = 132 | case compare x y of 133 | LT -> meet xs' ys 134 | EQ -> x : meet xs' ys' 135 | GT -> meet xs ys' 136 | 137 | (\\) :: Ord a => Set a -> Set a -> Set a 138 | S xs \\ S ys = S (diff xs ys) 139 | 140 | diff [] _ = [] 141 | diff xs [] = xs 142 | diff xs@(x:xs') ys@(y:ys') = 143 | case compare x y of 144 | LT -> x : diff xs' ys 145 | EQ -> diff xs' ys' 146 | GT -> diff xs ys' 147 | 148 | unionS :: Ord a => Set (Set a) -> Set a 149 | unionS = foldr (\/) emptyS . elemList 150 | 151 | interS :: Ord a => Set (Set a) -> Set a 152 | interS = foldr1 (/\) . elemList 153 | 154 | disjointS :: Ord a => Set a -> Set a -> Bool 155 | disjointS (S xs) (S ys) = null (meet xs ys) 156 | 157 | subS :: Ord a => Set a -> Set a -> Bool 158 | subS (S xs) (S ys) = null (diff xs ys) 159 | 160 | elemSubsetsOf :: Ord a => Int -> Set a -> Set (Set a) 161 | elemSubsetsOf n = 162 | S . map S . sublistsOf n . elemList 163 | where 164 | sublistsOf 0 _ = [[]] 165 | sublistsOf _ [] = [] 166 | sublistsOf n (x:xs) = 167 | map (x:) (sublistsOf (n-1) xs) ++ sublistsOf n xs 168 | 169 | powerS :: Ord a => Set a -> Set (Set a) 170 | powerS = 171 | S . map S . ([]:) . nonEmptySublists . elemList 172 | where 173 | nonEmptySublists [] = [] 174 | nonEmptySublists (x:xs) = 175 | [x] : map (x:) ss ++ ss 176 | where 177 | ss = nonEmptySublists xs 178 | 179 | -- outer 'set' used to be 'S' but then ordering between 180 | -- partitions can be wrong 181 | -- TO DO: instead reorder partitionsList computation? 182 | partitionsS :: Ord a => Set a -> Set (Set (Set a)) 183 | partitionsS = set . map (S . map S) . partitionsList . elemList 184 | where 185 | partitionsList [] = [[]] 186 | partitionsList (x:xs) = 187 | [[x] : p | p <- ps] ++ 188 | [(x:xs') : xss ++ xss' | p <- ps, (xss,xs':xss') <- splits p] 189 | where 190 | ps = partitionsList xs 191 | 192 | subsetPartitionsS :: Ord a => Int -> Set a -> Set (Set (Set a)) 193 | subsetPartitionsS n = S . map (S . map S) . sublistPartitionsList n . elemList 194 | where 195 | sublistPartitionsList n [] = [[] | n == 0] 196 | sublistPartitionsList n (x:xs) = 197 | [ [x] : p 198 | | n > 0, p <- sublistPartitionsList (n-1) xs ] ++ 199 | [ (x:xs') : xss ++ xss' 200 | | n > 0, p <- sublistPartitionsList n xs, (xss,xs':xss') <- splits p ] 201 | 202 | (<|) :: Ord a => (a -> Bool) -> Set a -> Set a 203 | (<|) p = S . filter p . elemList 204 | 205 | allS, anyS :: Ord a => (a -> Bool) -> Set a -> Bool 206 | allS p = all p . elemList 207 | anyS p = any p . elemList 208 | 209 | exactly :: 210 | Ord a => Int -> (a->Bool) -> Set a -> Bool 211 | exactly n p = 212 | exactlyList n p . elemList 213 | where 214 | exactlyList 0 p xs = not (any p xs) 215 | exactlyList n p [] = False 216 | exactlyList n p (x:xs) = exactlyList 217 | (if p x then n-1 else n) p xs 218 | 219 | forAll, thereExists :: Ord a => Set a -> (a->Bool) -> Bool 220 | forAll s p = allS p s 221 | thereExists s p = anyS p s 222 | 223 | forExactly :: Ord a => Int -> Set a -> (a->Bool) -> Bool 224 | forExactly n s p = exactly n p s 225 | 226 | mapS :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b 227 | mapS f = set . map f . elemList 228 | 229 | -- more efficient variant when f is monotonic 230 | mapMonoS :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b 231 | mapMonoS f = S . map f . elemList 232 | 233 | unionMapS :: (Ord a, Ord b) => (a -> Set b) -> Set a -> Set b 234 | unionMapS f = foldr (\/) emptyS . map f . elemList 235 | 236 | minimalS :: Ord a => (Set a -> Bool) -> Set a -> Bool 237 | minimalS p s = (p <| powerS s) == set [s] 238 | 239 | regular :: Ord a => Int -> Set (Set a) -> Bool 240 | regular d ss = 241 | -- every element occurs in exactly d sets 242 | forAll (unionS ss) $ \e -> 243 | forExactly d ss $ \s -> e <~ s 244 | -------------------------------------------------------------------------------- /bench/avltrees.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | import Test.FitSpec 3 | import AVLTree 4 | import Data.List (sort,nubBy) 5 | 6 | #if __GLASGOW_HASKELL__ >= 706 7 | import Prelude hiding (insert,find) 8 | #endif 9 | 10 | -- TODO: separate testing of data invariants from properties over trees. 11 | 12 | -- This instance could be made more efficient by choosing 13 | -- all possible mid-points of a list, then recursively 14 | -- generating trees for the rest of elements. 15 | instance (Ord a, Listable a) => Listable (Tree a) where 16 | tiers = map (nubBy same . sort) (noDupListCons fromList) 17 | 18 | instance (Ord a, Listable a) => Mutable (Tree a) where 19 | mutiers = mutiersEq 20 | 21 | instance (Ord a, Show a, Listable a) => ShowMutable (Tree a) where 22 | mutantS = mutantSEq 23 | 24 | 25 | -- * Tree Invariants: 26 | 27 | ordered :: Ord a => Tree a -> Bool 28 | ordered = ordList . flatten 29 | where ordList (x:y:xs) = x < y && ordList (y:xs) 30 | ordList _ = True 31 | 32 | balanced :: Tree a -> Bool 33 | balanced Empty = True 34 | balanced t@(Node _ lst _ rst) = abs (bf t) < 2 && balanced lst && balanced rst 35 | 36 | underHeightLimit :: Tree a -> Bool 37 | underHeightLimit t = n <= 2^h - 1 38 | where n = nElem t 39 | h = height t + 1 40 | 41 | -- | Compares the height stored in the tree to an explicitly implemented version 42 | correctHeight :: Tree a -> Bool 43 | correctHeight t = height t == explicitHeight t 44 | where 45 | explicitHeight Empty = -1 46 | explicitHeight (Node _ lt _ gt) = max (height lt) (height gt) + 1 47 | 48 | -- Our tiers enumeration guarantees that no mutant will produce a Tree not 49 | -- following the invariants. So 1-8 will always be reported as uneeded. 50 | properties :: (Ord a, Show a, Listable a) 51 | => (a -> Tree a -> Tree a) 52 | -> (a -> Tree a -> Tree a) 53 | -> (a -> Tree a -> Maybe a) 54 | -> [Property] 55 | properties insert remove find = 56 | [ property $ \x t -> ordered (insert x t) -- 1 57 | , property $ \x t -> ordered (remove x t) -- 2 58 | , property $ \x t -> balanced (insert x t) -- 3 59 | , property $ \x t -> balanced (remove x t) -- 4 60 | , property $ \x t -> underHeightLimit (insert x t) -- 5 61 | , property $ \x t -> underHeightLimit (remove x t) -- 6 62 | , property $ \x t -> correctHeight (insert x t) -- 7 63 | , property $ \x t -> correctHeight (remove x t) -- 8 64 | , property $ \x t -> find x (insert x t) == Just x -- 9 65 | , property $ \x t -> find x (remove x t) == Nothing -- 10 66 | ] 67 | 68 | type Insert a = a -> Tree a -> Tree a 69 | 70 | main :: IO () 71 | main = 72 | reportWith args { names = ["insert x t","remove x t","find x t"] 73 | , timeout = 0 } 74 | (insert :: Insert Word2, remove, find) 75 | (uncurry3 properties) 76 | 77 | uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d 78 | uncurry3 f = \(x,y,z) -> f x y z 79 | -------------------------------------------------------------------------------- /bench/bools.hs: -------------------------------------------------------------------------------- 1 | import Test.FitSpec 2 | 3 | propertiesN :: (Bool -> Bool) -> [Property] 4 | propertiesN not = 5 | [ property $ \p -> not (not p) == p 6 | , property $ \p -> not p /= p 7 | , property $ not True == False 8 | ] 9 | 10 | propertiesNA :: (Bool -> Bool) -> (Bool -> Bool -> Bool) -> [Property] 11 | propertiesNA not (&&) = 12 | [ property $ \p -> not (not p) == p 13 | , property $ \p q -> p && q == q && p 14 | , property $ \p -> p && p == p 15 | , property $ \p -> p && False == False 16 | , property $ \p q r -> p && (q && r) == (p && q) && r 17 | , property $ \p -> p && not p == False 18 | , property $ \p -> p && not False == p 19 | ] 20 | 21 | propertiesNAO :: (Bool->Bool) -> (Bool->Bool->Bool) -> (Bool->Bool->Bool) 22 | -> [Property] 23 | propertiesNAO not (&&) (||) = 24 | [ property $ not True == False 25 | , property $ \p -> not (not p) == p 26 | 27 | , property $ \p q -> p && q == q && p 28 | , property $ \p -> p && p == p 29 | , property $ \p -> p && True == p 30 | , property $ \p -> p && False == False 31 | , property $ \p q r -> p && (q && r) == q && (p && r) 32 | 33 | , property $ \p q -> p || q == q || p 34 | , property $ \p -> p || p == p 35 | , property $ \p -> p || True == True 36 | , property $ \p -> p || False == p 37 | , property $ \p q r -> p || (q || r) == q || (p || r) 38 | 39 | , property $ \p q -> p && (p || q) == p 40 | , property $ \p q -> p || (p && q) == p 41 | , property $ \p -> p && not p == False 42 | ] 43 | 44 | main = do 45 | as <- getArgsWith args { names = ["not p","p && q","p || q"] 46 | , nMutants = 100 47 | , nTests = 100 48 | , timeout = 0 } 49 | let run f ps = reportWith as f ps 50 | case concat $ extra as of 51 | "nao" -> run (not,(&&),(||)) (uncurry3 propertiesNAO) 52 | "na" -> run (not,(&&)) (uncurry propertiesNA) 53 | _ -> run not propertiesN 54 | 55 | uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d 56 | uncurry3 f (x,y,z) = f x y z 57 | -------------------------------------------------------------------------------- /bench/digraphs.hs: -------------------------------------------------------------------------------- 1 | -- This program applies FitSpec to the Digraph library. 2 | -- 3 | -- Usage: 4 | -- analyse properties about membership functions: 5 | -- ./digraphs [options] m 6 | -- 7 | -- analyse properties about ispath and subgraph functions: 8 | -- ./digraphs [options] ps 9 | -- 10 | -- 11 | -- This program is more complicated than it should, as it: 12 | -- * allows switching between two function-tuples/property-sets -- 'digraphs m' or 'digraphs ps'; 13 | -- * allows switching between refinements -- 'digraphs ps 0', 'digraphs ps 1', ...; 14 | -- * uses polymorphism where it could use monomorphism. 15 | import Digraph as D 16 | import Test.FitSpec 17 | import Data.List ((\\)) 18 | import qualified Data.List as L (delete) 19 | import Control.Monad 20 | 21 | instance (Ord a, Listable a) => Listable (Digraph a) where 22 | tiers = concatMapT graphs $ setsOf tiers 23 | where 24 | graphs ns = mapT (D . zip ns) 25 | $ listsOfLength (length ns) (setsOf $ toTiers ns) 26 | 27 | -- Our digraph instance above is too complicated. 28 | -- Simple reference implementation: 29 | listDigraphsInneficient :: (Ord a, Listable a) => [Digraph a] 30 | listDigraphsInneficient = concat tiers' 31 | where 32 | tiers' = cons1 D `suchThat` okDigraph `ofWeight` 0 33 | 34 | -- Tests Listable Digraph listable instance 35 | -- by comparing to an equivalent inneficient implementation: 36 | -- 37 | -- > tiers === tiersDigraphsInneficient 38 | listableOK :: Bool 39 | listableOK = and 40 | [ holds 10000 $ \d -> okDigraph (d :: Digraph A) -- sound 41 | , take 100 list `subset` (listDigraphsInneficient :: [Digraph A]) -- sound 42 | , take 100 (listDigraphsInneficient :: [Digraph A]) `subset` list -- complete 43 | ] 44 | where xs `subset` ys = all (`elem` ys) xs 45 | 46 | -- For debugging the digraphs instance 47 | putDigraphs :: Int -> IO () 48 | putDigraphs n = putStrLn . unlines . map (unlines . map show) 49 | $ take n (tiers :: [[Digraph A]]) 50 | 51 | 52 | instance (Ord a, Listable a) => Mutable (Digraph a) where mutiers = mutiersEq 53 | 54 | instance (Ord a, Show a, Listable a) => ShowMutable (Digraph a) where 55 | mutantS = mutantSEq 56 | 57 | 58 | 59 | type Preds a = a -> Digraph a -> [a] 60 | type Succs a = a -> Digraph a -> [a] 61 | type IsNode a = a -> Digraph a -> Bool 62 | type IsEdge a = a -> a -> Digraph a -> Bool 63 | 64 | type TyM a = (Preds a, Succs a, IsNode a, IsEdge a) 65 | 66 | -- | properties about membership in a digraph 67 | propertiesM :: (Ord a, Eq a, Show a, Listable a) => TyM a -> [Property] 68 | propertiesM (preds, succs, isNode, isEdge) = 69 | [ property $ \d t -> D.strictOrder (preds t d) 70 | , property $ \d s -> D.strictOrder (succs s d) 71 | , property $ \d s t -> (s `elem` preds t d) == (t `elem` succs s d) 72 | , property $ \d s t -> (t `elem` succs s d) == isEdge s t d 73 | , property $ \d s t -> isEdge s t d ==> (isNode s d && isNode t d) 74 | , property $ \d s -> isNode s d == (s `elem` D.nodes d) 75 | ] 76 | 77 | functionsM :: Ord a => TyM a 78 | functionsM = (preds,succs,isNode,isEdge) 79 | 80 | 81 | type IsPath a = a -> a -> Digraph a -> Bool 82 | type Subgraph a = [a] -> Digraph a -> Digraph a 83 | 84 | type TyPS a = (IsPath a, Subgraph a) 85 | 86 | -- | properties abouth path and subgraph 87 | propertiesPS :: (Ord a, Eq a, Show a, Listable a) => TyPS a -> [Property] 88 | propertiesPS (isPath, subgraph) = 89 | [ property $ \n d -> isPath n n d == isNode n d 90 | , property $ \n1 n2 n3 d -> isPath n1 n2 d && isPath n2 n3 d ==> isPath n1 n3 d 91 | , property $ \d -> subgraph (D.nodes d) d == d 92 | , property $ \ns1 ns2 d -> subgraph ns1 (subgraph ns2 d) == subgraph ns2 (subgraph ns1 d) 93 | , property $ \n1 n2 ns d -> isPath n1 n2 (subgraph ns d) ==> isPath n1 n2 d 94 | 95 | -- 5-7 96 | , property $ \n1 n2 d -> isPath n1 n2 d ==> isNode n1 d && isNode n2 d 97 | , property $ \n1 n2 d -> isPath n1 n2 d && n1 /= n2 ==> 98 | any (\n1' -> n1' /= n1 && isPath n1' n2 d) (succs n1 d) 99 | , property $ \n1 n2 d -> n1 /= n2 ==> 100 | isPath n1 n2 d == 101 | let d' = subgraph (nodes d \\ [n1]) d in 102 | any (\n1' -> isPath n1' n2 d') 103 | (succs n1 d) 104 | 105 | -- 8-9 106 | , property $ \n ns d -> isNode n (subgraph ns d) == (isNode n d && n `elem` ns) 107 | , property $ \n1 n2 ns d -> isEdge n1 n2 (subgraph ns d) 108 | == (isEdge n1 n2 d && n1 `elem` ns && n2 `elem` ns) 109 | ] 110 | 111 | functionsPS :: Ord a => TyPS a 112 | functionsPS = (isPath, subgraph) 113 | 114 | 115 | 116 | extraMutantsM :: Ord a => [TyM a] 117 | extraMutantsM = [] 118 | 119 | extraMutantsPS :: Ord a => [TyPS a] 120 | extraMutantsPS = drop 1 121 | [ (isPath, subgraph) 122 | , (\n1 n2 d -> isNode n1 d && isNode n2 d, subgraph) 123 | , (isPath, \ns d -> D []) 124 | ] 125 | 126 | main :: IO () 127 | main = do 128 | unless listableOK 129 | $ putStrLn "WARNING: Listable Digraph is broken! (read my source.)" 130 | 131 | as <- getArgsWith args { names = [ "isPath n1 n2 d" 132 | , "subgraph ns d" ] } 133 | 134 | let (pset,step) = case extra as of 135 | (p:s:_) -> (p ,read s) 136 | [p] -> (p ,0) 137 | [] -> ("m",0) 138 | 139 | case pset of 140 | "m" -> 141 | mainWith as { names = [ "preds n d" 142 | , "succs n d" 143 | , "isNode n d" 144 | , "isEdge s t d" ] } 145 | (functionsM :: TyM A) 146 | propertiesM 147 | 148 | "ps" -> 149 | let is = case step of 150 | 0 -> [ ] 151 | 1 -> [0,1,2,3,4 ] 152 | 2 -> [0,1,2,3,4,5,6 ] 153 | 3 -> [0,1,2,3,4,5,6, 8,9] 154 | 4 -> [0,1,2,3,4,5, 7,8,9] 155 | 5 -> [0, 7,8,9] 156 | _ -> [0,1,2,3,4,5,6,7,8,9] -- not an actual step 157 | in 158 | mainWith as { names = [ "isPath n1 n2 d" 159 | , "subgraph ns d" ] } 160 | (functionsPS :: TyPS A) 161 | ((!!! is) . propertiesPS) 162 | 163 | (!!!) :: [a] -> [Int] -> [a] 164 | xs !!! is = map (xs !!) is 165 | -------------------------------------------------------------------------------- /bench/haskell-src-exts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | import Test.FitSpec 3 | import Language.Haskell.Exts 4 | 5 | instance Eq a => Eq (ParseResult a) where 6 | ParseOk x == ParseOk y = x == y 7 | ParseFailed l1 s1 == ParseFailed l2 s2 = l1 == l2 && s1 == s2 8 | _ == _ = False 9 | 10 | deriveMutableCascading ''ParseResult 11 | deriveMutableCascading ''Module 12 | deriveMutableCascading ''SrcSpanInfo 13 | 14 | properties :: (String -> ParseResult (Module SrcSpanInfo) 15 | ,Module SrcSpanInfo -> String) 16 | -> [Property] 17 | properties (parseFileContents,prettyPrint) = 18 | [ property $ case parseFileContents "" of 19 | ParseOk (Module _ _ _ _ _) -> True 20 | _ -> False 21 | , property $ case parseFileContents "a" of 22 | ParseFailed (SrcLoc ".hs" 2 1) _ -> True 23 | _ -> False 24 | , property $ \m -> case parseFileContents (prettyPrint m) of 25 | ParseOk m' -> case parseFileContents (prettyPrint m') of 26 | ParseOk m'' -> m' == m'' 27 | _ -> False 28 | _ -> True 29 | -- Not true: 30 | --, property $ \s -> case parseFileContents s of 31 | -- ParseOk m' -> prettyPrint m' == s 32 | -- _ -> True 33 | ] 34 | 35 | main = mainWith args { names = ["parseFileContents f", "prettyPrint m"] } 36 | (parseFileContents,prettyPrint) 37 | properties 38 | -------------------------------------------------------------------------------- /bench/haskell-src.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, StandaloneDeriving #-} 2 | import Test.FitSpec 3 | import Language.Haskell.Parser 4 | import Language.Haskell.Pretty as P 5 | import Language.Haskell.Syntax 6 | import Data.Ratio 7 | import Data.List (intercalate) 8 | import Data.Function (on) 9 | import Data.Char 10 | 11 | deriving instance Eq HsModule -- needed for Mutable 12 | 13 | deriveMutableCascading ''HsModule 14 | 15 | -- change ``take 5'' below to ``take n'' where n `elem` [1,2,3,4] 16 | -- to see surviving mutants for different refinements 17 | -- 18 | -- All 5 properties should be reported as ``apparently complete'' 19 | -- so no surviving mutants. 20 | properties :: (HsModule -> String) -> [Property] 21 | properties prettyPrint = take 5 22 | [ property $ 23 | \nm loc -> (prettyPrint $ HsModule loc (Module nm) Nothing [] []) 24 | == "module " ++ nm ++ " where" 25 | 26 | , property $ 27 | \nm loc -> (prettyPrint $ HsModule loc (Module nm) (Just []) [] []) 28 | == "module " ++ nm ++ " () where" 29 | 30 | , property $ 31 | \nm loc -> (prettyPrint $ HsModule loc (Module nm) Nothing [] [HsFunBind []]) 32 | == "module " ++ nm ++ " where" 33 | 34 | , property $ 35 | \nm loc imports decls -> 36 | (prettyPrint $ HsModule loc (Module nm) Nothing imports decls) 37 | === unlines (("module " ++ nm ++ " where") 38 | :(map P.prettyPrint imports 39 | ++ map P.prettyPrint decls)) 40 | 41 | , property $ 42 | \nm loc imports exports decls -> 43 | (prettyPrint $ HsModule loc (Module nm) (Just exports) imports decls) 44 | === unlines (["module " ++ nm ++ " (" 45 | ++ intercalate ", " (map P.prettyPrint exports) 46 | ++ ") where"] 47 | ++ map P.prettyPrint imports 48 | ++ map P.prettyPrint decls) 49 | ] 50 | where 51 | (===) :: String -> String -> Bool 52 | (===) = (==) `on` (filter (not . null) . lines) 53 | 54 | main = mainWith args { names = ["prettyPrint"] 55 | , timeout = 0 56 | } 57 | prettyPrint 58 | properties 59 | -------------------------------------------------------------------------------- /bench/heaps.hs: -------------------------------------------------------------------------------- 1 | {-# Language DeriveDataTypeable, NoMonomorphismRestriction #-} 2 | import Test.FitSpec 3 | import Prelude hiding (null) 4 | import qualified Data.List as L 5 | import Data.Maybe (listToMaybe) 6 | import Heap 7 | import Control.Monad (unless) 8 | 9 | instance (Ord a, Listable a) => Listable (Heap a) where 10 | tiers = bagCons fromList 11 | 12 | -- a good property to assure that the above does not leave out elements is: 13 | -- 14 | -- \xs ys = xs `permutation` ys <==> fromList xs == fromList ys 15 | -- `asTypeOf` (undefined :: Heap a) 16 | 17 | instance (Ord a, Listable a) => Mutable (Heap a) where 18 | mutiers = mutiersEq 19 | 20 | instance (Ord a, Show a, Listable a) => ShowMutable (Heap a) where 21 | mutantS = mutantSEq 22 | 23 | -- Alias for type (they are repeated a lot) 24 | type Insert a = a -> Heap a -> Heap a 25 | type DeleteMin a = Heap a -> Heap a 26 | type Merge a = Heap a -> Heap a -> Heap a 27 | type Ty a = (Insert a, DeleteMin a, Merge a) 28 | 29 | properties :: (Ord a, Show a, Listable a) 30 | => Insert a 31 | -> DeleteMin a 32 | -> Merge a 33 | -> [Property] 34 | properties insert' deleteMin' merge' = 35 | [ property $ \x y h -> insert' x (insert' y h) == insert' y (insert' x h) -- 1 36 | , property $ \h x -> null (insert' x h) == False -- 2 37 | , property $ \x h -> L.insert x (toList h) == toList (insert' x h) -- 3 38 | 39 | , property $ \h h1 -> merge' h h1 == merge' h1 h -- 4 40 | , property $ \h -> merge' h Nil == h -- 5 41 | , property $ \h h1 h2 -> merge' h (merge' h1 h2) == merge' h1 (merge' h h2) -- 6 42 | , property $ \h -> not (null h) ==> findMin (merge' h h) == findMin h -- 7 43 | , property $ \h -> null (merge' h h) == null h -- 8 44 | , property $ \h h1 -> (null h && null h1) == null (merge' h h1) -- 9 45 | 46 | , property $ \h h1 x -> merge' h (insert' x h1) == insert' x (merge' h h1) -- 10 47 | , property $ \h -> not (null h) ==> merge' h (deleteMin' h) == deleteMin' (merge' h h) -- 11 48 | , property $ \x -> deleteMin' (insert' x Nil) == Nil -- 12 49 | ] 50 | 51 | sargs = args 52 | { timeout = 0 53 | , nMutants = 500 54 | , nTests = 500 55 | , names = ["insert x h","deleteMin h","merge h h'"] 56 | --, extraMutants = take 0 [(uncurry maxInsert,maxDeleteMin,uncurry maxMerge)] } 57 | } 58 | 59 | fns :: Ord a => Ty a 60 | fns = (insert, deleteMin, merge) 61 | 62 | em :: (Bounded a, Ord a) => [Ty a] 63 | em = take 3 64 | [ (maxInsert, maxDeleteMin, maxMerge) 65 | , (insert, deleteMin, crazyMerge) 66 | , (\i h -> Nil, deleteMin, merge) 67 | ] 68 | 69 | main :: IO () 70 | main = do 71 | as <- getArgsWith sargs 72 | let run f = reportWithExtra em as f (uncurry3 properties) 73 | case concat (extra as) of 74 | -- "bool" -> run (fns :: Ty Bool) 75 | -- "bools" -> run (fns :: Ty [Bool]) 76 | "i" -> run (fns :: Ty Int) 77 | "i1" -> run (fns :: Ty Int1) 78 | "i2" -> run (fns :: Ty Int2) 79 | "i3" -> run (fns :: Ty Int3) 80 | "w1" -> run (fns :: Ty Word1) 81 | "w2" -> run (fns :: Ty Word2) 82 | "w3" -> run (fns :: Ty Word3) 83 | "unit" -> run (fns :: Ty ()) 84 | "" -> run (fns :: Ty Word2) 85 | 86 | 87 | maxInsert :: Ord a => a -> Heap a -> Heap a 88 | maxInsert x h = maxMerge h (branch x Nil Nil) 89 | 90 | maxDeleteMin :: Ord a => Heap a -> Heap a 91 | maxDeleteMin (Branch _ _ l r) = maxMerge l r 92 | maxDeleteMin Nil = Nil 93 | 94 | maxMerge :: Ord a => Heap a -> Heap a -> Heap a 95 | maxMerge Nil h = h 96 | maxMerge h Nil = h 97 | maxMerge h1@(Branch _ x1 l1 r1) h2@(Branch _ x2 l2 r2) 98 | | x1 >= x2 = branch x1 (maxMerge l1 h2) r1 99 | | otherwise = maxMerge h2 h1 100 | 101 | uncurry3 :: (a->b->c->d) -> (a,b,c) -> d 102 | uncurry3 f (x,y,z) = f x y z 103 | 104 | crazyMerge :: (Bounded a, Ord a) => Heap a -> Heap a -> Heap a 105 | crazyMerge Nil Nil = Nil 106 | crazyMerge Nil h = h 107 | crazyMerge h Nil = h 108 | crazyMerge h h1 = insert maxBound $ merge h h1 109 | -------------------------------------------------------------------------------- /bench/id.hs: -------------------------------------------------------------------------------- 1 | -- Example benchmark that mutation tests properties over the function id 2 | import Test.FitSpec 3 | 4 | type Ty a = a -> a 5 | 6 | -- The property map 7 | properties :: (Eq a, Show a, Listable a) => Ty a -> [Property] 8 | properties id = 9 | [ property $ \x -> id x == x 10 | , property $ \x -> id x == id x 11 | , property $ \x -> (id . id) x == x 12 | ] 13 | 14 | sargs :: Args 15 | sargs = args 16 | { names = ["id x"] 17 | , nMutants = 1000 18 | , nTests = 2000 19 | , timeout = 0 20 | } 21 | 22 | main :: IO () 23 | main = do 24 | as <- getArgsWith sargs 25 | let run f = reportWith as f properties 26 | case concat (extra as) of 27 | "bool" -> run (id :: Ty Bool) 28 | "bools" -> run (id :: Ty [Bool]) 29 | "int" -> run (id :: Ty Int) 30 | "int2" -> run (id :: Ty UInt2) 31 | "int3" -> run (id :: Ty UInt3) 32 | "unit" -> run (id :: Ty ()) 33 | "" -> run (id :: Ty UInt2) 34 | -------------------------------------------------------------------------------- /bench/list.hs: -------------------------------------------------------------------------------- 1 | import Test.FitSpec 2 | import Data.List 3 | 4 | type Cons a = a -> [a] -> [a] 5 | type Head a = [a] -> a 6 | type Tail a = [a] -> [a] 7 | type Append a = [a] -> [a] -> [a] 8 | type Ty a = ( Cons a 9 | , Head a 10 | , Tail a 11 | , Append a 12 | ) 13 | 14 | -- The property map 15 | properties :: (Eq a, Show a, Listable a) 16 | => Cons a 17 | -> Head a 18 | -> Tail a 19 | -> Append a 20 | -> [Property] 21 | properties (-:) head tail (++) = 22 | [ property $ \xs -> [] ++ xs == xs && xs == xs ++ [] 23 | , property $ \x xs -> head (x-:xs) == x 24 | , property $ \x xs -> tail (x-:xs) == xs 25 | , property $ \xs -> null (xs ++ xs) == null xs 26 | , property $ \xs ys zs -> (xs ++ ys) ++ zs == xs ++ (ys ++ zs) 27 | , property $ \x xs ys -> x-:(xs ++ ys) == (x-:xs) ++ ys 28 | ] 29 | 30 | 31 | fns :: Ty a 32 | fns = ((:),head,tail,(++)) 33 | 34 | sargs :: Args 35 | sargs = args 36 | { names = ["(:) x xs","head xs","tail xs","(++) xs ys"] 37 | , nMutants = 1000 38 | , nTests = 1000 39 | , timeout = 0 40 | } 41 | 42 | --, extraMutants = takeWhile (const False) 43 | -- [ ((:),head,tail,(++-)) 44 | -- , ((:),head,tail,(++--)) 45 | -- ] 46 | 47 | main :: IO () 48 | main = do 49 | as <- getArgsWith sargs 50 | let run f = reportWith as f (uncurry4 properties) 51 | case concat (extra as) of 52 | "bool" -> run (fns :: Ty Bool) 53 | "bools" -> run (fns :: Ty [Bool]) 54 | "int" -> run (fns :: Ty Int) 55 | "int2" -> run (fns :: Ty UInt2) 56 | "int3" -> run (fns :: Ty UInt3) 57 | "unit" -> run (fns :: Ty ()) 58 | "" -> run (fns :: Ty UInt2) 59 | 60 | -- Some manual mutants 61 | (++-) :: [a] -> [a] -> [a] 62 | xs ++- ys = [] 63 | 64 | (++--) :: [a] -> [a] -> [a] 65 | xs ++-- ys = if length xs > length ys 66 | then xs 67 | else ys 68 | 69 | uncurry4 :: (a -> b -> c -> d -> e) -> (a,b,c,d) -> e 70 | uncurry4 f (x,y,z,w) = f x y z w 71 | 72 | -------------------------------------------------------------------------------- /bench/mergeheaps.hs: -------------------------------------------------------------------------------- 1 | {-# Language DeriveDataTypeable, NoMonomorphismRestriction #-} 2 | import Test.FitSpec 3 | import Prelude hiding (null) 4 | import qualified Data.List as L 5 | import Data.Maybe (listToMaybe) 6 | import Heap 7 | import Control.Monad (unless) 8 | 9 | instance (Ord a, Listable a) => Listable (Heap a) where 10 | tiers = bagCons fromList 11 | 12 | instance (Ord a, Listable a) => Mutable (Heap a) where 13 | mutiers = mutiersEq 14 | 15 | instance (Ord a, Show a, Listable a) => ShowMutable (Heap a) where 16 | mutantS = mutantSEq 17 | 18 | type Merge a = Heap a -> Heap a -> Heap a 19 | type Ty a = Merge a 20 | 21 | properties :: (Ord a, Show a, Listable a) 22 | => Merge a 23 | -> [Property] 24 | properties merge = 25 | [ property $ \h h1 -> merge h h1 == merge h1 h 26 | , property $ \h -> merge h Nil == h 27 | , property $ \x h h1 -> merge h (insert x h1) == insert x (merge h h1) 28 | , property $ \h h1 h2 -> merge h (merge h1 h2) == merge h1 (merge h h2) 29 | , property $ \h -> notNull h ==> findMin (merge h h) == findMin h 30 | , property $ \h -> null (merge h h) == null h 31 | , property $ \h -> notNull h ==> merge h (deleteMin h) == deleteMin (merge h h) 32 | , property $ \h h1 -> (null h && null h1) == null (merge h h1) 33 | --, property $ \xs ys -> merge (fromList xs) (fromList ys) == fromList (xs++ys) 34 | --, property $ \h h1 -> mergeLists (toList h) (toList h1) == toList (merge h h1) 35 | ] 36 | where notNull = not . null 37 | 38 | sargs = args 39 | { timeout = 0 40 | , nMutants = 500 41 | , nTests = 500 42 | , names = ["merge h h'"] 43 | } 44 | 45 | em :: (Bounded a, Ord a) => [Ty a] 46 | em = take 4 47 | [ (\_ _ -> Nil) 48 | , maxMerge 49 | , crazyMerge 50 | , mergeEqNil 51 | ] 52 | 53 | main :: IO () 54 | main = do 55 | as <- getArgsWith sargs 56 | let run f = reportWithExtra em as f properties 57 | case concat (extra as) of 58 | "bool" -> run (merge :: Ty Bool) 59 | "bools" -> run (merge :: Ty [Bool]) 60 | "i" -> run (merge :: Ty Int) 61 | "i1" -> run (merge :: Ty Int1) 62 | "i2" -> run (merge :: Ty Int2) 63 | "i3" -> run (merge :: Ty Int3) 64 | "w1" -> run (merge :: Ty Word1) 65 | "w2" -> run (merge :: Ty Word2) 66 | "w3" -> run (merge :: Ty Word3) 67 | "unit" -> run (merge :: Ty ()) 68 | "" -> run (merge :: Ty Word2) 69 | 70 | 71 | maxInsert :: Ord a => a -> Heap a -> Heap a 72 | maxInsert x h = maxMerge h (branch x Nil Nil) 73 | 74 | maxDeleteMin :: Ord a => Heap a -> Heap a 75 | maxDeleteMin (Branch _ _ l r) = maxMerge l r 76 | maxDeleteMin Nil = Nil 77 | 78 | maxMerge :: Ord a => Heap a -> Heap a -> Heap a 79 | maxMerge Nil h = h 80 | maxMerge h Nil = h 81 | maxMerge h1@(Branch _ x1 l1 r1) h2@(Branch _ x2 l2 r2) 82 | | x1 >= x2 = branch x1 (maxMerge l1 h2) r1 83 | | otherwise = maxMerge h2 h1 84 | 85 | uncurry3 :: (a->b->c->d) -> (a,b,c) -> d 86 | uncurry3 f (x,y,z) = f x y z 87 | 88 | crazyMerge :: (Bounded a, Ord a) => Heap a -> Heap a -> Heap a 89 | crazyMerge Nil Nil = Nil 90 | crazyMerge Nil h = h 91 | crazyMerge h Nil = h 92 | crazyMerge h h1 = insert maxBound $ merge h h1 93 | 94 | mergeEqNil :: (Ord a) => Heap a -> Heap a -> Heap a 95 | mergeEqNil h h1 | h == h1 = Nil 96 | | otherwise = merge h h1 97 | 98 | -- Only necessary for crazyMerge + bools to compile 99 | -- (it won't run, because it won't be able to PRINT surviving 100 | -- mutants). 101 | -- all other types should work fine 102 | instance Bounded a => Bounded [a] where 103 | minBound = [] 104 | maxBound = repeat maxBound 105 | -------------------------------------------------------------------------------- /bench/pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | import Test.FitSpec 3 | import Text.PrettyPrint as P 4 | 5 | #if __GLASGOW_HASKELL__ < 710 6 | -- pretty <= 1.1.1.1 (bundled with GHC <= 7.8) does not provide this instance 7 | -- pretty >= 1.1.2.0 (bundled with GHC >= 7.10) does provide this instance 8 | instance Eq Doc where 9 | d == d' = show d == show d' 10 | #endif 11 | 12 | instance Listable Doc where 13 | tiers = cons1 text -- TODO: Improve this 14 | 15 | instance Mutable Doc where 16 | mutiers = mutiersEq 17 | 18 | instance ShowMutable Doc where 19 | mutantS = mutantSEq 20 | 21 | properties :: (Doc->Doc->Doc) -> (Doc->Doc->Doc) -> (Int->Doc->Doc) -> [Property] 22 | properties (<>) ($$) nest = 23 | [ property $ \x y z -> (x <> y) <> z == x <> (y <> z) 24 | , property $ \x y z -> (x $$ y) $$ z == x $$ (y $$ z) 25 | , property $ \x -> x <> text "" == x 26 | , property $ \x k y -> nest k (x $$ y) == nest k x $$ nest k y 27 | , property $ \x k y -> nest k (x <> y) == nest k x <> y 28 | , property $ \x k y -> x <> nest k y == x <> y 29 | , property $ \x k k' -> nest k (nest k' x) == nest (k+k') x 30 | , property $ \x -> nest 0 x == x 31 | , property $ \x y z -> (x $$ y) <> z == x $$ (y <> z) 32 | , property $ \s y z -> text s <> ((text "" <> y) $$ z) == (text s <> y) $$ nest (length s) z 33 | , property $ \s t -> text s <> text t == text (s ++ t) 34 | ] 35 | 36 | propertiesQS :: (Doc->Doc->Doc) -> (Doc->Doc->Doc) -> (Int->Doc->Doc) -> [Property] 37 | propertiesQS (<>) ($$) nest = 38 | [ property $ \x y z -> (x <> y) <> z == x <> (y <> z) 39 | , property $ \x y z -> (x $$ y) $$ z == x $$ (y $$ z) 40 | , property $ \x y z -> (x $$ y) <> z == x $$ (y <> z) 41 | , property $ \x k y -> x <> nest k y == x <> y 42 | , property $ \x k y -> nest k (x <> y) == nest k x <> y 43 | , property $ \x k y -> nest k (x $$ y) == nest k x $$ nest k y 44 | , property $ \x k k' -> nest k (nest k' x) == nest k' (nest k x) 45 | ] 46 | 47 | main = do 48 | as <- getArgs 49 | let run ps = reportWith as ((P.<>),($$),nest) (uncurry3 ps) 50 | case concat (extra as) of 51 | "qs" -> run propertiesQS 52 | "" -> run properties 53 | 54 | uncurry3 :: (a -> b -> c -> d) -> (a,b,c) -> d 55 | uncurry3 f = \(x,y,z) -> f x y z 56 | -------------------------------------------------------------------------------- /bench/sets.hs: -------------------------------------------------------------------------------- 1 | import Set as S 2 | import Test.FitSpec hiding ((\/),Set) 3 | 4 | 5 | instance (Ord a, Listable a) => Listable (S.Set a) where 6 | tiers = setCons set 7 | 8 | instance (Ord a, Listable a) => Mutable (S.Set a) where 9 | mutiers = mutiersEq 10 | 11 | instance (Ord a, Show a, Listable a) => ShowMutable (S.Set a) where 12 | mutantS = mutantSEq 13 | 14 | 15 | type Elem a = a -> Set a -> Bool 16 | 17 | 18 | -- The property map. 19 | -- In a real program applying FitSpec, the 'Int' parameter would not exist. 20 | -- It is here so we can re-run the steps taken in creating the final 21 | -- property list (by @properties 3@). 22 | properties 0 ((<~), insertS, deleteS, (/\), (\/), subS) = 23 | [ 24 | ] 25 | properties 1 ((<~), insertS, deleteS, (/\), (\/), subS) = 26 | [ property $ \x s -> x <~ insertS x s 27 | , property $ \x s -> not (x <~ deleteS x s) 28 | , property $ \x s t -> (x <~ (s \/ t)) == ((x <~ s) || (x <~ t)) 29 | , property $ \x s t -> (x <~ (s /\ t)) == ((x <~ s) && (x <~ t)) 30 | , property $ \s t -> subS s (s \/ t) 31 | , property $ \s t -> subS (s /\ t) s 32 | , property $ \s t -> (s \/ t) == (t \/ s) 33 | , property $ \s t -> (s /\ t) == (t /\ s) 34 | ] 35 | properties 2 ((<~), insertS, deleteS, (/\), (\/), subS) = 36 | [ property $ \x s -> x <~ insertS x s 37 | , property $ \x s -> not (x <~ deleteS x s) 38 | , property $ \x s t -> (x <~ (s \/ t)) == ((x <~ s) || (x <~ t)) 39 | , property $ \x s t -> (x <~ (s /\ t)) == ((x <~ s) && (x <~ t)) 40 | , property $ \s t -> subS s t == allS (<~ t) s 41 | ] 42 | properties _ ((<~), insertS, deleteS, (/\), (\/), subS) = 43 | [ property $ \x y s -> x <~ insertS y s == (x == y || x <~ s) 44 | , property $ \x y s -> x <~ deleteS y s == (x <~ s && x /= y) 45 | , property $ \x s t -> (x <~ (s \/ t)) == ((x <~ s) || (x <~ t)) 46 | , property $ \x s t -> (x <~ (s /\ t)) == ((x <~ s) && (x <~ t)) 47 | , property $ \s t -> subS s t == allS (<~ t) s 48 | ] 49 | -- If we add (\\) to the functions under test, this property should follow: 50 | -- \x s t -> (x <~ (s \\ t)) == ((x <~ s) && not (x <~ t)) 51 | 52 | 53 | main :: IO () 54 | main = do 55 | as <- getArgs 56 | let psid = case concat . extra $ as of "" -> 0; cs -> read cs 57 | mainWith as { names = [ "x <~ s" 58 | , "insertS x s" 59 | , "deleteS x s" 60 | , "s /\\ t" 61 | , "s \\/ t" 62 | , "subS s t" ] } 63 | ((<~)::Elem Word2, insertS, deleteS, (/\), (\/), subS) 64 | (properties psid) 65 | -------------------------------------------------------------------------------- /bench/setsofsets.hs: -------------------------------------------------------------------------------- 1 | import Set as S 2 | import Test.FitSpec hiding ((\/),Set) 3 | 4 | 5 | instance (Ord a, Listable a) => Listable (S.Set a) where 6 | tiers = setCons set 7 | 8 | instance (Ord a, Listable a) => Mutable (S.Set a) where 9 | mutiers = mutiersEq 10 | 11 | instance (Ord a, Show a, Listable a) => ShowMutable (S.Set a) where 12 | mutantS = mutantSEq 13 | 14 | -- The Mutable and ShowMutable instances could be alternatively derived by: 15 | -- deriveMutable 'Set 16 | 17 | 18 | -- Type of functions under test 19 | type PowerS a = S.Set a -> S.Set (S.Set a) 20 | type PartitionsS a = S.Set a -> S.Set (S.Set (S.Set a)) 21 | type Ty a = (PowerS a, PartitionsS a) 22 | 23 | 24 | -- The property map. 25 | -- In a real program applying FitSpec, the 'Int' parameter would not exist. 26 | -- It is here so we can re-run the steps taken in creating the final 27 | -- property list (by @properties 5@). 28 | properties :: (Ord a, Eq a, Show a, Listable a) 29 | => Int -> Ty a -> [Property] 30 | properties 0 (powerS,partitionsS) = 31 | [ 32 | ] 33 | properties 1 (powerS,partitionsS) = 34 | [ property $ \s t -> (t <~ powerS s) == subS t s 35 | , property $ \s -> allS (allS (`subS` s)) (partitionsS s) 36 | ] 37 | properties 2 (powerS,partitionsS) = 38 | [ property $ \s t -> (t <~ powerS s) == subS t s 39 | , property $ \s -> allS (allS (`subS` s)) (partitionsS s) 40 | , property $ \s -> nonEmptyS (partitionsS s) 41 | ] 42 | properties 3 (powerS,partitionsS) = 43 | [ property $ \s t -> (t <~ powerS s) == subS t s 44 | , property $ \s -> allS (allS (`subS` s)) (partitionsS s) 45 | , property $ \s -> nonEmptyS (partitionsS s) 46 | , property $ \s -> allS (allS (\t -> nonEmptyS t && subS t s)) (partitionsS s) 47 | ] 48 | -- Ommited on paper -- we changed 4th to: 49 | --, property $ \s -> allS (\p -> unionS p == s && allS nonEmptyS p) (partitionsS s) 50 | properties _ (powerS,partitionsS) = 51 | [ property $ \s t -> (t <~ powerS s) == subS t s 52 | , property $ \s p -> (p <~ partitionsS s) == 53 | ( unionS p == s && 54 | allS nonEmptyS p && 55 | sum (map sizeS (elemList p)) == sizeS s ) 56 | ] 57 | 58 | 59 | fns :: Ord a => Ty a 60 | fns = (powerS, partitionsS) 61 | 62 | main :: IO () 63 | main = do 64 | as <- getArgs 65 | let psid = read . concat . extra $ as 66 | mainWith as { names = [ "powerS s" 67 | , "partitionsS s" ] } 68 | (fns::Ty Word2) 69 | (properties psid) 70 | -------------------------------------------------------------------------------- /bench/sieve.hs: -------------------------------------------------------------------------------- 1 | -- Example benchmark that mutation tests properties over an infinite list of primes 2 | import Test.FitSpec 3 | import Data.Maybe 4 | 5 | -- The code under test 6 | primes :: [Int] 7 | primes = sieve [2..] 8 | where sieve (p:ns) = p : sieve [n | n <- ns, n `mod` p /= 0] 9 | 10 | -- Some auxiliary functions 11 | strictlyOrdered [] = True 12 | strictlyOrdered [x] = True 13 | strictlyOrdered (x:y:xs) = x a -> [a] -> Bool 16 | x `elemO` [] = False 17 | x `elemO` (x':xs) = case x `compare` x' of 18 | LT -> False -- would already have appeared int the list 19 | EQ -> True 20 | GT -> x `elemO` xs 21 | infix 4 `elemO` 22 | 23 | notElemO :: Ord a => a -> [a] -> Bool 24 | notElemO = (not .) . elemO 25 | infix 4 `notElemO` 26 | 27 | -- The property map 28 | properties :: [Int] -> [Property] 29 | properties primes = 30 | [ property $ listToMaybe primes == Just 2 -- start with two 31 | --, property $ length (take n primes) == n -- infinite 32 | --, property $ allUnique (take n primes) 33 | --, property $ strictlyOrdered (take n primes) 34 | , property $ \x -> x `elemO` primes 35 | ==> x*x `notElemO` primes 36 | , property $ \x y -> x `elemO` primes 37 | && y `elemO` primes 38 | ==> x*y `notElemO` primes 39 | --, property $ \i' -> let i = fromIntegral (i'::Nat) 40 | -- p = primes !! i 41 | -- ps = drop (i+1) primes 42 | -- in p > 1 ==> all (\p' -> p' `mod` p /= 0) (take n ps) 43 | , property $ \x y -> x `elemO` primes 44 | && y `elemO` primes 45 | && x /= y 46 | ==> x `mod` y /= 0 47 | --, all prime (take n primes) -- sound 48 | --, all (`elemO` primes) [ x | x <- [1..n], prime x ] -- complete 49 | ] 50 | where prime x = x > 1 51 | && all (\p -> p > 0 && x `mod` p /= 0) 52 | (takeWhile (\p -> p*p <= x) primes) 53 | 54 | 55 | prime x = x > 1 && all (\p -> p `mod` x /= 0) (takeWhile (\p -> p*p <= x) primes) 56 | 57 | sargs :: Args 58 | sargs = args 59 | { nMutants = 20000 60 | , nTests = 100 61 | , timeout = 0 62 | } 63 | --, showMutantN = \_ _ -> showInfinite 64 | --where showInfinite xs | not . null $ drop 10 xs = (init . show $ take 10 xs) ++ "..." 65 | -- | otherwise = show xs 66 | 67 | main :: IO () 68 | main = mainWith sargs primes properties 69 | 70 | allUnique :: Ord a => [a] -> Bool 71 | allUnique [] = True 72 | allUnique (x:xs) = x `notElem` xs 73 | && allUnique lesser 74 | && allUnique greater 75 | where lesser = filter (< x) xs 76 | greater = filter (> x) xs 77 | -------------------------------------------------------------------------------- /bench/sorting.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | import Test.FitSpec 3 | 4 | 5 | ordered :: Ord a => [a] -> Bool 6 | ordered [] = True 7 | ordered [_] = True 8 | ordered (x:y:xs) = x <= y && ordered (y:xs) 9 | 10 | permutation :: Eq a => [a] -> [a] -> Bool 11 | [] `permutation` [] = True 12 | (_:_) `permutation` [] = False 13 | [] `permutation` (_:_) = False 14 | (x:xs) `permutation` ys = x `elem` ys && xs `permutation` delete x ys 15 | 16 | count :: Eq a => a -> [a] -> Int 17 | count x = length . filter (==x) 18 | 19 | 20 | properties :: (Ord a, Show a, Listable a) 21 | => ([a] -> [a]) -> [Property] 22 | properties sort = 23 | [ property $ \xs -> ordered (sort xs) 24 | , property $ \xs -> length (sort xs) == length xs 25 | , property $ \x xs -> elem x (sort xs) == elem x xs 26 | , property $ \x xs -> count x (sort xs) == count x xs 27 | , property $ \xs -> permutation xs (sort xs) 28 | , property $ \x xs -> insert x (sort xs) == sort (x:xs) 29 | ] 30 | 31 | 32 | sargs :: Args 33 | sargs = args 34 | { names = ["sort xs"] 35 | , timeout = 0 36 | , nMutants = 1000 37 | , nTests = 1000 38 | } 39 | --, extraMutants = take 0 40 | -- . concat 41 | -- . lsmap (. sort) 42 | -- $ cons2 (\y ys -> (++ (y:ys))) -- prepend non-empty list 43 | -- \++/ cons2 (\y ys -> ((y:ys) ++)) -- append non-empty list 44 | 45 | type Ty a = [a] -> [a] 46 | 47 | main :: IO () 48 | main = do 49 | as <- getArgsWith sargs 50 | let run f = reportWith as f properties 51 | case concat $ extra as of 52 | "bool" -> run (sort :: Ty Bool) 53 | "bools" -> run (sort :: Ty [Bool]) 54 | "int" -> run (sort :: Ty Int) 55 | "i1" -> run (sort :: Ty Int1) 56 | "i2" -> run (sort :: Ty Int2) 57 | "i3" -> run (sort :: Ty Int3) 58 | "w1" -> run (sort :: Ty Word1) 59 | "w2" -> run (sort :: Ty Word2) 60 | "w3" -> run (sort :: Ty Word3) 61 | "unit" -> run (sort :: Ty ()) 62 | "" -> run (sort :: Ty Word2) 63 | t -> putStrLn $ "unknown type " ++ t 64 | 65 | -- This hack is only necessary when using sortCounter as a manual mutant 66 | instance Bounded a => Bounded [a] where 67 | minBound = [] 68 | maxBound = repeat maxBound -- non terminating upper bound 69 | 70 | sortCounter :: (Bounded a, Ord a) => [a] -> [a] 71 | sortCounter = (++ [maxBound]) . sort 72 | -------------------------------------------------------------------------------- /bench/spring.hs: -------------------------------------------------------------------------------- 1 | import Test.FitSpec 2 | import Data.List 3 | 4 | type Add a = a -> a -> a 5 | type Prod a = a -> a -> a 6 | type Ty a = ( Add a 7 | , Prod a ) 8 | 9 | properties :: (Listable a, Show a, Eq a, Num a) 10 | => Add a 11 | -> Prod a 12 | -> [Property] 13 | properties (+) (*) = 14 | [ property $ \x y -> x + y == y + x 15 | , property $ \x y z -> x + (y + z) == (x + y) + z 16 | , property $ \x -> x + 0 == x 17 | , property $ \x -> 0 + x == x 18 | 19 | , property $ \x y -> x * y == y * x 20 | , property $ \x y z -> x * (y * z) == (x * y) * z 21 | , property $ \x -> x * 1 == x 22 | , property $ \x -> 1 * x == x 23 | 24 | , property $ \x y z -> x * (y + z) == (x * y) + (x * z) 25 | , property $ \x y z -> (y + z) * x == (y * x) + (z * x) 26 | ] 27 | 28 | 29 | fns :: Integral a => Ty a 30 | fns = ((+),(*)) 31 | 32 | 33 | sargs :: Args 34 | sargs = 35 | args { timeout = 0 36 | , nMutants = 1000 37 | , nTests = 1000 38 | , names = [ "x + y", "x * y" ] 39 | } 40 | -- , extraMutants = 41 | -- let ems = [ \x y -> x+y+1 42 | -- , \x y -> x*y+x*y 43 | -- , \x y -> x+y+x+y 44 | -- , (+++) 45 | -- , min 46 | -- , max 47 | -- -- another good example would be 48 | -- -- || and && defined over integers 49 | -- ] 50 | -- in drop 1 [ (s,p) 51 | -- | False -- was useExtra 52 | -- , s <- (+):(*):ems 53 | -- , p <- (*):(+):ems 54 | -- ] 55 | 56 | main :: IO () 57 | main = do 58 | as <- getArgsWith sargs 59 | let run f = reportWith as f (uncurry properties) 60 | case concat (extra as) of 61 | "int" -> run (fns :: Ty Int) 62 | "int2" -> run (fns :: Ty UInt2) 63 | "int3" -> run (fns :: Ty UInt3) 64 | "" -> run (fns :: Ty UInt2) 65 | 66 | (+++) :: (Show a, Read a, Integral a) => a -> a -> a 67 | x +++ 0 = x 68 | 0 +++ y = y 69 | x +++ y = read (show x ++ show (abs y)) 70 | -------------------------------------------------------------------------------- /doc/fitspec.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 19 | FitSpec 21 | 23 | 50 | 52 | 53 | 55 | image/svg+xml 56 | 58 | FitSpec 59 | 2018-11-24 60 | 61 | 62 | Rudy Matela 63 | 64 | 65 | https://github.com/rudymatela/fitspec 66 | 67 | 68 | FitSpec 69 | logo 70 | testing 71 | test 72 | property-based testing 73 | mutation testing 74 | 75 | 76 | FitSpec's logo. A check or tick is seen in blue intersected with a lambda. 77 | 79 | 80 | 82 | 84 | 86 | 88 | 90 | 92 | 94 | 95 | 96 | 97 | 102 | 107 | 112 | 117 | 122 | 127 | 128 | 129 | -------------------------------------------------------------------------------- /doc/modules.md: -------------------------------------------------------------------------------- 1 | Important modules 2 | ----------------- 3 | 4 | * [FitSpec](FitSpec.hs): 5 | the entry point, import this to use FitSpec; 6 | 7 | * [FitSpec.Engine](FitSpec/Engine.hs): 8 | main engine that tests mutants against properties; 9 | 10 | * [FitSpec.Report](FitSpec/Report.hs): 11 | gather results from the engine and build textual reports; 12 | 13 | * [FitSpec.Mutable](FitSpec/Mutable.hs): 14 | list mutations of a given function without repetitions; 15 | 16 | * [FitSpec.ShowMutable](FitSpec/ShowMutable.hs): 17 | show mutations; 18 | 19 | * [example benchmarks](bench): 20 | example use cases for FitSpec, 21 | some are customizable using command line arguments 22 | (sorting, booleans, lists, pretty-printing, etc). 23 | -------------------------------------------------------------------------------- /doc/tutorial-property-creation.md: -------------------------------------------------------------------------------- 1 | Using FitSpec to guide property creation 2 | ---------------------------------------- 3 | 4 | Suppose we want to write test properties for the function `sort`, 5 | but we do not know where to start. 6 | We can use FitSpec to guide property creation. 7 | 8 | 9 | We first import what is needed: 10 | 11 | import Test.FitSpec 12 | import Data.List (sort) 13 | 14 | 15 | Then we need a property list function: given a sorting implementation, return 16 | the properties applied to *that* implementation. Since we don't have any 17 | properties, we will start by returning and empty list: 18 | 19 | properties :: (Show a, Ord a, Listable a) 20 | => ([a] -> [a]) -> [Properties] 21 | properties sort' = 22 | [] 23 | 24 | 25 | Then, we need a main function, that calls the FitSpec's `report` function, 26 | which will report the results of mutation testing. 27 | It needs a function to be mutated and the property list. 28 | 29 | main = report (sort::[Int]->[Int]) properties 30 | 31 | Optionally, for a nicer output, you might want to use the reportWith function, 32 | which allows specifying function and argument names (among other options): 33 | 34 | main = reportWith args { callNames = ["sort xs"] } 35 | (sort::[Int]->[Int]) properties 36 | 37 | By having the three sections above in a file called sorting.hs, 38 | we then compile and run: 39 | 40 | $ ghc -ipath/to/leancheck:path/to/fitspec sorting.hs 41 | [9 of 9] Compiling Main ( sorting.hs, sorting.o ) 42 | Linking sorting ... 43 | 44 | $ ./sorting 45 | Results based on at most 4000 test cases for each of 2000 mutant variations. 46 | 47 | Property #Survivors Smallest or simplest 48 | sets (%Killed) surviving mutant 49 | 50 | [] 2000 (0%) \xs -> case xs of 51 | [] -> [0] 52 | _ -> sort xs 53 | 54 | The output is self-explanatory. Obviously, our empty property set `[]` did not 55 | kill any mutant (`0%`). In other words, all of the `2000` mutants survived. 56 | (The actual number of mutants tested will vary depending on your machine, it 57 | will probably be higher than 2000 *in this case*, by default FitSpec runs for 58 | at least 5 seconds.) 59 | 60 | The surviving mutant shown on the third column is clearly not a valid 61 | implementation of sort. For the empty list, it returns `[0]`. We should 62 | improve our property set by killing that mutant. Lets start very simple by 63 | adding a property stating that sorting an empty list must yield an empty list: 64 | 65 | properties sort' = 66 | [ property $ sort' [] == [] 67 | ] 68 | 69 | Above, we need to apply the function `property` to each property in the list. 70 | Now: 71 | 72 | $ ./sorting 73 | Results based on at most 4000 test cases for each of 2000 mutant variations. 74 | 75 | Property #Survivors Smallest or simplest 76 | sets (%Killed) surviving mutant 77 | 78 | [1] 984 (49%) \xs -> case xs of 79 | [0] -> [] 80 | _ -> sort xs 81 | 82 | [] 2000 (0%) \xs -> case xs of 83 | [] -> [0] 84 | _ -> sort xs 85 | 86 | The last row of results is the same as before (all mutants still obviously 87 | survive the empty property set). The *first row* show that there are `984` 88 | *surviving mutants* (`49%`) for the first property `[1]`: the smallest one is 89 | shown on the third column. It sorts `[0]` to `[]`, which is not valid. Lets 90 | still be very simple -- sorting a list with one value must yield a list with 91 | the same value: 92 | 93 | properties sort' = 94 | [ property $ sort' [] == [] 95 | , property $ \x -> sort' [x] == [x] 96 | ] 97 | 98 | Note that, our new property (2) has a free variable. Now: 99 | 100 | $ ./sorting 101 | Results based on at most 1000 test cases for each of 500 mutant variations. 102 | 103 | Property #Survivors Smallest or simplest 104 | sets (%Killed) surviving mutant 105 | 106 | [1,2] 134 (73%) \xs -> case xs of 107 | [0,0] -> [] 108 | _ -> sort xs 109 | ... 110 | 111 | Only 27% of mutants to go, perhaps a property stating that the length of the 112 | sorted list should not change? 113 | 114 | properties sort' = 115 | [ property $ sort' [] == [] 116 | , property $ \x -> sort' [x] == [x] 117 | , property $ \xs -> length (sort' xs) == length xs 118 | ] 119 | 120 | Now: 121 | 122 | $ ./sorting 123 | Results based on at most 1000 test cases for each of 500 mutant variations. 124 | 125 | Property #Survivors Smallest or simplest 126 | sets (%Killed) surviving mutant 127 | 128 | [2,3] 12 (97%) \xs -> case xs of 129 | [0,0] -> [0,1] 130 | _ -> sort xs 131 | ... 132 | 133 | Conjectures based on at most 1000 test cases for each of 500 mutant variations: 134 | [3] ==> [1] 95% killed (likely) 135 | 136 | The first row show that the current candidate minimal-complete propety-set 137 | kills all but `4` mutants and is composed only by properties 2 and 3 (`[2,3]`). 138 | When possible, FitSpec also reports *conjectures* based on test results. In 139 | this case, that property `sort [] == []` (1) follows from the length property 140 | (3). Since that is *clearly* true, we can safely remove that property. 141 | 142 | properties sort' = 143 | [ property $ \x -> sort' [x] == [x] 144 | , property $ \xs -> length (sort' xs) == length xs 145 | , property $ \x xs -> elem x (sort' xs) == elem x xs 146 | ] 147 | 148 | Now: 149 | 150 | $ ./sorting 151 | Property #Survivors Smallest or simplest 152 | sets (%Killed) surviving mutant 153 | 154 | [2,3] 2 (99%) \xs -> case xs of 155 | [0,1] -> [1,0] 156 | _ -> sort xs 157 | ... 158 | Conjectures based on at most 1000 test cases for each of 500 mutant variations: 159 | [2,3] ==> [1] 99% killed (possible+) 160 | 161 | We could go on, but *at this point, you probably got how it works*. As an 162 | exercise you can try to improve our property-set over `sort` by killing the 163 | above mutant by adding a new property. Later, you can try to improve the 164 | results by increasing the time limit (`minimumTime = 10` on args). 165 | 166 | 167 | -------------------------------------------------------------------------------- /eg/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for FitSpec 2 | 3 | # Configuration variables 4 | FITSPECPATH = ../src 5 | GHCFLAGS = -O2 -i$(FITSPECPATH) -dynamic 6 | 7 | # Misc variables 8 | 9 | all: sorting negation 10 | 11 | clean: 12 | rm -f *.hi *.o sorting negation 13 | 14 | # Implicit rules: 15 | 16 | %.o: %.hs 17 | ghc $(GHCFLAGS) $< 18 | 19 | %: %.hs 20 | ghc $(GHCFLAGS) $< 21 | 22 | .PHONY: %.ghci 23 | %.ghci: %.hs 24 | ghci $(GHCFLAGS) -O0 $< 25 | -------------------------------------------------------------------------------- /eg/alga.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | import Test.FitSpec 3 | import Test.LeanCheck.Tiers 4 | import Algebra.Graph 5 | 6 | instance (Listable a, Ord a) => Listable (Graph a) where 7 | tiers = nubT 8 | $ cons0 Empty 9 | \/ cons1 Vertex 10 | \/ cons2 Overlay 11 | \/ cons2 Connect 12 | 13 | deriveMutableE [''Ord] ''Graph 14 | 15 | instance Ord a => Ord (Graph a) where 16 | (<=) = isSubgraphOf 17 | 18 | type A = Int 19 | 20 | properties :: ( Graph A -> Graph A -> Graph A 21 | , Graph A -> Graph A -> Graph A ) 22 | -> [Property] 23 | properties (plus,times) = 24 | [ property $ \x y -> x + y == y + x 25 | , property $ \x y z -> x + (y + z) == (x + y) + z 26 | , property $ \x y z -> x * (y * z) == (x * y) * z 27 | , property $ \x y z -> x * (y * z) == (x * y) + (x * z) + (y * z) 28 | ] 29 | where 30 | (+) = plus 31 | (*) = times 32 | infixl 6 + 33 | infixl 7 * 34 | 35 | main :: IO () 36 | main = do 37 | args <- getArgsWith 38 | args { names = ["x + y", "x * y"] 39 | , nMutants = 1000 40 | , nTests = 1000 41 | , timeout = 0 42 | } 43 | reportWithExtra 44 | [ ((*),(+)) 45 | , ((*),(*)) 46 | , ((+),(+)) ] 47 | args 48 | ((+),(*)) 49 | properties 50 | -------------------------------------------------------------------------------- /eg/negation.hs: -------------------------------------------------------------------------------- 1 | -- Minimal example: mutation testing a negation specification 2 | import Test.FitSpec 3 | 4 | properties not = 5 | [ property $ \p -> not (not p) == p 6 | , property $ \p -> not (not (not p)) == not p 7 | ] 8 | 9 | main = mainWith args {names = ["not p"]} not properties 10 | -------------------------------------------------------------------------------- /eg/sorting.hs: -------------------------------------------------------------------------------- 1 | -- Minimal example: mutation testing a sort specification 2 | -- 3 | -- (this program might take a minute to run depending on your system) 4 | -- 5 | -- Usage: 6 | -- 7 | -- $ ghc -O2 sorting.hs 8 | -- $ ./sorting 9 | -- Apparent incomplete and non-minimal specification based on 10 | -- 4000 test cases for each of properties 1, 2, 3, 4 and 5 11 | -- for each of 4000 mutant variations. 12 | -- 13 | -- 3 survivors (99% killed), smallest: 14 | -- \xs -> case xs of 15 | -- [0,0,1] -> [0,1,1] 16 | -- _ -> sort xs 17 | -- 18 | -- apparent minimal property subsets: {1,2,3} {1,2,4} 19 | -- conjectures: {3} = {4} 96% killed (weak) 20 | -- {1,3} ==> {5} 98% killed (weak) 21 | 22 | import Test.FitSpec 23 | import Data.List (sort) 24 | 25 | properties sort = 26 | [ property $ \xs -> ordered (sort xs) 27 | , property $ \xs -> length (sort xs) == length xs 28 | , property $ \x xs -> elem x (sort xs) == elem x xs 29 | , property $ \x xs -> notElem x (sort xs) == notElem x xs 30 | , property $ \x xs -> minimum (x:xs) == head (sort (x:xs)) 31 | ] 32 | where 33 | ordered (x:y:xs) = x <= y && ordered (y:xs) 34 | ordered _ = True 35 | 36 | main = 37 | mainWith args { names = ["sort xs"] 38 | , nMutants = 4000 39 | , nTests = 4000 40 | , timeout = 0 41 | } 42 | (sort::[Word2]->[Word2]) 43 | properties 44 | -------------------------------------------------------------------------------- /fitspec.cabal: -------------------------------------------------------------------------------- 1 | name: fitspec 2 | version: 0.4.11 3 | synopsis: refining property sets for testing Haskell programs 4 | description: 5 | FitSpec provides automated assistance in the task of refining test properties 6 | for Haskell functions. 7 | . 8 | FitSpec tests mutant variations of functions under test against a given 9 | property set, recording any surviving mutants that pass all tests. FitSpec 10 | then reports: 11 | . 12 | * surviving mutants: indicating incompleteness of properties, 13 | prompting the user to amend a property or to add a new one; 14 | . 15 | * conjectures: indicating redundancy in the property set, 16 | prompting the user to remove properties so to reduce the cost of testing. 17 | 18 | homepage: https://github.com/rudymatela/fitspec#readme 19 | license: BSD3 20 | license-file: LICENSE 21 | author: Rudy Matela, Colin Runciman 22 | maintainer: Rudy Matela 23 | category: Testing 24 | build-type: Simple 25 | cabal-version: 1.18 26 | 27 | extra-doc-files: README.md 28 | , CREDITS.md 29 | , TODO.md 30 | , doc/modules.md 31 | , doc/tutorial-property-creation.md 32 | , doc/fitspec.svg 33 | extra-source-files: .gitignore 34 | , .github/workflows/build.yml 35 | , Makefile 36 | , bench/haskell-src-exts.hs 37 | , bench/haskell-src.hs 38 | , eg/Makefile 39 | , eg/alga.hs 40 | , eg/negation.hs 41 | , eg/sorting.hs 42 | , mk/depend.mk 43 | , mk/ghcdeps 44 | , mk/haddock-i 45 | , mk/haskell.mk 46 | , mk/install-on 47 | , stack.yaml 48 | , test/sdist 49 | tested-with: GHC==9.10 50 | , GHC==9.8 51 | , GHC==9.6 52 | , GHC==9.4 53 | , GHC==9.2 54 | , GHC==9.0 55 | , GHC==8.8 56 | 57 | source-repository head 58 | type: git 59 | location: https://github.com/rudymatela/fitspec 60 | 61 | source-repository this 62 | type: git 63 | location: https://github.com/rudymatela/fitspec 64 | tag: v0.4.11 65 | 66 | 67 | library 68 | exposed-modules: Test.FitSpec 69 | , Test.FitSpec.Engine 70 | , Test.FitSpec.Report 71 | , Test.FitSpec.Mutable 72 | , Test.FitSpec.Mutable.Tuples 73 | , Test.FitSpec.ShowMutable 74 | , Test.FitSpec.ShowMutable.Tuples 75 | , Test.FitSpec.Derive 76 | , Test.FitSpec.Main 77 | , Test.FitSpec.TestTypes 78 | , Test.FitSpec.Utils 79 | , Test.FitSpec.PrettyPrint 80 | other-modules: Test.FitSpec.Dot 81 | build-depends: base >= 4 && < 5, leancheck >= 0.9.6, cmdargs, template-haskell 82 | hs-source-dirs: src 83 | default-language: Haskell2010 84 | 85 | 86 | test-suite mutate 87 | type: exitcode-stdio-1.0 88 | main-is: mutate.hs 89 | hs-source-dirs: test 90 | build-depends: base >= 4 && < 5, leancheck, fitspec 91 | default-language: Haskell2010 92 | 93 | test-suite showmutable 94 | type: exitcode-stdio-1.0 95 | main-is: showmutable.hs 96 | hs-source-dirs: test 97 | build-depends: base >= 4 && < 5, leancheck, fitspec 98 | default-language: Haskell2010 99 | 100 | test-suite derive 101 | type: exitcode-stdio-1.0 102 | main-is: derive.hs 103 | hs-source-dirs: test 104 | build-depends: base >= 4 && < 5, leancheck, fitspec 105 | default-language: Haskell2010 106 | 107 | test-suite utils 108 | type: exitcode-stdio-1.0 109 | main-is: utils.hs 110 | hs-source-dirs: test 111 | build-depends: base >= 4 && < 5, leancheck, fitspec 112 | default-language: Haskell2010 113 | 114 | 115 | benchmark avltrees 116 | main-is: avltrees.hs 117 | other-modules: AVLTree 118 | build-depends: base >= 4 && < 5, fitspec 119 | hs-source-dirs: bench 120 | default-language: Haskell2010 121 | type: exitcode-stdio-1.0 122 | 123 | benchmark bools 124 | main-is: bools.hs 125 | build-depends: base >= 4 && < 5, fitspec 126 | hs-source-dirs: bench 127 | default-language: Haskell2010 128 | type: exitcode-stdio-1.0 129 | 130 | benchmark digraphs 131 | main-is: digraphs.hs 132 | other-modules: Digraph 133 | build-depends: base >= 4 && < 5, fitspec 134 | hs-source-dirs: bench 135 | default-language: Haskell2010 136 | type: exitcode-stdio-1.0 137 | 138 | -- The haskell-src and haskell-src-exts are commented out as they pull a lot of 139 | -- dependencies. Ultimately a flag could be added to optionally activate them, 140 | -- but better not make this cabal file too much complex. 141 | -- 142 | --benchmark haskell-src 143 | -- main-is: haskell-src.hs 144 | -- build-depends: base >= 4 && < 5, fitspec, haskell-src 145 | -- hs-source-dirs: bench 146 | -- default-language: Haskell2010 147 | -- type: exitcode-stdio-1.0 148 | -- 149 | --benchmark haskell-src-exts 150 | -- main-is: haskell-src-exts.hs 151 | -- build-depends: base >= 4 && < 5, fitspec, haskell-src-exts 152 | -- hs-source-dirs: bench 153 | -- default-language: Haskell2010 154 | -- type: exitcode-stdio-1.0 155 | 156 | benchmark heaps 157 | main-is: heaps.hs 158 | other-modules: Heap 159 | build-depends: base >= 4 && < 5, fitspec 160 | hs-source-dirs: bench 161 | default-language: Haskell2010 162 | type: exitcode-stdio-1.0 163 | 164 | benchmark id 165 | main-is: id.hs 166 | build-depends: base >= 4 && < 5, fitspec 167 | hs-source-dirs: bench 168 | default-language: Haskell2010 169 | type: exitcode-stdio-1.0 170 | 171 | benchmark list 172 | main-is: list.hs 173 | build-depends: base >= 4 && < 5, fitspec 174 | hs-source-dirs: bench 175 | default-language: Haskell2010 176 | type: exitcode-stdio-1.0 177 | 178 | benchmark mergeheaps 179 | main-is: mergeheaps.hs 180 | other-modules: Heap 181 | build-depends: base >= 4 && < 5, fitspec 182 | hs-source-dirs: bench 183 | default-language: Haskell2010 184 | type: exitcode-stdio-1.0 185 | 186 | benchmark pretty 187 | main-is: pretty.hs 188 | build-depends: base >= 4 && < 5, fitspec, pretty 189 | hs-source-dirs: bench 190 | default-language: Haskell2010 191 | type: exitcode-stdio-1.0 192 | 193 | benchmark sets 194 | main-is: sets.hs 195 | other-modules: Set 196 | build-depends: base >= 4 && < 5, fitspec 197 | hs-source-dirs: bench 198 | default-language: Haskell2010 199 | type: exitcode-stdio-1.0 200 | 201 | benchmark setsofsets 202 | main-is: setsofsets.hs 203 | other-modules: Set 204 | build-depends: base >= 4 && < 5, fitspec 205 | hs-source-dirs: bench 206 | default-language: Haskell2010 207 | type: exitcode-stdio-1.0 208 | 209 | benchmark sieve 210 | main-is: sieve.hs 211 | build-depends: base >= 4 && < 5, fitspec 212 | hs-source-dirs: bench 213 | default-language: Haskell2010 214 | type: exitcode-stdio-1.0 215 | 216 | benchmark sorting 217 | main-is: sorting.hs 218 | build-depends: base >= 4 && < 5, fitspec 219 | hs-source-dirs: bench 220 | default-language: Haskell2010 221 | type: exitcode-stdio-1.0 222 | 223 | benchmark spring 224 | main-is: spring.hs 225 | build-depends: base >= 4 && < 5, fitspec 226 | hs-source-dirs: bench 227 | default-language: Haskell2010 228 | type: exitcode-stdio-1.0 229 | -------------------------------------------------------------------------------- /mk/ghcdeps: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # ghcdeps: generate Haskell make dependencies for compiling with GHC. 4 | # 5 | # Copyright (c) 2015-2024 Rudy Matela. 6 | # Distributed under the 3-Clause BSD licence. 7 | # 8 | # From a list of files provided on standard input, 9 | # generate flat make dependencies. 10 | # 11 | # Transitive relations are repeated. 12 | # 13 | # Usage: 14 | # $ ghcdeps -isomedir:someother < ... 9 | # 10 | # will print -i parameters necessary for haddock to link to Haddock 11 | # documentation installed on your system, so you can: 12 | # 13 | # $ haddock-i base template-haskell | xargs haddock 14 | err() { 15 | echo "$@" > /dev/stderr 16 | } 17 | 18 | errxit() { 19 | err "$@" 20 | exit 1 21 | } 22 | 23 | iface-for() { 24 | ghc-pkg field $1 haddock-interfaces | sort -rV | head -1 | sed "s/.*: //" 25 | } 26 | 27 | html-for() { 28 | ghc-pkg field $1 haddock-html | sort -rV | head -1 | sed "s/.*: //" 29 | } 30 | 31 | for pkg in "$@" 32 | do 33 | iface=$(iface-for $pkg) 34 | html=$(html-for $pkg) 35 | [ -d "$html" -a -f "$iface" ] && echo "-i$html,$iface" || err "haddock-i: warning: could not find interface file for $pkg" 36 | done 37 | -------------------------------------------------------------------------------- /mk/haskell.mk: -------------------------------------------------------------------------------- 1 | # Implicit rules for compiling Haskell code. 2 | # 3 | # Copyright (c) 2015-2024 Rudy Matela. 4 | # Distributed under the 3-Clause BSD licence. 5 | # 6 | # You can optionally configure the "Configuration variables" below in your main 7 | # makefile, e.g.: 8 | # 9 | # GHCIMPORTDIRS = path/to/dir:path/to/another/dir 10 | # GHCFLAGS = -O2 -dynamic 11 | # GHC = ghc-7.6 12 | # include haskell.mk 13 | 14 | 15 | 16 | # Configuration variables 17 | 18 | # GHC Parameters 19 | GHCIMPORTDIRS ?= 20 | GHCFLAGS ?= 21 | GHC ?= ghc 22 | GHCCMD = $(GHC) -i$(GHCIMPORTDIRS) $(GHCFLAGS) 23 | HADDOCK ?= haddock 24 | CABAL_INSTALL = $(shell cabal --version | grep -q "version [0-2]\." && echo 'cabal install' || echo 'cabal install --lib') 25 | 26 | # Hugs Parameters 27 | HUGSIMPORTDIRS ?= "/usr/lib/hugs/packages/*" 28 | HUGSFLAGS ?= 29 | CPPHS_HUGS ?= cpphs-hugs --noline -D__HUGS__ 30 | HUGS ?= hugs 31 | RUNHUGS ?= runhugs 32 | HUGSCMD = $(HUGS) -F"$(CPPHS_HUGS)" -P$(HUGSIMPORTDIRS) $(HUGSFLAGS) 33 | RUNHUGSCMD = $(RUNHUGS) -F"$(CPPHS_HUGS)" -P$(HUGSIMPORTDIRS) $(HUGSFLAGS) 34 | 35 | 36 | # Makefile where to keep the dependencies 37 | DEPMK ?= mk/depend.mk 38 | 39 | # LIB_HSS: all library Haskell files 40 | # ALL_HSS: all Haskell files 41 | # You can override ALL/LIB_HSS in your main Makefile 42 | LIST_LIB_HSS ?= find src -name "*.hs" 43 | LIST_ALL_HSS ?= find \( -path "./dist*" -o -path "./.stack-work" -o -path "./Setup.hs" \) -prune \ 44 | -o -name "*.*hs" -print 45 | LIB_HSS ?= $(shell $(LIST_LIB_HSS)) 46 | ALL_HSS ?= $(shell $(LIST_ALL_HSS)) 47 | 48 | LIB_DEPS ?= base 49 | ALL_DEPS ?= $(LIB_DEPS) 50 | INSTALL_DEPS ?= 51 | 52 | PKGNAME = $(shell cat *.cabal | grep "^name:" | sed -e "s/name: *//") 53 | 54 | HADDOCK_HAS = haddock --help | grep -q -- 55 | 56 | 57 | # Implicit rules 58 | %.hi %.o: %.hs 59 | $(GHCCMD) $< && touch $@ 60 | 61 | %: %.hs 62 | $(GHCCMD) $< && touch $@ 63 | 64 | .PHONY: %.ghci 65 | %.ghci: %.hs 66 | $(GHCCMD) -O0 --interactive $< 67 | 68 | .PHONY: %.hugs 69 | %.hugs: %.hs 70 | $(HUGSCMD) $< 71 | 72 | .PHONY: %.runhugs 73 | %.runhugs: %.hs 74 | $(RUNHUGSCMD) $< 75 | 76 | 77 | # Cleaning rule (add as a clean dependency) 78 | clean-hs: clean-hi-o clean-haddock clean-cabal clean-stack 79 | 80 | clean-hi-o: 81 | find $(ALL_HSS) | sed -e 's/hs$$/o/' | xargs rm -f 82 | find $(ALL_HSS) | sed -e 's/hs$$/hi/' | xargs rm -f 83 | find $(ALL_HSS) | sed -e 's/hs$$/dyn_o/' | xargs rm -f 84 | find $(ALL_HSS) | sed -e 's/hs$$/dyn_hi/' | xargs rm -f 85 | 86 | 87 | # Update dependency file 88 | .PHONY: depend 89 | depend: 90 | find $(ALL_HSS) | ./mk/ghcdeps -i$(GHCIMPORTDIRS) $(GHCFLAGS) > $(DEPMK) 91 | 92 | install-dependencies: 93 | if [ -n "$(INSTALL_DEPS)" ]; then \ 94 | cd ~ && \ 95 | cabal update && \ 96 | $(CABAL_INSTALL) $(INSTALL_DEPS) || true; \ 97 | fi 98 | # above, "|| true" is needed for cabal >= 3.10.2 99 | # Before, cabal would successfully skip installation 100 | # of already existing packages 101 | # cd ~ is needed so cabal installs only dependencies 102 | 103 | # haddock rules 104 | haddock: doc/index.html 105 | 106 | clean-haddock: 107 | rm -f doc/*.{html,css,js,png,gif,json} doc/src/* README.html 108 | 109 | upload-haddock: 110 | @echo "use \`cabal upload -d' instead" 111 | @echo "(but 1st: cabal install --only-dependencies --enable-documentation)" 112 | @echo "(to just compile docs: cabal haddock --for-hackage)" 113 | @echo "(on Arch Linux, use: cabal haddock --for-hackage --haddock-options=--optghc=-dynamic)" 114 | 115 | doc/index.html: $(LIB_HSS) 116 | ./mk/haddock-i $(LIB_DEPS) | xargs \ 117 | $(HADDOCK) --html -odoc $(LIB_HSS) \ 118 | --title=$(PKGNAME) \ 119 | $(shell $(HADDOCK_HAS) --package-name && echo "--package-name=$(PKGNAME)" ) \ 120 | $(shell $(HADDOCK_HAS) --hyperlinked-source && echo "--hyperlinked-source" ) \ 121 | $(shell $(HADDOCK_HAS) --no-print-missing-docs && echo --no-print-missing-docs ) \ 122 | $(HADDOCKFLAGS) 123 | 124 | clean-cabal: 125 | rm -rf dist/ dist-newstyle/ cabal.project.local cabal.project.local~ 126 | 127 | clean-stack: 128 | rm -rf .stack-work/ stack.yaml.lock 129 | 130 | # lists all Haskell source files 131 | list-all-hss: 132 | @find $(ALL_HSS) 133 | 134 | # lists library Haskell source files 135 | list-lib-hss: 136 | @find $(LIB_HSS) 137 | 138 | bootstrap-haskell-mk: 139 | @[ -d "$(DEST)" ] || (echo -e "error: no destination found\nusage: \`make bootstrap-haskell-mk DEST=path/to/prj'"; exit 1) 140 | mkdir -p mk 141 | cp mk/{haskell.mk,ghcdeps,haddock-i} $(DEST)/mk 142 | touch $(DEST)/mk/depend.mk 143 | 144 | show-pkgname: 145 | @echo $(PKGNAME) 146 | 147 | include $(DEPMK) 148 | -------------------------------------------------------------------------------- /mk/install-on: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # mk/install-on: install or updates the mk folder on a Haskell project 4 | # 5 | # Copyright (c) 2019-2024 Rudy Matela. 6 | # Distributed under the 3-Clause BSD licence. 7 | # 8 | # usage: ./mk/install-on path/to/project 9 | # 10 | # This script assumes that: 11 | # 12 | # * tests are stored in a "test/" folder 13 | # * sources are stored in a "src/" folder 14 | set -e 15 | 16 | errxit() { 17 | echo "$@" > /dev/stderr 18 | exit 1 19 | } 20 | 21 | src=`dirname $0`/.. 22 | dst="$1" 23 | 24 | [ -n "$dst" ] || errxit "destination folder not provided" 25 | 26 | mkdir -p $dst/mk 27 | mkdir -p $dst/test 28 | 29 | cp $src/mk/ghcdeps $dst/mk/ghcdeps 30 | cp $src/mk/haddock-i $dst/mk/haddock-i 31 | cp $src/mk/haskell.mk $dst/mk/haskell.mk 32 | cp $src/mk/install-on $dst/mk/install-on 33 | cp $src/test/sdist $dst/test/sdist 34 | -------------------------------------------------------------------------------- /src/Test/FitSpec.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec 3 | -- Copyright : (c) 2015-2018 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- __ FitSpec: refining property-sets for functional testing __ 8 | -- 9 | -- FitSpec provides automated assistance in the task of refining test properties 10 | -- for Haskell functions. FitSpec tests mutant variations of functions under test 11 | -- against a given property set, recording any surviving mutants that pass all 12 | -- tests. FitSpec then reports: 13 | -- 14 | -- * /surviving mutants:/ 15 | -- indicating incompleteness of properties, 16 | -- prompting the user to amend a property or to add a new one; 17 | -- * /conjectures:/ 18 | -- indicating redundancy in the property set, 19 | -- prompting the user to remove properties so to reduce the cost of testing. 20 | -- 21 | -- Example, refining a @sort@ specification: 22 | -- 23 | -- > import Test.FitSpec 24 | -- > import Data.List (sort) 25 | -- > 26 | -- > properties sort = 27 | -- > [ property $ \xs -> ordered (sort xs) 28 | -- > , property $ \xs -> length (sort xs) == length xs 29 | -- > , property $ \x xs -> elem x (sort xs) == elem x xs 30 | -- > , property $ \x xs -> notElem x (sort xs) == notElem x xs 31 | -- > , property $ \x xs -> minimum (x:xs) == head (sort (x:xs)) 32 | -- > ] 33 | -- > where 34 | -- > ordered (x:y:xs) = x <= y && ordered (y:xs) 35 | -- > ordered _ = True 36 | -- > 37 | -- > main = mainWith args { names = ["sort xs"] 38 | -- > , nMutants = 4000 39 | -- > , nTests = 4000 40 | -- > , timeout = 0 41 | -- > } 42 | -- > (sort::[Word2]->[Word2]) 43 | -- > properties 44 | -- 45 | -- The above program reports the following: 46 | -- 47 | -- > Apparent incomplete and non-minimal specification based on 48 | -- > 4000 test cases for each of properties 1, 2, 3, 4 and 5 49 | -- > for each of 4000 mutant variations. 50 | -- > 51 | -- > 3 survivors (99% killed), smallest: 52 | -- > \xs -> case xs of 53 | -- > [0,0,1] -> [0,1,1] 54 | -- > _ -> sort xs 55 | -- > 56 | -- > apparent minimal property subsets: {1,2,3} {1,2,4} 57 | -- > conjectures: {3} = {4} 96% killed (weak) 58 | -- > {1,3} ==> {5} 98% killed (weak) 59 | module Test.FitSpec 60 | ( 61 | -- * Encoding properties 62 | Property 63 | , property 64 | 65 | -- * Configuring reports 66 | , Args (..), ShowMutantAs (..) 67 | , args 68 | , fixargs 69 | 70 | -- * Reporting results 71 | , report 72 | , reportWith 73 | , reportWithExtra 74 | 75 | -- ** Parsing command line arguments 76 | , mainWith 77 | , defaultMain 78 | , getArgs 79 | , getArgsWith 80 | 81 | -- * Mutable types 82 | , Mutable (..) 83 | , mutiersEq 84 | 85 | , ShowMutable (..) 86 | , mutantSEq 87 | , showMutantAsTuple 88 | , showMutantDefinition 89 | , showMutantNested 90 | , showMutantBindings 91 | 92 | -- * Automatic derivation 93 | , deriveMutable 94 | , deriveMutableE 95 | , deriveMutableCascading 96 | , deriveMutableCascadingE 97 | 98 | -- * Re-export modules 99 | , module Test.FitSpec.TestTypes 100 | , module Test.LeanCheck 101 | ) 102 | where 103 | 104 | import Test.FitSpec.Engine 105 | import Test.FitSpec.Report 106 | import Test.FitSpec.Main 107 | 108 | import Test.FitSpec.Mutable 109 | import Test.FitSpec.Mutable.Tuples 110 | import Test.FitSpec.ShowMutable 111 | import Test.FitSpec.ShowMutable.Tuples 112 | import Test.FitSpec.Derive 113 | import Test.FitSpec.TestTypes 114 | 115 | import Test.LeanCheck 116 | -------------------------------------------------------------------------------- /src/Test/FitSpec/Derive.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.Derive 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Experimental module for deriving 'Mutable' and 'ShowMutable' instances 8 | -- 9 | -- Needs GHC and Template Haskell 10 | -- (tested on GHC 7.4, 7.6, 7.8, 7.10 and 8.0) 11 | -- 12 | -- Despite 'Mutable' instances being actually very simple to write manually, 13 | -- this module can be used to derive those instances automatically. 14 | -- However, it will not work on all cases: 15 | -- when that happens, you should write your instances manually. 16 | -- 17 | -- If FitSpec does not compile under later GHCs, this module is probably the culprit. 18 | {-# LANGUAGE TemplateHaskell, CPP #-} 19 | module Test.FitSpec.Derive 20 | ( deriveMutable 21 | , deriveMutableE 22 | , deriveMutableCascading 23 | , deriveMutableCascadingE 24 | , module Test.FitSpec.Mutable 25 | , module Test.FitSpec.ShowMutable 26 | , module Test.LeanCheck 27 | ) 28 | where 29 | 30 | import Test.FitSpec.Mutable 31 | import Test.FitSpec.ShowMutable 32 | 33 | import Test.LeanCheck 34 | import Test.LeanCheck.Derive (deriveListableIfNeeded) 35 | import Language.Haskell.TH 36 | import Control.Monad (when, unless, liftM, liftM2, filterM) 37 | import Data.List (delete) 38 | 39 | #if __GLASGOW_HASKELL__ < 706 40 | -- reportWarning was only introduced in GHC 7.6 / TH 2.8 41 | reportWarning :: String -> Q () 42 | reportWarning = report False 43 | #endif 44 | 45 | -- | Derives 'Mutable', 'ShowMutable' and (optionally) 'Listable' instances 46 | -- for a given type 'Name'. 47 | -- 48 | -- Consider the following @Stack@ datatype: 49 | -- 50 | -- > data Stack a = Stack a (Stack a) | Empty 51 | -- 52 | -- Writing 53 | -- 54 | -- > deriveMutable ''Stack 55 | -- 56 | -- will automatically derive the following 57 | -- 'Listable', 'Mutable' and 'ShowMutable' instances: 58 | -- 59 | -- > instance Listable a => Listable (Stack a) where 60 | -- > tiers = cons2 Stack \/ cons0 Empty 61 | -- > 62 | -- > instance (Eq a, Listable a) => Mutable a 63 | -- > where mutiers = mutiersEq 64 | -- > 65 | -- > instance (Eq a, Show a) => ShowMutable a 66 | -- > where mutantS = mutantSEq 67 | -- 68 | -- If a 'Listable' instance already exists, it is not derived. 69 | -- (cf.: 'deriveListable') 70 | -- 71 | -- Needs the @TemplateHaskell@ extension. 72 | deriveMutable :: Name -> DecsQ 73 | deriveMutable = deriveMutableE [] 74 | 75 | deriveMutableCascading :: Name -> DecsQ 76 | deriveMutableCascading = deriveMutableCascadingE [] 77 | 78 | -- | Derives a Mutable instance for a given type 'Name' 79 | -- using a given context for all type variables. 80 | deriveMutableE :: [Name] -> Name -> DecsQ 81 | deriveMutableE = deriveMutableEX False 82 | 83 | deriveMutableCascadingE :: [Name] -> Name -> DecsQ 84 | deriveMutableCascadingE = deriveMutableEX True 85 | 86 | deriveMutableEX :: Bool -> [Name] -> Name -> DecsQ 87 | deriveMutableEX cascade cs t = do 88 | is <- t `isInstanceOf` ''Mutable 89 | if is 90 | then do 91 | reportWarning $ "Instance Mutable " ++ show t 92 | ++ " already exists, skipping derivation" 93 | return [] 94 | else do 95 | isEq <- t `isInstanceOf` ''Eq 96 | isShow <- t `isInstanceOf` ''Show 97 | unless isEq (fail $ "Unable to derive Mutable " ++ show t 98 | ++ " (missing Eq instance)") 99 | unless isShow (fail $ "Unable to derive Mutable " ++ show t 100 | ++ " (missing Show instance)") 101 | if cascade 102 | then liftM2 (++) (deriveListableCascading t) (reallyDeriveMutableCascading cs t) 103 | else liftM2 (++) (deriveListableIfNeeded t) (reallyDeriveMutable cs t) 104 | -- TODO: document deriveMutableE with an example 105 | -- TODO: create deriveListableE on LeanCheck? 106 | 107 | reallyDeriveMutable :: [Name] -> Name -> DecsQ 108 | reallyDeriveMutable cs t = do 109 | (nt,vs) <- normalizeType t 110 | #if __GLASGOW_HASKELL__ >= 710 111 | cxt <- sequence [ [t| $(conT c) $(return v) |] 112 | #else 113 | cxt <- sequence [ classP c [return v] 114 | #endif 115 | | v <- vs, c <- ''Eq:''Listable:''Show:cs ] 116 | #if __GLASGOW_HASKELL__ >= 708 117 | cxt |=>| [d| instance Mutable $(return nt) 118 | where mutiers = mutiersEq 119 | instance ShowMutable $(return nt) 120 | where mutantS = mutantSEq |] 121 | #else 122 | return [ InstanceD 123 | cxt 124 | (AppT (ConT ''Mutable) nt) 125 | [ValD (VarP 'mutiers) (NormalB (VarE 'mutiersEq)) []] 126 | , InstanceD 127 | cxt 128 | (AppT (ConT ''ShowMutable) nt) 129 | [ValD (VarP 'mutantS) (NormalB (VarE 'mutantSEq)) []] 130 | ] 131 | #endif 132 | 133 | reallyDeriveMutableCascading :: [Name] -> Name -> DecsQ 134 | reallyDeriveMutableCascading cs t = do 135 | return . concat 136 | =<< mapM (reallyDeriveMutable cs) 137 | =<< filterM (liftM not . isTypeSynonym) 138 | =<< return . (t:) . delete t 139 | =<< t `typeConCascadingArgsThat` (`isntInstanceOf` ''Mutable) 140 | 141 | 142 | -- * Template haskell utilities 143 | 144 | typeConArgs :: Name -> Q [Name] 145 | typeConArgs t = do 146 | is <- isTypeSynonym t 147 | if is 148 | then liftM typeConTs $ typeSynonymType t 149 | else liftM (nubMerges . map typeConTs . concat . map snd) $ typeConstructors t 150 | where 151 | typeConTs :: Type -> [Name] 152 | typeConTs (AppT t1 t2) = typeConTs t1 `nubMerge` typeConTs t2 153 | typeConTs (SigT t _) = typeConTs t 154 | typeConTs (VarT _) = [] 155 | typeConTs (ConT n) = [n] 156 | #if __GLASGOW_HASKELL__ >= 800 157 | -- typeConTs (PromotedT n) = [n] ? 158 | typeConTs (InfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2 159 | typeConTs (UInfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2 160 | typeConTs (ParensT t) = typeConTs t 161 | #endif 162 | typeConTs _ = [] 163 | 164 | typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name] 165 | typeConArgsThat t p = do 166 | targs <- typeConArgs t 167 | tbs <- mapM (\t' -> do is <- p t'; return (t',is)) targs 168 | return [t' | (t',p) <- tbs, p] 169 | 170 | typeConCascadingArgsThat :: Name -> (Name -> Q Bool) -> Q [Name] 171 | t `typeConCascadingArgsThat` p = do 172 | ts <- t `typeConArgsThat` p 173 | let p' t' = do is <- p t'; return $ t' `notElem` (t:ts) && is 174 | tss <- mapM (`typeConCascadingArgsThat` p') ts 175 | return $ nubMerges (ts:tss) 176 | 177 | -- Normalizes a type by applying it to necessary type variables, making it 178 | -- accept "zero" parameters. The normalized type is tupled with a list of 179 | -- necessary type variables. 180 | -- 181 | -- Suppose: 182 | -- 183 | -- > data DT a b c ... = ... 184 | -- 185 | -- Then, in pseudo-TH: 186 | -- 187 | -- > normalizeType [t|DT|] == Q (DT a b c ..., [a, b, c, ...]) 188 | normalizeType :: Name -> Q (Type, [Type]) 189 | normalizeType t = do 190 | ar <- typeArity t 191 | vs <- newVarTs ar 192 | return (foldl AppT (ConT t) vs, vs) 193 | where 194 | newNames :: [String] -> Q [Name] 195 | newNames = mapM newName 196 | newVarTs :: Int -> Q [Type] 197 | newVarTs n = liftM (map VarT) 198 | $ newNames (take n . map (:[]) $ cycle ['a'..'z']) 199 | 200 | -- Normalizes a type by applying it to units (`()`) while possible. 201 | -- 202 | -- > normalizeTypeUnits ''Int === [t| Int |] 203 | -- > normalizeTypeUnits ''Maybe === [t| Maybe () |] 204 | -- > normalizeTypeUnits ''Either === [t| Either () () |] 205 | normalizeTypeUnits :: Name -> Q Type 206 | normalizeTypeUnits t = do 207 | ar <- typeArity t 208 | return (foldl AppT (ConT t) (replicate ar (TupleT 0))) 209 | 210 | -- Given a type name and a class name, 211 | -- returns whether the type is an instance of that class. 212 | isInstanceOf :: Name -> Name -> Q Bool 213 | isInstanceOf tn cl = do 214 | ty <- normalizeTypeUnits tn 215 | isInstance cl [ty] 216 | 217 | isntInstanceOf :: Name -> Name -> Q Bool 218 | isntInstanceOf tn cl = liftM not (isInstanceOf tn cl) 219 | 220 | -- | Given a type name, return the number of arguments taken by that type. 221 | -- Examples in partially broken TH: 222 | -- 223 | -- > arity ''Int === Q 0 224 | -- > arity ''Int->Int === Q 0 225 | -- > arity ''Maybe === Q 1 226 | -- > arity ''Either === Q 2 227 | -- > arity ''Int-> === Q 1 228 | -- 229 | -- This works for Data's and Newtype's and it is useful when generating 230 | -- typeclass instances. 231 | typeArity :: Name -> Q Int 232 | typeArity t = do 233 | ti <- reify t 234 | return . length $ case ti of 235 | #if __GLASGOW_HASKELL__ < 800 236 | TyConI (DataD _ _ ks _ _) -> ks 237 | TyConI (NewtypeD _ _ ks _ _) -> ks 238 | #else 239 | TyConI (DataD _ _ ks _ _ _) -> ks 240 | TyConI (NewtypeD _ _ ks _ _ _) -> ks 241 | #endif 242 | TyConI (TySynD _ ks _) -> ks 243 | _ -> error $ "error (typeArity): symbol " ++ show t 244 | ++ " is not a newtype, data or type synonym" 245 | 246 | -- Given a type name, returns a list of its type constructor names paired with 247 | -- the type arguments they take. 248 | -- 249 | -- > typeConstructors ''() === Q [('(),[])] 250 | -- 251 | -- > typeConstructors ''(,) === Q [('(,),[VarT a, VarT b])] 252 | -- 253 | -- > typeConstructors ''[] === Q [('[],[]),('(:),[VarT a,AppT ListT (VarT a)])] 254 | -- 255 | -- > data Pair a = P a a 256 | -- > typeConstructors ''Pair === Q [('P,[VarT a, VarT a])] 257 | -- 258 | -- > data Point = Pt Int Int 259 | -- > typeConstructors ''Point === Q [('Pt,[ConT Int, ConT Int])] 260 | typeConstructors :: Name -> Q [(Name,[Type])] 261 | typeConstructors t = do 262 | ti <- reify t 263 | return . map simplify $ case ti of 264 | #if __GLASGOW_HASKELL__ < 800 265 | TyConI (DataD _ _ _ cs _) -> cs 266 | TyConI (NewtypeD _ _ _ c _) -> [c] 267 | #else 268 | TyConI (DataD _ _ _ _ cs _) -> cs 269 | TyConI (NewtypeD _ _ _ _ c _) -> [c] 270 | #endif 271 | _ -> error $ "error (typeConstructors): symbol " ++ show t 272 | ++ " is neither newtype nor data" 273 | where 274 | simplify (NormalC n ts) = (n,map snd ts) 275 | simplify (RecC n ts) = (n,map trd ts) 276 | simplify (InfixC t1 n t2) = (n,[snd t1,snd t2]) 277 | trd (x,y,z) = z 278 | 279 | isTypeSynonym :: Name -> Q Bool 280 | isTypeSynonym t = do 281 | ti <- reify t 282 | return $ case ti of 283 | TyConI (TySynD _ _ _) -> True 284 | _ -> False 285 | 286 | typeSynonymType :: Name -> Q Type 287 | typeSynonymType t = do 288 | ti <- reify t 289 | return $ case ti of 290 | TyConI (TySynD _ _ t') -> t' 291 | _ -> error $ "error (typeSynonymType): symbol " ++ show t 292 | ++ " is not a type synonym" 293 | 294 | -- Append to instance contexts in a declaration. 295 | -- 296 | -- > sequence [[|Eq b|],[|Eq c|]] |=>| [t|instance Eq a => Cl (Ty a) where f=g|] 297 | -- > == [t| instance (Eq a, Eq b, Eq c) => Cl (Ty a) where f = g |] 298 | (|=>|) :: Cxt -> DecsQ -> DecsQ 299 | c |=>| qds = do ds <- qds 300 | return $ map (`ac` c) ds 301 | #if __GLASGOW_HASKELL__ < 800 302 | where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds 303 | ac d _ = d 304 | #else 305 | where ac (InstanceD o c ts ds) c' = InstanceD o (c++c') ts ds 306 | ac d _ = d 307 | #endif 308 | 309 | -- > nubMerge xs ys == nub (merge xs ys) 310 | -- > nubMerge xs ys == nub (sort (xs ++ ys)) 311 | nubMerge :: Ord a => [a] -> [a] -> [a] 312 | nubMerge [] ys = ys 313 | nubMerge xs [] = xs 314 | nubMerge (x:xs) (y:ys) | x < y = x : xs `nubMerge` (y:ys) 315 | | x > y = y : (x:xs) `nubMerge` ys 316 | | otherwise = x : xs `nubMerge` ys 317 | 318 | nubMerges :: Ord a => [[a]] -> [a] 319 | nubMerges = foldr nubMerge [] 320 | -------------------------------------------------------------------------------- /src/Test/FitSpec/Dot.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.Dot 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Experimental module to generate dotfiles (for graphviz) with implications 8 | -- between property sub-sets. 9 | module Test.FitSpec.Dot where 10 | 11 | import Test.FitSpec 12 | import Test.FitSpec.Engine 13 | import Test.FitSpec.Utils 14 | import Data.List 15 | 16 | -- | Given a list of pairs of property groups and their implications, 17 | -- return implications between groups (transitive cases are ommitted). 18 | groupImplications :: Eq i => [([[i]], [i])] -> [([[i]],[[i]])] 19 | groupImplications [] = [] 20 | groupImplications (n:ns) = [ (fst n, fst n') 21 | | n' <- filterU (not ... implies) 22 | . filter (n `implies`) 23 | $ ns 24 | ] ++ groupImplications ns 25 | where actual (iss,is) = foldr union [] iss `union` is 26 | n `implies` m = actual n `contains` actual m 27 | 28 | isObvious :: Eq i => [[i]] -> [[i]] -> Bool 29 | isObvious as bs = or [ a `contains` b 30 | | a <- as 31 | , b <- bs ] 32 | 33 | attachObviousness :: Eq i => [([[i]], [[i]])] -> [([[i]],[[i]],Bool)] 34 | attachObviousness = map attachObviousness' 35 | where attachObviousness' (as,bs) = (as,bs,isObvious as bs) 36 | 37 | 38 | -- | Given a list of relations, generate a graphviz graph containing those relations. 39 | -- Generate a dotfile from implications between groups. 40 | genDotfileFromGI :: Show i 41 | => [([[i]],[[i]],Bool)] 42 | -> String 43 | genDotfileFromGI = (\s -> "digraph G {\n" ++ s ++ "}\n") 44 | . unlines 45 | . map showEntry 46 | where showG = unwords . map show 47 | showEntry (iss,jss,p) = "\"" ++ showG iss ++ "\" -> \"" 48 | ++ showG jss ++ "\"" 49 | ++ if p 50 | then " [ color = grey ]" 51 | else "" 52 | 53 | -- | Equivalent to 'getResults' but returns a dotfile 54 | getDotfile :: (Mutable a) 55 | => [a] 56 | -> Int -> Int -> a -> (a -> [Property]) 57 | -> String 58 | getDotfile ems m n f ps = genDotfileFromGI 59 | . attachObviousness 60 | . groupImplications 61 | . map (\r -> (sets r, implied r)) 62 | $ getResultsExtra ems f ps m n 63 | 64 | -- | Equivalent to report, but writes a dotfile to a file 65 | writeDotfile :: (Mutable a) 66 | => String 67 | -> [a] 68 | -> Int -> Int -> a -> (a -> [Property]) 69 | -> IO () 70 | writeDotfile fn ems m n f = writeFile fn . getDotfile ems m n f 71 | 72 | -- | Equivalent to report, but writes a dotfile to stdout 73 | putDotfile :: (Mutable a) 74 | => [a] 75 | -> Int -> Int -> a -> (a -> [Property]) 76 | -> IO () 77 | putDotfile ems m n f = putStr . getDotfile ems m n f 78 | -------------------------------------------------------------------------------- /src/Test/FitSpec/Engine.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.Engine 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- FitSpec: refining property-sets for functional testing 8 | -- 9 | -- This is the main engine, besides "Test.FitSpec.Mutable". 10 | module Test.FitSpec.Engine 11 | ( property 12 | , Property 13 | 14 | , getResults 15 | , getResultsExtra 16 | , getResultsExtraTimeout 17 | , Result (..) 18 | , Results 19 | 20 | , propertiesNTests 21 | , propertiesTestsExhausted 22 | , propertiesToMap 23 | , propertiesHold 24 | , propertiesCE 25 | 26 | , minimal 27 | , complete 28 | 29 | , reduceImplications 30 | , filterNonCanon 31 | , Conjecture (..) 32 | , conjectures 33 | ) 34 | where 35 | 36 | import Test.LeanCheck.Error 37 | import Test.FitSpec.Utils 38 | import Data.Maybe (catMaybes, listToMaybe) 39 | import Data.List ((\\),union,transpose) 40 | import Test.FitSpec.Mutable 41 | 42 | -- | An encoded representation of a property suitable for use by FitSpec. 43 | -- 44 | -- Each list of strings is a printable representation of one possible choice of 45 | -- argument values for the property. Each boolean indicate whether the 46 | -- property holds for this choice. 47 | type Property = [([String],Bool)] 48 | type Properties = [Property] 49 | 50 | -- | Given a 'Testable' type (as defined by "Test.LeanCheck"), returns a 'Property'. 51 | -- 52 | -- This function should be used on every property to create a property list to 53 | -- be passed to 'report', 'reportWith', 'mainDefault' or 'mainWith'. 54 | -- 55 | -- > property $ \x y -> x + y < y + (x::Int) 56 | property :: Testable a => a -> Property 57 | property = results 58 | 59 | propertyHolds :: Int -> Property -> Bool 60 | propertyHolds n = all snd . take n 61 | 62 | propertyCE :: Int -> Property -> Maybe String 63 | propertyCE n = listToMaybe . map (unwords . fst) . filter (not . snd) . take n 64 | 65 | propertiesToMap :: [Property] -> Int -> [Bool] 66 | propertiesToMap ps n = map (propertyHolds n) ps 67 | 68 | propertiesHold :: Int -> [Property] -> Bool 69 | propertiesHold n = all (propertyHolds n) 70 | 71 | propertiesCE :: Int -> [Property] -> Maybe String 72 | propertiesCE n = listToMaybe 73 | . catMaybes 74 | . zipWith (\n -> fmap ((show n ++ ": ") ++)) [1..] 75 | . map (propertyCE n) 76 | 77 | propertiesNTests :: Int -> [Property] -> [Int] 78 | propertiesNTests n = map (length . take n) 79 | 80 | propertiesTestsExhausted :: Int -> [Property] -> [Bool] 81 | propertiesTestsExhausted n = map (<= n) . propertiesNTests (n+1) 82 | 83 | filterNonCanon :: [Result a] -> [Result a] 84 | filterNonCanon [] = [] 85 | filterNonCanon (r:rs) = (r:) 86 | . filterNonCanon 87 | . filter (not . null . sets) 88 | . map (updateSets removeNonCanon) 89 | $ rs 90 | where removeNonCanon = filter (not . (\p' -> (p' `contains`) `any` tail (sets r))) 91 | updateSets f r = r { sets = f (sets r) } 92 | 93 | reduceImplications :: [Result a] -> [Result a] 94 | reduceImplications [] = [] 95 | reduceImplications (r:rs) = r : map (r `reduce`) (reduceImplications rs) 96 | where r `reduce` r' = if or [s `contained` s' | s <- sets r, s' <- sets r'] 97 | then r' { implied = implied r' \\ implied r } 98 | else r' 99 | 100 | 101 | -- | A line of result for a single equivalence class of properties 102 | -- with the exact same surviving mutants. 103 | data Result a = Result 104 | { sets :: [[Int]] -- ^ property-sets in the equivalence class 105 | , implied :: [Int] -- ^ properties implied by this class 106 | , survivors :: [a] -- ^ list of surviving mutants 107 | , smallestSurvivor :: Maybe a -- ^ smallest surviving mutant, if any 108 | , nSurvivors :: Int -- ^ number of surviving mutants 109 | , nKilled :: Int -- ^ number of killed mutants 110 | , totalMutants :: Int -- ^ total number of mutants generated and tested 111 | , score :: Int -- ^ percentage of killed mutants, 0-100 112 | , maxTests :: Int -- ^ Requested number of tests (same for all rs.) 113 | , mutantsExhausted :: Bool -- ^ mutants were exhausted 114 | } 115 | type Results a = [Result a] 116 | 117 | 118 | -- | Return minimality and completeness results. See 'report'. 119 | getResults :: (Mutable a) 120 | => a -> (a -> [Property]) -> Int -> Int 121 | -> Results a 122 | getResults = getResultsExtra [] 123 | 124 | getResultsExtra :: (Mutable a) 125 | => [a] 126 | -> a -> (a -> [Property]) -> Int -> Int 127 | -> Results a 128 | getResultsExtra ems f ps nms nts = map (uncurry $ processRawResult mex nts) 129 | $ getRawResults is pmap ms 130 | where is = [1..(length $ ps f)] 131 | pmap f = propertiesToMap (ps f) nts 132 | ms' = take (nms+1) (tail $ mutants f) 133 | mex = length ms' <= nms 134 | ms = take nms ms' ++ ems 135 | 136 | getResultsExtraTimeout :: (Mutable a) 137 | => Int 138 | -> [a] 139 | -> a -> (a -> [Property]) -> Int -> Int 140 | -> IO (Results a) 141 | getResultsExtraTimeout 0 ems f ps m n = return $ getResultsExtra ems f ps m n 142 | getResultsExtraTimeout t ems f ps nm0 nt0 = lastTimeout t resultss 143 | where 144 | resultss = map fst 145 | $ takeWhileIncreasingOn ((totalMutants . head) *** id) 146 | [ (getResultsExtra ems f ps nm nt, propertiesNTests nt $ ps f) 147 | | (nm,nt) <- iterate (incHalf *** incHalf) (nm0,nt0) ] 148 | incHalf x = x + x `div` 2 149 | 150 | processRawResult :: Bool -> Int -> [[Int]] -> [(a,Bool)] -> Result a 151 | processRawResult mex nt iss mhs = Result 152 | { sets = relevantPropertySets iss 153 | , implied = relevantImplications iss 154 | , survivors = ms 155 | , smallestSurvivor = listToMaybe ms 156 | , nSurvivors = ns 157 | , nKilled = nk 158 | , totalMutants = nm 159 | , score = nk*100 `div` nm 160 | , maxTests = nt 161 | , mutantsExhausted = mex 162 | } 163 | where ms = [m | (m,h) <- mhs, h] 164 | nm = length mhs 165 | ns = length ms 166 | nk = nm - ns 167 | 168 | minimal :: Results a -> Bool 169 | minimal (r:_) = null (implied r) 170 | && length (sets r) == 1 171 | 172 | complete :: Results a -> Bool 173 | complete (r:_) = nSurvivors r == 0 174 | 175 | relevantPropertySets :: Eq i => [[i]] -> [[i]] 176 | relevantPropertySets = filterU (not ... contained) . sortOn length 177 | 178 | relevantImplications :: Eq i => [[i]] -> [i] 179 | relevantImplications iss = foldr union [] iss 180 | \\ foldr union [] (relevantPropertySets iss) 181 | 182 | -- | Returns a description of property sets, grouping the ones that had the 183 | -- same surviving mutants. The resulting list is ordered starting with the 184 | -- least surviving mutants to the most surviving mutants. 185 | -- 186 | -- Arguments: 187 | -- 188 | -- * @is@: list of property ids (@length is == length (pmap x)@) 189 | -- 190 | -- * @pmap@: a property map 191 | -- 192 | -- * @ms@: list of mutants to apply to the property map 193 | -- 194 | -- Return a list of tuples containing: 195 | -- 196 | -- * a list of property sets 197 | -- * a list of mutants paired with booleans indicating whether each survived 198 | getRawResults :: [i] -> (a -> [Bool]) -> [a] -> [([[i]],[(a,Bool)])] 199 | getRawResults is ps ms = (id *** (zip ms)) `map` getRawResults' is ps ms 200 | 201 | -- | Returns a description of property sets, grouping the ones that had the 202 | -- same surviving mutants. The resulting list is ordered starting with the 203 | -- least surviving mutants to the most surviving mutants. 204 | -- 205 | -- Arguments: 206 | -- 207 | -- * @is@: list of property ids (@length is == length (pmap x)@) 208 | -- 209 | -- * @pmap@: a property map 210 | -- 211 | -- * @ms@: list of mutants to apply to the property map 212 | -- 213 | -- Return a list of tuples containing: 214 | -- 215 | -- * a list of property sets 216 | -- * a boolean list indicating whether a given mutant survived 217 | getRawResults' :: [i] -> (a -> [Bool]) -> [a] -> [([[i]],[Bool])] 218 | getRawResults' is pmap = sortOn (count id . snd) 219 | . sortAndGroupFstBySnd 220 | . zip (subsets is) 221 | . transpose 222 | . map (compositions . pmap) 223 | 224 | -- | @nSurv props fs@ returns the number of values that match 225 | -- compositions of properties on the property map. 226 | -- 227 | -- * @props@ should be a function from a value to a list of properties that 228 | -- match that value (in the case of functions, functions that "survive" those 229 | -- properties). 230 | -- 231 | -- * @fs@ is a list of values to be mapped over by @props@ 232 | -- 233 | -- > length (nSurvivors props fs) == 2 ^ (length (props fs)) 234 | -- 235 | -- This function is otherwise unused in this file. It is just a simpler 236 | -- version of 'pssurv' to serve as documentation. 237 | -- 238 | -- It is also not exported! 239 | nSurv :: (a -> [Bool]) -> [a] -> [Int] 240 | nSurv props = map (count id) 241 | . transpose 242 | . map (compositions . props) 243 | 244 | 245 | data Conjecture = Conjecture 246 | { isEq :: Bool 247 | , isIm :: Bool 248 | , cleft :: [Int] 249 | , cright :: [Int] 250 | , cscore :: Int 251 | , cnKilled :: Int 252 | , cnSurvivors :: Int 253 | } deriving Show 254 | 255 | conjectures :: [Result a] -> [Conjecture] 256 | conjectures = concatMap conjectures1 257 | . sortOn (abs . (50-) . score) -- closer to 50 the better! 258 | . reduceImplications 259 | . filterNonCanon 260 | . reverse 261 | 262 | conjectures1 :: Result a -> [Conjecture] 263 | conjectures1 r = [ p `eq` p' | p' <- ps ] 264 | ++ [ p `im` i | (not.null) i ] 265 | where 266 | (p:ps) = sets r 267 | i = implied r 268 | eq = conj True 269 | im = conj False 270 | conj isE p p' = Conjecture 271 | { isEq = isE 272 | , isIm = not isE 273 | , cleft = p 274 | , cright = p' 275 | , cscore = score r 276 | , cnKilled = nKilled r 277 | , cnSurvivors = nSurvivors r 278 | } 279 | -- TODO: improve implication score 280 | -- implication score can be improved by 281 | -- by separating each implication on its own: 282 | -- [4] ==> [2,3] 283 | -- become 284 | -- [4] ==> [2] 285 | -- [4] ==> [3] 286 | -- Then evaluating percentage of occurences of True ==> True and other cases 287 | -------------------------------------------------------------------------------- /src/Test/FitSpec/Main.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.Main 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Exports "main" functions for FitSpec. 8 | -- They work exactly by 'report' and 'reportWith' but can be customized by 9 | -- command line arguments. 10 | -- 11 | -- > main = mainWith args { ... } functions properties 12 | {-# Language DeriveDataTypeable, StandaloneDeriving #-} 13 | module Test.FitSpec.Main 14 | ( mainWith 15 | , defaultMain 16 | , getArgs 17 | , getArgsWith 18 | , module Test.FitSpec.Report -- deprecated export, remove later 19 | ) 20 | where 21 | 22 | import Test.FitSpec.Report 23 | import System.Console.CmdArgs hiding (args) 24 | import qualified System.Console.CmdArgs as CA (args) 25 | import Control.Monad (liftM) 26 | import Test.FitSpec.Mutable 27 | import Test.FitSpec.ShowMutable 28 | 29 | deriving instance Data ShowMutantAs 30 | deriving instance Data Args 31 | deriving instance Typeable ShowMutantAs 32 | deriving instance Typeable Args 33 | 34 | annotate :: Args -> Args 35 | annotate as = Args 36 | { nMutants = nMutants as &= name "m" 37 | &= help "(starting) number of function mutations" 38 | , nTests = nTests as &= name "n" 39 | &= help "(starting) number of test values (each prop.)" 40 | , timeout = timeout as &= name "t" &= name "s" 41 | &= help "timeout in seconds, 0 for just T*M" 42 | , names = names as 43 | &= ignore 44 | , rows = rows as 45 | &= help "how many rows of results to show" 46 | , verbose = verbose as 47 | &= help "activate verbose output" 48 | , showMutantAs = showMutantAs as &= name "a" 49 | &= help "how to show mutants (tuple / nestedtuple / definition / bindings)" 50 | &= typ "type" 51 | , extra = extra as &= CA.args 52 | &= typ "extra arguments" 53 | } &= summary "FitSpec" 54 | &= program "program" 55 | &= help "Refine property-sets for functional testing" 56 | 57 | getArgsWith :: Args -> IO Args 58 | getArgsWith = cmdArgs . annotate 59 | 60 | getArgs :: IO Args 61 | getArgs = getArgsWith args 62 | 63 | -- | Same as 'reportWith', but allow overriding of configuration via command 64 | -- line arguments. 65 | mainWith :: (Mutable a, ShowMutable a) 66 | => Args 67 | -> a -> (a -> [Property]) -> IO () 68 | mainWith as f ps = do 69 | as' <- getArgsWith as 70 | reportWith as' f ps 71 | 72 | -- | Same as 'report', but allow configuration via command line arguments. 73 | defaultMain :: (Mutable a, ShowMutable a) 74 | => a -> (a -> [Property]) -> IO () 75 | defaultMain = mainWith args 76 | -------------------------------------------------------------------------------- /src/Test/FitSpec/Mutable.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.Mutable 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Enumeration of function mutations 8 | module Test.FitSpec.Mutable 9 | ( Mutable (..) 10 | , mutiersEq 11 | --, mutantsIntegral 12 | ) 13 | where 14 | 15 | import Test.LeanCheck 16 | import Data.List (intercalate, delete) 17 | import Data.Maybe 18 | import Test.LeanCheck.Error (errorToNothing) 19 | import Data.Ratio (Ratio) 20 | import Data.Word (Word) 21 | 22 | -- | This typeclass is similar to 'Listable'. 23 | -- 24 | -- A type is 'Mutable' when there exists a function that 25 | -- is able to list mutations of a value. 26 | -- Ideally: list all possible values without repetitions. 27 | -- 28 | -- Instances are usually defined by a 'mutiers' function that 29 | -- given a value, returns tiers of mutants of that value: 30 | -- the first tier contains the equivalent mutant, of size 0, 31 | -- the second tier contains mutants of size 1, 32 | -- the third tier contains mutants of size 2, 33 | -- and so on. 34 | -- 35 | -- The equivalent mutant is the actual function without mutations. 36 | -- 37 | -- The size of a mutant is given by the sum of: 38 | -- the number of mutated points (relations) and 39 | -- the sizes of mutated arguments and results. 40 | -- 41 | -- To get only inequivalent mutants, 42 | -- just take the 'tail' of either 'mutants' or 'mutiers': 43 | -- 44 | -- > tail mutants 45 | -- 46 | -- > tail mutiers 47 | -- 48 | -- Given that the underlying 'Listable' enumeration has no repetitions, 49 | -- parametric instances defined in this file will have no repeated mutants. 50 | class Mutable a where 51 | mutiers :: a -> [[a]] 52 | mutants :: a -> [a] 53 | mutiers = map (:[]) . mutants 54 | mutants = concat . mutiers 55 | {-# MINIMAL mutants | mutiers #-} 56 | 57 | 58 | -- *** *** Instances for (non-functional) data types *** *** 59 | 60 | -- | Implementation of 'mutiers' for non-functional data types. 61 | -- Use this to create instances for user-defined data types, e.g.: 62 | -- 63 | -- > instance MyData 64 | -- > where mutiers = mutiersEq 65 | -- 66 | -- and for parametric datatypes: 67 | -- 68 | -- > instance (Eq a, Eq b) => MyDt a b 69 | -- > where mutiers = mutiersEq 70 | -- 71 | -- Examples: 72 | -- 73 | -- > mutiersEq True = [[True], [False]] 74 | -- > mutiersEq 2 = [[2], [0], [1], [], [3], [4], [5], [6], [7], [8], [9], ...] 75 | -- > mutiersEq [1] = [[[1]], [[]], [[0]], [[0,0]], [[0,0,0],[0,1],[1,0],[-1]], ...] 76 | mutiersEq :: (Listable a, Eq a) => a -> [[a]] 77 | mutiersEq x = [x] : deleteT x tiers 78 | 79 | -- | > mutants () = [()] 80 | instance Mutable () where mutiers = mutiersEq 81 | 82 | -- | > mutants 3 = [3,0,1,2,4,5,6,7,8,...] 83 | instance Mutable Int where mutiers = mutiersEq 84 | 85 | instance Mutable Integer where mutiers = mutiersEq 86 | 87 | instance Mutable Char where mutiers = mutiersEq 88 | 89 | -- | > mutants True = [True,False] 90 | instance Mutable Bool where mutiers = mutiersEq 91 | 92 | -- | > mutants [0] = [ [0], [], [0,0], [1], ... 93 | instance (Eq a, Listable a) => Mutable [a] where mutiers = mutiersEq 94 | 95 | -- | > mutants (Just 0) = [Just 0, Nothing, ... 96 | instance (Eq a, Listable a) => Mutable (Maybe a) where mutiers = mutiersEq 97 | 98 | instance (Eq a, Listable a, Eq b, Listable b) => Mutable (Either a b) 99 | where mutiers = mutiersEq 100 | 101 | instance (Eq a, Listable a, Integral a) => Mutable (Ratio a) 102 | where mutiers = mutiersEq 103 | 104 | instance Mutable Float where mutiers = mutiersEq 105 | instance Mutable Double where mutiers = mutiersEq 106 | instance Mutable Ordering where mutiers = mutiersEq 107 | instance Mutable Word where mutiers = mutiersEq 108 | 109 | {- Alternative implementations for Mutable Ints and Lists. 110 | -- These do not improve results significantly. 111 | -- That is why I have kept the simpler mutations above. 112 | 113 | -- |- Generate mutants of an Integral value. 114 | -- Alternates between successors and predecessors of the original number. 115 | -- The enumeration starts "towards" zero. 116 | mutantsIntegral :: Integral a => a -> [a] 117 | mutantsIntegral i | i > 0 = [i..] +| tail [i,(i-1)..] 118 | | otherwise = [i,(i-1)..] +| tail [i..] 119 | -- NOTE: tail is there to avoid generating out of bound values 120 | -- as (i-1) is usually safe while (i-2) is not. 121 | 122 | instance Mutable Int where mutants = mutantsIntegral 123 | 124 | instance (Listable a, Mutable a) => Mutable [a] 125 | where mutiers [] = [ [] ] 126 | : [ ] 127 | : tail tiers 128 | mutiers (x:xs) = [ (x:xs) ] 129 | : [ [] ] 130 | : tail (lsProductWith (:) (mutiers x) (mutiers xs)) 131 | -- -} 132 | 133 | 134 | -- *** *** Instances for functional types *** *** 135 | 136 | -- | Mutate a function at a single point. 137 | -- The following two declarations are equivalent: 138 | -- 139 | -- > id' = id `mut` (0,1) 140 | -- 141 | -- > id' 0 = 1 142 | -- > id' x = x 143 | mut :: Eq a => (a -> b) -> (a,b) -> (a -> b) 144 | mut f (x',fx') = \x -> if x == x' 145 | then fx' 146 | else f x 147 | 148 | -- | Mutate a function at several points. 149 | -- 150 | -- > f `mutate` [(x,a),(y,b),(z,c)] = f `mut` (x,a) `mut` (y,b) `mut` (z,c) 151 | mutate :: Eq a => (a -> b) -> [(a,b)] -> (a -> b) 152 | mutate f ms = foldr (flip mut) f ms -- or: foldl mut f ms 153 | 154 | -- | Return tiers of possible mutations for a single point of a function. 155 | -- If the function is undefined at that point, no mutations are provided. 156 | -- This function does not return the null mutant. 157 | -- 158 | -- > (+1) `mutationsFor` 1 = [ [(1,0)], [(1,1)], [], [(1,3)], [(1,4)], ... 159 | mutationsFor :: Mutable b => (a->b) -> a -> [[(a,b)]] 160 | mutationsFor f x = case errorToNothing (f x) of 161 | Nothing -> [] 162 | Just fx -> ((,) x) `mapT` tail (mutiers fx) 163 | 164 | -- | Returns tiers of mutants on a selection of arguments of a function. 165 | -- Will only return the null mutant from an empty selection of arguments. 166 | tiersMutantsOn :: (Eq a, Mutable b) => (a->b) -> [a] -> [[a->b]] 167 | tiersMutantsOn f xs = mutate f `mapT` products (map (mutationsFor f) xs) 168 | 169 | -- | 170 | -- > mutants not = 171 | -- > [ not 172 | -- > , \p -> case p of False -> False; _ -> not p 173 | -- > , \p -> case p of True -> True; _ -> not p 174 | -- > , \p -> case p of False -> False; True -> True 175 | -- > ] 176 | instance (Eq a, Listable a, Mutable b) => Mutable (a -> b) where 177 | mutiers f = tiersMutantsOn f `concatMapT` setsOf tiers 178 | 179 | 180 | -- *** *** Instances for tuples *** *** 181 | 182 | -- | > mutants (0,1) = [(0,1),(0,0),(1,1),(0,-1),...] 183 | instance (Mutable a, Mutable b) => Mutable (a,b) where 184 | mutiers (f,g) = mutiers f >< mutiers g 185 | 186 | instance (Mutable a, Mutable b, Mutable c) => Mutable (a,b,c) where 187 | mutiers (f,g,h) = productWith (\f' (g',h') -> (f',g',h')) 188 | (mutiers f) (mutiers (g,h)) 189 | 190 | instance (Mutable a, Mutable b, Mutable c, Mutable d) 191 | => Mutable (a,b,c,d) where 192 | mutiers (f,g,h,i) = productWith (\f' (g',h',i') -> (f',g',h',i')) 193 | (mutiers f) (mutiers (g,h,i)) 194 | 195 | instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e) 196 | => Mutable (a,b,c,d,e) where 197 | mutiers (f,g,h,i,j) = productWith (\f' (g',h',i',j') -> (f',g',h',i',j')) 198 | (mutiers f) (mutiers (g,h,i,j)) 199 | 200 | instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, Mutable f) 201 | => Mutable (a,b,c,d,e,f) where 202 | mutiers (f,g,h,i,j,k) = productWith (\f' (g',h',i',j',k') -> 203 | (f',g',h',i',j',k')) 204 | (mutiers f) (mutiers (g,h,i,j,k)) 205 | 206 | -- Further tuple instances are defined on FitSpec.Mutable.Tuples and are 207 | -- exported by default by Test.FitSpec. 208 | -------------------------------------------------------------------------------- /src/Test/FitSpec/Mutable/Tuples.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.Mutable.Tuples 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Mutable instances: septuples up to 12-tuples 8 | -- 9 | -- This is partly a Hack that allows those instances to be hidden from Haddock. 10 | -- Otherwise Haddock documentation will look very ugly. 11 | -- It also makes "Test.FitSpec.ShowMutable" more readable. 12 | -- 13 | -- This module is already exported by "Test.FitSpec", 14 | -- so it is not needed to import this explictly. 15 | module Test.FitSpec.Mutable.Tuples () where 16 | 17 | import Test.FitSpec.Mutable 18 | import Test.LeanCheck (productWith) 19 | 20 | instance (Mutable a, Mutable b, Mutable c, Mutable d, 21 | Mutable e, Mutable f, Mutable g) 22 | => Mutable (a,b,c,d,e,f,g) where 23 | mutiers (f,g,h,i,j,k,l) = productWith (\f' (g',h',i',j',k',l') -> 24 | (f',g',h',i',j',k',l')) 25 | (mutiers f) 26 | (mutiers (g,h,i,j,k,l)) 27 | 28 | instance (Mutable a, Mutable b, Mutable c, Mutable d, 29 | Mutable e, Mutable f, Mutable g, Mutable h) 30 | => Mutable (a,b,c,d,e,f,g,h) where 31 | mutiers (f,g,h,i,j,k,l,m) = productWith (\f' (g',h',i',j',k',l',m') -> 32 | (f',g',h',i',j',k',l',m')) 33 | (mutiers f) 34 | (mutiers (g,h,i,j,k,l,m)) 35 | 36 | instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, 37 | Mutable f, Mutable g, Mutable h, Mutable i) 38 | => Mutable (a,b,c,d,e,f,g,h,i) where 39 | mutiers (f,g,h,i,j,k,l,m,n) = 40 | productWith (\f' (g',h',i',j',k',l',m',n') -> 41 | (f',g',h',i',j',k',l',m',n')) 42 | (mutiers f) 43 | (mutiers (g,h,i,j,k,l,m,n)) 44 | 45 | instance (Mutable a, Mutable b, Mutable c, Mutable d, Mutable e, 46 | Mutable f, Mutable g, Mutable h, Mutable i, Mutable j) 47 | => Mutable (a,b,c,d,e,f,g,h,i,j) where 48 | mutiers (f,g,h,i,j,k,l,m,n,o) = 49 | productWith (\f' (g',h',i',j',k',l',m',n',o') -> 50 | (f',g',h',i',j',k',l',m',n',o')) 51 | (mutiers f) 52 | (mutiers (g,h,i,j,k,l,m,n,o)) 53 | 54 | instance (Mutable a, Mutable b, Mutable c, Mutable d, 55 | Mutable e, Mutable f, Mutable g, Mutable h, 56 | Mutable i, Mutable j, Mutable k) 57 | => Mutable (a,b,c,d,e,f,g,h,i,j,k) where 58 | mutiers (f,g,h,i,j,k,l,m,n,o,p) = 59 | productWith (\f' (g',h',i',j',k',l',m',n',o',p') -> 60 | (f',g',h',i',j',k',l',m',n',o',p')) 61 | (mutiers f) 62 | (mutiers (g,h,i,j,k,l,m,n,o,p)) 63 | 64 | instance (Mutable a, Mutable b, Mutable c, Mutable d, 65 | Mutable e, Mutable f, Mutable g, Mutable h, 66 | Mutable i, Mutable j, Mutable k, Mutable l) 67 | => Mutable (a,b,c,d,e,f,g,h,i,j,k,l) where 68 | mutiers (f,g,h,i,j,k,l,m,n,o,p,q) = 69 | productWith (\f' (g',h',i',j',k',l',m',n',o',p',q') -> 70 | (f',g',h',i',j',k',l',m',n',o',p',q')) 71 | (mutiers f) 72 | (mutiers (g,h,i,j,k,l,m,n,o,p,q)) 73 | -------------------------------------------------------------------------------- /src/Test/FitSpec/PrettyPrint.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.PrettyPrint 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- A very simple pretty printing library used to generate 'Test.FitSpec' reports. 8 | module Test.FitSpec.PrettyPrint 9 | ( beside 10 | , above 11 | , showTuple 12 | , table 13 | , columns 14 | , showQuantity 15 | , showEach 16 | , headToUpper 17 | ) 18 | where 19 | -- TODO: Fix somewhat inefficient implementations, i.e.: heavy use of '(++)'. 20 | 21 | import Data.List (intercalate,transpose,isSuffixOf) 22 | import Data.Char (toUpper) 23 | 24 | showQuantity :: Int -> String -> String 25 | showQuantity 1 what = "1 " ++ what 26 | showQuantity n what = show n ++ " " ++ pluralize what 27 | 28 | showEach :: Show a => String -> [a] -> String 29 | showEach what [x] = what ++ " " ++ show x 30 | showEach what xs = "each of " ++ pluralize what ++ " " 31 | ++ intercalate ", " (map show $ init xs) 32 | ++ " and " 33 | ++ show (last xs) 34 | 35 | -- | Pluralizes a word. 36 | -- Is not comprehensive (and may never be), 37 | -- add missing cases as they are found. 38 | -- 39 | -- > pluralize "test case" == "test cases" 40 | -- > pluralize "property" == "properties" 41 | pluralize :: String -> String 42 | pluralize s | s `ew` "se" = s ++ "s" 43 | | s `ew` "n" = s ++ "s" 44 | | s `ew` "y" = init s ++ "ies" 45 | | otherwise = s 46 | where ew = flip isSuffixOf 47 | 48 | 49 | -- | Appends two Strings side by side, line by line 50 | -- 51 | -- > beside ["asdf\nqw\n","zxvc\nas"] == 52 | -- > "asdfzxvc\n\ 53 | -- > \qw as\n" 54 | beside :: String -> String -> String 55 | beside cs ds = unlines $ zipWith (++) (normalize ' ' css) dss 56 | where [css,dss] = normalize "" [lines cs,lines ds] 57 | 58 | -- | Append two Strings on top of each other, adding line breaks *when needed*. 59 | above :: String -> String -> String 60 | above cs ds = if last cs == '\n' || head ds == '\n' 61 | then cs ++ ds 62 | else cs ++ '\n':ds 63 | 64 | -- | Show elements of a list as a tuple. If there are multiple lines in any of 65 | -- the strings, tuple is printed multiline. 66 | -- 67 | -- > showTuple ["asdf\nqwer\n","zxvc\nasdf\n"] == 68 | -- > "( asdf\n\ 69 | -- > \ qwer\n\ 70 | -- > \, zxvc\n\ 71 | -- > \ asdf )\n" 72 | -- 73 | -- > showTuple ["asdf","qwer"] == "(asdf,qwer)" 74 | showTuple :: [String] -> String 75 | showTuple [] = "" 76 | showTuple [s] = s 77 | showTuple (s:ss) = 78 | if any ('\n' `elem`) (s:ss) 79 | then "( " `beside` s 80 | ++ init (concatMap (", " `beside`) ss) 81 | ++ " )\n" 82 | else "(" ++ intercalate "," (s:ss) ++ ")" 83 | 84 | -- | Formats a table using a given separator. 85 | -- 86 | -- > table " " [ ["asdf", "qwer", "zxvc\nzxvc"] 87 | -- > , ["0", "1", "2"] 88 | -- > , ["123", "456\n789", "3"] ] == 89 | -- > "asdf qwer zxvc\n\ 90 | -- > \ zxvc\n\ 91 | -- > \0 1 2\n\ 92 | -- > \123 456 3\n\ 93 | -- > \ 789\n\" 94 | table :: String -> [[String]] -> String 95 | table s [] = "" 96 | table s sss = unlines 97 | . map (removeTrailing ' ') 98 | . map (intercalate s) 99 | . transpose 100 | . map (normalize ' ') 101 | . foldr1 (zipWith (++)) 102 | . map (normalize "" . map lines) 103 | . normalize "" 104 | $ sss 105 | 106 | -- | Given a separator, format strings in columns 107 | -- 108 | -- > columns " | " ["asdf", "qw\nzxcv", "as\ndf"] == 109 | -- > "asdf | qw | as\n\ 110 | -- > \ | zxcv | df\n" 111 | columns :: String -> [String] -> String 112 | columns s = unlines 113 | . map (removeTrailing ' ') 114 | . map (intercalate s) 115 | . transpose 116 | . map (normalize ' ') 117 | . normalize "" 118 | . map lines 119 | 120 | -- | Fits a list to a certain width by appending a certain value 121 | -- 122 | -- > fit ' ' 6 "str" == "str " 123 | -- 124 | -- > fit 0 6 [1,2,3] == [1,2,3,0,0,0] 125 | fit :: a -> Int -> [a] -> [a] 126 | fit x n xs = xs ++ replicate (n - length xs) x 127 | 128 | -- | normalize makes all list the same length by adding a value 129 | -- 130 | -- > normalize ["asdf","qw","er"] == normalize ["asdf","qw ","er "] 131 | normalize :: a -> [[a]] -> [[a]] 132 | normalize x xs = map (x `fit` maxLength xs) xs 133 | 134 | -- | Given a list of lists returns the maximum length 135 | maxLength :: [[a]] -> Int 136 | maxLength = maximum . (0:) . map length 137 | 138 | removeTrailing :: Eq a => a -> [a] -> [a] 139 | removeTrailing x = reverse 140 | . dropWhile (==x) 141 | . reverse 142 | 143 | headToUpper :: [Char] -> [Char] 144 | headToUpper [] = [] 145 | headToUpper (c:cs) = toUpper c : cs 146 | -------------------------------------------------------------------------------- /src/Test/FitSpec/Report.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.Report 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- Generate 'Test.FitSpec' reports. 8 | module Test.FitSpec.Report 9 | ( report 10 | , reportWith 11 | , reportWithExtra 12 | , Args(..) 13 | , args 14 | , fixargs 15 | , Property 16 | , ShowMutantAs(..) 17 | ) 18 | where 19 | 20 | import Data.List (intercalate, intersperse) 21 | import Data.Maybe (fromMaybe) 22 | 23 | import Test.FitSpec.Engine 24 | import Test.FitSpec.Mutable 25 | import Test.FitSpec.ShowMutable 26 | import Test.FitSpec.Utils 27 | import Test.FitSpec.PrettyPrint 28 | 29 | -- | How to show mutants. Use this to fill 'showMutantAs'. 30 | data ShowMutantAs = Tuple | NestedTuple 31 | | Definition | Bindings 32 | 33 | -- | Extra arguments / configuration for 'reportWith'. 34 | -- See 'args' for default values. 35 | data Args = Args 36 | { nMutants :: Int -- ^ (starting) number of function mutations 37 | , nTests :: Int -- ^ (starting) number of test values (for each prop.) 38 | , timeout :: Int -- ^ timeout in seconds, 0 for just 'nTests' * 'nMutants' 39 | , names :: [String] -- ^ names of functions: @["foo x y","goo x y"]@ 40 | 41 | -- advanced options: 42 | , verbose :: Bool -- ^ whether to show detailed results 43 | , showMutantAs :: ShowMutantAs -- ^ how to show mutants 44 | , rows :: Maybe Int -- ^ number of surviving mutants to show 45 | , extra :: [String] -- ^ ignored argument (user defined meaning) 46 | } 47 | 48 | -- | Default arguments for 'reportWith': 49 | -- 50 | -- * @nMutants = 500@, start with 500 mutants 51 | -- 52 | -- * @nTests = 1000@, start with 1000 test values 53 | -- 54 | -- * @timeout = 5@, keep incresing the number of mutants 55 | -- until 5 seconds elapse 56 | -- 57 | -- * @names = []@, default function call template: 58 | -- 59 | -- > ["f x y z", "g x y z", "h x y z", ...] 60 | args :: Args 61 | args = Args { nMutants = 500 62 | , nTests = 1000 63 | , timeout = 5 -- seconds 64 | , names = [] 65 | , verbose = False 66 | , showMutantAs = Tuple 67 | , rows = Nothing 68 | , extra = [] 69 | } 70 | 71 | -- | Non timed-out default arguments. 72 | -- Make conjectures based on a fixed number of mutants and tests, e.g.: 73 | -- 74 | -- > reportWith (fixargs 100 200) f pmap 75 | -- 76 | -- This is just a shorthand, see: 77 | -- 78 | -- > fixargs nm nt = args { nMutants = nm, nTests = nt, timeout = 0 } 79 | -- 80 | -- > (fixargs nm nt) { nMutants = 500, nTests = 1000, timeout = 5 } = args 81 | fixargs :: Int -> Int -> Args 82 | fixargs nm nt = args 83 | { nMutants = nm 84 | , nTests = nt 85 | , timeout = 0 86 | } 87 | 88 | showMutant :: ShowMutable a => Args -> a -> a -> String 89 | showMutant as = showMutantByType (showMutantAs as) (names as) 90 | where 91 | showMutantByType Tuple = showMutantAsTuple 92 | showMutantByType NestedTuple = showMutantNested 93 | showMutantByType Definition = showMutantDefinition 94 | showMutantByType Bindings = showMutantBindings 95 | 96 | -- | Report results generated by FitSpec. 97 | -- Uses standard configuration (see 'args'). 98 | -- Needs a function to be mutated and a property map. 99 | -- Example (specification of boolean negation): 100 | -- 101 | -- > properties not = 102 | -- > [ property $ \p -> not (not p) == p 103 | -- > , property $ \p -> not (not (not p)) == not p 104 | -- > ] 105 | -- > 106 | -- > main = report not properties 107 | report :: (Mutable a, ShowMutable a) 108 | => a -> (a -> [Property]) -> IO () 109 | report = reportWith args 110 | 111 | 112 | -- | Same as 'report' but can be configured via 'Args' ('args' or 'fixargs'), 113 | -- e.g.: 114 | -- 115 | -- > reportWith args { timeout = 10 } fun properties 116 | reportWith :: (Mutable a, ShowMutable a) 117 | => Args -> a -> (a -> [Property]) -> IO () 118 | reportWith = reportWithExtra [] 119 | 120 | 121 | -- | Same as 'reportWith', but accepts a list of manually defined (extra) 122 | -- mutants to be tested alongside those automatically generated. 123 | reportWithExtra :: (Mutable a, ShowMutable a) 124 | => [a] -> Args -> a -> (a -> [Property]) -> IO () 125 | reportWithExtra extraMutants args f properties = do 126 | let nm = nMutants args 127 | nt = nTests args 128 | case propertiesCE nt (properties f) of 129 | Nothing -> reportWithExtra' extraMutants args f properties 130 | Just ce -> do 131 | putStrLn $ "ERROR: The original function-set does not follow property set for " 132 | ++ show nt ++ " tests" 133 | putStrLn $ "Counter-example to property " ++ ce 134 | putStrLn $ "Aborting." 135 | 136 | -- | Same as 'reportWithExtra', does not abort if the original function does not 137 | -- follow the property set. 138 | reportWithExtra' :: (Mutable a, ShowMutable a) 139 | => [a] -> Args -> a -> (a -> [Property]) -> IO () 140 | reportWithExtra' extraMutants args f properties = do 141 | results <- getResultsExtraTimeout (timeout args) 142 | extraMutants 143 | f properties 144 | (nMutants args) (nTests args) 145 | 146 | let nm = totalMutants $ head results 147 | nt = maxTests $ head results 148 | nts = propertiesNTests nt (properties f) 149 | tex = and $ propertiesTestsExhausted nt (properties f) 150 | mex = mutantsExhausted $ head results 151 | apparent | tex && mex = "" 152 | | otherwise = "apparent " 153 | putStrLn . headToUpper $ apparent ++ qualifyCM results ++ " specification based on" 154 | putStrLn $ showNumberOfTestsAndMutants tex mex nts nm False 155 | 156 | let showR | verbose args = showDetailedResults 157 | | otherwise = showResults 158 | putStrLn $ showR (rows args) (showMutant args f) results 159 | 160 | 161 | showResults :: Maybe Int -> (a -> String) 162 | -> [Result a] -> String 163 | showResults mlimit showMutant rs@(r:_) = completeness 164 | ++ "\n" ++ minimality 165 | where 166 | showMutants ms = init . unlines $ map showMutant ms 167 | completeness = show (nSurvivors r) ++ " survivors (" 168 | ++ show (score r) ++ "% killed)" 169 | ++ case take (fromMaybe 1 mlimit) $ survivors r of 170 | [] -> ".\n" 171 | [m] -> ", smallest:\n" 172 | ++ " " `beside` showMutant m 173 | ms -> ", " ++ show (length ms) ++ " smallest:\n" 174 | ++ " " `beside` showMutants ms 175 | minimality = "apparent minimal property subsets: " 176 | ++ (unwords . map showPropertySet $ sets r) ++ "\n" 177 | ++ case showConjectures False rs of 178 | "" -> "No conjectures.\n" 179 | cs -> "conjectures: " `beside` cs 180 | 181 | 182 | showDetailedResults :: Maybe Int -> (a -> String) 183 | -> [Result a] -> String 184 | showDetailedResults mlimit showMutant rs = completeness 185 | ++ "\n" ++ minimality 186 | where 187 | completeness = table " " . intersperse ["\n"] 188 | . ([ "Property\n sets" 189 | , "#Survivors\n (%Killed)" 190 | , "Smallest or simplest\n surviving mutant" 191 | ]:) 192 | . map showResult 193 | . maybe id take mlimit 194 | $ rs 195 | showResult r = [ unwords . map showPropertySet $ sets r 196 | , show (nSurvivors r) ++ " (" ++ show (score r) ++ "%)" 197 | , maybe "" showMutant $ smallestSurvivor r 198 | ] 199 | minimality = case showConjectures True rs of 200 | "" -> "No conjectures.\n" 201 | cs -> "Conjectures:\n" ++ cs 202 | 203 | 204 | showNumberOfTestsAndMutants :: Bool -> Bool -> [Int] -> Int -> Bool -> String 205 | showNumberOfTestsAndMutants tex mex nts nm ssum = numTests ++ numMutants 206 | where 207 | mexS | mex = " (exhausted)" 208 | | otherwise = "" 209 | numMutants = "for each of " ++ showQuantity nm "mutant variation" ++ mexS ++ ".\n" 210 | numTests | ssum = showQuantity (sum nts) "test case" 211 | ++ (if tex then " (exhausted)" else "") 212 | ++ "\n" 213 | | otherwise = unlines 214 | . (++ ["(test cases exhausted)" | tex]) 215 | . sortGroupAndCollapse fst snd testsForProps 216 | $ zip nts [1..] 217 | testsForProps n ps = showQuantity n "test case" 218 | ++ " for " ++ showEach "property" ps 219 | 220 | showPropertySet :: Show i => [i] -> String 221 | showPropertySet = (\s -> "{" ++ s ++ "}") . intercalate "," . map show 222 | 223 | 224 | -- | Show conjectures derived from results 225 | showConjectures :: Bool -> [Result a] -> String 226 | showConjectures showVeryWeak = table " " 227 | . map showConjecture 228 | . filter (\r -> showVeryWeak 229 | || cnKilled r /= 0 230 | && cnSurvivors r /= 0) 231 | . conjectures 232 | 233 | showConjecture :: Conjecture -> [String] 234 | showConjecture Conjecture {isEq=eq, cleft=l, cright=r, cscore=s} = 235 | [ showPropertySet l 236 | , if eq then " = " else "==>" 237 | , showPropertySet r 238 | , " " 239 | , show s ++ "% killed" 240 | , sMeaning 241 | ] 242 | where sMeaning | s < 1 || 99 < s = "(very weak)" 243 | | s < 11 || 89 < s = "(weak)" 244 | | s < 33 || 67 < s = "(mild)" 245 | | otherwise = "(strong)" -- the closer to 50 the better 246 | 247 | qualifyCM :: Results a -> String 248 | qualifyCM rs | c && m = "complete and minimal" 249 | | c = "complete but non-minimal" 250 | | m = "minimal but incomplete" 251 | | otherwise = "incomplete and non-minimal" 252 | where c = complete rs 253 | m = minimal rs 254 | -------------------------------------------------------------------------------- /src/Test/FitSpec/ShowMutable/Tuples.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.Tuples 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- ShowMutable instances: septuples up to 12-tuples 8 | -- 9 | -- This is partly a Hack that allows those instances to be hidden from Haddock. 10 | -- Otherwise Haddock documentation will look very ugly. 11 | -- It also makes "Test.FitSpec.ShowMutable" more readable. 12 | module Test.FitSpec.ShowMutable.Tuples () where 13 | 14 | import Test.FitSpec.ShowMutable 15 | 16 | instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, 17 | ShowMutable e, ShowMutable f, ShowMutable g) 18 | => ShowMutable (a,b,c,d,e,f,g) where 19 | mutantS (f,g,h,i,j,k,l) (f',g',h',i',j',k',l') = mutantSTuple 20 | [ mutantS f f' 21 | , mutantS g g' 22 | , mutantS h h' 23 | , mutantS i i' 24 | , mutantS j j' 25 | , mutantS k k' 26 | , mutantS l l' ] 27 | 28 | instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, 29 | ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h) 30 | => ShowMutable (a,b,c,d,e,f,g,h) where 31 | mutantS (f,g,h,i,j,k,l,m) (f',g',h',i',j',k',l',m') = mutantSTuple 32 | [ mutantS f f' 33 | , mutantS g g' 34 | , mutantS h h' 35 | , mutantS i i' 36 | , mutantS j j' 37 | , mutantS k k' 38 | , mutantS l l' 39 | , mutantS m m' ] 40 | 41 | instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, 42 | ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, 43 | ShowMutable i) 44 | => ShowMutable (a,b,c,d,e,f,g,h,i) where 45 | mutantS (f,g,h,i,j,k,l,m,n) (f',g',h',i',j',k',l',m',n') = mutantSTuple 46 | [ mutantS f f' 47 | , mutantS g g' 48 | , mutantS h h' 49 | , mutantS i i' 50 | , mutantS j j' 51 | , mutantS k k' 52 | , mutantS l l' 53 | , mutantS m m' 54 | , mutantS n n' ] 55 | 56 | instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, 57 | ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, 58 | ShowMutable i, ShowMutable j) 59 | => ShowMutable (a,b,c,d,e,f,h,g,i,j) where 60 | mutantS (f,g,h,i,j,k,l,m,n,o) (f',g',h',i',j',k',l',m',n',o') = mutantSTuple 61 | [ mutantS f f' 62 | , mutantS g g' 63 | , mutantS h h' 64 | , mutantS i i' 65 | , mutantS j j' 66 | , mutantS k k' 67 | , mutantS l l' 68 | , mutantS m m' 69 | , mutantS n n' 70 | , mutantS o o' ] 71 | 72 | instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, 73 | ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, 74 | ShowMutable i, ShowMutable j, ShowMutable k) 75 | => ShowMutable (a,b,c,d,e,f,g,h,i,j,k) where 76 | mutantS (f,g,h,i,j,k,l,m,n,o,p) (f',g',h',i',j',k',l',m',n',o',p') = mutantSTuple 77 | [ mutantS f f' 78 | , mutantS g g' 79 | , mutantS h h' 80 | , mutantS i i' 81 | , mutantS j j' 82 | , mutantS k k' 83 | , mutantS l l' 84 | , mutantS m m' 85 | , mutantS n n' 86 | , mutantS o o' 87 | , mutantS p p' ] 88 | 89 | instance (ShowMutable a, ShowMutable b, ShowMutable c, ShowMutable d, 90 | ShowMutable e, ShowMutable f, ShowMutable g, ShowMutable h, 91 | ShowMutable i, ShowMutable j, ShowMutable k, ShowMutable l) 92 | => ShowMutable (a,b,c,d,e,f,g,h,i,j,k,l) where 93 | mutantS (f,g,h,i,j,k,l,m,n,o,p,q) (f',g',h',i',j',k',l',m',n',o',p',q') = mutantSTuple 94 | [ mutantS f f' 95 | , mutantS g g' 96 | , mutantS h h' 97 | , mutantS i i' 98 | , mutantS j j' 99 | , mutantS k k' 100 | , mutantS l l' 101 | , mutantS m m' 102 | , mutantS n n' 103 | , mutantS o o' 104 | , mutantS p p' 105 | , mutantS q q' ] 106 | -------------------------------------------------------------------------------- /src/Test/FitSpec/TestTypes.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.TestTypes 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- FitSpec's Test Types: 8 | -- 'Nat', 9 | -- 'Int2', 'Int3', 'Int4', 10 | -- 'UInt2', 'UInt3', 'UInt4'. 11 | -- 12 | -- This module re-exports "Test.LeanCheck.Utils.Types" module 13 | -- and defines 'Mutable' and 'ShowMutable' instances for the types 14 | -- defined there. 15 | module Test.FitSpec.TestTypes (module Test.LeanCheck.Utils.Types) where 16 | 17 | import Test.FitSpec.Mutable 18 | import Test.FitSpec.ShowMutable 19 | import Test.LeanCheck.Utils.Types 20 | 21 | -- {- Standard implementation: 22 | instance Mutable Nat where mutiers = mutiersEq 23 | instance Mutable Int1 where mutiers = mutiersEq 24 | instance Mutable Int2 where mutiers = mutiersEq 25 | instance Mutable Int3 where mutiers = mutiersEq 26 | instance Mutable Int4 where mutiers = mutiersEq 27 | instance Mutable Word1 where mutiers = mutiersEq 28 | instance Mutable Word2 where mutiers = mutiersEq 29 | instance Mutable Word3 where mutiers = mutiersEq 30 | instance Mutable Word4 where mutiers = mutiersEq 31 | -- -} 32 | {- Alternative implementation: 33 | instance Mutable Nat where mutants = mutantsIntegral 34 | instance Mutable Int2 where mutants = mutantsIntegral 35 | instance Mutable Int3 where mutants = mutantsIntegral 36 | instance Mutable Int4 where mutants = mutantsIntegral 37 | instance Mutable Word2 where mutants = mutantsIntegral 38 | instance Mutable Word3 where mutants = mutantsIntegral 39 | instance Mutable Word4 where mutants = mutantsIntegral 40 | -- -} 41 | instance ShowMutable Nat where mutantS = mutantSEq 42 | instance ShowMutable Int1 where mutantS = mutantSEq 43 | instance ShowMutable Int2 where mutantS = mutantSEq 44 | instance ShowMutable Int3 where mutantS = mutantSEq 45 | instance ShowMutable Int4 where mutantS = mutantSEq 46 | instance ShowMutable Word1 where mutantS = mutantSEq 47 | instance ShowMutable Word2 where mutantS = mutantSEq 48 | instance ShowMutable Word3 where mutantS = mutantSEq 49 | instance ShowMutable Word4 where mutantS = mutantSEq 50 | -------------------------------------------------------------------------------- /src/Test/FitSpec/Utils.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Test.FitSpec.Utils 3 | -- Copyright : (c) 2015-2017 Rudy Matela 4 | -- License : 3-Clause BSD (see the file LICENSE) 5 | -- Maintainer : Rudy Matela 6 | -- 7 | -- General purpose utility functions for FitSpec 8 | {-# LANGUAGE CPP #-} 9 | module Test.FitSpec.Utils 10 | ( (...) 11 | , uncurry3 12 | , count 13 | , compositions 14 | , subsets 15 | , contained 16 | , contains 17 | , filterU 18 | , sortAndGroupOn 19 | , sortAndGroupFstBySnd 20 | , sortGroupAndCollapse 21 | , takeWhileIncreasing 22 | , takeWhileIncreasingOn 23 | , lastTimeout 24 | , sortOn 25 | , (***) 26 | ) 27 | where 28 | 29 | #if __GLASGOW_HASKELL__ <= 704 30 | import Prelude hiding (catch) 31 | #endif 32 | import System.IO.Unsafe (unsafePerformIO) 33 | import Control.Exception ( Exception 34 | , SomeException 35 | , ArithException 36 | , ArrayException 37 | , ErrorCall 38 | , PatternMatchFail 39 | , catch 40 | , catches 41 | , Handler (Handler) 42 | , evaluate 43 | ) 44 | import Data.Function (on) 45 | import Data.Ord (comparing) 46 | import Data.List (groupBy,sortBy) 47 | import Data.IORef (IORef, newIORef, readIORef, writeIORef) 48 | import Control.Concurrent (forkIO, threadDelay, killThread) 49 | import Control.Monad (liftM) 50 | 51 | -- | Compose composed with compose operator. 52 | -- 53 | -- > (f ... g) x y === f (g x y) 54 | (...) :: (c->d) -> (a->b->c) -> a -> b -> d 55 | (...) = (.) . (.) 56 | -- f ... g = \x y -> f (g x y) 57 | 58 | uncurry3 :: (a->b->c->d) -> (a,b,c) -> d 59 | uncurry3 f (x,y,z) = f x y z 60 | 61 | count :: (a -> Bool) -> [a] -> Int 62 | count p = length . filter p 63 | 64 | -- | 'compositions' @bs@ returns all compositions formed by taking values of @bs@ 65 | compositions :: [Bool] -> [Bool] 66 | compositions = map and . subsets 67 | 68 | -- | 'subsets' @xs@ returns the list of sublists formed by taking values of @xs@ 69 | subsets :: [a] -> [[a]] 70 | subsets [] = [[]] 71 | subsets (x:xs) = map (x:) (subsets xs) ++ subsets xs 72 | 73 | -- TODO: rename contained and contains to subset and superset? 74 | 75 | -- | Check if all elements of a list is contained in another list 76 | contained :: Eq a => [a] -> [a] -> Bool 77 | xs `contained` ys = all (`elem` ys) xs 78 | 79 | contains :: Eq a => [a] -> [a] -> Bool 80 | contains = flip contained 81 | 82 | -- | 'filterU' filter greater-later elements in a list according to a partial 83 | -- ordering relation. 84 | -- 85 | -- > filterU (notContained) [[1],[2],[1,2,3],[3,4,5]] == [[1],[2],[3,4,5]] 86 | filterU :: (a -> a -> Bool) -> [a] -> [a] 87 | filterU f [] = [] 88 | filterU f (x:xs) = x : filter (f x) (filterU f xs) 89 | 90 | sortOn :: Ord b => (a -> b) -> [a] -> [a] 91 | sortOn f = sortBy (compare `on` f) 92 | 93 | sortAndGroupOn :: Ord b => (a -> b) -> [a] -> [[a]] 94 | sortAndGroupOn f = groupBy ((==) `on` f) 95 | . sortOn f 96 | 97 | sortGroupAndCollapse :: Ord b 98 | => (a -> b) -> (a -> c) -> (b -> [c] -> d) 99 | -> [a] -> [d] 100 | sortGroupAndCollapse f g h = map collapse 101 | . sortAndGroupOn f 102 | where collapse (x:xs) = f x `h` map g (x:xs) 103 | 104 | sortAndGroupFstBySnd :: Ord b => [(a,b)] -> [([a],b)] 105 | sortAndGroupFstBySnd = sortGroupAndCollapse snd fst (flip (,)) 106 | 107 | -- | Takes values from a list while the values increase. If the original list 108 | -- is non-empty, the returning list will also be non-empty 109 | takeWhileIncreasing :: (a -> a -> Ordering) -> [a] -> [a] 110 | takeWhileIncreasing _ [] = [] 111 | takeWhileIncreasing _ [x] = [x] 112 | takeWhileIncreasing cmp (x:y:xs) = x : case x `cmp` y of 113 | LT -> takeWhileIncreasing cmp (y:xs) 114 | _ -> [] 115 | 116 | 117 | takeWhileIncreasingOn :: Ord b => (a -> b) -> [a] -> [a] 118 | takeWhileIncreasingOn f = takeWhileIncreasing (compare `on` f) 119 | 120 | readIORefUntil :: (a -> Bool) -> IORef a -> IO a 121 | readIORefUntil p r = do 122 | x <- readIORef r 123 | if p x 124 | then return x 125 | else threadDelay 100000 -- 100ms 126 | >> readIORefUntil p r 127 | 128 | -- | @lastTimeout s xs@ will take the last value of @xs@ it is able evaluate 129 | -- before @s@ seconds elapse. 130 | lastTimeout :: Int -> [a] -> IO a 131 | lastTimeout _ [] = error "lastTimeout: empty list" 132 | lastTimeout 0 (x:_) = return x -- no time to lose 133 | lastTimeout s xs = do 134 | r <- newIORef (undefined,False) 135 | tid <- forkIO $ keepImproving r xs 136 | threadDelay (s*1000000) -- TODO: change to waitForThread!!! 137 | (x,_) <- readIORefUntil snd r 138 | killThread tid 139 | return x 140 | where keepImproving _ [] = return () 141 | keepImproving r (x:xs) = do 142 | evaluate x 143 | writeIORef r (x,True) 144 | keepImproving r xs 145 | 146 | (***) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d) 147 | f *** g = \(x,y) -> (f x, g y) 148 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 # or ghc-9.4.8 2 | 3 | packages: 4 | - . 5 | 6 | extra-deps: 7 | - leancheck-1.0.2 8 | -------------------------------------------------------------------------------- /test/derive.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2015-2017 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | {-# LANGUAGE TemplateHaskell #-} 4 | import System.Exit (exitFailure) 5 | import Data.List (elemIndices,sort) 6 | 7 | import Test.FitSpec hiding (Set) 8 | 9 | data D0 = D0 deriving (Show,Eq,Ord) 10 | data D1 a = D1 a deriving (Show,Eq,Ord) 11 | data D2 a b = D2 a b deriving (Show,Eq,Ord) 12 | data D3 a b c = D3 a b c deriving (Show,Eq,Ord) 13 | data C1 a = C11 a | C10 deriving (Show,Eq,Ord) 14 | data C2 a b = C22 a b | C21 a | C20 deriving (Show,Eq,Ord) 15 | data I a b = a :+ b deriving (Show,Eq,Ord) 16 | deriveMutable ''D0 17 | deriveMutable ''D1 18 | deriveMutable ''D2 19 | deriveMutable ''D3 20 | deriveMutable ''C1 21 | deriveMutable ''C2 22 | deriveMutable ''I 23 | 24 | -- Those should have no effect (instance already exists): 25 | {- uncommenting those should generate warnings 26 | deriveMutable ''Bool 27 | deriveMutable ''Maybe 28 | deriveMutable ''Either 29 | -} 30 | 31 | data Set a = Set [a] deriving (Show,Eq,Ord) 32 | 33 | instance (Ord a, Listable a) => Listable (Set a) where 34 | tiers = setCons Set 35 | 36 | deriveMutableE [''Ord] ''Set 37 | 38 | main :: IO () 39 | main = 40 | case elemIndices False (tests 100) of 41 | [] -> putStrLn "Tests passed!" 42 | is -> do putStrLn ("Failed tests:" ++ show is) 43 | exitFailure 44 | 45 | type Id a = a -> a 46 | 47 | tests n = 48 | [ True 49 | , allUnique $ concat $ showNewMutants1 (id :: Id D0) 7 50 | , allUnique $ concat $ showNewMutants1 (id :: Id (D1 UInt2)) 7 51 | , allUnique $ concat $ showNewMutants1 (id :: Id (D2 UInt2 UInt2)) 7 52 | , allUnique $ concat $ showNewMutants1 (id :: Id (D3 UInt2 UInt2 UInt2)) 7 53 | , allUnique $ concat $ showNewMutants1 (id :: Id (C1 UInt2)) 7 54 | , allUnique $ concat $ showNewMutants1 (id :: Id (C2 UInt2 UInt2)) 7 55 | , allUnique $ concat $ showNewMutants1 (id :: Id (I UInt2 UInt2)) 7 56 | , allUnique $ concat $ showNewMutants1 (id :: Id (Set UInt2)) 7 57 | ] 58 | 59 | showNewMutants1 :: (ShowMutable a, Mutable a) 60 | => a -> Int -> [[String]] 61 | showNewMutants1 f n = mapT (showMutantAsTuple [] f) 62 | $ take n 63 | $ mutiers f 64 | 65 | allUnique :: Ord a => [a] -> Bool 66 | allUnique [] = True 67 | allUnique (x:xs) = x `notElem` xs 68 | && allUnique lesser 69 | && allUnique greater 70 | where lesser = filter (< x) xs 71 | greater = filter (> x) xs 72 | -------------------------------------------------------------------------------- /test/mutate.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2015-2017 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import System.Exit (exitFailure) 4 | import Data.List (elemIndices, sort) 5 | import Data.Tuple (swap) 6 | 7 | import Test.FitSpec 8 | import Test.FitSpec.Utils (contained) 9 | import Test.LeanCheck.Error (errorToNothing, errorToFalse) 10 | 11 | import Data.Monoid ((<>)) 12 | import Data.Word (Word) -- for GHC <= 7.10 13 | 14 | polyAppend :: [a] -> [b] -> [Either a b] 15 | polyAppend xs ys = map Left xs ++ map Right ys 16 | 17 | main :: IO () 18 | main = 19 | case elemIndices False tests of 20 | [] -> putStrLn "Tests passed!" 21 | is -> do putStrLn ("Failed tests:" ++ show is) 22 | exitFailure 23 | 24 | tests = map errorToFalse 25 | [ True 26 | 27 | , allUnique $ concat $ showNewMutants1 (sort :: [Int] -> [Int]) 7 28 | , allUnique $ concat $ showNewMutants2 ((++) :: [Int] -> [Int] -> [Int]) 7 29 | 30 | , allUnique $ concat $ showNewMutants1 (swap :: (Int,Int) -> (Int,Int)) 7 31 | , allUnique $ concat $ showNewMutants1 (swap :: (Bool,Bool) -> (Bool,Bool)) 7 32 | 33 | , allUnique $ concat $ showNewMutants2 ((,) :: Int -> Bool -> (Int,Bool)) 7 34 | , allUnique $ concat $ showNewMutants2 ((,) :: Bool -> Int -> (Bool,Int)) 7 35 | 36 | , allUnique $ concat $ showNewMutants2 (polyAppend :: [String] -> [Int] -> [Either String Int]) 7 37 | , allUnique $ concat $ showNewMutants2 ((+) :: Float -> Float -> Float) 7 38 | , allUnique $ concat $ showNewMutants2 ((+) :: Double -> Double -> Double) 7 39 | , allUnique $ concat $ showNewMutants2 ((<>) :: Ordering -> Ordering -> Ordering) 7 40 | , allUnique $ concat $ showNewMutants2 ((+) :: Word -> Word -> Word) 7 41 | 42 | {- 43 | , checkBindingsOfLength 7 2 ((,) :: Bool -> Bool -> (Bool,Bool)) 44 | , checkBindingsOfLength 7 2 ((,) :: Int -> Int -> (Int,Int)) 45 | , checkBindingsOfLength 7 1 (swap :: (Bool,Bool) -> (Bool,Bool)) 46 | , checkBindingsOfLength 4 1 (swap :: (Bool,Bool) -> (Bool,Bool),sort :: [Int] -> [Int]) 47 | -} 48 | 49 | , holds 25 (uniqueMutants 100 :: [Bool] -> Bool) 50 | , holds 25 (mutantsInListing 100 :: [Bool] -> Bool) 51 | , holds 25 (listingInMutants 100 :: [Bool] -> Bool) 52 | , holds 25 (uniqueMutants 100 :: [Int] -> Bool) 53 | , holds 25 (mutantsInListing 100 :: [Int] -> Bool) 54 | , holds 25 (listingInMutants 100 :: [Int] -> Bool) 55 | , holds 25 (uniqueMutants 100 :: [()] -> Bool) 56 | , holds 25 (mutantsInListing 100 :: [()] -> Bool) 57 | , holds 25 (listingInMutants 100 :: [()] -> Bool) 58 | , holds 25 (uniqueMutants 100 :: Bool -> Bool) 59 | , holds 25 (mutantsInListing 100 :: Bool -> Bool) 60 | , holds 25 (listingInMutants 100 :: Bool -> Bool) 61 | , holds 25 (uniqueMutants 100 :: Int -> Bool) 62 | , holds 25 (mutantsInListing 100 :: Int -> Bool) 63 | , holds 25 (listingInMutants 100 :: Int -> Bool) 64 | , holds 25 (uniqueMutants 100 :: () -> Bool) 65 | , holds 25 (mutantsInListing 100 :: () -> Bool) 66 | , holds 25 (listingInMutants 100 :: () -> Bool) 67 | ] 68 | 69 | 70 | uniqueMutants :: (Ord a, Listable a, Mutable a) => Int -> a -> Bool 71 | uniqueMutants n = allUnique . take n . mutants 72 | 73 | mutantsInListing :: (Eq a, Listable a, Mutable a) => Int -> a -> Bool 74 | mutantsInListing n x = take n (mutants x) `contained` list 75 | 76 | listingInMutants :: (Eq a, Listable a, Mutable a) => Int -> a -> Bool 77 | listingInMutants n x = take n list `contained` mutants x 78 | 79 | 80 | {- does not work as for the new interface for mutantS 81 | checkBindingsOfLength :: (Mutable a, ShowMutable a) 82 | => Int -> Int -> a -> Bool 83 | checkBindingsOfLength n len f = (all . all) (bindingsOfLength len) 84 | . concat 85 | . take n 86 | . mapT (mutantS f) 87 | $ mutiers f 88 | -} 89 | 90 | 91 | bindingsOfLength :: Int -> [([String],String)] -> Bool 92 | bindingsOfLength n = all ((== n) . length . fst) 93 | 94 | 95 | showNewMutants1 :: (ShowMutable a, Mutable a) 96 | => a -> Int -> [[String]] 97 | showNewMutants1 f n = mapT (showMutantAsTuple [] f) 98 | $ take n 99 | $ mutiers f 100 | 101 | showNewMutants2 :: ( Eq a, Eq b, Eq c 102 | , Show a, Show b, Show c 103 | , Listable a, Listable b, Mutable c 104 | , ShowMutable c ) 105 | => (a -> b -> c) -> Int -> [[String]] 106 | showNewMutants2 f n = mapT (showMutantAsTuple [] uf . uncurry) 107 | $ take n 108 | $ mutiers f 109 | where uf = uncurry f 110 | 111 | canonicalMutation :: Eq b => (a -> b) -> [(a, b)] -> Bool 112 | -- This simple version on the line below 113 | -- is one that does not deal with partially undefined functions. 114 | -- canonicalMutation f = all (\(a,r) -> f a /= r) 115 | canonicalMutation f = all different 116 | where 117 | -- the errorToNothing here deals partial functions (error/undefined) 118 | -- We define that mutating undefined values is noncanonical 119 | different (a,r) = case errorToNothing $ f a of 120 | Just r' -> r' /= r 121 | Nothing -> False -- for our purposes, 122 | -- undefined is equal to anything 123 | 124 | allUnique :: Ord a => [a] -> Bool 125 | allUnique [] = True 126 | allUnique (x:xs) = x `notElem` xs 127 | && allUnique lesser 128 | && allUnique greater 129 | where lesser = filter (< x) xs 130 | greater = filter (> x) xs 131 | -------------------------------------------------------------------------------- /test/sdist: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # test/sdist: tests the package generated by "cabal sdist". 4 | # 5 | # Copyright (c) 2015-2024 Rudy Matela. 6 | # Distributed under the 3-Clause BSD licence. 7 | 8 | set -xe 9 | 10 | export LC_ALL=C # consistent sort 11 | 12 | pkgver=` cat *.cabal | grep "^version:" | sed -e "s/version: *//"` 13 | pkgname=`cat *.cabal | grep "^name:" | sed -e "s/name: *//"` 14 | pkgbase=$pkgname-$pkgver 15 | 16 | cabal sdist 17 | 18 | # Try to find the package generated by cabal. 19 | pkg=`find dist* -name $pkgbase.tar.gz` 20 | [ -f "$pkg" ] 21 | # If the script fails here, either: 22 | # * no package was generated 23 | # * there are packages in both dist and dist-newstyle folders. 24 | 25 | tmp=`mktemp -d /tmp/test-sdist-XXXXXXXXXX` 26 | 27 | # Test if our file is compatible with case-insensitive filesystems. 28 | tar -tf $pkg | sort --ignore-case > $tmp/ls-cabal-i 29 | tar -tf $pkg | sort --ignore-case --unique > $tmp/ls-cabal-iu 30 | diff -rud $tmp/ls-cabal-i $tmp/ls-cabal-iu 31 | 32 | # Check if we have a clone of the repo and git is available 33 | # The check that we can run git ls-files is needed to avoid: 34 | # fatal: detected dubious ownership in repository at '/__w/.../hello-haskell' 35 | # on CI. 36 | if [ -d .git ] && git --version && git ls-files >/dev/null 37 | then 38 | # Test if files included by cabal are the same as files tracked in git. 39 | git ls-files | sort > $tmp/ls-git 40 | tar -tf $pkg | grep -v "/$" | sed -e "s,$pkgbase/,," | sort > $tmp/ls-cabal 41 | diff -rud $tmp/ls-git $tmp/ls-cabal 42 | fi 43 | 44 | rm -r $tmp 45 | -------------------------------------------------------------------------------- /test/showmutable.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2015-2017 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | {-# LANGUAGE NoMonomorphismRestriction #-} 4 | import System.Exit (exitFailure) 5 | import System.Environment (getArgs) 6 | import Data.List (elemIndices, sort) 7 | import Data.Tuple (swap) 8 | 9 | import Test.FitSpec 10 | import Test.FitSpec.ShowMutable 11 | import Test.FitSpec.PrettyPrint 12 | import Test.LeanCheck.Error (errorToNothing) 13 | import Test.LeanCheck.Utils.TypeBinding 14 | 15 | main :: IO () 16 | main = do 17 | as <- System.Environment.getArgs 18 | let n = case as of [] -> 10 19 | (s:_) -> read s 20 | -- n == 10 -- 1s on zero 21 | -- n == 32 -- 4s on zero 22 | -- n == 100 -- 15s on zero 23 | -- n == 200 -- 30s on zero 24 | case elemIndices False (tests n) of 25 | [] -> putStrLn "Tests passed!" 26 | is -> do putStrLn ("Failed tests:" ++ show is) 27 | exitFailure 28 | 29 | -- Below, some of the tests are marked as failing: 30 | -- They simply fail because there are too many values 31 | -- being tested (the showMutant function only approximates 32 | -- the printing of a mutant) 33 | -- There is a TODO in the other file related to this 34 | -- to allow configuration of how many values should be 35 | -- tried when enumerating the mutants. 36 | tests n = 37 | [ True 38 | 39 | , holds n $ prop_0 -:> int 40 | , holds n $ prop_0 -:> bool 41 | , holds n $ prop_0 -:> char 42 | , holds n $ prop_0 -:> string 43 | , fails n $ prop_0 -:> (int,int) 44 | 45 | , holds n $ prop_00 -:> (int,int) 46 | , holds n $ prop_00 -:> (bool,int) 47 | , holds n $ prop_00 -:> (int,bool) 48 | , holds n $ prop_00 -:> (string,char) 49 | , holds n $ prop_00 -:> (char,string) 50 | 51 | , h1 $ id -:> int 52 | , h1 $ id -:> bool 53 | , h1 $ id -:> (int,int) 54 | , h1 $ id -:> (bool,int) 55 | , h1 $ id -:> (int,bool) 56 | , h1 $ id -:> (bool,bool) 57 | , h1 $ id -:> (int,int,int) 58 | , h1 $ id -:> (int,(int,int)) 59 | , h1 $ id -:> ((int,int),int) 60 | , h1 $ const True -:> int -- fails (500 tests)! 61 | , h1 $ const (0::Int) -:> bool 62 | , h1 $ swap -:> (int,bool) 63 | , h1 $ swap -:> (bool,int) 64 | , h1 $ swap -:> (int,(int,int)) 65 | , h1 $ swap -:> ((int,int),int) 66 | 67 | , h2 $ const -: int >- int >- und 68 | , h2 $ const -: int >- bool >- und 69 | , h2 $ const -: bool >- int >- und -- fails (1000 tests)! 70 | , h2 $ (+) -:> int 71 | , hI $ (+) -:> int 72 | , h2 $ (*) -:> int 73 | , h2 $ (&&) 74 | , h2 $ (||) 75 | , h2 $ (:) -:> int -- fails (2000 tests)! 76 | , h2 $ (++) -:> [int] -- fails (3000 tests)! 77 | 78 | , h11 (id -:> int) (id ->: bool) 79 | , h11 (id -:> bool) (id ->: int) 80 | , h11 (swap -:> ((int,int),int)) (swap ->: (int,(int,int))) 81 | 82 | , h111 (id -:> int) (id ->: bool) (id ->: char) 83 | , h111 (id -:> bool) (id ->: char) (id ->: int) 84 | , h111 (swap -:> ((int,int),(int,int))) 85 | (swap -:> ((int,int),int)) 86 | (swap -:> (int,(int,int))) 87 | 88 | , h11' (id -:> int) (id ->: bool) (id ->: char) 89 | , h11' (id -:> bool) (id ->: char) (id ->: int) 90 | , h11' (swap -:> ((int,int),(int,int))) 91 | (swap -:> ((int,int),int)) 92 | (swap -:> (int,(int,int))) 93 | ] 94 | where h1 = holds n . prop_1 95 | h2 = holds n . prop_2 96 | hI = holds n . prop_I 97 | h11 f = holds n . prop_11 f 98 | h111 f g = holds n . prop_111 f g 99 | h11' f g = holds n . prop_11' f g 100 | 101 | -- prop_N, asserts the format of a mutation of a value of N arguments 102 | -- prop_MN, asserts the format of a pair of values of M and N arguments 103 | -- prop_MNO, asserts the format of a triple of values 104 | 105 | prop_0 :: (Eq a, Show a, Listable a, ShowMutable a) 106 | => a -> a -> Bool 107 | prop_0 x x' | x == x' = s == "x" 108 | | otherwise = s == show x' 109 | where s = showMutantAsTuple ["x"] x x' 110 | 111 | prop_00 :: ( Eq a, Show a, Listable a, ShowMutable a 112 | , Eq b, Show b, Listable b, ShowMutable b ) 113 | => (a,b) -> (a,b) -> Bool 114 | prop_00 (x,y) (x',y') | x == x' && y == y' = s == "(x,y)" 115 | | x == x' = s == "(x," ++ show y' ++ ")" 116 | | y == y' = s == "(" ++ show x' ++ ",y)" 117 | | otherwise = s == "(" ++ show x' 118 | ++ "," ++ show y' ++ ")" 119 | where s = showMutantAsTuple ["x","y"] (x,y) (x',y') 120 | 121 | prop_1 :: ( Eq a, Show a, Listable a, ShowMutable a 122 | , Eq b, Show b, Listable b, ShowMutable b ) 123 | => (a->b) -> a -> b -> Bool 124 | prop_1 f x fx = fx /= f x 125 | ==> showMutantAsTuple ["f x"] f (mutate f x fx) == showMutantF "f" x fx 126 | && showMutantDefinition ["f x"] f (mutate f x fx) == showMutantB "f" x fx 127 | 128 | prop_11 :: ( Eq a, Show a, Listable a, ShowMutable a 129 | , Eq b, Show b, Listable b, ShowMutable b 130 | , Eq c, Show c, Listable c, ShowMutable c 131 | , Eq d, Show d, Listable d, ShowMutable d ) 132 | => (a->b) -> (c->d) -> a -> b -> c -> d -> Bool 133 | prop_11 f g x fx y gy = fx /= f x && gy /= g y 134 | ==> showMutantAsTuple ["f x","g x"] (f,g) (mutate f x fx, mutate g y gy) 135 | == showTuple [showMutantF "f" x fx, showMutantF "g" y gy] 136 | && showMutantDefinition ["f x","g x"] (f,g) (mutate f x fx, mutate g y gy) 137 | == concat [showMutantB "f" x fx, showMutantB "g" y gy] 138 | 139 | prop_111 :: ( Eq a, Show a, Listable a, ShowMutable a 140 | , Eq b, Show b, Listable b, ShowMutable b 141 | , Eq c, Show c, Listable c, ShowMutable c 142 | , Eq d, Show d, Listable d, ShowMutable d 143 | , Eq e, Show e, Listable e, ShowMutable e 144 | , Eq f, Show f, Listable f, ShowMutable f ) 145 | => (a->b) -> (c->d) -> (e->f) -> a -> b -> c -> d -> e -> f -> Bool 146 | prop_111 f g h x fx y gy z hz = fx /= f x 147 | && gy /= g y 148 | && hz /= h z 149 | ==> showMutantAsTuple ["f x","g x","h x"] (f,g,h) 150 | ( mutate f x fx 151 | , mutate g y gy 152 | , mutate h z hz ) 153 | == showTuple [ showMutantF "f" x fx 154 | , showMutantF "g" y gy 155 | , showMutantF "h" z hz ] 156 | && showMutantDefinition ["f x","g x","h x"] (f,g,h) 157 | ( mutate f x fx 158 | , mutate g y gy 159 | , mutate h z hz ) 160 | == concat [ showMutantB "f" x fx 161 | , showMutantB "g" y gy 162 | , showMutantB "h" z hz ] 163 | 164 | prop_11' :: ( Eq a, Show a, Listable a, ShowMutable a 165 | , Eq b, Show b, Listable b, ShowMutable b 166 | , Eq c, Show c, Listable c, ShowMutable c 167 | , Eq d, Show d, Listable d, ShowMutable d 168 | , Eq e, Show e, Listable e, ShowMutable e 169 | , Eq f, Show f, Listable f, ShowMutable f ) 170 | => (a->b) -> (c->d) -> (e->f) -> a -> b -> c -> d -> e -> f -> Bool 171 | prop_11' f g h x fx y gy z hz = fx /= f x 172 | && gy /= g y 173 | && hz /= h z 174 | ==> showMutantAsTuple ["f x","g x","h x"] (f,(g,h)) 175 | ( mutate f x fx 176 | , ( mutate g y gy 177 | , mutate h z hz ) ) 178 | == showTuple [ showMutantF "f" x fx 179 | , showTuple [ showMutantF "(??)" y gy 180 | , showMutantF "(??)" z hz ] ] 181 | && showMutantDefinition ["f x","g x","h x"] (f,(g,h)) 182 | ( mutate f x fx 183 | , ( mutate g y gy 184 | , mutate h z hz ) ) 185 | == concat [ showMutantB "f" x fx 186 | , "g' = " 187 | `beside` showTuple [ showMutantF "(??)" y gy 188 | , showMutantF "(??)" z hz ] ] 189 | 190 | prop_2 :: ( Eq a, Show a, Listable a, ShowMutable a 191 | , Eq b, Show b, Listable b, ShowMutable b 192 | , Eq c, Show c, Listable c, ShowMutable c ) 193 | => (a->b->c) -> a -> b -> c -> Bool 194 | prop_2 f x y fxy = fxy /= f x y ==> 195 | showMutantAsTuple ["f x y"] f (mutate2 f x y fxy) == showMutantF2 "f" x y fxy && 196 | showMutantDefinition ["f x y"] f (mutate2 f x y fxy) == showMutantB2 "f" x y fxy 197 | 198 | 199 | prop_I :: ( Eq a, Show a, Listable a, ShowMutable a 200 | , Eq b, Show b, Listable b, ShowMutable b 201 | , Eq c, Show c, Listable c, ShowMutable c ) 202 | => (a->b->c) -> a -> b -> c -> Bool 203 | prop_I f x y fxy = fxy /= f x y ==> 204 | showMutantAsTuple ["x + y"] f (mutate2 f x y fxy) == showMutantI "+" x y fxy && 205 | showMutantDefinition ["x + y"] f (mutate2 f x y fxy) == showMutantBI "+" x y fxy 206 | 207 | mutate :: Eq a => (a -> b) -> a -> b -> (a -> b) 208 | mutate f x y x' | x' == x = y 209 | | otherwise = f x' 210 | 211 | mutate2 :: (Eq a, Eq b) => (a -> b -> c) -> a -> b -> c -> (a -> b -> c) 212 | mutate2 f x y z = curry (mutate (uncurry f) (x,y) z) 213 | 214 | -- | Show a mutant of a function of one argument 215 | showMutantF :: (Show a, Show b) 216 | => String -> a -> b -> String 217 | showMutantF f x y = "\\x -> case x of\n" 218 | ++ " " ++ show x ++ " -> " ++ show y ++ "\n" 219 | ++ " _ -> " ++ f ++ " x\n" 220 | 221 | -- | Show a mutant of a function of two arguments 222 | showMutantF2 :: (Show a, Show b, Show c) 223 | => String -> a -> b -> c -> String 224 | showMutantF2 f x y z = "\\x y -> case (x,y) of\n" 225 | ++ " (" ++ show x ++ "," ++ show y ++ ") -> " 226 | ++ show z ++ "\n" 227 | ++ " _ -> " ++ f ++ " x y\n" 228 | 229 | showMutantB :: (Show a, Show b) 230 | => String -> a -> b -> String 231 | showMutantB f x fx = table " " 232 | [ [f ++ "'", show x, "=", show fx] 233 | , [f ++ "'", "x", "=", f ++ " x"] ] 234 | 235 | showMutantB2 :: (Show a, Show b, Show c) 236 | => String -> a -> b -> c -> String 237 | showMutantB2 f x y fxy = table " " 238 | [ [f ++ "'", show x, show y, "=", show fxy] 239 | , [f ++ "'", "x", "y", "=", f ++ " x y"] ] 240 | 241 | -- | Show a mutant of an infix 242 | showMutantI :: (Show a, Show b, Show c) 243 | => String -> a -> b -> c -> String 244 | showMutantI o x y z = "\\x y -> case (x,y) of\n" 245 | ++ " (" ++ show x ++ "," ++ show y ++ ") -> " 246 | ++ show z ++ "\n" 247 | ++ " _ -> x " ++ o ++ " y\n" 248 | 249 | showMutantBI :: (Show a, Show b, Show c) 250 | => String -> a -> b -> c -> String 251 | showMutantBI o x y fxy = table " " 252 | [ [show x, o ++ "-", show y, "=", show fxy] 253 | , ["x", o ++ "-", "y", "=", "x " ++ o ++ " y"] ] 254 | -------------------------------------------------------------------------------- /test/utils.hs: -------------------------------------------------------------------------------- 1 | -- Copyright (c) 2015-2017 Rudy Matela. 2 | -- Distributed under the 3-Clause BSD licence (see the file LICENSE). 3 | import System.Exit (exitFailure) 4 | import Data.List (elemIndices,sortBy) 5 | 6 | import Data.Function 7 | 8 | import Test.LeanCheck 9 | import Test.FitSpec.Utils 10 | 11 | main :: IO () 12 | main = 13 | case elemIndices False (tests 500) of 14 | [] -> putStrLn "Tests passed!" 15 | is -> do putStrLn ("Failed tests:" ++ show is) 16 | exitFailure 17 | 18 | tests :: Int -> [Bool] 19 | tests n = 20 | [ True 21 | 22 | , sortOn snd [(1,3),(2,2),(3,1)] == [(3,1),(2,2),(1,3)] 23 | , holds n $ (propSortOn fst :: [(Int,Int)] -> Bool) 24 | , holds n $ (propSortOn snd :: [(Int,Int)] -> Bool) 25 | , holds n $ (propSortOn abs :: [Int] -> Bool) 26 | ] 27 | 28 | propSortOn :: (Eq a, Ord b) => (a -> b) -> [a] -> Bool 29 | propSortOn f xs = sortOn f xs == sortBy (compare `on` f) xs 30 | --------------------------------------------------------------------------------