├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── cabal.haskell-ci ├── hedgehog-classes.cabal ├── imgs ├── badlist.png └── badsemigroup.png ├── src └── Hedgehog │ ├── Classes.hs │ └── Classes │ ├── Alternative.hs │ ├── Applicative.hs │ ├── Arrow.hs │ ├── Bifoldable.hs │ ├── Bifunctor.hs │ ├── Binary.hs │ ├── Bitraversable.hs │ ├── Bits.hs │ ├── Category.hs │ ├── Common.hs │ ├── Common │ ├── ApTrans.hs │ ├── Bottom.hs │ ├── Compat.hs │ ├── Equation.hs │ ├── Func.hs │ ├── Gen.hs │ ├── IO.hs │ ├── Laws.hs │ ├── PP.hs │ ├── Property.hs │ └── Types.hs │ ├── Comonad.hs │ ├── Contravariant.hs │ ├── Enum.hs │ ├── Eq.hs │ ├── Foldable.hs │ ├── Functor.hs │ ├── Generic.hs │ ├── Integral.hs │ ├── Ix.hs │ ├── Json.hs │ ├── MVector.hs │ ├── Monad.hs │ ├── MonadFix.hs │ ├── MonadIO.hs │ ├── MonadPlus.hs │ ├── MonadZip.hs │ ├── Monoid.hs │ ├── Ord.hs │ ├── Prim.hs │ ├── Semigroup.hs │ ├── Semiring.hs │ ├── Show.hs │ ├── ShowRead.hs │ ├── Storable.hs │ └── Traversable.hs └── test ├── Spec.hs └── Spec ├── Alternative.hs ├── Applicative.hs ├── Arrow.hs ├── Bifoldable.hs ├── Bifunctor.hs ├── Binary.hs ├── Bitraversable.hs ├── Bits.hs ├── Category.hs ├── Comonad.hs ├── Contravariant.hs ├── Enum.hs ├── Eq.hs ├── Foldable.hs ├── Functor.hs ├── Generic.hs ├── Integral.hs ├── Ix.hs ├── Json.hs ├── MVector.hs ├── Monad.hs ├── Monoid.hs ├── Ord.hs ├── Prim.hs ├── Semigroup.hs ├── Semiring.hs ├── Show.hs ├── Storable.hs └── Traversable.hs /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | *.prof 12 | *.aux 13 | *.hp 14 | *.eventlog 15 | .virtualenv 16 | .hsenv 17 | .hpc 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | cabal.config 21 | cabal.project.local 22 | .ghc.environment.* 23 | .HTF/ 24 | # Stack 25 | .stack-work/ 26 | 27 | ### IDE/support 28 | # Vim 29 | [._]*.s[a-v][a-z] 30 | [._]*.sw[a-p] 31 | [._]s[a-v][a-z] 32 | [._]sw[a-p] 33 | *~ 34 | tags 35 | 36 | # IntellijIDEA 37 | .idea/ 38 | .ideaHaskellLib/ 39 | *.iml 40 | 41 | # Atom 42 | .haskell-ghc-mod.json 43 | 44 | # VS 45 | .vscode/ 46 | 47 | # Emacs 48 | *# 49 | .dir-locals.el 50 | TAGS 51 | 52 | # other 53 | .DS_Store 54 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'hedgehog-classes.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.10.1 12 | # 13 | version: ~> 1.0 14 | language: c 15 | os: linux 16 | dist: xenial 17 | git: 18 | # whether to recursively clone submodules 19 | submodules: false 20 | cache: 21 | directories: 22 | - $HOME/.cabal/packages 23 | - $HOME/.cabal/store 24 | - $HOME/.hlint 25 | before_cache: 26 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 27 | # remove files that are regenerated by 'cabal update' 28 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 29 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 30 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 31 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 32 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 33 | - rm -rfv $CABALHOME/packages/head.hackage 34 | jobs: 35 | include: 36 | - compiler: ghc-8.10.1 37 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}} 38 | os: linux 39 | - compiler: ghc-8.8.3 40 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}} 41 | os: linux 42 | - compiler: ghc-8.6.5 43 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}} 44 | os: linux 45 | before_install: 46 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 47 | - WITHCOMPILER="-w $HC" 48 | - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') 49 | - HCPKG="$HC-pkg" 50 | - unset CC 51 | - CABAL=/opt/ghc/bin/cabal 52 | - CABALHOME=$HOME/.cabal 53 | - export PATH="$CABALHOME/bin:$PATH" 54 | - TOP=$(pwd) 55 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 56 | - echo $HCNUMVER 57 | - CABAL="$CABAL -vnormal+nowrap" 58 | - set -o pipefail 59 | - TEST=--enable-tests 60 | - BENCH=--enable-benchmarks 61 | - HEADHACKAGE=false 62 | - rm -f $CABALHOME/config 63 | - | 64 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 65 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 66 | echo "write-ghc-environment-files: always" >> $CABALHOME/config 67 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 68 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 69 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 70 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 71 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 72 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 73 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 74 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 75 | echo "install-dirs user" >> $CABALHOME/config 76 | echo " prefix: $CABALHOME" >> $CABALHOME/config 77 | echo "repository hackage.haskell.org" >> $CABALHOME/config 78 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 79 | install: 80 | - ${CABAL} --version 81 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 82 | - | 83 | echo "program-default-options" >> $CABALHOME/config 84 | echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config 85 | - cat $CABALHOME/config 86 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 87 | - travis_retry ${CABAL} v2-update -v 88 | # Generate cabal.project 89 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 90 | - touch cabal.project 91 | - | 92 | echo "packages: ." >> cabal.project 93 | - echo 'package hedgehog-classes' >> cabal.project 94 | - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" 95 | - | 96 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(hedgehog-classes)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 97 | - cat cabal.project || true 98 | - cat cabal.project.local || true 99 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 100 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} 101 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 102 | - rm cabal.project.freeze 103 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all 104 | - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all 105 | script: 106 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 107 | # Packaging... 108 | - ${CABAL} v2-sdist all 109 | # Unpacking... 110 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 111 | - cd ${DISTDIR} || false 112 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 113 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 114 | - PKGDIR_hedgehog_classes="$(find . -maxdepth 1 -type d -regex '.*/hedgehog-classes-[0-9.]*')" 115 | # Generate cabal.project 116 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 117 | - touch cabal.project 118 | - | 119 | echo "packages: ${PKGDIR_hedgehog_classes}" >> cabal.project 120 | - echo 'package hedgehog-classes' >> cabal.project 121 | - "echo ' ghc-options: -Werror=missing-methods' >> cabal.project" 122 | - | 123 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(hedgehog-classes)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 124 | - cat cabal.project || true 125 | - cat cabal.project.local || true 126 | # Building... 127 | # this builds all libraries and executables (without tests/benchmarks) 128 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 129 | # Building with tests and benchmarks... 130 | # build & run tests, build benchmarks 131 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all 132 | # Testing... 133 | - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all 134 | # cabal check... 135 | - (cd ${PKGDIR_hedgehog_classes} && ${CABAL} -vnormal check) 136 | # haddock... 137 | - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all 138 | # Building without installed constraints for packages in global-db... 139 | - rm -f cabal.project.local 140 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 141 | 142 | # REGENDATA ("0.10.1",["hedgehog-classes.cabal"]) 143 | # EOF 144 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | `hedgehog-classes` uses [PVP Versioning][1]. 4 | The changelog is available [on GitHub][2]. 5 | 6 | Unreleased 7 | ======= 8 | * Make `Hedgehog.Classes.Aeson` module empty when the `aeson` flag is disabled. 9 | * Make `Hedgehog.Classes.Prim` module empty when the `primitive` flag is disabled. 10 | 11 | 0.2.5.3 12 | ======= 13 | * Correct bug in which `storablePeekByte` uses the wrong offset values 14 | * Update base upper bound. [4.12, 4.15) -> [4.12, 4.17) 15 | * Update semirings upper bound. [0.2, 0.7) -> [0.2, 0.8) 16 | * Update aeson upper bound. [0.9, 1.6) -> [0.9, 2.1) 17 | 18 | 0.2.5.2 19 | ======= 20 | * Update semirings upper bound. [0.2, 0.6) -> [0.2, 0.7) 21 | 22 | 0.2.5.1 23 | ======= 24 | * Bump upper bound on pretty-show from <1.10 to <1.11 25 | 26 | 0.2.5 27 | ===== 28 | * Add MUVector laws 29 | * Update upper bounds on dependencies 30 | 31 | 0.2.4.1 32 | ======= 33 | * Fix error introduced by change of hedgehog's 34 | internal API between hedgehog-1.0.1 and 35 | hedgehog-1.0.2. 36 | * Re-add GHC 8.8.1 to cabal's tested-with field. 37 | 38 | 0.2.4 39 | ===== 40 | * Semirings upper bound increased to 0.6. [0.2, 0.5) -> [0.2, 0.6) 41 | * Add `primLaws`. 42 | * Remove GHC 8.8.1 from cabal's tested-with field. 43 | * Add documentation to `comonadLaws`. 44 | 45 | 0.2.3 46 | ===== 47 | * Semirings upper bound increased to 0.5. Lower bound not touched. 48 | [0.2, 0.4) -> [0.2, 0.5) 49 | * Add `comonadLaws`. 50 | 51 | 0.2.2 52 | ===== 53 | * fix problem in storable set-get that caused attempt to index into 54 | 0-element malloc'd array 55 | * Test suite now tests almost all laws sans arrow/category (thanks @ag-eitilt!) 56 | * Correct tcName of `MonadPlus`. Was `Monad`, now it's `MonadPlus`. 57 | 58 | 0.2.1 59 | ===== 60 | * fix problem where ordLaws failed for everything. there was 61 | some messed up logic used to check that transitivity held. 62 | Thanks very much to @ocharles for reporting this. 63 | 64 | 0.2.0.1 65 | ======= 66 | * improve reliability of hedgehog output filtering. 67 | 68 | 0.2 69 | === 70 | * switch to hedgehog-1.0 71 | * add `binaryLaws` 72 | * relax cabal-version to 2.2 73 | * use randomly generated, not hard-coded functions, in bifoldable tests 74 | * significantly simplify pretty printing using `silently` package, and 75 | bad hack. 76 | * make several haddock improvements. 77 | 78 | 0.1.2 79 | ===== 80 | 81 | * add `semiringLaws`, `ringLaws`, `starLaws` 82 | * fix bug in `foldableLaws` that could cause implementations of 83 | `foldMap` and `fold` that evaluate in weird orders to pass (rather than fail). 84 | 85 | 0.1.1 86 | ===== 87 | 88 | * Initial (stable) hackage release. 89 | 90 | 0.0.0 91 | ===== 92 | 93 | * Initially created. 94 | 95 | [1]: https://pvp.haskell.org 96 | [2]: https://github.com/chessai/hedgehog-classes/releases 97 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2020, chessai 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | hedgehog-classes [![Hackage][hackage-shield]][hackage] 2 | ================ 3 | 4 | > Hedgehog will eat your typeclass bugs. 5 | 6 | 7 | 8 | ## Motivation 9 | 10 | `hedgehog-classes` is a wrapper around [Hedgehog](http://hedgehog.qa/) that aims to provide a simple, straightforward API for testing common typeclass laws quickly, while providing good error messages to help debug any failing tests. It is inspired by the [quickcheck-classes](http://hackage.haskell.org/package/quickcheck-classes) library. 11 | 12 | ## API Overview 13 | 14 | The API of `hedgehog-classes` is dead simple. There are three parts. 15 | 16 | The first part is a datatype, called 'Laws', which looks like this: 17 | 18 | ```haskell 19 | data Laws = Laws 20 | { lawsTypeclass :: String 21 | , lawsProperties :: [(String,Property)] 22 | } 23 | ``` 24 | 25 | It is a typeclass name along with a list of named property tests. 26 | 27 | The second part of `hedgehog-classes` are the functions, which follow a simple structure. All functions in `hedgehog-classes` have one of the following three type signatures, based on the kind of the type which the corresponding typeclass parameterises (Nullary, Unary, or Binary). Note that they all return a 'Laws', only the inputs are different. Below, 'Ctx' refers to the typeclass in question: 28 | 29 | ```haskell 30 | -- Typeclasses that have kind 'Type -> Constraint', e.g. 'Eq' 31 | tcLaw :: (Ctx a, Eq a, Show a) => Gen a -> Laws 32 | 33 | -- Typeclasses that have kind '(Type -> Type) -> Constraint', e.g. 'Functor' 34 | tcLaw1 :: 35 | ( Ctx f 36 | , forall x. Eq x => Eq (f x) 37 | , forall x. Show x => Show (f x) 38 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 39 | 40 | -- Typeclasses that have kind '(Type -> Type -> Type) -> Constraint', e.g. 'Bifunctor' 41 | tcLaw2 :: 42 | ( Ctx f 43 | , forall x y. (Eq x, Eq y) => Eq (f x y) 44 | , forall x y. (Show x, Show y) => Show (f x y) 45 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws 46 | ``` 47 | 48 | The third and last part of `hedgehog-classes` are the three convenience functions used to run your tests. They all return an `IO Bool`, where `True` is returned if all the tests pass, and `False` otherwise. They are as following: 49 | 50 | ```haskell 51 | -- Test a single typeclasses' laws. 52 | lawsCheck :: Laws -> IO Bool 53 | 54 | -- Test multiple typeclass laws for a single type. 55 | lawsCheckOne :: Gen a -> [Gen a -> Laws] -> IO Bool 56 | 57 | -- Test mutliple typeclass laws for multiple types. 58 | -- The argument is pairs of type names and their associated laws to test. 59 | lawsCheckMany :: [(String, [Laws])] -> IO Bool 60 | ``` 61 | 62 | That is all there is to using `hedgehog-classes` in your test suite. For usage examples, see the [haddocks](http://hackage.haskell.org/package/hedgehog-classes). 63 | 64 | ## Distributing your own `Laws` 65 | 66 | `hedgehog-classes` also exports some functions which you may find useful for writing functions that allow users to test the laws of typeclasses you define in your own libraries, along with utilities for providing custom error messages. They can be found [here](http://hackage.haskell.org/package/hedgehog-classes-0.1.0.0/docs/Hedgehog.-Classes.html#g:6). 67 | 68 | ## Example error messages 69 | Below is an example of an error message one might get from a failed test from `hedgehog-classes`: 70 | 71 | ![alt text](imgs/badlist.png "Here we can see a definition of foldl' that does not accumulate strictly") 72 | 73 | ![alt text](imgs/badsemigroup.png "Here we can see a semigroup instance which is not associative") 74 | 75 | ## Similar libraries 76 | There are a number of libraries that have similar goals to `hedgehog-classes`: 77 | 78 | - [hedgehog-checkers](https://github.com/bitemyapp/hedgehog-checkers): 79 | - [hedgehog-laws](https://github.com/qfpl/hedgehog-laws): 80 | 81 | ## Supported Typeclasses 82 | 83 | - `base` 84 | - Alternative 85 | - Applicative 86 | - Arrow 87 | - Bifoldable 88 | - Bifunctor 89 | - Bitraversable 90 | - Bits/FiniteBits 91 | - Category 92 | - Contravariant 93 | - Enum 94 | - Eq 95 | - Foldable 96 | - Functor 97 | - Generic 98 | - Integral 99 | - Monad 100 | - MonadIO 101 | - MonadPlus 102 | - MonadZip 103 | - Ord 104 | - Semigroup 105 | - Show 106 | - ShowRead 107 | - Storable 108 | - Traversable 109 | - `aeson` 110 | - ToJSON 111 | - ToJSON/FromJSON 112 | - `comonad` 113 | - Comonad 114 | - `semirings` 115 | - Semiring 116 | - Ring 117 | - `primitive` 118 | - Prim 119 | 120 | Some typeclasses can have additional laws, which are not part of their sufficient definition. A common example is commutativity of a monoid. In such cases where this is sensible, `hedgehog-classes` provides functions such `commutativeMonoidLaws`, `commutativeSemigroupLaws`, etc. `hedgehog-classes` also tests that `foldl'`/`foldr'` actually accumulate strictly. There are other such cases that are documented on Hackage. 121 | 122 | Support will be added for the typeclasses from [semigroupoids](http://hackage.haskell.org/package/semigroupoids). 123 | 124 | Support will be added for the `Semiring`/`Ring` typeclasses from [semirings](http://hackage.haskell.org/package/semirings). 125 | 126 | ## Building 127 | 128 | Currently, you need GHC >= 8.5 to build this (because of `-XQuantifiedConstraints`). Some CPP can be used to make this buildable with older GHCs, I just have not done so yet. I would gladly take a PR that does so, but only for GHC 8.2.2 and newer. 129 | 130 | To use this library for testing, just add it to a test stanza of your cabal file. 131 | 132 | To use this library to export your own `Laws` functions which you wish to distribute, add it to the library stanza of your cabal file. 133 | 134 | [hackage]: http://hackage.haskell.org/package/hedgehog-classes 135 | [hackage-shield]: https://img.shields.io/badge/hackage-v0.2.4.1-blue.svg 136 | 137 | ## Improvements 138 | 139 | There are a number of improvements that can be made to the API of `hedgehog-classes`: 140 | 141 | - Traversable needs better error messages, without exposing library internals. 142 | - Arrow Laws 5/6/7 need names. 143 | - Some laws could use better names, as some of them I had to make up. 144 | - ixLaws can accidentally be extremely inefficient and I'm not sure how to fix that. 145 | - The test suite is incomplete. 146 | - There is no 'bad' test suite, for testing error messages. 147 | - There could be spelling mistakes/grammatical errors/inconsistencies in the custom error messages. 148 | 149 | You can help fix any of the above by opening an issue/PR! Thanks. 150 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | ghc-head: False 2 | jobs: 2 3 | no-tests-no-benchmarks: False 4 | unconstrained: False 5 | install-dependencies: False 6 | copy-fields: all 7 | installed: +all -transformers 8 | -------------------------------------------------------------------------------- /hedgehog-classes.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: 3 | hedgehog-classes 4 | version: 5 | 0.2.5.4 6 | synopsis: 7 | Hedgehog will eat your typeclass bugs 8 | description: 9 | This library provides Hedgehog properties to ensure 10 | that typeclass instances adhere to the set of laws 11 | that they are supposed to. There are other libraries 12 | that do similar things, such as `genvalidity-hspec` and `checkers`. 13 | This library differs from other solutions by not introducing any 14 | new typeclasses that the user needs to learn, and otherwise minimal 15 | API overhead. 16 | . 17 | This library is directly inspired by `quickcheck-classes`. 18 | homepage: 19 | https://github.com/hedgehogqa/haskell-hedgehog-classes 20 | bug-reports: 21 | https://github.com/hedgehogqa/haskell-hedgehog-classes/issues 22 | license: 23 | BSD-3-Clause 24 | license-file: 25 | LICENSE 26 | author: 27 | chessai 28 | maintainer: 29 | chessai1996@gmail.com 30 | copyright: 31 | 2020 chessai 32 | category: 33 | Testing 34 | build-type: 35 | Simple 36 | extra-doc-files: 37 | README.md 38 | , CHANGELOG.md 39 | tested-with: 40 | GHC == 8.6.5 41 | , GHC == 8.8.3 42 | , GHC == 8.10.1 43 | , GHC == 9.0.1 44 | , GHC == 9.2.4 45 | , GHC == 9.4.2 46 | 47 | source-repository head 48 | type: 49 | git 50 | location: 51 | https://github.com/hedgehogqa/haskell-hedgehog-classes.git 52 | 53 | flag aeson 54 | description: 55 | You can disable the use of the `aeson` package using `-f-aeson`. 56 | . 57 | This may be useful for accelerating builds in sandboxes for expert users. 58 | default: True 59 | manual: True 60 | 61 | -- flag semigroupoids 62 | -- description: 63 | -- You can disable the use of the `semigroupoids` package using `-f-semigroupoids`. 64 | -- . 65 | -- This may be useful for accelerating builds in sandboxes for expert users. 66 | -- default: True 67 | -- manual: True 68 | 69 | flag comonad 70 | description: 71 | You can disable the use of the `comonad` package using `-f-comonad`. 72 | . 73 | This may be useful for accelerating builds in sandboxes for expert users. 74 | default: True 75 | manual: True 76 | 77 | flag semirings 78 | description: 79 | You can disable the use of the `semirings` package using `-f-semirings`. 80 | . 81 | This may be useful for accelerating builds in sandboxes for expert users. 82 | default: True 83 | manual: True 84 | 85 | flag primitive 86 | description: 87 | You can disable the use of the `primitive` package using `-f-primitive`. 88 | . 89 | This may be useful for accelerating builds in sandboxes for expert users. 90 | default: True 91 | manual: True 92 | 93 | flag vector 94 | description: 95 | You can disable the use of the `vector` package using `-f-vector`. 96 | . 97 | This may be useful for accelerating builds in sandboxes for expert users. 98 | default: True 99 | manual: True 100 | 101 | library 102 | hs-source-dirs: 103 | src 104 | exposed-modules: 105 | Hedgehog.Classes 106 | other-modules: 107 | Hedgehog.Classes.Alternative 108 | Hedgehog.Classes.Applicative 109 | Hedgehog.Classes.Arrow 110 | Hedgehog.Classes.Bifoldable 111 | Hedgehog.Classes.Bifunctor 112 | Hedgehog.Classes.Binary 113 | Hedgehog.Classes.Bitraversable 114 | Hedgehog.Classes.Bits 115 | Hedgehog.Classes.Category 116 | Hedgehog.Classes.Common 117 | Hedgehog.Classes.Common.ApTrans 118 | Hedgehog.Classes.Common.Bottom 119 | Hedgehog.Classes.Common.Compat 120 | Hedgehog.Classes.Common.Equation 121 | Hedgehog.Classes.Common.Func 122 | Hedgehog.Classes.Common.Gen 123 | Hedgehog.Classes.Common.IO 124 | Hedgehog.Classes.Common.Laws 125 | Hedgehog.Classes.Common.Property 126 | Hedgehog.Classes.Common.PP 127 | Hedgehog.Classes.Comonad 128 | Hedgehog.Classes.Contravariant 129 | Hedgehog.Classes.Enum 130 | Hedgehog.Classes.Eq 131 | Hedgehog.Classes.Foldable 132 | Hedgehog.Classes.Functor 133 | Hedgehog.Classes.Generic 134 | Hedgehog.Classes.Integral 135 | -- Hedgehog.Classes.Ix 136 | Hedgehog.Classes.Json 137 | Hedgehog.Classes.Monad 138 | -- Hedgehog.Classes.MonadFix 139 | Hedgehog.Classes.MonadIO 140 | Hedgehog.Classes.MonadPlus 141 | Hedgehog.Classes.MonadZip 142 | Hedgehog.Classes.Monoid 143 | Hedgehog.Classes.MVector 144 | Hedgehog.Classes.Ord 145 | Hedgehog.Classes.Prim 146 | Hedgehog.Classes.Semigroup 147 | Hedgehog.Classes.Semiring 148 | Hedgehog.Classes.Show 149 | Hedgehog.Classes.ShowRead 150 | Hedgehog.Classes.Storable 151 | Hedgehog.Classes.Traversable 152 | build-depends: 153 | , base >= 4.12 && < 4.21 154 | , binary >= 0.8 && < 0.9 155 | , containers >= 0.5 && < 0.8 156 | , hedgehog >= 1 && < 1.6 157 | , pretty-show >= 1.9 && < 1.11 158 | , silently >= 1.2 && < 1.3 159 | , transformers >= 0.5 && < 0.7 160 | , wl-pprint-annotated >= 0.0 && < 0.2 161 | ghc-options: 162 | -Wall 163 | default-language: 164 | Haskell2010 165 | if flag(aeson) 166 | build-depends: aeson >= 0.9 && < 2.3 167 | cpp-options: -DHAVE_AESON 168 | -- if flag(semigroupoids) 169 | -- build-depends: semigroupoids >= 0.5.3.0 && < 0.6.0.0 170 | -- cpp-options: -DHAVE_SEMIGROUPOIDS 171 | if flag(semirings) 172 | build-depends: semirings >= 0.2 && < 0.8 173 | cpp-options: -DHAVE_SEMIRINGS 174 | if flag(comonad) 175 | build-depends: comonad >= 5.0 && < 5.1 176 | cpp-options: -DHAVE_COMONAD 177 | if flag(vector) 178 | build-depends: vector >= 0.12 && < 0.14 179 | cpp-options: -DHAVE_VECTOR 180 | if flag(primitive) 181 | build-depends: primitive >= 0.6.4 && < 0.10 182 | cpp-options: -DHAVE_PRIMITIVE 183 | 184 | test-suite spec 185 | type: 186 | exitcode-stdio-1.0 187 | hs-source-dirs: 188 | test 189 | main-is: 190 | Spec.hs 191 | other-modules: 192 | Spec.Alternative 193 | Spec.Applicative 194 | Spec.Arrow 195 | Spec.Bifoldable 196 | Spec.Bifunctor 197 | Spec.Binary 198 | Spec.Bitraversable 199 | Spec.Bits 200 | Spec.Category 201 | Spec.Comonad 202 | Spec.Contravariant 203 | Spec.Enum 204 | Spec.Eq 205 | Spec.Foldable 206 | Spec.Functor 207 | Spec.Generic 208 | Spec.Integral 209 | -- Spec.Ix 210 | Spec.Json 211 | Spec.Monad 212 | Spec.Monoid 213 | Spec.MVector 214 | Spec.Ord 215 | Spec.Prim 216 | Spec.Semigroup 217 | Spec.Semiring 218 | Spec.Show 219 | Spec.Storable 220 | Spec.Traversable 221 | build-depends: 222 | , aeson 223 | , base 224 | , binary 225 | , comonad 226 | , containers 227 | , hedgehog 228 | , hedgehog-classes 229 | ghc-options: 230 | -Wall 231 | default-language: 232 | Haskell2010 233 | if flag(vector) 234 | build-depends: vector 235 | cpp-options: -DHAVE_VECTOR 236 | -------------------------------------------------------------------------------- /imgs/badlist.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hedgehogqa/haskell-hedgehog-classes/69212627dca7b21252a55495299e9bb84434d2ac/imgs/badlist.png -------------------------------------------------------------------------------- /imgs/badsemigroup.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/hedgehogqa/haskell-hedgehog-classes/69212627dca7b21252a55495299e9bb84434d2ac/imgs/badsemigroup.png -------------------------------------------------------------------------------- /src/Hedgehog/Classes.hs: -------------------------------------------------------------------------------- 1 | {-# language CPP #-} 2 | 3 | {-| This library provides sets of properties that should hold for common 4 | typeclasses. 5 | 6 | /Note:/ functions that test laws of a subclass never test the laws of 7 | a superclass. For example, 'commutativeSemigroupLaws' never tests 8 | the laws provided by 'semigroupLaws'. 9 | -} 10 | module Hedgehog.Classes 11 | ( -- * Running 12 | lawsCheck 13 | , lawsCheckOne 14 | , lawsCheckMany 15 | 16 | -- * Properties 17 | -- ** Ground types 18 | , binaryLaws 19 | , bitsLaws 20 | , eqLaws 21 | , integralLaws 22 | , monoidLaws 23 | , commutativeMonoidLaws 24 | , ordLaws 25 | -- , ixLaws 26 | , enumLaws 27 | , boundedEnumLaws 28 | , semigroupLaws 29 | , commutativeSemigroupLaws 30 | , exponentialSemigroupLaws 31 | , idempotentSemigroupLaws 32 | , rectangularBandSemigroupLaws 33 | #if HAVE_AESON 34 | , jsonLaws 35 | #endif 36 | , genericLaws 37 | #if HAVE_PRIMITIVE 38 | , primLaws 39 | #endif 40 | #if HAVE_SEMIRINGS 41 | , semiringLaws 42 | , ringLaws 43 | , starLaws 44 | #endif 45 | , showLaws 46 | , showReadLaws 47 | , storableLaws 48 | #if HAVE_VECTOR 49 | , muvectorLaws 50 | #endif 51 | -- ** Unary type constructors 52 | , alternativeLaws 53 | , applicativeLaws 54 | #ifdef HAVE_COMONAD 55 | , comonadLaws 56 | #endif 57 | , contravariantLaws 58 | , foldableLaws 59 | , functorLaws 60 | , monadLaws 61 | -- , monadFixLaws 62 | , monadIOLaws 63 | , monadPlusLaws 64 | , monadZipLaws 65 | , traversableLaws 66 | 67 | -- ** Binary type constructors 68 | , arrowLaws 69 | , bifoldableLaws 70 | , bifoldableFunctorLaws 71 | , bifunctorLaws 72 | , bitraversableLaws 73 | , categoryLaws 74 | , commutativeCategoryLaws 75 | 76 | -- * Defining your own 'Laws' 77 | , Laws(..) 78 | , LawContext(..) 79 | , Context(..) 80 | , contextualise 81 | 82 | -- * Hedgehog equality tests sans source information 83 | , hLessThan, hGreaterThan 84 | , heq, heq1, heq2 85 | , heqCtx, heqCtx1, heqCtx2 86 | , hneq, hneq1, hneq2 87 | , hneqCtx, hneqCtx1, hneqCtx2 88 | ) where 89 | 90 | import Hedgehog.Classes.Alternative (alternativeLaws) 91 | import Hedgehog.Classes.Applicative (applicativeLaws) 92 | import Hedgehog.Classes.Arrow (arrowLaws) 93 | import Hedgehog.Classes.Bifoldable (bifoldableLaws, bifoldableFunctorLaws) 94 | import Hedgehog.Classes.Bifunctor (bifunctorLaws) 95 | import Hedgehog.Classes.Binary (binaryLaws) 96 | import Hedgehog.Classes.Bitraversable (bitraversableLaws) 97 | import Hedgehog.Classes.Bits (bitsLaws) 98 | import Hedgehog.Classes.Category (categoryLaws, commutativeCategoryLaws) 99 | import Hedgehog.Classes.Common 100 | #ifdef HAVE_COMONAD 101 | import Hedgehog.Classes.Comonad (comonadLaws) 102 | #endif 103 | import Hedgehog.Classes.Contravariant (contravariantLaws) 104 | import Hedgehog.Classes.Enum (enumLaws, boundedEnumLaws) 105 | import Hedgehog.Classes.Eq (eqLaws) 106 | import Hedgehog.Classes.Foldable (foldableLaws) 107 | import Hedgehog.Classes.Functor (functorLaws) 108 | import Hedgehog.Classes.Generic (genericLaws) 109 | import Hedgehog.Classes.Integral (integralLaws) 110 | --import Hedgehog.Classes.Ix (ixLaws) 111 | #if HAVE_AESON 112 | import Hedgehog.Classes.Json (jsonLaws) 113 | #endif 114 | import Hedgehog.Classes.Monad (monadLaws) 115 | import Hedgehog.Classes.MonadIO (monadIOLaws) 116 | import Hedgehog.Classes.MonadPlus (monadPlusLaws) 117 | import Hedgehog.Classes.MonadZip (monadZipLaws) 118 | import Hedgehog.Classes.Monoid (monoidLaws, commutativeMonoidLaws) 119 | #if HAVE_VECTOR 120 | import Hedgehog.Classes.MVector (muvectorLaws) 121 | #endif 122 | import Hedgehog.Classes.Ord (ordLaws) 123 | #if HAVE_PRIMITIVE 124 | import Hedgehog.Classes.Prim (primLaws) 125 | #endif 126 | import Hedgehog.Classes.Semigroup (semigroupLaws, commutativeSemigroupLaws, exponentialSemigroupLaws, idempotentSemigroupLaws, rectangularBandSemigroupLaws) 127 | #if HAVE_SEMIRINGS 128 | import Hedgehog.Classes.Semiring (semiringLaws, ringLaws, starLaws) 129 | #endif 130 | import Hedgehog.Classes.Show (showLaws) 131 | import Hedgehog.Classes.ShowRead (showReadLaws) 132 | import Hedgehog.Classes.Storable (storableLaws) 133 | import Hedgehog.Classes.Traversable (traversableLaws) 134 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Alternative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Hedgehog.Classes.Alternative (alternativeLaws) where 6 | 7 | import Control.Applicative (Alternative(..)) 8 | 9 | import Hedgehog 10 | import Hedgehog.Classes.Common 11 | 12 | -- | Tests the following 'Alternative' laws: 13 | -- 14 | -- [__Left Identity__]: @'empty' '<|>' a@ ≡ @a@ 15 | -- [__Right Identity__]: @a '<|>' 'empty'@ ≡ @a@ 16 | -- [__Associativity__]: @a '<|>' (b '<|>' c)@ ≡ @(a '<|>' b) '<|>' c@ 17 | alternativeLaws :: 18 | ( Alternative f 19 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 20 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 21 | alternativeLaws gen = Laws "Alternative" 22 | [ ("Left Identity", alternativeLeftIdentity gen) 23 | , ("Right Identity", alternativeRightIdentity gen) 24 | , ("Associativity", alternativeAssociativity gen) 25 | ] 26 | 27 | type AlternativeProp f = 28 | ( Alternative f 29 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 30 | ) => (forall x. Gen x -> Gen (f x)) -> Property 31 | 32 | alternativeLeftIdentity :: forall f. AlternativeProp f 33 | alternativeLeftIdentity fgen = property $ do 34 | a <- forAll $ fgen genSmallInteger 35 | let lhs = empty <|> a 36 | let rhs = a 37 | let ctx = contextualise $ LawContext 38 | { lawContextLawName = "Left Identity", lawContextLawBody = "empty <|> a" `congruency` "a" 39 | , lawContextTcName = "Alternative", lawContextTcProp = 40 | let showA = show a; 41 | in lawWhere 42 | [ "empty <|> a" `congruency` "a, where" 43 | , "a = " ++ showA 44 | ] 45 | , lawContextReduced = reduced lhs rhs 46 | } 47 | heqCtx1 lhs rhs ctx 48 | 49 | alternativeRightIdentity :: forall f. AlternativeProp f 50 | alternativeRightIdentity fgen = property $ do 51 | a <- forAll $ fgen genSmallInteger 52 | let lhs = a <|> empty 53 | let rhs = a 54 | let ctx = contextualise $ LawContext 55 | { lawContextLawName = "Right Identity", lawContextLawBody = "a <|> empty" `congruency` "a" 56 | , lawContextTcName = "Alternative", lawContextTcProp = 57 | let showA = show a; 58 | in lawWhere 59 | [ "a <|> empty" `congruency` "a, where" 60 | , "a = " ++ showA 61 | ] 62 | , lawContextReduced = reduced lhs rhs 63 | } 64 | heqCtx1 lhs rhs ctx 65 | 66 | alternativeAssociativity :: forall f. AlternativeProp f 67 | alternativeAssociativity fgen = property $ do 68 | a <- forAll $ fgen genSmallInteger 69 | b <- forAll $ fgen genSmallInteger 70 | c <- forAll $ fgen genSmallInteger 71 | let lhs = (a <|> (b <|> c)) 72 | let rhs = ((a <|> b) <|> c) 73 | let ctx = contextualise $ LawContext 74 | { lawContextLawName = "Associativity", lawContextLawBody = "a <|> (b <|> c)" `congruency` "(a <|> b) <|> c" 75 | , lawContextTcName = "Alternative", lawContextTcProp = 76 | let showA = show a; showB = show b; showC = show c; 77 | in lawWhere 78 | [ "a <|> (b <|> c)" `congruency` "(a <|> b) <|> c), where" 79 | , "a = " ++ showA 80 | , "b = " ++ showB 81 | , "c = " ++ showC 82 | ] 83 | , lawContextReduced = reduced lhs rhs 84 | } 85 | heqCtx1 lhs rhs ctx 86 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Applicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Hedgehog.Classes.Applicative (applicativeLaws) where 6 | 7 | import qualified Control.Applicative as App (liftA2) 8 | 9 | import Hedgehog 10 | import Hedgehog.Classes.Common 11 | 12 | -- | Tests the following 'Applicative' laws: 13 | -- 14 | -- [__Identity__]: @'pure' 'id' '<*>' v@ ≡ @v@ 15 | -- [__Composition__]: @'pure' ('.') '<*>' u '<*>' v '<*>' w@ ≡ @u '<*>' (v '<*>' w)@ 16 | -- [__Homomorphism__]: @'pure' f '<*>' 'pure'@ x ≡ @'pure' (f x)@ 17 | -- [__Interchange__]: @u '<*>' 'pure' y@ ≡ @'pure' ('$' y) '<*>' u@ 18 | -- [__LiftA2 1__]: @'App.liftA2' 'id' f x@ ≡ @f '<*>' x@ 19 | -- [__LiftA2 2__]: @'App.liftA2' f x y@ ≡ @f '<$>' x '<*>' y@ 20 | applicativeLaws :: 21 | ( Applicative f 22 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 23 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 24 | applicativeLaws gen = Laws "Applicative" 25 | [ ("Identity", applicativeIdentity gen) 26 | , ("Composition", applicativeComposition gen) 27 | , ("Homomorphism", applicativeHomomorphism gen) 28 | , ("Interchange", applicativeInterchange gen) 29 | , ("LiftA2 Part 1", applicativeLiftA2_1 gen) 30 | , ("LiftA2 Part 2", applicativeLiftA2_2 gen) 31 | ] 32 | 33 | type ApplicativeProp f = 34 | ( Applicative f 35 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 36 | ) => (forall x. Gen x -> Gen (f x)) -> Property 37 | 38 | applicativeIdentity :: forall f. ApplicativeProp f 39 | applicativeIdentity fgen = property $ do 40 | a <- forAll $ fgen genSmallInteger 41 | let lhs = pure id <*> a 42 | let rhs = a 43 | let ctx = contextualise $ LawContext 44 | { lawContextLawName = "Identity", lawContextLawBody = "pure id <*> v" `congruency` "v" 45 | , lawContextTcName = "Applicative", lawContextTcProp = 46 | let showA = show a 47 | in lawWhere 48 | [ "pure id <*> v" `congruency` "v, where" 49 | , "v = " ++ showA 50 | ] 51 | , lawContextReduced = reduced lhs rhs 52 | } 53 | heqCtx1 lhs rhs ctx 54 | 55 | applicativeComposition :: forall f. ApplicativeProp f 56 | applicativeComposition fgen = property $ do 57 | u' <- forAll $ fgen genQuadraticEquation 58 | v' <- forAll $ fgen genQuadraticEquation 59 | w' <- forAll genSmallInteger 60 | let u = runQuadraticEquation <$> u' 61 | v = runQuadraticEquation <$> v' 62 | w = pure w' 63 | let lhs = pure (.) <*> u <*> v <*> w 64 | let rhs = u <*> (v <*> w) 65 | let ctx = contextualise $ LawContext 66 | { lawContextLawName = "Composition", lawContextLawBody = "pure (.) <*> u <*> v <*> w == u <*> (v <*> w)" 67 | , lawContextTcName = "Applicative", lawContextTcProp = 68 | let showU = show u'; showV = show v'; showW = show w'; 69 | in lawWhere 70 | [ "pure (.) <*> u <*> v <*> w", congruent, "u <*> (v <*> w), where" 71 | , "u = " ++ showU 72 | , "v = " ++ showV 73 | , "w = " ++ showW 74 | ] 75 | , lawContextReduced = reduced lhs rhs 76 | } 77 | 78 | heqCtx1 lhs rhs ctx 79 | 80 | applicativeHomomorphism :: forall f. ApplicativeProp f 81 | applicativeHomomorphism _ = property $ do 82 | e <- forAll genQuadraticEquation 83 | a <- forAll genSmallInteger 84 | let f = runQuadraticEquation e 85 | let lhs = pure f <*> pure a 86 | let rhs = pure (f a) :: f Integer 87 | let ctx = contextualise $ LawContext 88 | { lawContextLawName = "Homomorphism", lawContextLawBody = "pure f <*> pure x" `congruency` "pure (f x)" 89 | , lawContextTcName = "Applicative", lawContextTcProp = 90 | let showF = show e; showX = show a; 91 | in lawWhere 92 | [ "pure f <*> pure x", congruent, "pure (f x), where" 93 | , "f = " ++ showF 94 | , "x = " ++ showX 95 | ] 96 | , lawContextReduced = reduced lhs rhs 97 | } 98 | heqCtx1 lhs rhs ctx 99 | 100 | applicativeInterchange :: forall f. ApplicativeProp f 101 | applicativeInterchange fgen = property $ do 102 | u' <- forAll $ fgen genQuadraticEquation 103 | y <- forAll genSmallInteger 104 | let u = fmap runQuadraticEquation u' 105 | let lhs = (u <*> pure y) 106 | let rhs = pure ($ y) <*> u 107 | let ctx = contextualise $ LawContext 108 | { lawContextLawName = "Interchange", lawContextLawBody = "u <*> pure y" `congruency` "pure ($ y) <*> u" 109 | , lawContextTcName = "Applicative", lawContextTcProp = 110 | let showU = show u'; showY = show y; 111 | in lawWhere 112 | [ "u <*> pure y", congruent, "pure ($ y) <*> u, where" 113 | , "u = " ++ showU 114 | , "y = " ++ showY 115 | ] 116 | , lawContextReduced = reduced lhs rhs 117 | } 118 | heqCtx1 lhs rhs ctx 119 | 120 | applicativeLiftA2_1 :: forall f. ApplicativeProp f 121 | applicativeLiftA2_1 fgen = property $ do 122 | f' <- forAll $ fgen genQuadraticEquation 123 | x <- forAll $ fgen genSmallInteger 124 | let f = fmap runQuadraticEquation f' 125 | let lhs = App.liftA2 id f x 126 | let rhs = f <*> x 127 | let ctx = contextualise $ LawContext 128 | { lawContextLawName = "LiftA2 1", lawContextLawBody = "liftA2 id f x" `congruency` "f <*> x" 129 | , lawContextTcName = "Applicative", lawContextTcProp = 130 | let showF = show f'; showX = show x; 131 | in lawWhere 132 | [ "liftA2 id f x", congruent, "f <*> x, where" 133 | , "f = " ++ showF 134 | , "x = " ++ showX 135 | ] 136 | , lawContextReduced = reduced lhs rhs 137 | } 138 | heqCtx1 lhs rhs ctx 139 | 140 | applicativeLiftA2_2 :: forall f. ApplicativeProp f 141 | applicativeLiftA2_2 fgen = property $ do 142 | x <- forAll $ fgen genSmallInteger 143 | y <- forAll $ fgen genSmallInteger 144 | f' <- forAll $ genLinearEquationTwo 145 | let f = runLinearEquationTwo f' 146 | let lhs = App.liftA2 f x y 147 | let rhs = f <$> x <*> y 148 | let ctx = contextualise $ LawContext 149 | { lawContextLawName = "LiftA2 2", lawContextLawBody = "liftA2 f x y == f <$> x <*> y" 150 | , lawContextTcName = "Applicative", lawContextTcProp = 151 | let showF = show f'; showX = show x; showY = show y; 152 | in lawWhere 153 | [ "liftA2 f x y" `congruency` "f <$> x <*> y, where" 154 | , "f = " ++ showF 155 | , "x = " ++ showX 156 | , "y = " ++ showY 157 | ] 158 | , lawContextReduced = reduced lhs rhs 159 | } 160 | heqCtx1 lhs rhs ctx 161 | 162 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Arrow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE QuantifiedConstraints #-} 4 | 5 | module Hedgehog.Classes.Arrow (arrowLaws) where 6 | 7 | import Hedgehog 8 | import Hedgehog.Classes.Common 9 | 10 | import Control.Arrow(Arrow(..), (>>>)) 11 | import Control.Category(Category(..)) 12 | import Prelude hiding (id, (.)) 13 | import qualified Prelude 14 | 15 | -- | Tests the following 'Arrow' laws: 16 | -- 17 | -- [__Arr Identity__]: @'arr' 'id'@ ≡ @'id'@ 18 | -- [__Arr Composition__]: @'arr' (f '>>>' g)@ ≡ @'arr' f '>>>' 'arr' g@ 19 | -- [__Arr-First inverse__]: @'first' ('arr' f)@ ≡ @'arr' ('first' f)@ 20 | -- [__First Composition__]: @'first' (f '>>>' g)@ ≡ @'first' f '>>>' 'first' g@ 21 | -- [__Arrow Law 5__]: @'first' f '>>>' 'arr' 'fst'@ ≡ @'arr' 'fst' '>>>' f@ 22 | -- [__Arrow Law 6__]: @'first' f '>>>' 'arr' ('id' '***' g)@ ≡ @'arr' ('id' '***' g) '>>>' 'first' f@ 23 | -- [__Arrow Law 7__]: @'first' ('first' f) '>>>' 'arr' assoc@ ≡ @'arr' assoc '>>>' 'first' f, where assoc ((a,b),c) = (a,(b,c))@ 24 | arrowLaws :: forall f. 25 | ( Arrow f 26 | , forall x y. (Eq x, Eq y) => Eq (f x y) 27 | , forall x y. (Show x, Show y) => Show (f x y) 28 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws 29 | arrowLaws gen = Laws "Arrow" 30 | [ ("Arr Identity", arrowLaw1 gen) 31 | , ("Arr Composition", arrowLaw2 gen) 32 | , ("Arr . First == First . Arr", arrowLaw3 gen) 33 | , ("First Composition", arrowLaw4 gen) 34 | , ("Arrow Law 5", arrowLaw5 gen) 35 | , ("Arrow Law 6", arrowLaw6 gen) 36 | , ("Arrow Law 7", arrowLaw7 gen) 37 | ] 38 | 39 | type ArrowProp f = 40 | ( Arrow f 41 | , forall x y. (Eq x, Eq y) => Eq (f x y) 42 | , forall x y. (Show x, Show y) => Show (f x y) 43 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property 44 | 45 | arrowLaw1 :: forall f. ArrowProp f 46 | arrowLaw1 _ = property $ do 47 | arr Prelude.id `heq2` (id :: f Integer Integer) 48 | 49 | arrowLaw2 :: forall f. ArrowProp f 50 | arrowLaw2 _ = property $ do 51 | f' <- forAll genQuadraticEquation 52 | g' <- forAll genQuadraticEquation 53 | let f = runQuadraticEquation f' 54 | g = runQuadraticEquation g' 55 | (arr (f >>> g) :: f Integer Integer) `heq2` (arr f >>> arr g) 56 | 57 | arrowLaw3 :: forall f. ArrowProp f 58 | arrowLaw3 _ = property $ do 59 | f' <- forAll genQuadraticEquation 60 | let f = runQuadraticEquation f' 61 | let x = first (arr f) :: f (Integer, Integer) (Integer, Integer) 62 | let y = arr (first f) :: f (Integer, Integer) (Integer, Integer) 63 | x `heq2` y 64 | 65 | arrowLaw4 :: forall f. ArrowProp f 66 | arrowLaw4 fgen = property $ do 67 | f <- forAll $ fgen genSmallInteger genSmallInteger 68 | g <- forAll $ fgen genSmallInteger genSmallInteger 69 | let x = first (f >>> g) :: f (Integer, Integer) (Integer, Integer) 70 | let y = first f >>> first g :: f (Integer, Integer) (Integer, Integer) 71 | x `heq2` y 72 | 73 | arrowLaw5 :: forall f. ArrowProp f 74 | arrowLaw5 fgen = property $ do 75 | f <- forAll $ fgen genSmallInteger genSmallInteger 76 | let x = first f >>> arr fst :: f (Integer, Integer) Integer 77 | let y = arr fst >>> f :: f (Integer, Integer) Integer 78 | x `heq2` y 79 | 80 | arrowLaw6 :: forall f. ArrowProp f 81 | arrowLaw6 fgen = property $ do 82 | f <- forAll $ fgen genSmallInteger genSmallInteger 83 | g' <- forAll genQuadraticEquation 84 | let g = runQuadraticEquation g' 85 | let x = ((first f) >>> (arr (Prelude.id *** g))) :: f (Integer, Integer) (Integer, Integer) 86 | let y = arr (id *** g) >>> first f :: f (Integer, Integer) (Integer, Integer) 87 | x `heq2` y 88 | 89 | arrowLaw7 :: forall f. ArrowProp f 90 | arrowLaw7 fgen = property $ do 91 | let assoc ((a,b),c) = (a,(b,c)) 92 | f <- forAll $ fgen genSmallInteger genSmallInteger 93 | let x = first (first f) >>> arr assoc :: f ((Integer, Integer), Integer) (Integer, (Integer, Integer)) 94 | let y = arr assoc >>> first f :: f ((Integer, Integer), Integer) (Integer, (Integer, Integer)) 95 | x `heq2` y 96 | 97 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Bifoldable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE QuantifiedConstraints #-} 4 | 5 | module Hedgehog.Classes.Bifoldable (bifoldableLaws, bifoldableFunctorLaws) where 6 | 7 | import Hedgehog 8 | import Hedgehog.Classes.Common 9 | 10 | import Data.Bifoldable (Bifoldable(..)) 11 | import Data.Bifunctor (Bifunctor(..)) 12 | import Data.Monoid (Endo(..), Sum(..), Product(..)) 13 | 14 | -- | Tests the following 'Bifoldable' laws: 15 | -- 16 | -- [__Identity__]: @'bifold'@ ≡ @'bifoldMap' 'id' 'id'@ 17 | -- [__FoldMap__]: @'bifoldMap' f g@ ≡ @'bifoldr' ('mappend' '.' f) ('mappend' '.' g) 'mempty'@ 18 | -- [__Foldr__]: @'bifoldr' f g z t@ ≡ @'appEndo' ('bifoldMap' ('Endo' '.' f) ('Endo' '.' g) t) z@ 19 | bifoldableLaws :: forall f. 20 | ( Bifoldable f 21 | , forall x y. (Eq x, Eq y) => Eq (f x y) 22 | , forall x y. (Show x, Show y) => Show (f x y) 23 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws 24 | bifoldableLaws gen = Laws "Bifoldable" 25 | [ ("Identity", bifoldableIdentity gen) 26 | , ("FoldMap", bifoldableFoldMap gen) 27 | , ("Foldr", bifoldableFoldr gen) 28 | ] 29 | 30 | -- | Tests the following 'Bifoldable' / 'Bifunctor' laws: 31 | -- 32 | -- [__Composition__]: @'bifoldMap' f g@ ≡ @'bifold' '.' 'bimap' f g@ 33 | -- [__FoldMap__]: @'bifoldMap' f g '.' 'bimap' h i@ ≡ @'bifoldMap' (f '.' h) (g '.' i)@ 34 | bifoldableFunctorLaws :: forall f. 35 | ( Bifoldable f, Bifunctor f 36 | , forall x y. (Eq x, Eq y) => Eq (f x y) 37 | , forall x y. (Show x, Show y) => Show (f x y) 38 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws 39 | bifoldableFunctorLaws gen = Laws "Bifoldable/Bifunctor" 40 | [ ("Composition", bifoldableFunctorComposition gen) 41 | , ("FoldMap", bifoldableFunctorFoldMap gen) 42 | ] 43 | 44 | type BifoldableProp f = 45 | ( Bifoldable f 46 | , forall x y. (Eq x, Eq y) => Eq (f x y) 47 | , forall x y. (Show x, Show y) => Show (f x y) 48 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property 49 | 50 | bifoldableIdentity :: forall f. BifoldableProp f 51 | bifoldableIdentity fgen = property $ do 52 | x <- forAll $ fgen genSmallSum genSmallSum 53 | let lhs = bifold x 54 | let rhs = bifoldMap id id x 55 | let ctx = contextualise $ LawContext 56 | { lawContextLawName = "Identity", lawContextLawBody = "bifold" `congruency` "bifoldMap id id" 57 | , lawContextTcName = "Bifoldable", lawContextTcProp = 58 | let showX = show x; 59 | in lawWhere 60 | [ "bimap id id x" `congruency` "x, where" 61 | , "x = " ++ showX 62 | ] 63 | , lawContextReduced = reduced lhs rhs 64 | } 65 | heqCtx lhs rhs ctx 66 | 67 | bifoldableFoldMap :: forall f. BifoldableProp f 68 | bifoldableFoldMap fgen = property $ do 69 | x <- forAll $ fgen genSmallInteger genSmallInteger 70 | f' <- forAll genQuadraticEquation 71 | g' <- forAll genQuadraticEquation 72 | let f = Sum . runQuadraticEquation f' 73 | let g = Sum . runQuadraticEquation g' 74 | let lhs = (bifoldMap f g x) 75 | let rhs = (bifoldr (mappend . f) (mappend . g) mempty x) 76 | let ctx = contextualise $ LawContext 77 | { lawContextLawName = "FoldMap", lawContextLawBody = "bifoldMap f g" `congruency` "bifoldr (mappend . f) (mappend . g) mempty" 78 | , lawContextTcName = "Bifoldable", lawContextTcProp = 79 | let showX = show x; 80 | showF = show f'; 81 | showG = show g'; 82 | in lawWhere 83 | [ "bifoldMap f g x" `congruency` "bifoldr (mappend . f) (mappend . g) mempty x, where" 84 | , "f = " ++ showF 85 | , "g = " ++ showG 86 | , "x = " ++ showX 87 | ] 88 | , lawContextReduced = reduced lhs rhs 89 | } 90 | heqCtx lhs rhs ctx 91 | 92 | bifoldableFoldr :: forall f. BifoldableProp f 93 | bifoldableFoldr fgen = property $ do 94 | x <- forAll $ fgen genSmallInteger genSmallInteger 95 | f' <- forAll genLinearEquationTwo 96 | g' <- forAll genLinearEquationTwo 97 | let f = runLinearEquationTwo f' 98 | let g = runLinearEquationTwo g' 99 | let z0 = 0 100 | let lhs = (bifoldr f g z0 x) 101 | let rhs = (appEndo (bifoldMap (Endo . f) (Endo . g) x) z0) 102 | let ctx = contextualise $ LawContext 103 | { lawContextLawName = "Foldr", lawContextLawBody = "bifoldr f g z t" `congruency` "appEndo (bifoldMap (Endo . f) (Endo . g) t) z" 104 | , lawContextTcName = "Bifoldable", lawContextTcProp = 105 | let showX = show x; showF = show f'; showG = show g'; showZ = show z0; 106 | in lawWhere 107 | [ "bifoldr f g z t" `congruency` "appEndo (bifoldMap (Endo . f) (Endo . g) t z, where" 108 | , "f = " ++ showF 109 | , "g = " ++ showG 110 | , "t = " ++ showX 111 | , "z = " ++ showZ 112 | ] 113 | , lawContextReduced = reduced lhs rhs 114 | } 115 | heqCtx lhs rhs ctx 116 | 117 | type BifoldableFunctorProp f = 118 | ( Bifoldable f, Bifunctor f 119 | , forall x y. (Eq x, Eq y) => Eq (f x y) 120 | , forall x y. (Show x, Show y) => Show (f x y) 121 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property 122 | 123 | bifoldableFunctorComposition :: forall f. BifoldableFunctorProp f 124 | bifoldableFunctorComposition fgen = property $ do 125 | x <- forAll $ fgen genSmallSum genSmallSum 126 | let f = Product; g = Product . (+1) 127 | let lhs = bifoldMap f g x 128 | let rhs = bifold (bimap f g x) 129 | let ctx = contextualise $ LawContext 130 | { lawContextLawName = "Composition", lawContextLawBody = "bifoldMap f g" `congruency` "bifold . bimap f g" 131 | , lawContextTcName = "Bifoldable/Bifunctor", lawContextTcProp = 132 | let showX = show x; 133 | in lawWhere 134 | [ "bifoldMap f g x" `congruency` "bifold . bimap f g $ x" 135 | , "f = \\x -> Product x" 136 | , "g = \\x -> Product (x + 1)" 137 | , "x = " ++ showX 138 | ] 139 | , lawContextReduced = reduced lhs rhs 140 | } 141 | heqCtx lhs rhs ctx 142 | 143 | bifoldableFunctorFoldMap :: forall f. BifoldableFunctorProp f 144 | bifoldableFunctorFoldMap fgen = property $ do 145 | x <- forAll $ fgen genSmallSum genSmallSum 146 | let h (Sum s) = s * s + 3; showH = "\\(Sum s) -> s * s + 3" 147 | let i (Sum s) = s + s - 7; showI = "\\(Sum s) -> s + s - 7" 148 | let f = Sum; showF = "\\x -> Sum x"; g = Sum . (+1); showG = "\\x -> Sum (x + 1)" 149 | let lhs = bifoldMap f g (bimap h i x) 150 | let rhs = bifoldMap (f . h) (g . i) x 151 | let ctx = contextualise $ LawContext 152 | { lawContextLawName = "FoldMap", lawContextLawBody = "bifoldMap f g . bimap h i" `congruency` "bifoldMap (f . h) (g . i)" 153 | , lawContextTcName = "Bifoldable/Bifunctor", lawContextTcProp = 154 | let showX = show x; 155 | in lawWhere 156 | [ "bifoldMap f g . bimap h i $ x" `congruency` "bifoldMap (f . h) (g . i) $ x, where" 157 | , "f = " ++ showF 158 | , "g = " ++ showG 159 | , "h = " ++ showH 160 | , "i = " ++ showI 161 | , "x = " ++ showX 162 | ] 163 | , lawContextReduced = reduced lhs rhs 164 | } 165 | heqCtx lhs rhs ctx 166 | 167 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Bifunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE QuantifiedConstraints #-} 4 | 5 | module Hedgehog.Classes.Bifunctor (bifunctorLaws) where 6 | 7 | import Hedgehog 8 | import Hedgehog.Classes.Common 9 | 10 | import Data.Bifunctor (Bifunctor(..)) 11 | 12 | -- | Tests the following 'Bifunctor' laws: 13 | -- 14 | -- [__Identity__]: @'bimap' 'id' 'id'@ ≡ @'id'@ 15 | -- [__First Identity__]: @'first' 'id'@ ≡ @'id'@ 16 | -- [__Second Identity__]: @'second' 'id'@ ≡ @'id'@ 17 | -- [__Composition__]: @'bimap' 'id' 'id'@ ≡ @'first' 'id' '.' 'second' 'id'@ 18 | bifunctorLaws :: forall f. 19 | ( Bifunctor f 20 | , forall x y. (Eq x, Eq y) => Eq (f x y) 21 | , forall x y. (Show x, Show y) => Show (f x y) 22 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws 23 | bifunctorLaws gen = Laws "Bifunctor" 24 | [ ("Identity", bifunctorIdentity gen) 25 | , ("First Identity", bifunctorFirstIdentity gen) 26 | , ("Second Identity", bifunctorSecondIdentity gen) 27 | , ("Composition", bifunctorComposition gen) 28 | ] 29 | 30 | type BifunctorProp f = 31 | ( Bifunctor f 32 | , forall x y. (Eq x, Eq y) => Eq (f x y) 33 | , forall x y. (Show x, Show y) => Show (f x y) 34 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property 35 | 36 | bifunctorIdentity :: forall f. BifunctorProp f 37 | bifunctorIdentity fgen = property $ do 38 | x <- forAll $ fgen genSmallInteger genSmallInteger 39 | let lhs = bimap id id x 40 | let rhs = x 41 | let ctx = contextualise $ LawContext 42 | { lawContextLawName = "Identity", lawContextLawBody = "bimap id id" `congruency` "id" 43 | , lawContextTcName = "Bifunctor", lawContextTcProp = 44 | let showX = show x; 45 | in lawWhere 46 | [ "bimap id id x" `congruency` "x, where" 47 | , "x = " ++ showX 48 | ] 49 | , lawContextReduced = reduced lhs rhs 50 | } 51 | heqCtx2 lhs rhs ctx 52 | 53 | bifunctorFirstIdentity :: forall f. BifunctorProp f 54 | bifunctorFirstIdentity fgen = property $ do 55 | x <- forAll $ fgen genSmallInteger genSmallInteger 56 | let lhs = first id x 57 | let rhs = x 58 | let ctx = contextualise $ LawContext 59 | { lawContextLawName = "First Identity", lawContextLawBody = "first id" `congruency` "id" 60 | , lawContextTcName = "Bifunctor", lawContextTcProp = 61 | let showX = show x; 62 | in lawWhere 63 | [ "first id x" `congruency` "x, where" 64 | , "x = " ++ showX 65 | ] 66 | , lawContextReduced = reduced lhs rhs 67 | } 68 | heqCtx2 lhs rhs ctx 69 | 70 | bifunctorSecondIdentity :: forall f. BifunctorProp f 71 | bifunctorSecondIdentity fgen = property $ do 72 | x <- forAll $ fgen genSmallInteger genSmallInteger 73 | let lhs = second id x 74 | let rhs = x 75 | let ctx = contextualise $ LawContext 76 | { lawContextLawName = "Second Identity", lawContextLawBody = "second id" `congruency` "id" 77 | , lawContextTcName = "Bifunctor", lawContextTcProp = 78 | let showX = show x; 79 | in lawWhere 80 | [ "second id x" `congruency` "x, where" 81 | , "x = " ++ showX 82 | ] 83 | , lawContextReduced = reduced lhs rhs 84 | } 85 | heqCtx2 lhs rhs ctx 86 | 87 | bifunctorComposition :: forall f. BifunctorProp f 88 | bifunctorComposition fgen = property $ do 89 | z <- forAll $ fgen genSmallInteger genSmallInteger 90 | let lhs = bimap id id z 91 | let rhs = (first id . second id) z 92 | let ctx = contextualise $ LawContext 93 | { lawContextLawName = "Composition", lawContextLawBody = "bimap id id" `congruency` "first id . second id" 94 | , lawContextTcName = "Bifunctor", lawContextTcProp = 95 | let showX = show z; 96 | in lawWhere 97 | [ "bimap id id x" `congruency` "first id . second id $ x, where" 98 | , "x = " ++ showX 99 | ] 100 | , lawContextReduced = reduced lhs rhs 101 | } 102 | heqCtx2 lhs rhs ctx 103 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Binary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module Hedgehog.Classes.Binary (binaryLaws) where 5 | 6 | import Hedgehog 7 | import Hedgehog.Classes.Common 8 | import Data.Binary (Binary) 9 | import qualified Data.Binary as Binary 10 | 11 | -- | Tests the following 'Binary' laws: 12 | -- 13 | -- [__Encoding Partial Isomorphism__]: @'Binary.decode' '.' 'Binary.encode'@ ≡ @'id'@ 14 | binaryLaws :: (Binary a, Eq a, Show a) => Gen a -> Laws 15 | binaryLaws gen = Laws "Binary" 16 | [ ("Partial Isomorphism", binaryPartialIsomorphism gen) 17 | ] 18 | 19 | binaryPartialIsomorphism :: forall a. (Binary a, Show a, Eq a) => Gen a -> Property 20 | binaryPartialIsomorphism gen = property $ do 21 | x <- forAll gen 22 | let encoded = Binary.encode x 23 | let lhs = Binary.decode @a encoded 24 | let rhs = x 25 | let ctx = contextualise $ LawContext 26 | { lawContextLawName = "Partial Isomorphism", lawContextTcName = "Binary" 27 | , lawContextLawBody = "decode . encode" `congruency` "id" 28 | , lawContextTcProp = 29 | let showX = show x 30 | showEncoded = show encoded 31 | in lawWhere 32 | [ "decode . encode $ x" `congruency` "x, where" 33 | , "x = " ++ showX 34 | , "encode x = " ++ showEncoded 35 | ] 36 | , lawContextReduced = reduced lhs rhs 37 | } 38 | heqCtx lhs rhs ctx 39 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Bitraversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE QuantifiedConstraints #-} 4 | 5 | module Hedgehog.Classes.Bitraversable (bitraversableLaws) where 6 | 7 | import Hedgehog 8 | import Hedgehog.Classes.Common 9 | 10 | import Data.Bitraversable (Bitraversable(..)) 11 | import Data.Functor.Compose (Compose(..)) 12 | import Data.Functor.Identity (Identity(..)) 13 | 14 | import qualified Data.Set as S 15 | import qualified Control.Monad.Trans.Writer.Lazy as WL 16 | 17 | -- | Tests the following 'Bitraversable' laws: 18 | -- 19 | -- [__Naturality__]: @'bitraverse' (t '.' f) (t '.' g)@ ≡ @t '.' 'bitraverse' f g, for every applicative transformation t@ 20 | -- [__Identity__]: @'bitraverse' 'Identity' 'Identity'@ ≡ @'Identity'@ 21 | -- [__Composition__]: @'Compose' '.' 'fmap' ('bitraverse' g1 g2) '.' 'bitraverse' f1 f2@ ≡ @'bitraverse' ('Compose' '.' 'fmap' g1 '.' f1) ('Compose' '.' 'fmap' g2 '.' f2)@ 22 | bitraversableLaws :: forall f. 23 | ( Bitraversable f 24 | , forall x y. (Eq x, Eq y) => Eq (f x y) 25 | , forall x y. (Show x, Show y) => Show (f x y) 26 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws 27 | bitraversableLaws gen = Laws "Bitraversable" 28 | [ ("Naturality", bitraversableNaturality gen) 29 | , ("Identity", bitraversableIdentity gen) 30 | , ("Composition", bitraversableComposition gen) 31 | ] 32 | 33 | type BitraversableProp f = 34 | ( Bitraversable f 35 | , forall x y. (Eq x, Eq y) => Eq (f x y) 36 | , forall x y. (Show x, Show y) => Show (f x y) 37 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property 38 | 39 | bitraversableNaturality :: forall f. BitraversableProp f 40 | bitraversableNaturality fgen = property $ do 41 | x <- forAll $ fgen genSmallInteger genSmallInteger 42 | let t = apTrans; f = func4; g = func4 43 | let lhs = bitraverse (t . f) (t . g) x 44 | let rhs = t (bitraverse f g x) 45 | let ctx = contextualise $ LawContext 46 | { lawContextLawName = "Naturality", lawContextLawBody = "bitraverse (t . f) (t . g)" `congruency` "t . bitraverse f g, for every applicative transformation t" 47 | , lawContextTcName = "Bitraversable", lawContextTcProp = 48 | let showX = show x; 49 | in lawWhere 50 | [ "bitraverse (t . f) (t . g) $ x" `congruency` "t . bitraverse f g $ x, for every applicative transformation t, where" 51 | , "x = " ++ showX 52 | ] 53 | , lawContextReduced = reduced lhs rhs 54 | } 55 | heqCtx1 lhs rhs ctx 56 | 57 | bitraversableIdentity :: forall f. BitraversableProp f 58 | bitraversableIdentity fgen = property $ do 59 | x <- forAll $ fgen genSmallInteger genSmallInteger 60 | let lhs = bitraverse Identity Identity x 61 | let rhs = Identity x 62 | let ctx = contextualise $ LawContext 63 | { lawContextLawName = "Identity", lawContextLawBody = "bitraverse Identity Identity" `congruency` "Identity" 64 | , lawContextTcName = "Bitraversable", lawContextTcProp = 65 | let showX = show x; 66 | in lawWhere 67 | [ "bitraverse Identity Identity x" `congruency` "Identity x, where" 68 | , "x = " ++ showX 69 | ] 70 | , lawContextReduced = reduced lhs rhs 71 | } 72 | heqCtx1 lhs rhs ctx 73 | 74 | bitraversableComposition :: forall f. BitraversableProp f 75 | bitraversableComposition fgen = property $ do 76 | x <- forAll $ fgen genSmallInteger genSmallInteger 77 | let f1 = func6; f2 = func5; g1 = func4; g2 = func4 78 | let lhs :: Compose Triple (Compose Triple (WL.Writer (S.Set Integer))) (f Integer Integer) 79 | lhs = Compose . fmap (bitraverse g1 g2) . bitraverse f1 f2 $ x 80 | 81 | let rhs :: Compose Triple (Compose Triple (WL.Writer (S.Set Integer))) (f Integer Integer) 82 | rhs = bitraverse (Compose . fmap g1 . f1) (Compose . fmap g2 . f2) x 83 | let ctx = contextualise $ LawContext 84 | { lawContextLawName = "Composition", lawContextLawBody = "Compose . fmap (bitraverse g1 g2) . bitraverse f1 f2" `congruency` "bitraverse (Compose . fmap g1 . f1) (Compose . fmap g2 . f2)" 85 | , lawContextTcName = "Bitraversable", lawContextTcProp = 86 | let showX = show x; 87 | in lawWhere 88 | [ "Compose . fmap (bitraverse g1 g2) . bitraverse f1 f2 $ x" `congruency` "bitraverse (Compose . fmap g1 . f1) (Compose . fmap g2 . f2) $ x, where" 89 | , "x = " ++ showX 90 | ] 91 | , lawContextReduced = reduced lhs rhs 92 | } 93 | heqCtx1 lhs rhs ctx 94 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Category.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE QuantifiedConstraints #-} 4 | 5 | module Hedgehog.Classes.Category (categoryLaws, commutativeCategoryLaws) where 6 | 7 | import Hedgehog 8 | import Hedgehog.Classes.Common 9 | 10 | import Control.Category(Category(..)) 11 | import Prelude hiding (id, (.)) 12 | 13 | -- | Tests the following 'Category' laws: 14 | -- 15 | -- [__Left Identity__]: @'id' '.' f@ ≡ @f@ 16 | -- [__Right Identity__]: @f '.' 'id'@ ≡ @f@ 17 | -- [__Associativity__]: @f '.' (g '.' h)@ ≡ @(f '.' g) '.' h@ 18 | categoryLaws :: forall f. 19 | ( Category f 20 | , forall x y. (Eq x, Eq y) => Eq (f x y) 21 | , forall x y. (Show x, Show y) => Show (f x y) 22 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws 23 | categoryLaws gen = Laws "Category" 24 | [ ("Left Identity", categoryLeftIdentity gen) 25 | , ("Right Identity", categoryRightIdentity gen) 26 | , ("Associativity", categoryAssociativity gen) 27 | ] 28 | 29 | -- | Tests the following 'Category' laws: 30 | -- 31 | -- [__Commutativity__]: @f '.' g@ ≡ @g '.' f@ 32 | commutativeCategoryLaws :: forall f. 33 | ( Category f 34 | , forall x y. (Eq x, Eq y) => Eq (f x y) 35 | , forall x y. (Show x, Show y) => Show (f x y) 36 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Laws 37 | commutativeCategoryLaws gen = Laws "Commutative Category" 38 | [ ("Commutativity", categoryCommutativity gen) 39 | ] 40 | 41 | categoryRightIdentity :: forall f. 42 | ( Category f 43 | , forall x y. (Eq x, Eq y) => Eq (f x y) 44 | , forall x y. (Show x, Show y) => Show (f x y) 45 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property 46 | categoryRightIdentity fgen = property $ do 47 | x <- forAll $ fgen genSmallInteger genSmallInteger 48 | (x . id) `heq2` x 49 | 50 | categoryLeftIdentity :: forall f. 51 | ( Category f 52 | , forall x y. (Eq x, Eq y) => Eq (f x y) 53 | , forall x y. (Show x, Show y) => Show (f x y) 54 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property 55 | categoryLeftIdentity fgen = property $ do 56 | x <- forAll $ fgen genSmallInteger genSmallInteger 57 | (id . x) `heq2` x 58 | 59 | categoryAssociativity :: forall f. 60 | ( Category f 61 | , forall x y. (Eq x, Eq y) => Eq (f x y) 62 | , forall x y. (Show x, Show y) => Show (f x y) 63 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property 64 | categoryAssociativity fgen = property $ do 65 | f <- forAll $ fgen genSmallInteger genSmallInteger 66 | g <- forAll $ fgen genSmallInteger genSmallInteger 67 | h <- forAll $ fgen genSmallInteger genSmallInteger 68 | (f . (g . h)) `heq2` ((f . g) . h) 69 | 70 | categoryCommutativity :: forall f. 71 | ( Category f 72 | , forall x y. (Eq x, Eq y) => Eq (f x y) 73 | , forall x y. (Show x, Show y) => Show (f x y) 74 | ) => (forall x y. Gen x -> Gen y -> Gen (f x y)) -> Property 75 | categoryCommutativity fgen = property $ do 76 | f <- forAll $ fgen genSmallInteger genSmallInteger 77 | g <- forAll $ fgen genSmallInteger genSmallInteger 78 | (f . g) `heq2` (g . f) 79 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common.hs: -------------------------------------------------------------------------------- 1 | module Hedgehog.Classes.Common 2 | ( module Common 3 | ) where 4 | 5 | import Hedgehog.Classes.Common.ApTrans as Common 6 | import Hedgehog.Classes.Common.Bottom as Common 7 | import Hedgehog.Classes.Common.Compat as Common 8 | import Hedgehog.Classes.Common.Equation as Common 9 | import Hedgehog.Classes.Common.Func as Common 10 | import Hedgehog.Classes.Common.Gen as Common 11 | import Hedgehog.Classes.Common.IO as Common 12 | import Hedgehog.Classes.Common.Laws as Common 13 | import Hedgehog.Classes.Common.Property as Common 14 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common/ApTrans.hs: -------------------------------------------------------------------------------- 1 | module Hedgehog.Classes.Common.ApTrans 2 | ( apTrans 3 | , toSpecialApplicative 4 | ) where 5 | 6 | import Data.Tuple (swap) 7 | import Data.Functor.Compose 8 | import qualified Data.Set as S 9 | import qualified Control.Monad.Trans.Writer.Lazy as WL 10 | 11 | import Hedgehog.Classes.Common.Func 12 | 13 | -- Reverse the list and accumulate the writers. We 14 | -- cannot use Sum or Product or else it won't actually 15 | -- be a valid applicative transformation. 16 | apTrans :: 17 | Compose Triple (WL.Writer (S.Set Integer)) a 18 | -> Compose (WL.Writer (S.Set Integer)) Triple a 19 | apTrans (Compose xs) = Compose (sequenceA (reverseTriple xs)) 20 | 21 | toSpecialApplicative :: 22 | Compose Triple ((,) (S.Set Integer)) Integer 23 | -> Compose Triple (WL.Writer (S.Set Integer)) Integer 24 | toSpecialApplicative (Compose (Triple a b c)) = 25 | Compose (Triple (WL.writer (swap a)) (WL.writer (swap b)) (WL.writer (swap c))) 26 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common/Bottom.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Hedgehog.Classes.Common.Bottom 4 | ( Bottom(..), genBottom 5 | ) where 6 | 7 | import Hedgehog 8 | import qualified Hedgehog.Gen as Gen 9 | 10 | data Bottom a = BottomUndefined | BottomValue a 11 | deriving (Eq) 12 | 13 | instance Show a => Show (Bottom a) where 14 | show = \case 15 | BottomUndefined -> "undefined" 16 | BottomValue a -> show a 17 | 18 | genBottom :: Gen a -> Gen (Bottom a) 19 | genBottom = fmap maybeToBottom . Gen.maybe 20 | 21 | maybeToBottom :: Maybe a -> Bottom a 22 | maybeToBottom = \case { Nothing -> BottomUndefined; Just a -> BottomValue a } 23 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuantifiedConstraints #-} 2 | 3 | module Hedgehog.Classes.Common.Compat 4 | ( readMaybe 5 | , eq 6 | , eq1 7 | , eq2 8 | 9 | , show1 10 | , show2 11 | 12 | , neq 13 | , neq1 14 | , neq2 15 | ) where 16 | 17 | import Text.Read (readMaybe) 18 | 19 | eq :: Eq a => a -> a -> Bool 20 | eq = (==) 21 | 22 | neq :: Eq a => a -> a -> Bool 23 | neq = (/=) 24 | 25 | eq1 :: (Eq a, forall x. Eq x => Eq (f x)) => f a -> f a -> Bool 26 | eq1 = (==) 27 | 28 | neq1 :: (Eq a, forall x. Eq x => Eq (f x)) => f a -> f a -> Bool 29 | neq1 = (/=) 30 | 31 | eq2 :: (Eq a, Eq b, forall x y. (Eq x, Eq y) => Eq (f x y)) => f a b -> f a b -> Bool 32 | eq2 = (==) 33 | 34 | neq2 :: (Eq a, Eq b, forall x y. (Eq x, Eq y) => Eq (f x y)) => f a b -> f a b -> Bool 35 | neq2 = (/=) 36 | 37 | show1 :: (Show a, forall x. (Show x) => Show (f x)) => f a -> String 38 | show1 = Prelude.show 39 | 40 | show2 :: (Show a, Show b, forall x y. (Show x, Show y) => Show (f x y)) => f a b -> String 41 | show2 = Prelude.show 42 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common/Equation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE QuantifiedConstraints #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | 8 | module Hedgehog.Classes.Common.Equation 9 | ( LinearEquation(..), runLinearEquation, genLinearEquation 10 | , LinearEquationTwo(..), runLinearEquationTwo, genLinearEquationTwo 11 | , LinearEquationM(..), runLinearEquationM, genLinearEquationM 12 | , QuadraticEquation(..), runQuadraticEquation, genQuadraticEquation 13 | , CubicEquation(..), runCubicEquation, genCubicEquation 14 | 15 | #ifdef HAVE_COMONAD 16 | , LinearEquationW(..), runLinearEquationW, genLinearEquationW 17 | #endif 18 | ) where 19 | 20 | import Hedgehog 21 | import Hedgehog.Classes.Common.Gen 22 | import qualified Hedgehog.Gen as Gen 23 | import qualified Hedgehog.Range as Range 24 | import qualified Data.List as List 25 | 26 | import Data.Monoid (Endo(..)) 27 | 28 | #ifdef HAVE_COMONAD 29 | import Control.Comonad 30 | #endif 31 | 32 | data QuadraticEquation = QuadraticEquation 33 | { _quadraticEquationQuadratic :: Integer 34 | , _quadraticEquationLinear :: Integer 35 | , _quadraticEquationConstant :: Integer 36 | } 37 | deriving (Eq) 38 | 39 | -- This show instance does not actually provide a way 40 | -- to create an equation. Instead, it makes it look 41 | -- like a lambda. 42 | instance Show QuadraticEquation where 43 | show (QuadraticEquation a b c) = "\\x -> " ++ show a ++ " * x ^ 2 + " ++ show b ++ " * x + " ++ show c 44 | 45 | genQuadraticEquation :: Gen QuadraticEquation 46 | genQuadraticEquation = do 47 | a <- Gen.integral (Range.linear 0 15) 48 | b <- Gen.integral (Range.linear 0 15) 49 | c <- Gen.integral (Range.linear 0 15) 50 | pure (QuadraticEquation a b c) 51 | 52 | runQuadraticEquation :: QuadraticEquation -> Integer -> Integer 53 | runQuadraticEquation (QuadraticEquation a b c) x = a * x ^ (2 :: Integer) + b * x + c 54 | 55 | data LinearEquation = LinearEquation 56 | { _linearEquationLinear :: Integer 57 | , _linearEquationConstant :: Integer 58 | } 59 | deriving (Eq) 60 | 61 | instance Show LinearEquation where 62 | showsPrec _ (LinearEquation a b) = shows a . showString " * x + " . shows b 63 | showList xs = appEndo 64 | $ mconcat 65 | $ [Endo (showChar '[')] 66 | ++ List.intersperse (Endo (showChar ',')) (map (Endo . showsPrec 0) xs) 67 | ++ [Endo (showChar ']')] 68 | 69 | runLinearEquation :: LinearEquation -> Integer -> Integer 70 | runLinearEquation (LinearEquation a b) x = a * x + b 71 | 72 | genLinearEquation :: Gen LinearEquation 73 | genLinearEquation = LinearEquation <$> genSmallInteger <*> genSmallInteger 74 | #ifdef HAVE_COMONAD 75 | data LinearEquationW w = LinearEquationW (w LinearEquation) (w LinearEquation) 76 | 77 | deriving instance (forall x. Eq x => Eq (w x)) => Eq (LinearEquationW w) 78 | instance (forall x. Show x => Show (w x)) => Show (LinearEquationW w) where 79 | show (LinearEquationW a b) = (\f -> f "") 80 | $ showString "\\x -> if odd x then " 81 | . showsPrec 0 a 82 | . showString " else " 83 | . showsPrec 0 b 84 | 85 | runLinearEquationW :: Comonad w 86 | => LinearEquationW w -> w Integer -> Integer 87 | runLinearEquationW (LinearEquationW e1 e2) (extract -> i) = if odd i 88 | then runLinearEquation (extract e1) i 89 | else runLinearEquation (extract e2) i 90 | 91 | genLinearEquationW :: Comonad w 92 | => (forall x. Gen x -> Gen (w x)) 93 | -> Gen (LinearEquationW w) 94 | genLinearEquationW fgen = LinearEquationW 95 | <$> fgen genLinearEquation 96 | <*> fgen genLinearEquation 97 | #endif 98 | 99 | data LinearEquationM m = LinearEquationM (m LinearEquation) (m LinearEquation) 100 | 101 | deriving instance (forall x. Eq x => Eq (m x)) => Eq (LinearEquationM m) 102 | 103 | instance (forall x. Show x => Show (m x)) => Show (LinearEquationM m) where 104 | show (LinearEquationM a b) = (\f -> f "") 105 | $ showString "\\x -> if odd x then " 106 | . showsPrec 0 a 107 | . showString " else " 108 | . showsPrec 0 b 109 | 110 | runLinearEquationM :: Functor m => LinearEquationM m -> Integer -> m Integer 111 | runLinearEquationM (LinearEquationM e1 e2) i = if odd i 112 | then fmap (flip runLinearEquation i) e1 113 | else fmap (flip runLinearEquation i) e2 114 | 115 | genLinearEquationM :: Applicative m => Gen (LinearEquationM m) 116 | genLinearEquationM = LinearEquationM <$> (pure <$> genLinearEquation) <*> (pure <$> genLinearEquation) 117 | 118 | data LinearEquationTwo = LinearEquationTwo 119 | { _linearEquationTwoX :: Integer 120 | , _linearEquationTwoY :: Integer 121 | , _linearEquationTwoConstant :: Integer 122 | } 123 | 124 | instance Show LinearEquationTwo where 125 | show (LinearEquationTwo x y c) = "\\x y -> " ++ show x ++ " * x + " ++ show y ++ " * y + " ++ show c 126 | 127 | genLinearEquationTwo :: Gen LinearEquationTwo 128 | genLinearEquationTwo = LinearEquationTwo <$> absGenInteger <*> absGenInteger <*> absGenInteger 129 | where 130 | absGenInteger = abs <$> genSmallInteger 131 | 132 | runLinearEquationTwo :: LinearEquationTwo -> Integer -> Integer -> Integer 133 | runLinearEquationTwo (LinearEquationTwo a b c) x y = a * x + b * y + c 134 | 135 | data CubicEquation = CubicEquation 136 | { _cubicEquationCubic :: Integer 137 | , _cubicEquationQuadratic :: Integer 138 | , _cubicEquationLinear :: Integer 139 | , _cubicEquationConstant :: Integer 140 | } 141 | 142 | instance Show CubicEquation where 143 | show (CubicEquation x y z c) = "\\x -> " ++ show x ++ " * x ^ 3 + " ++ show y ++ " * x ^ 2 + " ++ show z ++ " * x + " ++ show c 144 | 145 | genCubicEquation :: Gen CubicEquation 146 | genCubicEquation = CubicEquation <$> genSmallInteger <*> genSmallInteger <*> genSmallInteger <*> genSmallInteger 147 | 148 | runCubicEquation :: CubicEquation -> Integer -> Integer -> Integer -> Integer 149 | runCubicEquation (CubicEquation a b c d) x y z = a * x + b * y + c * z + d 150 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common/Func.hs: -------------------------------------------------------------------------------- 1 | module Hedgehog.Classes.Common.Func 2 | ( func1 3 | , func2 4 | , func3 5 | , func4 6 | , func5 7 | , func6 8 | 9 | , Triple(..), reverseTriple, genTriple 10 | ) where 11 | 12 | import Hedgehog 13 | import Data.Functor.Classes (Eq1(..), Show1(..)) 14 | import Data.Functor.Compose 15 | import qualified Data.Set as S 16 | import qualified Control.Monad.Trans.Writer.Lazy as WL 17 | import Data.Semigroup 18 | 19 | func1 :: Integer -> (Integer, Integer) 20 | func1 i = (div (i + 5) 3, i * i - 2 * i + 1) 21 | 22 | func2 :: (Integer, Integer) -> (Bool, Either Ordering Integer) 23 | func2 (a,b) = (odd a, if even a then Left (compare a b) else Right (b + 2)) 24 | 25 | func3 :: Integer -> Sum Integer 26 | func3 i = Sum (3 * i * i - 7 * i + 4) 27 | 28 | func4 :: Integer -> Compose Triple (WL.Writer (S.Set Integer)) Integer 29 | func4 i = Compose $ Triple 30 | (WL.writer (i * i, S.singleton (i * 7 + 5))) 31 | (WL.writer (i + 2, S.singleton (i * i + 3))) 32 | (WL.writer (i * 7, S.singleton 4)) 33 | 34 | func5 :: Integer -> Triple Integer 35 | func5 i = Triple (i + 2) (i * 3) (i * i) 36 | 37 | func6 :: Integer -> Triple Integer 38 | func6 i = Triple (i * i * i) (4 * i - 7) (i * i * i) 39 | 40 | reverseTriple :: Triple a -> Triple a 41 | reverseTriple (Triple a b c) = Triple c b a 42 | 43 | data Triple a = Triple a a a 44 | deriving (Show, Eq) 45 | 46 | instance Functor Triple where 47 | fmap f (Triple a b c) = Triple (f a) (f b) (f c) 48 | 49 | instance Applicative Triple where 50 | pure a = Triple a a a 51 | Triple f g h <*> Triple a b c = Triple (f a) (g b) (h c) 52 | 53 | instance Foldable Triple where 54 | foldMap f (Triple a b c) = f a <> f b <> f c 55 | 56 | instance Traversable Triple where 57 | traverse f (Triple a b c) = Triple <$> f a <*> f b <*> f c 58 | 59 | tripleLiftEq :: (a -> b -> Bool) -> Triple a -> Triple b -> Bool 60 | tripleLiftEq p (Triple a1 b1 c1) (Triple a2 b2 c2) = 61 | p a1 a2 && p b1 b2 && p c1 c2 62 | 63 | tripleLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Triple a -> ShowS 64 | tripleLiftShowsPrec elemShowsPrec _ p (Triple a b c) = showParen (p > 10) 65 | $ showString "Triple " 66 | . elemShowsPrec 11 a 67 | . showString " " 68 | . elemShowsPrec 11 b 69 | . showString " " 70 | . elemShowsPrec 11 c 71 | 72 | instance Eq1 Triple where 73 | liftEq = tripleLiftEq 74 | 75 | instance Show1 Triple where 76 | liftShowsPrec = tripleLiftShowsPrec 77 | 78 | genTriple :: Gen a -> Gen (Triple a) 79 | genTriple gen = Triple <$> gen <*> gen <*> gen 80 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common/Gen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Hedgehog.Classes.Common.Gen 4 | ( genSmallList 5 | , genVerySmallList 6 | , genSmallNonEmptyList 7 | , genShowReadPrecedence 8 | , genSmallString 9 | , genSmallInteger 10 | , genSmallSum 11 | , genCompose 12 | , genSetInteger 13 | 14 | -- * Used for 'Hedgehog.Classes.ixLaws' 15 | , genTuple 16 | , genTuple3 17 | , genInRange 18 | , genValidRange 19 | ) where 20 | 21 | import Data.Ix (Ix(..)) 22 | import Hedgehog 23 | import Data.Functor.Compose 24 | import qualified Data.Set as S 25 | import Data.Semigroup 26 | import qualified Hedgehog.Gen as Gen 27 | import qualified Hedgehog.Range as Range 28 | 29 | genSmallSum :: Gen (Sum Integer) 30 | genSmallSum = fmap Sum genSmallInteger 31 | 32 | genSmallInteger :: Gen Integer 33 | genSmallInteger = Gen.integral (Range.linear 0 20) 34 | 35 | genSmallNonEmptyList :: Gen a -> Gen [a] 36 | genSmallNonEmptyList gen = Gen.list (Range.linear 1 7) gen 37 | 38 | genSmallList :: Gen a -> Gen [a] 39 | genSmallList gen = Gen.list (Range.linear 0 6) gen 40 | 41 | genVerySmallList :: Gen a -> Gen [a] 42 | genVerySmallList gen = Gen.list (Range.linear 0 2) gen 43 | 44 | genSmallString :: Gen String 45 | genSmallString = Gen.string (Range.linear 0 6) Gen.ascii 46 | 47 | -- Haskell uses the operator precedences 0..9, the special function application 48 | -- precedence 10 and the precedence 11 for function arguments. Both show and 49 | -- read instances have to accept this range. According to the Haskell Language 50 | -- Report, the output of derived show instances in precedence context 11 has to 51 | -- be an atomic expression. 52 | genShowReadPrecedence :: Gen Int 53 | genShowReadPrecedence = Gen.element [0..11] 54 | 55 | genCompose :: forall f g a. Gen a -> (forall x. Gen x -> Gen (f x)) -> (forall x. Gen x -> Gen (g x)) -> Gen (Compose f g a) 56 | genCompose gen fgen ggen = Compose <$> fgen (ggen gen) 57 | 58 | genTuple :: Gen a -> Gen b -> Gen (a,b) 59 | genTuple a b = (,) <$> a <*> b 60 | 61 | genTuple3 :: Gen a -> Gen b -> Gen c -> Gen (a, b, c) 62 | genTuple3 gena genb genc = do 63 | a <- gena 64 | b <- genb 65 | c <- genc 66 | pure (a, b, c) 67 | 68 | genValidRange :: Ix a => Gen a -> Gen (a, a) 69 | genValidRange gen = do 70 | Gen.filter (\(l,u) -> l <= u) (genTuple gen gen) 71 | 72 | genInRange :: (Ix a) => Gen a -> Gen (a, a, a) 73 | genInRange gen = do 74 | Gen.filter (\(l,u,i) -> inRange (l,u) i) (genTuple3 gen gen gen) 75 | 76 | genSetInteger :: Gen (S.Set Integer) 77 | genSetInteger = do 78 | xs <- sequence $ fmap (const genSmallInteger) [1..10 :: Integer] 79 | pure $ foldMap S.singleton xs 80 | 81 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common/IO.hs: -------------------------------------------------------------------------------- 1 | module Hedgehog.Classes.Common.IO 2 | ( genIO 3 | , showIO 4 | ) where 5 | 6 | import Hedgehog 7 | import System.IO.Unsafe (unsafePerformIO) 8 | 9 | genIO :: Gen a -> Gen (IO a) 10 | genIO gen = fmap pure gen 11 | 12 | showIO :: Show a => IO a -> String 13 | showIO io = unsafePerformIO $ do 14 | x <- fmap show io 15 | let y = "IO " ++ x 16 | pure y 17 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common/PP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ImplicitParams #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | #if HAVE_QUANTIFIED_CONSTRAINTS 9 | {-# LANGUAGE QuantifiedConstraints #-} 10 | #endif 11 | 12 | -- | Reverse-engineered hedgehog internals that don't print out source locations. 13 | module Hedgehog.Classes.Common.PP 14 | ( ppResult 15 | , renderResult 16 | ) where 17 | 18 | import Control.Monad.IO.Class (MonadIO(..)) 19 | import Hedgehog.Internal.Report hiding (ppResult, renderResult) 20 | import Text.PrettyPrint.Annotated.WL (Doc) 21 | import qualified Hedgehog.Internal.Report as R 22 | import Hedgehog.Internal.Config (UseColor(..)) 23 | 24 | renderResult :: MonadIO m 25 | => Report Result 26 | -> m String 27 | renderResult x = renderDoc u =<< ppResult x 28 | where 29 | #if MIN_VERSION_hedgehog(1,0,2) 30 | u = EnableColor 31 | #else 32 | u = Just EnableColor 33 | #endif 34 | 35 | ppResult :: MonadIO m 36 | => Report Result 37 | -> m (Doc Markup) 38 | #if MIN_VERSION_hedgehog(1,2,0) 39 | ppResult r@(Report tests discards coverage seed status) = case status of 40 | Failed (FailureReport shrinks shrinkPath _mcoverage annots _mspan msg _mdiff footnotes) -> 41 | let failure = Failed $ FailureReport shrinks shrinkPath Nothing annots Nothing msg Nothing footnotes 42 | in R.ppResult Nothing (Report tests discards coverage seed failure) 43 | _ -> R.ppResult Nothing r 44 | #else 45 | ppResult r@(Report tests discards coverage status) = case status of 46 | Failed (FailureReport size seed shrinks _mcoverage annots _mspan msg _mdiff footnotes) -> 47 | let failure = Failed $ FailureReport size seed shrinks Nothing annots Nothing msg Nothing footnotes 48 | in R.ppResult Nothing (Report tests discards coverage failure) 49 | _ -> R.ppResult Nothing r 50 | #endif -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common/Property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ImplicitParams #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE QuantifiedConstraints #-} 8 | 9 | -- | This module exports hedgehog comparison tests 10 | -- that don't contain CallStack information, since this would 11 | -- expose library internals in error messages. 12 | module Hedgehog.Classes.Common.Property 13 | ( heq, heq1, heq2 14 | , heqCtx, heqCtx1, heqCtx2 15 | , hneq, hneq1, hneq2 16 | , hneqCtx, hneqCtx1, hneqCtx2 17 | , himplCtx 18 | , hLessThan, hGreaterThan 19 | , hLessThanCtx, hGreaterThanCtx 20 | , bar 21 | , Context(..) 22 | ) where 23 | 24 | import Control.Exception (SomeException(..), displayException) 25 | import Data.Typeable (typeOf) 26 | import GHC.Stack 27 | import Hedgehog.Classes.Common.Compat 28 | import Hedgehog.Internal.Exception (tryEvaluate) 29 | import Hedgehog.Internal.Property (MonadTest, liftTest, mkTest, success, discard, Failure(..), PropertyT) 30 | import Text.Show.Pretty (ppShow) 31 | import qualified Data.Char as Char 32 | import qualified Data.List as List 33 | 34 | bar :: String 35 | bar = "━━━" 36 | 37 | bar5 :: String 38 | bar5 = "━━━━━━━━━━━━━━━" 39 | 40 | evalNoSrc :: (MonadTest m, HasCallStack) => a -> m a 41 | evalNoSrc x = either (withFrozenCallStack failExceptionNoSrc) pure (tryEvaluate x) 42 | 43 | failWithNoSrc :: (MonadTest m, HasCallStack) => String -> m a 44 | failWithNoSrc msg = do 45 | liftTest $ mkTest (Left $ Failure Nothing msg Nothing, mempty) 46 | 47 | failExceptionNoSrc :: (MonadTest m, HasCallStack) => SomeException -> m a 48 | failExceptionNoSrc (SomeException x) = withFrozenCallStack $ 49 | failWithNoSrc $ unlines 50 | [ bar ++ " Exception: " ++ show (typeOf x) ++ " " ++ bar 51 | , List.dropWhileEnd Char.isSpace (displayException x) 52 | ] 53 | 54 | -- | You can provide a 'Context' to 'heqCtx','heqCtx1','heqCtx2','hneqCtx','hneqCtx1',or 'hneqCtx2'. The 'Context' is used to provide useful error messages in the event of a failure. 55 | data Context = NoContext | Context String 56 | 57 | contextToString :: Context -> String 58 | contextToString = \case 59 | NoContext -> "No Context provided." 60 | Context ctx -> bar ++ " Context " ++ bar ++ "\n" ++ ctx ++ "\n" ++ bar5 61 | 62 | failContext:: 63 | ( MonadTest m, HasCallStack 64 | ) => Context -> m () 65 | failContext ctx = withFrozenCallStack $ 66 | failWithNoSrc $ contextToString ctx 67 | 68 | -- | Fails the test with the given context if the right argument is 69 | -- less than or equal to the left. 70 | hLessThanCtx :: 71 | ( MonadTest m 72 | , Ord a 73 | , Show a 74 | , HasCallStack 75 | ) => a -> a -> Context -> m () 76 | hLessThanCtx x y ctx = do 77 | ok <- withFrozenCallStack $ evalNoSrc (x < y) 78 | if ok 79 | then success 80 | else withFrozenCallStack $ failContext ctx 81 | 82 | -- | Fails the test with the given context if the right argument is 83 | -- greater than or equal to the left. 84 | hGreaterThanCtx :: 85 | ( MonadTest m 86 | , Ord a 87 | , Show a 88 | , HasCallStack 89 | ) => a -> a -> Context -> m () 90 | hGreaterThanCtx x y ctx = do 91 | ok <- withFrozenCallStack $ evalNoSrc (x > y) 92 | if ok 93 | then success 94 | else withFrozenCallStack $ failContext ctx 95 | 96 | -- | Fails the test if the right argument is less than or equal to the left. 97 | -- see https://github.com/hedgehogqa/haskell-hedgehog/pull/196 98 | hLessThan :: (MonadTest m, Ord a, Show a, HasCallStack) => a -> a -> m () 99 | hLessThan x y = do 100 | ok <- withFrozenCallStack $ evalNoSrc (x < y) 101 | if ok 102 | then success 103 | else withFrozenCallStack $ failWithNoSrc $ unlines 104 | [ bar ++ "Not Less Than " ++ bar 105 | , ppShow x ++ " is not less than " ++ ppShow y 106 | ] 107 | 108 | -- | Fails the test if the right argument is greater than or equal to the left. 109 | -- see https://github.com/hedgehogqa/haskell-hedgehog/pull/196 110 | hGreaterThan :: (MonadTest m, Ord a, Show a, HasCallStack) => a -> a -> m () 111 | hGreaterThan x y = do 112 | ok <- withFrozenCallStack $ evalNoSrc (x > y) 113 | if ok 114 | then success 115 | else withFrozenCallStack $ failWithNoSrc $ unlines 116 | [ bar ++ "Not Greater Than " ++ bar 117 | , ppShow x ++ " is not greater than " ++ ppShow y 118 | ] 119 | 120 | infix 4 `hneq` 121 | 122 | -- | Passes the test if the given arguments are not equal. Otherwise fails 123 | -- with the given 'Context'. 124 | hneqCtx :: 125 | ( MonadTest m 126 | , HasCallStack 127 | , Eq a 128 | , Show a 129 | ) => a -> a -> Context -> m () 130 | hneqCtx x y ctx = do 131 | ok <- withFrozenCallStack $ evalNoSrc (x `neq` y) 132 | if ok 133 | then success 134 | else withFrozenCallStack $ failContext ctx 135 | 136 | -- | Passes the test if the given arguments are not equal. Otherwise fails 137 | -- with 'NoContext'. 138 | hneq :: 139 | ( MonadTest m 140 | , HasCallStack 141 | , Eq a 142 | , Show a 143 | ) => a -> a -> m () 144 | hneq x y = hneqCtx x y NoContext 145 | 146 | infix 4 `heq` 147 | 148 | -- | Passes the test if the given arguments are equal. Otherwise fails 149 | -- with the given 'Context'. 150 | heqCtx :: 151 | ( MonadTest m 152 | , HasCallStack 153 | , Eq a 154 | , Show a 155 | ) => a -> a -> Context -> m () 156 | heqCtx x y ctx = do 157 | ok <- withFrozenCallStack $ evalNoSrc (x `eq` y) 158 | if ok 159 | then success 160 | else withFrozenCallStack $ failContext ctx 161 | 162 | -- | Passes the test if the given arguments are equal. Otherwise fails 163 | -- with 'NoContext'. 164 | heq :: 165 | ( MonadTest m 166 | , HasCallStack 167 | , Eq a 168 | , Show a 169 | ) => a -> a -> m () 170 | heq x y = heqCtx x y NoContext 171 | 172 | infix 4 `heq1` 173 | 174 | -- | Passes the test if the given arguments are not equal. Otherwise fails 175 | -- with the given 'Context'. 176 | hneqCtx1 :: 177 | ( MonadTest m 178 | , HasCallStack 179 | , Eq a 180 | , Show a 181 | , forall x. Eq x => Eq (f x) 182 | , forall x. Show x => Show (f x) 183 | ) => f a -> f a -> Context -> m () 184 | hneqCtx1 x y ctx = do 185 | ok <- withFrozenCallStack $ evalNoSrc (x `neq1` y) 186 | if ok 187 | then success 188 | else withFrozenCallStack $ failContext ctx 189 | 190 | -- | Passes the test if the given arguments are not equal. Otherwise fails 191 | -- with 'NoContext'. 192 | hneq1 :: 193 | ( MonadTest m 194 | , HasCallStack 195 | , Eq a 196 | , Show a 197 | , forall x. Eq x => Eq (f x) 198 | , forall x. Show x => Show (f x) 199 | ) => f a -> f a -> m () 200 | hneq1 x y = hneqCtx1 x y NoContext 201 | 202 | -- | Passes the test if the given arguments are equal. Otherwise fails 203 | -- with the given 'Context'. 204 | heqCtx1 :: 205 | ( MonadTest m 206 | , HasCallStack 207 | , Eq a 208 | , Show a 209 | , forall x. Eq x => Eq (f x) 210 | , forall x. Show x => Show (f x) 211 | ) => f a -> f a -> Context -> m () 212 | heqCtx1 x y ctx = do 213 | ok <- withFrozenCallStack $ evalNoSrc (x `eq1` y) 214 | if ok 215 | then success 216 | else withFrozenCallStack $ failContext ctx 217 | 218 | -- | Passes the test if the given arguments are equal. Otherwise fails 219 | -- with 'NoContext'. 220 | heq1 :: 221 | ( MonadTest m 222 | , HasCallStack 223 | , Eq a 224 | , Show a 225 | , forall x. Eq x => Eq (f x) 226 | , forall x. Show x => Show (f x) 227 | ) => f a -> f a -> m () 228 | heq1 x y = heqCtx1 x y NoContext 229 | 230 | infix 4 `heq2` 231 | 232 | -- | Passes the test if the given arguments are equal. Otherwise fails 233 | -- with the given 'Context'. 234 | heqCtx2 :: 235 | ( MonadTest m 236 | , HasCallStack 237 | , Eq a 238 | , Eq b 239 | , Show a 240 | , Show b 241 | , forall x y. (Eq x, Eq y) => Eq (f x y) 242 | , forall x y. (Show x, Show y) => Show (f x y) 243 | ) => f a b -> f a b -> Context -> m () 244 | heqCtx2 x y ctx = do 245 | ok <- withFrozenCallStack $ evalNoSrc (x `eq2` y) 246 | if ok 247 | then success 248 | else withFrozenCallStack $ failContext ctx 249 | 250 | -- | Passes the test if the given arguments are equal. Otherwise fails 251 | -- with 'NoContext'. 252 | heq2 :: 253 | ( MonadTest m 254 | , HasCallStack 255 | , Eq a 256 | , Eq b 257 | , Show a 258 | , Show b 259 | , forall x y. (Eq x, Eq y) => Eq (f x y) 260 | , forall x y. (Show x, Show y) => Show (f x y) 261 | ) => f a b -> f a b -> m () 262 | heq2 x y = heqCtx2 x y NoContext 263 | 264 | infix 4 `hneq2` 265 | 266 | -- | Passes the test if the given arguments are not equal. Otherwise fails 267 | -- with the given 'Context'. 268 | hneqCtx2 :: 269 | ( MonadTest m 270 | , HasCallStack 271 | , Eq a 272 | , Eq b 273 | , Show a 274 | , Show b 275 | , forall x y. (Eq x, Eq y) => Eq (f x y) 276 | , forall x y. (Show x, Show y) => Show (f x y) 277 | ) => f a b -> f a b -> Context -> m () 278 | hneqCtx2 x y ctx = do 279 | ok <- withFrozenCallStack $ evalNoSrc (x `neq2` y) 280 | if ok 281 | then success 282 | else withFrozenCallStack $ failContext ctx 283 | 284 | -- | Passes the test if the given arguments are not equal. Otherwise fails 285 | -- with 'NoContext'. 286 | hneq2 :: 287 | ( MonadTest m 288 | , HasCallStack 289 | , Eq a 290 | , Eq b 291 | , Show a 292 | , Show b 293 | , forall x y. (Eq x, Eq y) => Eq (f x y) 294 | , forall x y. (Show x, Show y) => Show (f x y) 295 | ) => f a b -> f a b -> m () 296 | hneq2 x y = hneqCtx2 x y NoContext 297 | 298 | -- | Passes the test if the LHS implies the RHS. Otherwise fails with 299 | -- the given 'Context'. 300 | himplCtx :: 301 | ( Monad m 302 | , HasCallStack 303 | ) => Bool -> Bool -> Context -> PropertyT m () 304 | himplCtx False _ _ = discard 305 | himplCtx True b ctx = if b 306 | then success 307 | else withFrozenCallStack $ failContext ctx 308 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Common/Types.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | ConstraintKinds 3 | , KindSignatures 4 | , ImpredicativeTypes 5 | , QuantifiedConstraints 6 | , RankNTypes 7 | #-} 8 | 9 | module Hedgehog.Classes.Common.Types 10 | ( Ctx 11 | , Ctx1 12 | , Ctx2 13 | 14 | , Gen1 15 | , Gen2 16 | ) where 17 | 18 | import Hedgehog 19 | 20 | import Data.Kind (Type, Constraint) 21 | 22 | type Ctx (c :: Type -> Constraint) (a :: Type) 23 | = ( c a 24 | , Eq a 25 | , Show a 26 | ) 27 | 28 | type Ctx1 (c :: (Type -> Type) -> Constraint) (f :: Type -> Type) 29 | = (( c f 30 | , forall x. Eq x => Eq (f x) 31 | , forall x. Show x => Show (f x) 32 | ) :: Constraint) 33 | 34 | type Ctx2 (c :: (Type -> Type -> Type) -> Constraint) f 35 | = (( c f 36 | , forall x y. (Eq x, Eq y) => Eq (f x y) 37 | , forall x y. (Show x, Show y) => Show (f x y) 38 | ) :: Constraint) 39 | 40 | type Gen1 f = forall x. Gen x -> Gen (f x) 41 | 42 | type Gen2 f = forall x y. Gen x -> Gen y -> Gen (f x y) 43 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Contravariant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Hedgehog.Classes.Contravariant (contravariantLaws) where 6 | 7 | import Data.Functor.Contravariant (Contravariant(..)) 8 | 9 | import Hedgehog 10 | import Hedgehog.Classes.Common 11 | 12 | -- | Tests the following 'Contravariant' laws: 13 | -- 14 | -- [__Identity__]: @'contramap' 'id'@ ≡ @'id'@ 15 | -- [__Composition__]: @'contramap' f '.' 'contramap' g@ ≡ @'contramap' (g '.' f)@ 16 | contravariantLaws :: 17 | ( Contravariant f 18 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 19 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 20 | contravariantLaws gen = Laws "Contravariant" 21 | [ ("Identity", contravariantIdentity gen) 22 | , ("Composition", contravariantComposition gen) 23 | ] 24 | 25 | contravariantIdentity :: 26 | ( Contravariant f 27 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 28 | ) => (forall x. Gen x -> Gen (f x)) -> Property 29 | contravariantIdentity fgen = property $ do 30 | a <- forAll $ fgen genSmallInteger 31 | let lhs = contramap id a 32 | let rhs = id a 33 | let ctx = contextualise $ LawContext 34 | { lawContextLawName = "Identity", lawContextLawBody = "contramap id" `congruency` "id" 35 | , lawContextTcName = "Contravariant", lawContextTcProp = 36 | let showA = show a 37 | in lawWhere 38 | [ "contramap id x" `congruency` "id x, where" 39 | , "x = " ++ showA 40 | ] 41 | , lawContextReduced = reduced lhs rhs 42 | } 43 | heqCtx1 lhs rhs ctx 44 | 45 | contravariantComposition :: 46 | ( Contravariant f 47 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 48 | ) => (forall x. Gen x -> Gen (f x)) -> Property 49 | contravariantComposition fgen = property $ do 50 | a <- forAll $ fgen genSmallInteger 51 | f' <- forAll genQuadraticEquation 52 | g' <- forAll genQuadraticEquation 53 | let f = runQuadraticEquation f' 54 | let g = runQuadraticEquation g' 55 | let lhs = contramap f (contramap g a) 56 | let rhs = contramap (g . f) a 57 | let ctx = contextualise $ LawContext 58 | { lawContextLawName = "Composition", lawContextLawBody = "contramap f . contramap g" `congruency` "contramap (g . f)" 59 | , lawContextTcName = "Contravariant", lawContextTcProp = 60 | let showF = show f'; showG = show g'; showA = show a; 61 | in lawWhere 62 | [ "contramap f . contramap g $ a" `congruency` "contramap (g . f) a, where" 63 | , "f = " ++ showF 64 | , "g = " ++ showG 65 | , "a = " ++ showA 66 | ] 67 | , lawContextReduced = reduced lhs rhs 68 | } 69 | heqCtx1 lhs rhs ctx 70 | 71 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Enum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Hedgehog.Classes.Enum (enumLaws, boundedEnumLaws) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes.Common 7 | 8 | import qualified Hedgehog.Gen as Gen 9 | 10 | -- | Tests the following 'Enum' laws: 11 | -- 12 | -- [__Succ-Pred Identity__]: @'succ' '.' 'pred'@ ≡ @'id'@ 13 | -- [__Pred-Succ Identity__]: @'pred' '.' 'succ'@ ≡ @'id'@ 14 | enumLaws :: (Enum a, Eq a, Show a) => Gen a -> Laws 15 | enumLaws gen = Laws "Enum" 16 | [ ("Succ Pred Identity", succPredIdentity gen) 17 | , ("Pred Succ Identity", predSuccIdentity gen) 18 | ] 19 | 20 | -- | Tests the same laws as 'enumLaws', but uses the 'Bounded' 21 | -- constraint to ensure that 'succ' and 'pred' behave as though 22 | -- they are total. This should always be preferred if your type 23 | -- has a 'Bounded' instance. 24 | boundedEnumLaws :: (Bounded a, Enum a, Eq a, Show a) => Gen a -> Laws 25 | boundedEnumLaws gen = Laws "Bounded Enum" 26 | [ ("Succ Pred Identity", succPredBoundedIdentity gen) 27 | , ("Pred Succ Identity", predSuccBoundedIdentity gen) 28 | ] 29 | 30 | succPredIdentity :: forall a. (Enum a, Eq a, Show a) => Gen a -> Property 31 | succPredIdentity gen = property $ do 32 | x <- forAll gen 33 | let lhs = succ (pred x); rhs = x; 34 | let ctx = contextualise $ LawContext 35 | { lawContextLawName = "Succ-Pred Identity" 36 | , lawContextLawBody = "succ . pred" `congruency` "id" 37 | , lawContextTcName = "Enum" 38 | , lawContextTcProp = 39 | let showX = show x 40 | in lawWhere 41 | [ "succ . pred $ x" `congruency` "id x, where" 42 | , "x = " ++ showX 43 | ] 44 | , lawContextReduced = reduced lhs rhs 45 | } 46 | heqCtx lhs rhs ctx 47 | 48 | predSuccIdentity :: forall a. (Enum a, Eq a, Show a) => Gen a -> Property 49 | predSuccIdentity gen = property $ do 50 | x <- forAll gen 51 | let lhs = pred (succ x); rhs = x; 52 | let ctx = contextualise $ LawContext 53 | { lawContextLawName = "Pred-Succ Identity" 54 | , lawContextLawBody = "pred . succ" `congruency` "id" 55 | , lawContextTcName = "Enum" 56 | , lawContextTcProp = 57 | let showX = show x 58 | in lawWhere 59 | [ "pred . succ $ x" `congruency` "id x, where" 60 | , "x = " ++ showX 61 | ] 62 | , lawContextReduced = reduced lhs rhs 63 | } 64 | heqCtx lhs rhs ctx 65 | 66 | succPredBoundedIdentity :: forall a. (Bounded a, Enum a, Eq a, Show a) => Gen a -> Property 67 | succPredBoundedIdentity gen = property $ do 68 | x <- forAll $ Gen.filter (/= minBound) gen 69 | let lhs = succ (pred x); rhs = x; 70 | let ctx = contextualise $ LawContext 71 | { lawContextLawName = "Succ-Pred Identity" 72 | , lawContextLawBody = "succ . pred" `congruency` "id" 73 | , lawContextTcName = "Enum" 74 | , lawContextTcProp = 75 | let showX = show x 76 | in lawWhere 77 | [ "succ . pred $ x" `congruency` "id x, where" 78 | , "x = " ++ showX 79 | ] 80 | , lawContextReduced = reduced lhs rhs 81 | } 82 | heqCtx lhs rhs ctx 83 | 84 | predSuccBoundedIdentity :: forall a. (Bounded a, Enum a, Eq a, Show a) => Gen a -> Property 85 | predSuccBoundedIdentity gen = property $ do 86 | x <- forAll $ Gen.filter (/= maxBound) gen 87 | let lhs = pred (succ x); rhs = x; 88 | let ctx = contextualise $ LawContext 89 | { lawContextLawName = "Pred-Succ Identity" 90 | , lawContextLawBody = "pred . succ" `congruency` "id" 91 | , lawContextTcName = "Enum" 92 | , lawContextTcProp = 93 | let showX = show x 94 | in lawWhere 95 | [ "pred . succ $ x" `congruency` "id x, where" 96 | , "x = " ++ showX 97 | ] 98 | , lawContextReduced = reduced lhs rhs 99 | } 100 | heqCtx lhs rhs ctx 101 | 102 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Eq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Hedgehog.Classes.Eq (eqLaws) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes.Common 7 | 8 | -- | Tests the following 'Eq' laws: 9 | -- 10 | -- [__Reflexivity__]: @x '==' x@ ≡ @'True'@ 11 | -- [__Symmetry__]: @x '==' y@ ≡ @y '==' x@ 12 | -- [__Transitivity__]: @x '==' y '&&' y '==' z@ ≡ @x '==' z@ 13 | -- [__Negation__]: @x '/=' y@ ≡ @'not' (x '==' y)@ 14 | eqLaws :: (Eq a, Show a) => Gen a -> Laws 15 | eqLaws gen = Laws "Eq" 16 | [ ("Transitivity", eqTransitive gen) 17 | , ("Symmetry", eqSymmetric gen) 18 | , ("Reflexivity", eqReflexive gen) 19 | , ("Negation", eqNegation gen) 20 | ] 21 | 22 | eqTransitive :: forall a. (Eq a, Show a) => Gen a -> Property 23 | eqTransitive gen = property $ do 24 | a <- forAll gen 25 | b <- forAll gen 26 | c <- forAll gen 27 | let lhs = a == b && b == c; rhs = a == c 28 | let ctx = contextualise $ LawContext 29 | { lawContextLawName = "Transitivity", lawContextLawBody = "a == b ∧ b == c" `congruency` "a == c" 30 | , lawContextTcName = "Eq", lawContextTcProp = 31 | let showA = show a; showB = show b; showC = show c; 32 | in lawWhere 33 | [ "a == b ∧ b == c" `congruency` "a == c, where" 34 | , "a = " ++ showA 35 | , "b = " ++ showB 36 | , "c = " ++ showC 37 | ] 38 | , lawContextReduced = reduced lhs rhs 39 | } 40 | case a == b of 41 | True -> case b == c of { True -> heqCtx a c ctx; False -> hneqCtx a c ctx } 42 | False -> case b == c of { True -> hneqCtx a c ctx; False -> success } 43 | 44 | eqSymmetric :: forall a. (Eq a, Show a) => Gen a -> Property 45 | eqSymmetric gen = property $ do 46 | a <- forAll gen 47 | b <- forAll gen 48 | let lhs = a == b; rhs = b == a 49 | let ctx = contextualise $ LawContext 50 | { lawContextLawName = "Symmetry", lawContextLawBody = "a == b" `congruency` "b == a" 51 | , lawContextTcName = "Eq", lawContextTcProp = 52 | let showA = show a; showB = show b; 53 | in lawWhere 54 | [ "a == b" `congruency` "b == a, where" 55 | , "a = " ++ showA 56 | , "b = " ++ showB 57 | ] 58 | , lawContextReduced = reduced lhs rhs 59 | } 60 | heqCtx lhs rhs ctx 61 | 62 | eqReflexive :: forall a. (Eq a, Show a) => Gen a -> Property 63 | eqReflexive gen = property $ do 64 | a <- forAll gen 65 | let lhs = a 66 | let rhs = a 67 | let ctx = contextualise $ LawContext 68 | { lawContextLawName = "Reflexivity", lawContextLawBody = "a" `congruency` "a" 69 | , lawContextTcName = "Eq" 70 | , lawContextTcProp = let showA = show a in lawWhere [ "a" `congruency` "a, where", "a = " ++ showA ] 71 | , lawContextReduced = reduced a a 72 | } 73 | heqCtx lhs rhs ctx 74 | 75 | eqNegation :: forall a. (Eq a, Show a) => Gen a -> Property 76 | eqNegation gen = property $ do 77 | x <- forAll gen 78 | y <- forAll gen 79 | let lhs = x /= y 80 | let rhs = not (x == y) 81 | let ctx = contextualise $ LawContext 82 | { lawContextLawName = "Negation", lawContextLawBody = "x /= y" `congruency` "not (x == y)" 83 | , lawContextTcName = "Eq" 84 | , lawContextReduced = reduced lhs rhs 85 | , lawContextTcProp = 86 | let showX = show x; showY = show y; 87 | in lawWhere 88 | [ "x /= y" `congruency` "not (x == y), where" 89 | , "x = " ++ showX 90 | , "y = " ++ showY 91 | ] 92 | } 93 | heqCtx lhs rhs ctx 94 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Hedgehog.Classes.Functor (functorLaws) where 6 | 7 | import Hedgehog 8 | import Hedgehog.Classes.Common 9 | 10 | -- | Tests the following 'Functor' laws: 11 | -- 12 | -- [__Identity__]: @'fmap' 'id'@ ≡ @'id'@ 13 | -- [__Composition__]: @'fmap' f '.' 'fmap' g@ ≡ @'fmap' (f '.' g)@ 14 | -- [__Const__]: @'fmap' ('const' x)@ ≡ @x '<$'@ 15 | functorLaws :: 16 | ( Functor f 17 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 18 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 19 | functorLaws gen = Laws "Functor" 20 | [ ("Identity", functorIdentity gen) 21 | , ("Composition", functorComposition gen) 22 | , ("Const", functorConst gen) 23 | ] 24 | 25 | functorIdentity :: 26 | ( Functor f 27 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 28 | ) => (forall x. Gen x -> Gen (f x)) -> Property 29 | functorIdentity fgen = property $ do 30 | a <- forAll $ fgen genSmallInteger 31 | let lhs = fmap id a 32 | let rhs = id a 33 | let ctx = contextualise $ LawContext 34 | { lawContextLawName = "Identity", lawContextTcName = "Functor" 35 | , lawContextLawBody = "fmap id" `congruency` "id" 36 | , lawContextTcProp = 37 | let showA = show a 38 | in lawWhere 39 | [ "fmap id a" `congruency` "id a, where" 40 | , "a = " ++ showA 41 | ] 42 | , lawContextReduced = reduced lhs rhs 43 | } 44 | heqCtx lhs rhs ctx 45 | 46 | functorComposition :: 47 | ( Functor f 48 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 49 | ) => (forall x. Gen x -> Gen (f x)) -> Property 50 | functorComposition fgen = property $ do 51 | a <- forAll $ fgen genSmallInteger 52 | let f = func2; g = func1 53 | let lhs = fmap f (fmap g a) 54 | let rhs = fmap (f . g) a 55 | let ctx = contextualise $ LawContext 56 | { lawContextLawName = "Composition", lawContextTcName = "Functor" 57 | , lawContextLawBody = "fmap f . fmap g" `congruency` "fmap (f . g)" 58 | , lawContextTcProp = 59 | let showA = show a 60 | showF = "\\(a,b) -> (odd a, if even a then Left (compare a b) else Right (b + 2)" 61 | showG = "\\i -> (div (i + 5) 3, i * i - 2 * i + 1)" 62 | in lawWhere 63 | [ "fmap f . fmap g $ a" `congruency` "fmap (f . g) a, where" 64 | , "f = " ++ showF 65 | , "g = " ++ showG 66 | , "a = " ++ showA 67 | ] 68 | , lawContextReduced = reduced lhs rhs 69 | } 70 | heqCtx lhs rhs ctx 71 | 72 | functorConst :: 73 | ( Functor f 74 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 75 | ) => (forall x. Gen x -> Gen (f x)) -> Property 76 | functorConst fgen = property $ do 77 | a <- forAll $ fgen genSmallInteger 78 | let x = 'X' 79 | let lhs = fmap (const x) a 80 | let rhs = x <$ a 81 | let ctx = contextualise $ LawContext 82 | { lawContextLawName = "Const", lawContextTcName = "Functor" 83 | , lawContextLawBody = "fmap (const x)" `congruency` "x <$" 84 | , lawContextTcProp = 85 | let showA = show a 86 | showX = show x 87 | in lawWhere 88 | [ "fmap (const x) a" `congruency` "x <$ a, where" 89 | , "x = " ++ showX 90 | , "a = " ++ showA 91 | ] 92 | , lawContextReduced = reduced lhs rhs 93 | } 94 | heqCtx lhs rhs ctx 95 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE QuantifiedConstraints #-} 6 | 7 | module Hedgehog.Classes.Generic (genericLaws) where 8 | 9 | import Hedgehog 10 | import Hedgehog.Classes.Common 11 | 12 | import GHC.Generics (Generic(..)) 13 | 14 | -- | Tests the following 'Generic' laws: 15 | -- 16 | -- [__From-To Inverse__]: @'from' '.' 'to'@ ≡ @'id'@ 17 | -- [__To-From Inverse__]: @'to' '.' 'from'@ ≡ @'id'@ 18 | genericLaws :: 19 | ( Generic a, Eq a, Show a 20 | , Eq (Rep a x), Show (Rep a x) 21 | ) 22 | => Gen a 23 | -> Gen (Rep a x) 24 | -> Laws 25 | genericLaws gena genr = Laws "Generic" 26 | [ ("From-To inverse", fromToInverse gena genr) 27 | , ("To-From inverse", toFromInverse gena genr) 28 | ] 29 | 30 | fromToInverse :: forall a x. 31 | ( Generic a 32 | , Eq (Rep a x) 33 | , Show (Rep a x) 34 | ) => Gen a -> Gen (Rep a x) -> Property 35 | fromToInverse _gena genr = property $ do 36 | r <- forAll genr 37 | let lhs = r 38 | let rhs = from (to r :: a) 39 | let ctx = contextualise $ LawContext 40 | { lawContextLawName = "From-To inverse", lawContextTcName = "Generic" 41 | , lawContextLawBody = "from . to" `congruency` "id" 42 | , lawContextTcProp = 43 | let showR = show r 44 | in lawWhere 45 | [ "from . to $ r" `congruency` "id r, where" 46 | , "r = " ++ showR 47 | ] 48 | , lawContextReduced = reduced lhs rhs 49 | } 50 | heqCtx lhs rhs ctx 51 | 52 | toFromInverse :: forall a x. 53 | ( Generic a 54 | , Eq a 55 | , Show a 56 | ) => Gen a -> Gen (Rep a x) -> Property 57 | toFromInverse gena _genr = property $ do 58 | v <- forAll gena 59 | let lhs = to (from v) 60 | let rhs = v 61 | let ctx = contextualise $ LawContext 62 | { lawContextLawName = "To-From inverse", lawContextTcName = "Generic" 63 | , lawContextLawBody = "to . from" `congruency` "id" 64 | , lawContextTcProp = 65 | let showV = show v 66 | in lawWhere 67 | [ "to . from $ v" `congruency` "id v, where" 68 | , "v = " ++ showV 69 | ] 70 | , lawContextReduced = reduced lhs rhs 71 | } 72 | heqCtx lhs rhs ctx 73 | 74 | {- 75 | type Generic1Prop f = 76 | ( Generic1 f 77 | , forall x. Eq x => Eq (f x) 78 | , forall x. Show x => Show (f x) 79 | , forall x. Eq x => Eq (Rep1 f x) 80 | , forall x. Show x => Show (Rep1 f x) 81 | ) => (forall x. Gen x -> Gen (f x)) 82 | -> (forall x. Gen x -> Gen (Rep1 f x)) 83 | -> Property 84 | 85 | fromToInverse1 :: forall f. Generic1Prop f 86 | fromToInverse1 _genf genr = property $ do 87 | r <- forAll $ genr genSmallInteger 88 | r === (from1 (to1 r :: f Integer)) 89 | 90 | toFromInverse1 :: forall f. Generic1Prop f 91 | toFromInverse1 genf _genr = property $ do 92 | v <- forAll $ genf genSmallInteger 93 | v === (to1 . from1 $ v) 94 | -} 95 | 96 | {- 97 | generic1Laws :: 98 | ( Generic1 f 99 | , forall x. Eq x => Eq (f x) 100 | , forall x. Show x => Show (f x) 101 | , forall x. Eq x => Eq (Rep1 f x) 102 | , forall x. Show x => Show (Rep1 f x) 103 | ) => (forall x. Gen x -> Gen (f x)) 104 | -> (forall x. Gen x -> Gen (Rep1 f x)) 105 | -> Laws 106 | generic1Laws genf genr = Laws "Generic1" 107 | [ ("From1-To1 inverse", fromToInverse1 genf genr) 108 | , ("To1-From1 inverse", toFromInverse1 genf genr) 109 | ] 110 | -} 111 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Integral.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Hedgehog.Classes.Integral (integralLaws) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes.Common 7 | 8 | -- | Tests the following 'Integral' laws: 9 | -- 10 | -- [__Quotient Remainder__]: @'quot' x y '*' y '+' ('rem' x y)@ ≡ @x@ 11 | -- [__Division Modulus__]: @('div' x y) '*' y '+' ('mod' x y)@ ≡ @x@ 12 | -- [__Integer Roundtrip__]: @'fromInteger' '.' 'toInteger'@ ≡ @'id'@ 13 | integralLaws :: (Integral a, Show a) => Gen a -> Laws 14 | integralLaws gen = Laws "Integral" 15 | [ ("Quotient Remainder", integralQuotientRemainder gen) 16 | , ("Division Modulus", integralDivisionModulus gen) 17 | , ("Integer Roundtrip", integralIntegerRoundtrip gen) 18 | ] 19 | 20 | integralQuotientRemainder :: forall a. (Integral a, Show a) => Gen a -> Property 21 | integralQuotientRemainder gen = property $ do 22 | x <- forAll gen 23 | y <- forAll gen 24 | let lhs = (quot x y) * y + (rem x y) 25 | let rhs = x 26 | let ctx = contextualise $ LawContext 27 | { lawContextLawName = "Quotient Remainder", lawContextTcName = "Integral" 28 | , lawContextLawBody = "quot x y * y + (rem x y)" `congruency` "x" 29 | , lawContextTcProp = 30 | let showX = show x; showY = show y; 31 | in lawWhere 32 | [ "quot x y * y + (rem x y)" `congruency` "x, where" 33 | , "x = " ++ showX 34 | , "y = " ++ showY 35 | ] 36 | , lawContextReduced = reduced lhs rhs 37 | } 38 | heqCtx lhs rhs ctx 39 | 40 | integralDivisionModulus :: forall a. (Integral a, Show a) => Gen a -> Property 41 | integralDivisionModulus gen = property $ do 42 | x <- forAll gen 43 | y <- forAll gen 44 | let lhs = (div x y) * y + (mod x y) 45 | let rhs = x 46 | let ctx = contextualise $ LawContext 47 | { lawContextLawName = "Division Modulus", lawContextTcName = "Integral" 48 | , lawContextLawBody = "(div x y) * y + (mod x y)" `congruency` "x" 49 | , lawContextTcProp = 50 | let showX = show x; showY = show y; 51 | in lawWhere 52 | [ "(div x y) * y + (mod x y)" `congruency` "x, where" 53 | , "x = " ++ showX 54 | , "y = " ++ showY 55 | ] 56 | , lawContextReduced = reduced lhs rhs 57 | } 58 | heqCtx lhs rhs ctx 59 | 60 | integralIntegerRoundtrip :: forall a. (Integral a, Show a) => Gen a -> Property 61 | integralIntegerRoundtrip gen = property $ do 62 | x <- forAll gen 63 | let lhs = fromInteger (toInteger x) 64 | let rhs = x 65 | let ctx = contextualise $ LawContext 66 | { lawContextLawName = "Integer Roundtrip", lawContextTcName = "Integral" 67 | , lawContextLawBody = "fromInteger . toInteger" `congruency` "id" 68 | , lawContextTcProp = 69 | let showX = show x; 70 | in lawWhere 71 | [ "fromInteger . toInteger $ x" `congruency` "id x, where" 72 | , "x = " ++ showX 73 | ] 74 | , lawContextReduced = reduced lhs rhs 75 | } 76 | heqCtx lhs rhs ctx 77 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Ix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module Hedgehog.Classes.Ix (ixLaws) where 5 | 6 | import Hedgehog 7 | import Hedgehog.Classes.Common 8 | 9 | import Data.Ix (Ix(..)) 10 | 11 | ixLaws :: forall a. (Ix a, Eq a, Show a) => Gen a -> Laws 12 | ixLaws gen = Laws "Ix" 13 | [ ("InRange", ixInRange gen) 14 | , ("RangeIndex", ixRangeIndex gen) 15 | , ("MapIndexRange", ixMapIndexRange gen) 16 | , ("RangeSize", ixRangeSize gen) 17 | ] 18 | 19 | type IxProp a = 20 | ( Eq a 21 | , Ix a 22 | , Show a 23 | ) => Gen a -> Property 24 | 25 | ixInRange :: IxProp a 26 | ixInRange gen = property $ do 27 | (l,u) <- forAll $ genValidRange gen 28 | i <- forAll gen 29 | inRange (l,u) i === elem i (range (l,u)) 30 | 31 | ixRangeIndex :: IxProp a 32 | ixRangeIndex gen = property $ do 33 | (l,u,i) <- forAll $ genInRange gen 34 | range (l,u) !! index (l,u) i === i 35 | 36 | ixMapIndexRange :: IxProp a 37 | ixMapIndexRange gen = property $ do 38 | (l,u) <- forAll $ genValidRange gen 39 | map (index (l,u)) (range (l,u)) === [0 .. rangeSize (l,u) - 1] 40 | 41 | ixRangeSize :: IxProp a 42 | ixRangeSize gen = property $ do 43 | (l,u) <- forAll $ genValidRange gen 44 | rangeSize (l,u) === length (range (l,u)) 45 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Json.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | #ifndef HAVE_AESON 5 | 6 | module Hedgehog.Classes.Json () where 7 | 8 | #else 9 | 10 | module Hedgehog.Classes.Json (jsonLaws) where 11 | 12 | import Hedgehog 13 | import Hedgehog.Classes.Common 14 | import Data.Aeson (FromJSON, ToJSON(toJSON)) 15 | import qualified Data.Aeson as Aeson 16 | 17 | -- | Tests the following 'ToJSON' / 'FromJSON' laws: 18 | -- 19 | -- [__Encoding Partial Isomorphism__]: @'Aeson.decode' '.' 'Aeson.encode'@ ≡ @'Just'@ 20 | -- [__Encoding Equals Value__]: @'Aeson.decode' '.' 'Aeson.encode'@ ≡ @'Just' '.' 'Aeson.toJSON'@ 21 | jsonLaws :: (FromJSON a, ToJSON a, Eq a, Show a) => Gen a -> Laws 22 | jsonLaws gen = Laws "ToJSON/FromJSON" 23 | [ ("Partial Isomorphism", jsonEncodingPartialIsomorphism gen) 24 | , ("Encoding equals value", jsonEncodingEqualsValue gen) 25 | ] 26 | 27 | jsonEncodingPartialIsomorphism :: forall a. (ToJSON a, FromJSON a, Show a, Eq a) => Gen a -> Property 28 | jsonEncodingPartialIsomorphism gen = property $ do 29 | x <- forAll gen 30 | let encoded = Aeson.encode x 31 | let lhs = Aeson.decode encoded 32 | let rhs = Just x 33 | let ctx = contextualise $ LawContext 34 | { lawContextLawName = "Partial Isomorphism", lawContextTcName = "ToJSON/FromJSON" 35 | , lawContextLawBody = "decode . encode" `congruency` "Just" 36 | , lawContextTcProp = 37 | let showX = show x 38 | showEncoded = show encoded 39 | in lawWhere 40 | [ "decode . encode $ x" `congruency` "Just x, where" 41 | , "x = " ++ showX 42 | , "encode x = " ++ showEncoded 43 | ] 44 | , lawContextReduced = reduced lhs rhs 45 | } 46 | heqCtx lhs rhs ctx 47 | 48 | jsonEncodingEqualsValue :: forall a. (ToJSON a, Show a) => Gen a -> Property 49 | jsonEncodingEqualsValue gen = property $ do 50 | x <- forAll gen 51 | let encoded = Aeson.encode x 52 | let decoded = Aeson.decode encoded :: Maybe Aeson.Value 53 | let lhs = decoded 54 | let rhs = Just (toJSON x) 55 | let ctx = contextualise $ LawContext 56 | { lawContextLawName = "Encoding equals value", lawContextTcName = "ToJSON" 57 | , lawContextLawBody = "decode . encode" `congruency` "Just . toJSON" 58 | , lawContextTcProp = 59 | let showX = show x 60 | showEncoded = show encoded 61 | showDecoded = show decoded 62 | in lawWhere 63 | [ "decode . encode $ x" `congruency` "Just . toJSON, where" 64 | , "x = " ++ showX 65 | , "encoded = " ++ showEncoded 66 | , "decoded = " ++ showDecoded 67 | ] 68 | , lawContextReduced = reduced lhs rhs 69 | } 70 | heqCtx lhs rhs ctx 71 | 72 | #endif 73 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Hedgehog.Classes.Monad (monadLaws) where 6 | 7 | import Control.Monad (ap) 8 | 9 | import Hedgehog 10 | import Hedgehog.Classes.Common 11 | 12 | -- | Tests the following 'Monad' laws: 13 | -- 14 | -- [__Left Identity__]: @'return' a '>>=' k@ ≡ @k a@ 15 | -- [__Right Identity__]: @m '>>=' 'return'@ ≡ @m@ 16 | -- [__Associativity__]: @m '>>=' (\\x -> k x '>>=' h)@ ≡ @(m '>>=' k) '>>=' h@ 17 | -- [__Return__]: @'return'@ ≡ @'pure'@ 18 | -- [__Ap__]: @'ap' f x@ ≡ @f '<*>' x@ 19 | monadLaws :: 20 | ( Monad f 21 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 22 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 23 | monadLaws gen = Laws "Monad" 24 | [ ("Left Identity", monadLeftIdentity gen) 25 | , ("Right Identity", monadRightIdentity gen) 26 | , ("Associativity", monadAssociativity gen) 27 | , ("Return", monadReturn gen) 28 | , ("Ap", monadAp gen) 29 | ] 30 | 31 | type MonadProp f = 32 | ( Monad f 33 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 34 | ) => (forall x. Gen x -> Gen (f x)) -> Property 35 | 36 | monadLeftIdentity :: forall f. MonadProp f 37 | monadLeftIdentity _ = property $ do 38 | k' :: LinearEquationM f <- forAll genLinearEquationM 39 | a <- forAll $ genSmallInteger 40 | let k = runLinearEquationM k' 41 | 42 | let lhs = return a >>= k 43 | let rhs = k a 44 | let ctx = contextualise $ LawContext 45 | { lawContextLawName = "Left Identity", lawContextTcName = "Monad" 46 | , lawContextLawBody = "return a >>= k" `congruency` "k a" 47 | , lawContextReduced = reduced lhs rhs 48 | , lawContextTcProp = 49 | let showK = show k' 50 | showA = show a 51 | in lawWhere 52 | [ "return a >>= k" `congruency` "k a, where" 53 | , "k = " ++ showK 54 | , "a = " ++ showA 55 | ] 56 | } 57 | heqCtx1 lhs rhs ctx 58 | 59 | monadRightIdentity :: forall f. MonadProp f 60 | monadRightIdentity fgen = property $ do 61 | m <- forAll $ fgen genSmallInteger 62 | let lhs = m >>= return 63 | let rhs = m 64 | let ctx = contextualise $ LawContext 65 | { lawContextLawName = "Right Identity", lawContextTcName = "Monad" 66 | , lawContextLawBody = "m >>= return" `congruency` "m" 67 | , lawContextReduced = reduced lhs rhs 68 | , lawContextTcProp = 69 | let showM = show m 70 | in lawWhere 71 | [ "m >>= return" `congruency` "m, where" 72 | , "m = " ++ showM 73 | ] 74 | } 75 | heqCtx1 lhs rhs ctx 76 | 77 | monadAssociativity :: forall f. MonadProp f 78 | monadAssociativity fgen = property $ do 79 | m <- forAll $ fgen genSmallInteger 80 | k' :: LinearEquationM f <- forAll genLinearEquationM 81 | h' :: LinearEquationM f <- forAll genLinearEquationM 82 | let k = runLinearEquationM k' 83 | h = runLinearEquationM h' 84 | let lhs = m >>= (\x -> k x >>= h) 85 | let rhs = (m >>= k) >>= h 86 | let ctx = contextualise $ LawContext 87 | { lawContextLawName = "Associativity", lawContextTcName = "Monad" 88 | , lawContextLawBody = "m >>= (\\x -> k x >>= h)" `congruency` "(m >>= k) >>= h" 89 | , lawContextReduced = reduced lhs rhs 90 | , lawContextTcProp = 91 | let showM = show m 92 | showK = show k' 93 | showH = show h' 94 | in lawWhere 95 | [ "m >>= (\\x -> k x >>= h)" `congruency` "(m >>= k) >>= h, where" 96 | , "m = " ++ showM 97 | , "k = " ++ showK 98 | , "h = " ++ showH 99 | ] 100 | } 101 | heqCtx1 lhs rhs ctx 102 | 103 | monadReturn :: forall f. MonadProp f 104 | monadReturn _ = property $ do 105 | x <- forAll genSmallInteger 106 | let lhs = return x 107 | let rhs = pure x :: f Integer 108 | let ctx = contextualise $ LawContext 109 | { lawContextLawName = "Return", lawContextTcName = "Monad" 110 | , lawContextLawBody = "return" `congruency` "pure" 111 | , lawContextReduced = reduced lhs rhs 112 | , lawContextTcProp = 113 | let showX = show x 114 | in lawWhere 115 | [ "return x" `congruency` "pure x, where" 116 | , "x = " ++ showX 117 | ] 118 | } 119 | heqCtx1 lhs rhs ctx 120 | 121 | monadAp :: forall f. MonadProp f 122 | monadAp _ = property $ do 123 | f' :: f QuadraticEquation <- forAll $ pure <$> genQuadraticEquation 124 | x :: f Integer <- forAll $ pure <$> genSmallInteger 125 | let f = fmap runQuadraticEquation f' 126 | 127 | let lhs = ap f x 128 | let rhs = f <*> x 129 | let ctx = contextualise $ LawContext 130 | { lawContextLawName = "Ap", lawContextTcName = "Monad" 131 | , lawContextLawBody = "ap f" `congruency` "f <*>" 132 | , lawContextReduced = reduced lhs rhs 133 | , lawContextTcProp = 134 | let showX = show x 135 | showF = show f' 136 | in lawWhere 137 | [ "ap f x" `congruency` "f <*> x, where" 138 | , "f = " ++ showF 139 | , "x = " ++ showX 140 | ] 141 | } 142 | heqCtx1 lhs rhs ctx 143 | 144 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/MonadFix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE QuantifiedConstraints #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | 6 | module Hedgehog.Classes.MonadFix (monadFixLaws) where 7 | 8 | import Control.Monad.Fix (MonadFix(..)) 9 | import Data.Function (fix) 10 | 11 | import Hedgehog 12 | import Hedgehog.Classes.Common 13 | 14 | monadFixLaws :: 15 | ( MonadFix f 16 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 17 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 18 | monadFixLaws gen = Laws "MonadFix" 19 | [ ("Purity", monadFixPurity gen) 20 | , ("Left Shrinking (or Tightening)", monadFixLeftShrinking gen) 21 | , ("Sliding", monadFixSliding gen) 22 | , ("Nesting", monadFixNesting gen) 23 | ] 24 | 25 | type MonadFixProp f = 26 | ( MonadFix f 27 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 28 | ) => (forall x. Gen x -> Gen (f x)) -> Property 29 | 30 | monadFixPurity :: forall f. MonadFixProp f 31 | monadFixPurity _ = property $ do 32 | h' <- forAll genQuadraticEquation 33 | let h = runQuadraticEquation h' 34 | let x = mfix (pure . h) :: f Integer 35 | let y = pure (fix h) :: f Integer 36 | x === y 37 | 38 | monadFixLeftShrinking :: forall f. MonadFixProp f 39 | monadFixLeftShrinking fgen = property $ do 40 | a <- forAll $ fgen genSmallInteger 41 | f' <- forAll genLinearEquationTwo 42 | let f a' b' = pure $ runLinearEquationTwo f' a' b' 43 | let x' = mfix (\x -> a >>= \y -> f x y) :: f Integer 44 | let y' = a >>= \y -> mfix (\x -> f x y) :: f Integer 45 | x' === y' 46 | 47 | monadFixSliding :: forall f. MonadFixProp f 48 | monadFixSliding _ = property $ do 49 | f' <- forAll genQuadraticEquation 50 | let f = pure . runQuadraticEquation f' 51 | let h !i = let !x = i*i + 7 in x 52 | let x' = mfix (fmap h . f) :: f Integer 53 | let y' = fmap h (mfix (f . h)) :: f Integer 54 | 55 | x' === y' 56 | 57 | monadFixNesting :: forall f. MonadFixProp f 58 | monadFixNesting _ = property $ do 59 | f' <- forAll genLinearEquationTwo 60 | let f a' b' = pure $ runLinearEquationTwo f' a' b' 61 | let x' = mfix (\x -> mfix (\y -> f x y)) :: f Integer 62 | let y' = mfix (\x -> f x x) :: f Integer 63 | x' === y' 64 | 65 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/MonadIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Hedgehog.Classes.MonadIO (monadIOLaws) where 6 | 7 | import Control.Monad.IO.Class (MonadIO(..)) 8 | 9 | import Hedgehog 10 | import Hedgehog.Classes.Common 11 | 12 | -- | Tests the following 'MonadIO' laws: 13 | -- 14 | -- [__Return__]: @'liftIO' '.' 'return'@ ≡ @'return'@ 15 | -- [__Lift__]: @'liftIO' (m '>>=' f)@ ≡ @'liftIO' m '>>=' ('liftIO' '.' f)@ 16 | monadIOLaws :: 17 | ( MonadIO f 18 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 19 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 20 | monadIOLaws gen = Laws "MonadIO" 21 | [ ("Return", monadIOReturn gen) 22 | , ("Lift", monadIOLift gen) 23 | ] 24 | 25 | type MonadIOProp f = 26 | ( MonadIO f 27 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 28 | ) => (forall x. Gen x -> Gen (f x)) -> Property 29 | 30 | monadIOReturn :: forall f. MonadIOProp f 31 | monadIOReturn _fgen = property $ do 32 | x <- forAll genSmallInteger 33 | let lhs = liftIO (return x) 34 | let rhs = return x :: f Integer 35 | let ctx = contextualise $ LawContext 36 | { lawContextLawName = "Return", lawContextTcName = "MonadIO" 37 | , lawContextLawBody = "liftIO . return" `congruency` "return" 38 | , lawContextReduced = reduced lhs rhs 39 | , lawContextTcProp = 40 | let showX = show x 41 | in lawWhere 42 | [ "liftIO . return $ x" `congruency` "return x, where" 43 | , "x = " ++ showX 44 | ] 45 | } 46 | heqCtx1 lhs rhs ctx 47 | 48 | monadIOLift :: forall f. MonadIOProp f 49 | monadIOLift _fgen = property $ do 50 | m <- forAllWith showIO $ genIO genSmallInteger 51 | f' <- forAll genLinearEquation 52 | let f = pure . runLinearEquation f' 53 | let lhs = liftIO (m >>= f) :: f Integer 54 | let rhs = liftIO m >>= (liftIO . f) :: f Integer 55 | let ctx = contextualise $ LawContext 56 | { lawContextLawName = "Lift", lawContextTcName = "MonadIO" 57 | , lawContextLawBody = "liftIO (m >>= f)" `congruency` "liftIO m >>= (liftIO . f)" 58 | , lawContextReduced = reduced lhs rhs 59 | , lawContextTcProp = 60 | let showM = showIO m 61 | showF = show f' 62 | in lawWhere 63 | [ "liftIO (m >>= f)" `congruency` "liftIO m >>= (liftIO . f), where" 64 | , "f = " ++ showF 65 | , "m = " ++ showM 66 | ] 67 | } 68 | heqCtx1 lhs rhs ctx 69 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/MonadPlus.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Hedgehog.Classes.MonadPlus (monadPlusLaws) where 6 | 7 | import Control.Monad (MonadPlus(..)) 8 | 9 | import Hedgehog 10 | import Hedgehog.Classes.Common 11 | 12 | -- | Tests the following 'MonadPlus' laws: 13 | -- 14 | -- [__Left Identity__]: @'mplus' 'mzero'@ ≡ @'id'@ 15 | -- [__Right Identity__]: @'flip' 'mplus' 'mzero'@ ≡ @'id'@ 16 | -- [__Associativity__]: @'mplus' a ('mplus' b c)@ ≡ @'mplus' ('mplus' a b) c@ 17 | -- [__Left Zero__]: @'mzero' '>>=' f@ ≡ @'mzero'@ 18 | -- [__Right Zero__]: @v '>>' 'mzero'@ ≡ @'mzero'@ 19 | monadPlusLaws :: 20 | ( MonadPlus f 21 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 22 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 23 | monadPlusLaws gen = Laws "MonadPlus" 24 | [ ("Left Identity", monadPlusLeftIdentity gen) 25 | , ("Right Identity", monadPlusRightIdentity gen) 26 | , ("Associativity", monadPlusAssociativity gen) 27 | , ("Left Zero", monadPlusLeftZero gen) 28 | , ("Right Zero", monadPlusRightZero gen) 29 | ] 30 | 31 | type MonadPlusProp f = 32 | ( MonadPlus f 33 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 34 | ) => (forall x. Gen x -> Gen (f x)) -> Property 35 | 36 | monadPlusLeftIdentity :: forall f. MonadPlusProp f 37 | monadPlusLeftIdentity fgen = property $ do 38 | x <- forAll $ fgen genSmallInteger 39 | let lhs = mplus mzero x 40 | let rhs = x 41 | let ctx = contextualise $ LawContext 42 | { lawContextLawName = "Left Identity", lawContextTcName = "MonadPlus" 43 | , lawContextLawBody = "mplus mzero" `congruency` "id" 44 | , lawContextReduced = reduced lhs rhs 45 | , lawContextTcProp = 46 | let showX = show x; showMZero = show (mzero :: f Integer); 47 | in lawWhere 48 | [ "mplus mzero x" `congruency` "id x, where" 49 | , "x = " ++ showX 50 | , "mzero = " ++ showMZero 51 | ] 52 | } 53 | heqCtx1 lhs rhs ctx 54 | 55 | monadPlusRightIdentity :: forall f. MonadPlusProp f 56 | monadPlusRightIdentity fgen = property $ do 57 | x <- forAll $ fgen genSmallInteger 58 | let lhs = mplus x mzero 59 | let rhs = x 60 | let ctx = contextualise $ LawContext 61 | { lawContextLawName = "Right Identity", lawContextTcName = "MonadPlus" 62 | , lawContextLawBody = "flip mplus mzero" `congruency` "id" 63 | , lawContextReduced = reduced lhs rhs 64 | , lawContextTcProp = 65 | let showX = show x; showMZero = show (mzero :: f Integer); 66 | in lawWhere 67 | [ "mplus x mzero" `congruency` "id x, where" 68 | , "x = " ++ showX 69 | , "mzero = " ++ showMZero 70 | ] 71 | } 72 | heqCtx1 lhs rhs ctx 73 | 74 | monadPlusAssociativity :: forall f. MonadPlusProp f 75 | monadPlusAssociativity fgen = property $ do 76 | a <- forAll $ fgen genSmallInteger 77 | b <- forAll $ fgen genSmallInteger 78 | c <- forAll $ fgen genSmallInteger 79 | let lhs = mplus a (mplus b c) 80 | let rhs = mplus (mplus a b) c 81 | let ctx = contextualise $ LawContext 82 | { lawContextLawName = "Associativity", lawContextTcName = "MonadPlus" 83 | , lawContextLawBody = "mplus a (mplus b c)" `congruency` "mplus (mplus a b) c" 84 | , lawContextReduced = reduced lhs rhs 85 | , lawContextTcProp = 86 | let showA = show a; showB = show b; showC = show c; 87 | in lawWhere 88 | [ "mplus a (mplus b c)" `congruency` "mplus (mplus a b) c, where" 89 | , "a = " ++ showA 90 | , "b = " ++ showB 91 | , "c = " ++ showC 92 | ] 93 | } 94 | heqCtx1 lhs rhs ctx 95 | 96 | monadPlusLeftZero :: forall f. MonadPlusProp f 97 | monadPlusLeftZero _ = property $ do 98 | k' :: LinearEquationM f <- forAll genLinearEquationM 99 | let lhs = mzero >>= runLinearEquationM k' 100 | let rhs = mzero 101 | let ctx = contextualise $ LawContext 102 | { lawContextLawName = "Left Zero", lawContextTcName = "MonadPlus" 103 | , lawContextLawBody = "mzero >>= f" `congruency` "mzero" 104 | , lawContextReduced = reduced lhs rhs 105 | , lawContextTcProp = 106 | let showF = show k'; showMZero = show (mzero :: f Integer); 107 | in lawWhere 108 | [ "mzero >>= f" `congruency` "mzero, where" 109 | , "f = " ++ showF 110 | , "mzero = " ++ showMZero 111 | ] 112 | } 113 | heqCtx1 lhs rhs ctx 114 | 115 | monadPlusRightZero :: forall f. MonadPlusProp f 116 | monadPlusRightZero fgen = property $ do 117 | v <- forAll $ fgen genSmallInteger 118 | let lhs = v >> (mzero :: f Integer) 119 | let rhs = mzero 120 | let ctx = contextualise $ LawContext 121 | { lawContextLawName = "Right Zero", lawContextTcName = "MonadPlus" 122 | , lawContextLawBody = "v >> mzero" `congruency` "mzero" 123 | , lawContextReduced = reduced lhs rhs 124 | , lawContextTcProp = 125 | let showV = show v; showMZero = show (mzero :: f Integer); 126 | in lawWhere 127 | [ "v >> mzero" `congruency` "mzero, where" 128 | , "v = " ++ showV 129 | , "mzero = " ++ showMZero 130 | ] 131 | } 132 | heqCtx1 lhs rhs ctx 133 | 134 | 135 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/MonadZip.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | 5 | module Hedgehog.Classes.MonadZip (monadZipLaws) where 6 | 7 | import Control.Arrow (Arrow(..)) 8 | import Control.Monad.Zip (MonadZip(mzip)) 9 | 10 | import Hedgehog 11 | import Hedgehog.Classes.Common 12 | 13 | -- | Tests the following 'MonadZip' laws: 14 | -- 15 | -- [__Naturality__]: @'fmap' (f '***' g) ('mzip' ma mb)@ ≡ @'mzip' ('fmap' f ma) ('fmap' g mb)@ 16 | monadZipLaws :: 17 | ( MonadZip f 18 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 19 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 20 | monadZipLaws gen = Laws "Monad" 21 | [ ("Naturality", monadZipNaturality gen) 22 | ] 23 | 24 | type MonadZipProp f = 25 | ( MonadZip f 26 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 27 | ) => (forall x. Gen x -> Gen (f x)) -> Property 28 | 29 | monadZipNaturality :: forall f. MonadZipProp f 30 | monadZipNaturality fgen = property $ do 31 | f' <- forAll genLinearEquation 32 | g' <- forAll genLinearEquation 33 | let f = runLinearEquation f' 34 | g = runLinearEquation g' 35 | ma <- forAll $ fgen genSmallInteger 36 | mb <- forAll $ fgen genSmallInteger 37 | let lhs = fmap (f *** g) (mzip ma mb) 38 | let rhs = mzip (fmap f ma) (fmap g mb) 39 | let ctx = contextualise $ LawContext 40 | { lawContextLawName = "Naturality", lawContextTcName = "MonadZip" 41 | , lawContextLawBody = "(fmap (f *** g) (mzip ma mb)" `congruency` "mzip (fmap f ma) (fmap g mb)" 42 | , lawContextReduced = reduced lhs rhs 43 | , lawContextTcProp = 44 | let showF = show f'; showG = show g'; showMA = show ma; showMB = show mb; 45 | in lawWhere 46 | [ "fmap (f *** g) (mzip ma mb)" `congruency` "mzip (fmap f ma) (fmap g mb), where" 47 | , "f = " ++ showF 48 | , "g = " ++ showG 49 | , "ma = " ++ showMA 50 | , "mb = " ++ showMB 51 | ] 52 | } 53 | heqCtx1 lhs rhs ctx 54 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Monoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Hedgehog.Classes.Monoid (monoidLaws, commutativeMonoidLaws) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes.Common 7 | 8 | -- | Tests the following 'Monoid' laws: 9 | -- 10 | -- [__Left Identity__]: @'mappend' 'mempty'@ ≡ @'id'@ 11 | -- [__Right Identity__]: @'flip' 'mappend' 'mempty'@ ≡ @'id'@ 12 | -- [__Associativity__]: @'mappend' a ('mappend' b c)@ ≡ @'mappend' ('mappend' a b) c@ 13 | -- [__Concatenation__]: @'mconcat'@ ≡ @'foldr' 'mappend' 'mempty'@ 14 | monoidLaws :: (Eq a, Monoid a, Show a) => Gen a -> Laws 15 | monoidLaws gen = Laws "Monoid" 16 | [ ("Left Identity", monoidLeftIdentity gen) 17 | , ("Right Identity", monoidRightIdentity gen) 18 | , ("Associativity", monoidAssociative gen) 19 | , ("Concatenation", monoidConcatenation gen) 20 | ] 21 | 22 | -- | Tests the following 'Monoid' laws: 23 | -- 24 | -- [__Commutativity__]: @'mappend' a b@ ≡ @'mappend' b a@ 25 | commutativeMonoidLaws :: (Eq a, Monoid a, Show a) => Gen a -> Laws 26 | commutativeMonoidLaws gen = Laws "Commutative Monoid" 27 | [ ("Commutativity", monoidCommutative gen) 28 | ] 29 | 30 | monoidConcatenation :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property 31 | monoidConcatenation gen = property $ do 32 | as <- forAll $ genSmallList gen 33 | let lhs = mconcat as 34 | let rhs = foldr mappend mempty as 35 | let ctx = contextualise $ LawContext 36 | { lawContextLawName = "Concatenation", lawContextTcName = "Monoid" 37 | , lawContextLawBody = "mconcat" `congruency` "foldr mappend mempty" 38 | , lawContextReduced = reduced lhs rhs 39 | , lawContextTcProp = 40 | let showAS = show as; showMempty = show (mempty :: a); 41 | in lawWhere 42 | [ "mconcat as" `congruency` "foldr mappend mempty as, where" 43 | , "as = " ++ showAS 44 | , "mempty = " ++ showMempty 45 | ] 46 | } 47 | heqCtx lhs rhs ctx 48 | 49 | monoidAssociative :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property 50 | monoidAssociative gen = property $ do 51 | a <- forAll gen 52 | b <- forAll gen 53 | c <- forAll gen 54 | let lhs = mappend a (mappend b c) 55 | let rhs = mappend (mappend a b) c 56 | let ctx = contextualise $ LawContext 57 | { lawContextLawName = "Associativity", lawContextTcName = "Monoid" 58 | , lawContextLawBody = "mappend a (mappend b c)" `congruency` "mappend (mappend a b) c" 59 | , lawContextReduced = reduced lhs rhs 60 | , lawContextTcProp = 61 | let showA = show a; showB = show b; showC = show c; 62 | in lawWhere 63 | [ "mappend a (mappend b c)" `congruency` "mappend (mappend a b) c, where" 64 | , "a = " ++ showA 65 | , "b = " ++ showB 66 | , "c = " ++ showC 67 | ] 68 | } 69 | heqCtx lhs rhs ctx 70 | 71 | monoidLeftIdentity :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property 72 | monoidLeftIdentity gen = property $ do 73 | a <- forAll gen 74 | let lhs = mappend mempty a 75 | let rhs = a 76 | let ctx = contextualise $ LawContext 77 | { lawContextLawName = "Left Identity", lawContextTcName = "Monoid" 78 | , lawContextLawBody = "mappend mempty" `congruency` "id" 79 | , lawContextReduced = reduced lhs rhs 80 | , lawContextTcProp = 81 | let showA = show a; showMempty = show (mempty :: a); 82 | in lawWhere 83 | [ "mappend mempty a" `congruency` "a, where" 84 | , "a = " ++ showA 85 | , "mempty = " ++ showMempty 86 | ] 87 | } 88 | heqCtx lhs rhs ctx 89 | 90 | monoidRightIdentity :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property 91 | monoidRightIdentity gen = property $ do 92 | a <- forAll gen 93 | let lhs = mappend a mempty 94 | let rhs = a 95 | let ctx = contextualise $ LawContext 96 | { lawContextLawName = "Right Identity", lawContextTcName = "Monoid" 97 | , lawContextLawBody = "flip mappend mempty" `congruency` "id" 98 | , lawContextReduced = reduced lhs rhs 99 | , lawContextTcProp = 100 | let showA = show a; showMempty = show (mempty :: a); 101 | in lawWhere 102 | [ "mappend a mempty" `congruency` "a, where" 103 | , "a = " ++ showA 104 | , "mempty = " ++ showMempty 105 | ] 106 | } 107 | heqCtx lhs rhs ctx 108 | 109 | monoidCommutative :: forall a. (Eq a, Monoid a, Show a) => Gen a -> Property 110 | monoidCommutative gen = property $ do 111 | a <- forAll gen 112 | b <- forAll gen 113 | let lhs = mappend a b 114 | let rhs = mappend b a 115 | let ctx = contextualise $ LawContext 116 | { lawContextLawName = "Commutativity", lawContextTcName = "Monoid (Commutative)" 117 | , lawContextLawBody = "mappend" `congruency` "flip mappend" 118 | , lawContextReduced = reduced lhs rhs 119 | , lawContextTcProp = 120 | let showA = show a; showB = show b; 121 | in lawWhere 122 | [ "mappend a b" `congruency` "mappend b a, where" 123 | , "a = " ++ showA 124 | , "b = " ++ showB 125 | ] 126 | } 127 | heqCtx lhs rhs ctx 128 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Ord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Hedgehog.Classes.Ord (ordLaws) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes.Common 7 | 8 | -- | Tests the following 'Ord' laws: 9 | -- 10 | -- [__Antisymmetry__]: @x '<=' y '&&' y '<=' x@ ≡ @x '==' y@ 11 | -- [__Transitivity__]: @x '<=' y '&&' y '<=' z@ ≡ @x '<=' z@ 12 | -- [__Reflexivity__]: @x '<=' x@ ≡ @'True'@ 13 | -- [__Totality__]: @x '<=' y '||' y '<=' x@ ≡ @'True'@ 14 | ordLaws :: forall a. (Ord a, Show a) => Gen a -> Laws 15 | ordLaws gen = Laws "Ord" 16 | [ ("Antisymmetry", ordAntisymmetric gen) 17 | , ("Transitivity", ordTransitive gen) 18 | , ("Reflexivity", ordReflexive gen) 19 | , ("Totality", ordTotal gen) 20 | ] 21 | 22 | ordAntisymmetric :: forall a. (Ord a, Show a) => Gen a -> Property 23 | ordAntisymmetric gen = property $ do 24 | a <- forAll gen 25 | b <- forAll gen 26 | let lhs = (a <= b) && (b <= a) 27 | let rhs = a == b 28 | let ctx = contextualise $ LawContext 29 | { lawContextLawName = "Antisymmetry", lawContextTcName = "Ord" 30 | , lawContextLawBody = "x <= y && y <= x" `congruency` "x == y" 31 | , lawContextReduced = reduced lhs rhs 32 | , lawContextTcProp = 33 | let showA = show a; showB = show b; 34 | in lawWhere 35 | [ "x <= y && y <= x" `congruency` "x == y, where" 36 | , "x = " ++ showA 37 | , "y = " ++ showB 38 | ] 39 | } 40 | heqCtx lhs rhs ctx 41 | 42 | ordTransitive :: forall a. (Ord a, Show a) => Gen a -> Property 43 | ordTransitive gen = property $ do 44 | x <- forAll gen 45 | y <- forAll gen 46 | z <- forAll gen 47 | let lhs = x <= y && y <= z 48 | let rhs = x <= z 49 | let ctx = contextualise $ LawContext 50 | { lawContextLawName = "Transitivity", lawContextTcName = "Ord" 51 | , lawContextLawBody = "x <= y && y <= z" `implies` "x <= z" 52 | , lawContextReduced = reduced lhs rhs 53 | , lawContextTcProp = 54 | let showX = show x; showY = show y; showZ = show z; 55 | in lawWhere 56 | [ "x <= y && y <= z" `implies` "x <= z, where" 57 | , "x = " ++ showX 58 | , "y = " ++ showY 59 | , "z = " ++ showZ 60 | ] 61 | } 62 | case (compare x y, compare y z) of 63 | (LT,LT) -> hLessThanCtx x z ctx 64 | (LT,EQ) -> hLessThanCtx x z ctx 65 | (LT,GT) -> success 66 | (EQ,LT) -> hLessThanCtx x z ctx 67 | (EQ,EQ) -> heqCtx x z ctx 68 | (EQ,GT) -> hGreaterThanCtx x z ctx 69 | (GT,LT) -> success 70 | (GT,EQ) -> hGreaterThanCtx x z ctx 71 | (GT,GT) -> hGreaterThanCtx x z ctx 72 | 73 | ordTotal :: forall a. (Ord a, Show a) => Gen a -> Property 74 | ordTotal gen = property $ do 75 | a <- forAll gen 76 | b <- forAll gen 77 | let lhs = (a <= b) || (b <= a) 78 | let rhs = True 79 | let ctx = contextualise $ LawContext 80 | { lawContextLawName = "Totality", lawContextTcName = "Ord" 81 | , lawContextLawBody = "x <= y || y <= x" `congruency` "True" 82 | , lawContextReduced = reduced lhs rhs 83 | , lawContextTcProp = 84 | let showA = show a; showB = show b; 85 | in lawWhere 86 | [ "(x <= y) || (y <= x)" `congruency` "True, where" 87 | , "x = " ++ showA 88 | , "y = " ++ showB 89 | ] 90 | } 91 | heqCtx lhs rhs ctx 92 | 93 | ordReflexive :: forall a. (Ord a, Show a) => Gen a -> Property 94 | ordReflexive gen = property $ do 95 | x <- forAll gen 96 | let lhs = x <= x 97 | let rhs = True 98 | let ctx = contextualise $ LawContext 99 | { lawContextLawName = "Reflexivity", lawContextTcName = "Ord" 100 | , lawContextLawBody = "x <= x" `congruency` "True" 101 | , lawContextReduced = reduced lhs rhs 102 | , lawContextTcProp = 103 | let showX = show x; 104 | in lawWhere 105 | [ "x <= x" `congruency` "True, where" 106 | , "x = " ++ showX 107 | ] 108 | } 109 | heqCtx lhs rhs ctx 110 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Semigroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Hedgehog.Classes.Semigroup 4 | ( semigroupLaws 5 | , commutativeSemigroupLaws 6 | , exponentialSemigroupLaws 7 | , idempotentSemigroupLaws 8 | , rectangularBandSemigroupLaws 9 | ) where 10 | 11 | import Data.Semigroup (Semigroup(..)) 12 | import Hedgehog 13 | import Hedgehog.Classes.Common 14 | import Data.List.NonEmpty 15 | import qualified Hedgehog.Gen as Gen 16 | import qualified Hedgehog.Range as Range 17 | import qualified Data.Foldable as Foldable 18 | 19 | -- | Tests the following 'Semigroup' laws: 20 | -- 21 | -- [__Associativity__]: @a '<>' (b '<>' c)@ ≡ @(a '<>' b) '<>' c@ 22 | -- [__Concatenation__]: @'sconcat'@ ≡ @'Foldable.foldr1' ('<>')@ 23 | -- [__Times__]: @'stimes' n a@ ≡ @'foldr1' ('<>') ('replicate' n a)@ 24 | semigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws 25 | semigroupLaws gen = Laws "Semigroup" 26 | [ ("Associativity", semigroupAssociative gen) 27 | , ("Concatenation", semigroupConcatenation gen) 28 | , ("Times", semigroupTimes gen) 29 | ] 30 | 31 | -- | Tests the following 'Semigroup' laws: 32 | -- 33 | -- [__Commutativity__]: @a '<>' b@ ≡ @b '<>' a@ 34 | commutativeSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws 35 | commutativeSemigroupLaws gen = Laws "Commutative Semigroup" 36 | [ ("Commutative", semigroupCommutative gen) 37 | ] 38 | 39 | -- | Tests the following 'Semigroup' laws: 40 | -- 41 | -- [__Exponentiality__]: @'stimes' n (a '<>' b)@ ≡ @'stimes' n a '<>' 'stimes' n b@ 42 | exponentialSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws 43 | exponentialSemigroupLaws gen = Laws "Exponential Semigroup" 44 | [ ("Exponential", semigroupExponential gen) 45 | ] 46 | 47 | -- | Tests the following 'Semigroup' laws: 48 | -- 49 | -- [__Idempotency__]: @a '<>' a@ ≡ @a@ 50 | idempotentSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws 51 | idempotentSemigroupLaws gen = Laws "Idempotent Semigroup" 52 | [ ("Idempotent", semigroupIdempotent gen) 53 | ] 54 | 55 | -- | Tests the following 'Semigroup' laws: 56 | -- 57 | -- [__Rectangular Bandedness__]: @a '<>' b '<>' a@ ≡ @a@ 58 | rectangularBandSemigroupLaws :: (Eq a, Semigroup a, Show a) => Gen a -> Laws 59 | rectangularBandSemigroupLaws gen = Laws "Rectangular Band Semigroup" 60 | [ ("Rectangular Band", semigroupRectangularBand gen) 61 | ] 62 | 63 | semigroupAssociative :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property 64 | semigroupAssociative gen = property $ do 65 | a <- forAll gen 66 | b <- forAll gen 67 | c <- forAll gen 68 | let lhs = a <> (b <> c) 69 | let rhs = (a <> b) <> c 70 | let ctx = contextualise $ LawContext 71 | { lawContextLawName = "Associativity", lawContextTcName = "Semigroup" 72 | , lawContextLawBody = "a <> (b <> c)" `congruency` "(a <> b) <> c" 73 | , lawContextReduced = reduced lhs rhs 74 | , lawContextTcProp = 75 | let showA = show a; showB = show b; showC = show c; 76 | in lawWhere 77 | [ "a <> (b <> c)" `congruency` "(a <> b) <> c, where" 78 | , "a = " ++ showA 79 | , "b = " ++ showB 80 | , "c = " ++ showC 81 | ] 82 | } 83 | heqCtx lhs rhs ctx 84 | 85 | semigroupCommutative :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property 86 | semigroupCommutative gen = property $ do 87 | a <- forAll gen 88 | b <- forAll gen 89 | let lhs = a <> b 90 | let rhs = b <> a 91 | let ctx = contextualise $ LawContext 92 | { lawContextLawName = "Commutativity", lawContextTcName = "Semigroup" 93 | , lawContextLawBody = "a <> b" `congruency` "b <> a" 94 | , lawContextReduced = reduced lhs rhs 95 | , lawContextTcProp = 96 | let showA = show a; showB = show b; 97 | in lawWhere 98 | [ "a <> b" `congruency` "b <> a, where" 99 | , "a = " ++ showA 100 | , "b = " ++ showB 101 | ] 102 | } 103 | heqCtx lhs rhs ctx 104 | 105 | semigroupConcatenation :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property 106 | semigroupConcatenation gen = property $ do 107 | a <- forAll gen 108 | as <- forAll $ genSmallList gen 109 | let ne = a :| as 110 | let lhs = sconcat ne 111 | let rhs = Foldable.foldr1 (<>) ne 112 | let ctx = contextualise $ LawContext 113 | { lawContextLawName = "Concatenation", lawContextTcName = "Semigroup" 114 | , lawContextLawBody = "sconcat" `congruency` "foldr1 (<>)" 115 | , lawContextReduced = reduced lhs rhs 116 | , lawContextTcProp = 117 | let showNE = show ne; 118 | in lawWhere 119 | [ "sconcat ne" `congruency` "foldr1 (<>) ne, where" 120 | , "ne = " ++ showNE 121 | ] 122 | } 123 | heqCtx lhs rhs ctx 124 | 125 | semigroupTimes :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property 126 | semigroupTimes gen = property $ do 127 | a <- forAll gen 128 | n <- forAll (Gen.int (Range.linear 2 5)) 129 | let lhs = stimes n a 130 | let rhs = Foldable.foldr1 (<>) (replicate n a) 131 | let ctx = contextualise $ LawContext 132 | { lawContextLawName = "Times", lawContextTcName = "Semigroup" 133 | , lawContextLawBody = "stimes n a" `congruency` "foldr1 (<>) (replicate n a)" 134 | , lawContextReduced = reduced lhs rhs 135 | , lawContextTcProp = 136 | let showN = show n; showA = show a; 137 | in lawWhere 138 | [ "stimes n a" `congruency` "foldr1 (<>) (replicate n a), where" 139 | , "a = " ++ showA 140 | , "n = " ++ showN 141 | ] 142 | } 143 | heqCtx lhs rhs ctx 144 | 145 | semigroupExponential :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property 146 | semigroupExponential gen = property $ do 147 | a <- forAll gen 148 | b <- forAll gen 149 | n <- forAll (Gen.int (Range.linear 2 5)) 150 | let lhs = stimes n (a <> b) 151 | let rhs = stimes n a <> stimes n b 152 | let ctx = contextualise $ LawContext 153 | { lawContextLawName = "Exponential", lawContextTcName = "Semigroup" 154 | , lawContextLawBody = "stimes n (a <> b)" `congruency` "stimes n a <> stimes n b" 155 | , lawContextReduced = reduced lhs rhs 156 | , lawContextTcProp = 157 | let showN = show n; showA = show a; showB = show b; 158 | in lawWhere 159 | [ "stimes n (a <> b)" `congruency` "stimes n a <> stimes n b, where" 160 | , "a = " ++ showA 161 | , "b = " ++ showB 162 | , "n = " ++ showN 163 | ] 164 | } 165 | heqCtx lhs rhs ctx 166 | 167 | semigroupIdempotent :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property 168 | semigroupIdempotent gen = property $ do 169 | a <- forAll gen 170 | let lhs = a <> a 171 | let rhs = a 172 | let ctx = contextualise $ LawContext 173 | { lawContextLawName = "Idempotency", lawContextTcName = "Semigroup" 174 | , lawContextLawBody = "a <> a" `congruency` "a" 175 | , lawContextReduced = reduced lhs rhs 176 | , lawContextTcProp = 177 | let showA = show a; 178 | in lawWhere 179 | [ "a <> a" `congruency` "a, where" 180 | , "a = " ++ showA 181 | ] 182 | } 183 | heqCtx lhs rhs ctx 184 | 185 | semigroupRectangularBand :: forall a. (Eq a, Semigroup a, Show a) => Gen a -> Property 186 | semigroupRectangularBand gen = property $ do 187 | a <- forAll gen 188 | b <- forAll gen 189 | let lhs = a <> b <> a 190 | let rhs = a 191 | let ctx = contextualise $ LawContext 192 | { lawContextLawName = "Rectangular Band", lawContextTcName = "Semigroup" 193 | , lawContextLawBody = "a <> b <> a" `congruency` "a" 194 | , lawContextReduced = reduced lhs rhs 195 | , lawContextTcProp = 196 | let showA = show a; showB = show b; 197 | in lawWhere 198 | [ "a <> b <> a" `congruency` "a, where" 199 | , "a = " ++ showA 200 | , "b = " ++ showB 201 | ] 202 | } 203 | heqCtx lhs rhs ctx 204 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Show.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Hedgehog.Classes.Show (showLaws) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes.Common 7 | 8 | -- | Tests the following 'Show' laws: 9 | -- 10 | -- [__ShowsPrec Zero__]: @'show' a@ ≡ @'showsPrec' 0 a \"\"@ 11 | -- [__ShowsPrec Equivariance__]: @'showsPrec' p a r '++' s@ ≡ @'showsPrec p a (r '++' s)@ 12 | -- [__ShowsPrec ShowList__]: @'showList' as r '++' s@ ≡ @'showList' as (r '++' s)@ 13 | showLaws :: (Show a) => Gen a -> Laws 14 | showLaws gen = Laws "Show" 15 | [ ("ShowsPrec Zero", showShowsPrecZero gen) 16 | , ("Equivariance: showsPrec", equivarianceShowsPrec gen) 17 | , ("Equivariance: showList", equivarianceShowList gen) 18 | ] 19 | 20 | showShowsPrecZero :: forall a. (Show a) => Gen a -> Property 21 | showShowsPrecZero gen = property $ do 22 | a <- forAll gen 23 | let lhs = show a 24 | let rhs = showsPrec 0 a "" 25 | let ctx = contextualise $ LawContext 26 | { lawContextLawName = "ShowsPrec Zero", lawContextTcName = "Show" 27 | , lawContextLawBody = "show a" `congruency` "showsPrec 0 a \"\"" 28 | , lawContextReduced = reduced lhs rhs 29 | , lawContextTcProp = 30 | let showA = show a; 31 | in lawWhere 32 | [ "show a" `congruency` "showsPrec 0 a \"\", where" 33 | , "a = " ++ showA 34 | ] 35 | } 36 | heqCtx lhs rhs ctx 37 | 38 | equivarianceShowsPrec :: forall a. (Show a) => Gen a -> Property 39 | equivarianceShowsPrec gen = property $ do 40 | p <- forAll genShowReadPrecedence 41 | a <- forAll gen 42 | r <- forAll genSmallString 43 | s <- forAll genSmallString 44 | let lhs = showsPrec p a r ++ s 45 | let rhs = showsPrec p a (r ++ s) 46 | let ctx = contextualise $ LawContext 47 | { lawContextLawName = "ShowsPrec Equivariance", lawContextTcName = "Show" 48 | , lawContextLawBody = "showsPrec p a r ++ s" `congruency` "showsPrec p a (r ++ s)" 49 | , lawContextReduced = reduced lhs rhs 50 | , lawContextTcProp = 51 | let showP = show p; showA = show a; showR = show r; showS = show s; 52 | in lawWhere 53 | [ "showsPrec p a r ++ s" `congruency` "showsPrec p a (r ++ s), where" 54 | , "p = " ++ showP 55 | , "a = " ++ showA 56 | , "r = " ++ showR 57 | , "s = " ++ showS 58 | ] 59 | } 60 | heqCtx lhs rhs ctx 61 | 62 | equivarianceShowList :: forall a. (Show a) => Gen a -> Property 63 | equivarianceShowList gen = property $ do 64 | as <- forAll $ genSmallList gen 65 | r <- forAll genSmallString 66 | s <- forAll genSmallString 67 | let lhs = showList as r ++ s 68 | let rhs = showList as (r ++ s) 69 | let ctx = contextualise $ LawContext 70 | { lawContextLawName = "ShowList Equivariance", lawContextTcName = "Show" 71 | , lawContextLawBody = "showList as r ++ s" `congruency` "showList as (r ++ s)" 72 | , lawContextReduced = reduced lhs rhs 73 | , lawContextTcProp = 74 | let showAS = show as; showR = show r; showS = show s; 75 | in lawWhere 76 | [ "showList as r ++ s" `congruency` "showList as (r ++ s), where" 77 | , "as = " ++ showAS 78 | , "r = " ++ showR 79 | , "s = " ++ showS 80 | ] 81 | } 82 | heqCtx lhs rhs ctx 83 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/ShowRead.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Hedgehog.Classes.ShowRead (showReadLaws) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes.Common 7 | 8 | import Text.Read (readListDefault, readMaybe) 9 | import Text.Show (showListWith) 10 | 11 | -- | Tests the following 'Show' / 'Read' laws: 12 | -- 13 | -- [__Partial Isomorphism: show/read__]: @'readMaybe' '.' 'show'@ ≡ @'Just'@ 14 | -- [__Partial Isomorphism: show/read with initial space__]: @'readMaybe' '.' (\" \" '++') '.' 'show'@ ≡ @'Just'@ 15 | -- [__Partial Isomorphism: showsPrec/readPrec__]: @(a,\"\") `elem` 'readsPrec' p ('showsPrec' p a \"\")@ ≡ @'True'@ 16 | -- [__Partial Isomorphism: showList/readList__]: @(as,\"\") `elem` 'readList' ('showList' as \"\")@ ≡ @'True'@ 17 | -- [__Partial Isomorphism: showListWith shows/readListDefault__]: @(as,\"\") `elem` 'readListDefault' ('showListWith' 'shows' as \"\")@ ≡ @'True'@ 18 | showReadLaws :: (Eq a, Read a, Show a) => Gen a -> Laws 19 | showReadLaws gen = Laws "Show/Read" 20 | [ ("Partial Isomorphism: show/read", showReadPartialIsomorphism gen) 21 | , ("Partial Isomorphism: show/read with initial space", showReadSpacePartialIsomorphism gen) 22 | , ("Partial Isomorphism: showsPrec/readsPrec", showsPrecReadsPrecPartialIsomorphism gen) 23 | , ("Partial Isomorphism: showList/readList", showListReadListPartialIsomorphism gen) 24 | , ("Partial Isomorphism: showListWith shows/readListDefault", showListWithShowsReadListDefaultPartialIsomorphism gen) 25 | ] 26 | 27 | showReadPartialIsomorphism :: forall a. (Eq a, Read a, Show a) => Gen a -> Property 28 | showReadPartialIsomorphism gen = property $ do 29 | a <- forAll gen 30 | let lhs = readMaybe (show a) 31 | let rhs = Just a 32 | let ctx = contextualise $ LawContext 33 | { lawContextLawName = "Show/Read Partial Isomorphism", lawContextTcName = "Show/Read" 34 | , lawContextLawBody = "readMaybe . show" `congruency` "Just" 35 | , lawContextReduced = reduced lhs rhs 36 | , lawContextTcProp = 37 | let showA = show a; 38 | in lawWhere 39 | [ "readMaybe . show $ a" `congruency` "Just a, where" 40 | , "a = " ++ showA 41 | ] 42 | } 43 | heqCtx lhs rhs ctx 44 | 45 | showReadSpacePartialIsomorphism :: forall a. (Eq a, Read a, Show a) => Gen a -> Property 46 | showReadSpacePartialIsomorphism gen = property $ do 47 | a <- forAll gen 48 | let lhs = readMaybe (" " ++ show a) 49 | let rhs = Just a 50 | let ctx = contextualise $ LawContext 51 | { lawContextLawName = "Show/Read Partial Isomorphism With Initial Space", lawContextTcName = "Show/Read" 52 | , lawContextLawBody = "readMaybe . (\" \" ++) . show" `congruency` "Just" 53 | , lawContextReduced = reduced lhs rhs 54 | , lawContextTcProp = 55 | let showA = show a; 56 | in lawWhere 57 | [ "readMaybe . (\" \" ++) . show $ a" `congruency` "Just a, where" 58 | , "a = " ++ showA 59 | ] 60 | } 61 | heqCtx lhs rhs ctx 62 | 63 | showsPrecReadsPrecPartialIsomorphism :: forall a. (Eq a, Read a, Show a) => Gen a -> Property 64 | showsPrecReadsPrecPartialIsomorphism gen = property $ do 65 | a <- forAll gen 66 | p <- forAll genShowReadPrecedence 67 | let lhs = (a,"") `elem` readsPrec p (showsPrec p a "") 68 | let rhs = True 69 | let ctx = contextualise $ LawContext 70 | { lawContextLawName = "ShowsPrec/ReadsPrec partial isomorphism", lawContextTcName = "Show/Read" 71 | , lawContextLawBody = "(a,\"\") `elem` readsPrec p (showsPrec p a \"\")" `congruency` "True" 72 | , lawContextReduced = reduced lhs rhs 73 | , lawContextTcProp = 74 | let showA = show a; showP = show p 75 | in lawWhere 76 | [ "(a,\"\") `elem` readsPrec p (showsPrec p a \"\")" `congruency` "True, where" 77 | , "a = " ++ showA 78 | , "p = " ++ showP 79 | ] 80 | } 81 | heqCtx lhs rhs ctx 82 | 83 | showListReadListPartialIsomorphism :: forall a. (Eq a, Read a, Show a) => Gen a -> Property 84 | showListReadListPartialIsomorphism gen = property $ do 85 | as <- forAll $ genSmallList gen 86 | let lhs = (as,"") `elem` readList (showList as "") 87 | let rhs = True 88 | let ctx = contextualise $ LawContext 89 | { lawContextLawName = "ShowsList/ReadsList partial isomorphism", lawContextTcName = "Show/Read" 90 | , lawContextLawBody = "(as,\"\") `elem` readList (showList as \"\")" `congruency` "True" 91 | , lawContextReduced = reduced lhs rhs 92 | , lawContextTcProp = 93 | let showAS = show as 94 | in lawWhere 95 | [ "(as,\"\") `elem` readList (showList as \"\")" `congruency` "True, where" 96 | , "as = " ++ showAS 97 | ] 98 | } 99 | heqCtx lhs rhs ctx 100 | 101 | showListWithShowsReadListDefaultPartialIsomorphism :: forall a. (Eq a, Read a, Show a) => Gen a -> Property 102 | showListWithShowsReadListDefaultPartialIsomorphism gen = property $ do 103 | as <- forAll $ genSmallList gen 104 | let lhs = (as,"") `elem` readListDefault (showListWith shows as "") 105 | let rhs = True 106 | let ctx = contextualise $ LawContext 107 | { lawContextLawName = "ShowListWith/ReadListDefault partial isomorphism", lawContextTcName = "Show/Read" 108 | , lawContextLawBody = "(as,\"\") `elem` readListDefault (showListWith shows as \"\")" `congruency` "True" 109 | , lawContextReduced = reduced lhs rhs 110 | , lawContextTcProp = 111 | let showAS = show as 112 | in lawWhere 113 | [ "(as,\"\") `elem` readListDefault (showListWith shows as \"\")" `congruency` "True, where" 114 | , "as = " ++ showAS 115 | ] 116 | } 117 | heqCtx lhs rhs ctx 118 | 119 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Storable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Hedgehog.Classes.Storable (storableLaws) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes.Common 7 | import Hedgehog.Internal.Gen (sample) 8 | 9 | import qualified Data.List as List 10 | import qualified Hedgehog.Gen as Gen 11 | import qualified Hedgehog.Range as Range 12 | 13 | import Foreign.Marshal.Alloc 14 | import Foreign.Marshal.Array 15 | import GHC.Ptr (Ptr(..), nullPtr, plusPtr, minusPtr, alignPtr) 16 | import Foreign.Storable (Storable(..)) 17 | import System.IO.Unsafe (unsafePerformIO) 18 | 19 | -- | Tests the following 'Storable' laws: 20 | -- 21 | -- [__Set-Get__]: @'pokeElemOff' ptr ix a '>>' 'peekElemOff' ptr ix@ ≡ @'pure' a@ 22 | -- [__Get-Set__]: @'peekElemOff' ptr ix '>>=' 'pokeElemOff' ptr ix@ ≡ @'pure' ()@ (Putting back what you got out has no effect) 23 | -- [__List Conversion Roundtrips__]: Mallocing a list and then reconstructing it gives you the same list 24 | -- [__PeekElemOff/Peek__]: @'peekElemOff' a i@ ≡ @'peek' ('plusPtr' a (i '*' 'sizeOf' 'undefined'))@ 25 | -- [__PokeElemOff/Poke__]: @'pokeElemOff' a i x@ ≡ @'poke' ('plusPtr' a (i '*' 'sizeOf' 'undefined')) x@ 26 | -- [__PeekByteOff/Peek__]: @'peekByteOff' a i@ ≡ @'peek' ('plusPtr' a i)@ 27 | -- [__PokeByteOff/Peek__]: @'pokeByteOff' a i x@ ≡ @'poke' ('plusPtr' a i) x@ 28 | storableLaws :: (Eq a, Show a, Storable a) => Gen a -> Laws 29 | storableLaws gen = Laws "Storable" 30 | [ ("Set-Get (you get back what you put in)", storableSetGet gen) 31 | , ("Get-Set (putting back what you got out has no effect)", storableGetSet gen) 32 | , ("List Conversion Roundtrips", storableList gen) 33 | , ("peekElemOff a i ≡ peek (plusPtr a (i * sizeOf undefined))", storablePeekElem gen) 34 | , ("pokeElemOff a i x ≡ poke (plusPtr a (i * sizeOf undefined)) x ≡ id ", storablePokeElem gen) 35 | , ("peekByteOff a i ≡ peek (plusPtr a i)", storablePeekByte gen) 36 | , ("pokeByteOff a i x ≡ poke (plusPtr a i) x ≡ id ", storablePokeByte gen) 37 | ] 38 | 39 | genArray :: forall a. (Storable a) => Gen a -> Int -> IO (Ptr a) 40 | genArray gen len = do 41 | let go ix xs = if ix == len 42 | then pure xs 43 | else do 44 | x <- sample gen 45 | go (ix + 1) (x : xs) 46 | as <- go 0 [] 47 | newArray as 48 | 49 | storablePeekElem :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property 50 | storablePeekElem gen = property $ do 51 | as <- forAll $ genSmallNonEmptyList gen 52 | let len = List.length as 53 | ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) 54 | unsafePerformIO $ do 55 | addr <- genArray gen len 56 | x <- peekElemOff addr ix 57 | y <- peek (addr `plusPtr` (ix * sizeOf (undefined :: a))) 58 | free addr 59 | pure (x === y) 60 | 61 | storablePokeElem :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property 62 | storablePokeElem gen = property $ do 63 | as <- forAll $ genSmallNonEmptyList gen 64 | x <- forAll gen 65 | let len = List.length as 66 | ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) 67 | unsafePerformIO $ do 68 | addr <- genArray gen len 69 | pokeElemOff addr ix x 70 | u <- peekElemOff addr ix 71 | poke (addr `plusPtr` (ix * sizeOf x)) x 72 | v <- peekElemOff addr ix 73 | free addr 74 | pure (u === v) 75 | 76 | storablePeekByte :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property 77 | storablePeekByte gen = property $ do 78 | as <- forAll $ genSmallNonEmptyList gen 79 | let len = List.length as 80 | ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) 81 | let off = ix * (nullPtr `plusPtr` sizeOf (head as)) `alignPtr` alignment (head as) `minusPtr` nullPtr 82 | unsafePerformIO $ do 83 | addr <- genArray gen len 84 | x :: a <- peekByteOff addr off 85 | y :: a <- peek (addr `plusPtr` off) 86 | free addr 87 | pure (x === y) 88 | 89 | storablePokeByte :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property 90 | storablePokeByte gen = property $ do 91 | as <- forAll $ genSmallNonEmptyList gen 92 | x <- forAll gen 93 | let len = List.length as 94 | off <- forAll $ Gen.int (Range.linear 0 (len - 1)) 95 | unsafePerformIO $ do 96 | addr <- genArray gen len 97 | pokeByteOff addr off x 98 | u :: a <- peekByteOff addr off 99 | poke (addr `plusPtr` off) x 100 | v :: a <- peekByteOff addr off 101 | free addr 102 | pure (u === v) 103 | 104 | storableSetGet :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property 105 | storableSetGet gen = property $ do 106 | a <- forAll gen 107 | len <- forAll $ Gen.int (Range.linear 1 20) 108 | ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) 109 | unsafePerformIO $ do 110 | ptr <- genArray gen len 111 | pokeElemOff ptr ix a 112 | a' <- peekElemOff ptr ix 113 | free ptr 114 | pure (a === a') 115 | 116 | storableGetSet :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property 117 | storableGetSet gen = property $ do 118 | as <- forAll $ genSmallNonEmptyList gen 119 | let len = List.length as 120 | ix <- forAll $ Gen.int (Range.linear 0 (len - 1)) 121 | unsafePerformIO $ do 122 | ptrA <- newArray as 123 | ptrB <- genArray gen len 124 | copyArray ptrB ptrA len 125 | a <- peekElemOff ptrA ix 126 | pokeElemOff ptrA ix a 127 | res <- arrayEq ptrA ptrB len 128 | free ptrA 129 | free ptrB 130 | pure (res === True) 131 | 132 | storableList :: forall a. (Eq a, Show a, Storable a) => Gen a -> Property 133 | storableList gen = property $ do 134 | as <- forAll $ genSmallNonEmptyList gen 135 | unsafePerformIO $ do 136 | let len = List.length as 137 | ptr <- newArray as 138 | let rebuild :: Int -> IO [a] 139 | rebuild ix = if ix < len 140 | then (:) <$> peekElemOff ptr ix <*> rebuild (ix + 1) 141 | else pure [] 142 | asNew <- rebuild 0 143 | free ptr 144 | pure (as === asNew) 145 | 146 | arrayEq :: forall a. (Eq a, Storable a) => Ptr a -> Ptr a -> Int -> IO Bool 147 | arrayEq ptrA ptrB len = go 0 where 148 | go i = if i < len 149 | then do 150 | a <- peekElemOff ptrA i 151 | b <- peekElemOff ptrB i 152 | if a == b 153 | then go (i + 1) 154 | else pure False 155 | else pure True 156 | -------------------------------------------------------------------------------- /src/Hedgehog/Classes/Traversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE QuantifiedConstraints #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | 6 | module Hedgehog.Classes.Traversable (traversableLaws) where 7 | 8 | import Hedgehog 9 | import Hedgehog.Classes.Common 10 | 11 | import Data.Functor.Identity 12 | import Data.Functor.Compose 13 | import Data.Traversable (Traversable(..), foldMapDefault, fmapDefault) 14 | 15 | -- | Tests the following 'Traversable' laws: 16 | -- 17 | -- [__Naturality__]: @t '.' 'traverse' f@ ≡ @'traverse' (t '.' f), for every applicative transformation t@ 18 | -- [__Identity__]: @'traverse' 'Identity'@ ≡ @'Identity'@ 19 | -- [__Composition__]: @'traverse' ('Compose' '.' 'fmap' g '.' f)@ ≡ @'Compose' '.' 'fmap' ('traverse' g) '.' 'traverse' f@ 20 | -- [__SequenceA Naturality__]: @t '.' 'sequenceA'@ ≡ @'sequenceA' '.' 'fmap' t, for every applicative transformation t@ 21 | -- [__SequenceA Identity__]: @'sequenceA' '.' 'fmap' 'Identity'@ ≡ @'Identity'@ 22 | -- [__SequenceA Composition__]: @'sequenceA' '.' 'fmap' 'Compose'@ ≡ @'Compose' '.' 'fmap' 'sequenceA' '.' 'sequenceA'@ 23 | -- [__FoldMap__]: @'foldMap'@ ≡ @'foldMapDefault'@ 24 | -- [__Fmap__]: @'fmap'@ ≡ @'fmapDefault'@ 25 | traversableLaws :: 26 | ( Traversable f 27 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 28 | ) => (forall x. Gen x -> Gen (f x)) -> Laws 29 | traversableLaws gen = Laws "Traversable" 30 | [ ("Naturality", traversableNaturality gen) 31 | , ("Identity", traversableIdentity gen) 32 | , ("Composition", traversableComposition gen) 33 | , ("Sequence Naturality", traversableSequenceNaturality gen) 34 | , ("Sequence Identity", traversableSequenceIdentity gen) 35 | , ("Sequence Composition", traversableSequenceComposition gen) 36 | , ("foldMap", traversableFoldMap gen) 37 | , ("fmap", traversableFmap gen) 38 | ] 39 | 40 | type TraversableProp f = 41 | ( Traversable f 42 | , forall x. Eq x => Eq (f x), forall x. Show x => Show (f x) 43 | ) => (forall x. Gen x -> Gen (f x)) -> Property 44 | 45 | traversableNaturality :: TraversableProp f 46 | traversableNaturality fgen = property $ do 47 | a <- forAll $ fgen genSmallInteger 48 | (apTrans (traverse func4 a)) `heq1` (traverse (apTrans . func4) a) 49 | 50 | traversableIdentity :: TraversableProp f 51 | traversableIdentity fgen = property $ do 52 | t <- forAll $ fgen genSmallInteger 53 | (traverse Identity t) `heq1` (Identity t) 54 | 55 | traversableComposition :: TraversableProp f 56 | traversableComposition fgen = property $ do 57 | t <- forAll $ fgen genSmallInteger 58 | let lhs = (traverse (Compose . fmap func5 . func6) t) 59 | let rhs = (Compose (fmap (traverse func5) (traverse func6 t))) 60 | lhs `heq1` rhs 61 | 62 | traversableSequenceNaturality :: TraversableProp f 63 | traversableSequenceNaturality fgen = property $ do 64 | x <- forAll $ fgen (genCompose genSmallInteger genTriple (genTuple genSetInteger)) 65 | let a = fmap toSpecialApplicative x 66 | (apTrans (sequenceA a)) `heq1` (sequenceA (fmap apTrans a)) 67 | 68 | traversableSequenceIdentity :: TraversableProp f 69 | traversableSequenceIdentity fgen = property $ do 70 | t <- forAll $ fgen genSmallInteger 71 | (sequenceA (fmap Identity t)) `heq1` (Identity t) 72 | 73 | traversableSequenceComposition :: TraversableProp f 74 | traversableSequenceComposition fgen = property $ do 75 | let genTripleInteger = genTriple genSmallInteger 76 | t <- forAll $ fgen (genTriple genTripleInteger) 77 | (sequenceA (fmap Compose t)) `heq1` (Compose (fmap sequenceA (sequenceA t))) 78 | 79 | traversableFoldMap :: TraversableProp f 80 | traversableFoldMap fgen = property $ do 81 | t <- forAll $ fgen genSmallInteger 82 | foldMap func3 t `heq1` foldMapDefault func3 t 83 | 84 | traversableFmap :: TraversableProp f 85 | traversableFmap fgen = property $ do 86 | t <- forAll $ fgen genSmallInteger 87 | fmap func3 t `heq1` fmapDefault func3 t 88 | 89 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Hedgehog.Classes 4 | 5 | import Spec.Alternative 6 | import Spec.Applicative 7 | import Spec.Arrow 8 | import Spec.Bifoldable 9 | import Spec.Bifunctor 10 | import Spec.Binary 11 | import Spec.Bitraversable 12 | import Spec.Bits 13 | import Spec.Category 14 | import Spec.Comonad 15 | import Spec.Contravariant 16 | import Spec.Enum 17 | import Spec.Eq 18 | import Spec.Foldable 19 | import Spec.Functor 20 | import Spec.Generic 21 | import Spec.Integral 22 | --import Spec.Ix 23 | import Spec.Json 24 | import Spec.Monad 25 | import Spec.Monoid 26 | import Spec.MVector 27 | import Spec.Ord 28 | import Spec.Prim 29 | import Spec.Semigroup 30 | import Spec.Semiring 31 | import Spec.Show 32 | import Spec.Storable 33 | import Spec.Traversable 34 | 35 | main :: IO Bool 36 | main = lawsCheckMany allLaws 37 | 38 | allNullaryLaws :: [(String, [Laws])] 39 | allNullaryLaws = testBits 40 | ++ testEnum 41 | ++ testBoundedEnum 42 | ++ testBinary 43 | ++ testEq 44 | ++ testGeneric 45 | ++ testIntegral 46 | -- ++ testIx 47 | ++ testJson 48 | ++ testMonoid 49 | ++ testCommutativeMonoid 50 | ++ testOrd 51 | ++ testPrim 52 | ++ testSemigroup 53 | ++ testCommutativeSemigroup 54 | ++ testExponentialSemigroup 55 | ++ testIdempotentSemigroup 56 | ++ testRectangularBandSemigroup 57 | ++ testSemiring 58 | ++ testRing 59 | ++ testStar 60 | ++ testShow 61 | ++ testShowRead 62 | ++ testStorable 63 | ++ testMUVector 64 | 65 | allUnaryLaws :: [(String, [Laws])] 66 | allUnaryLaws = testAlternative 67 | ++ testApplicative 68 | ++ testComonad 69 | ++ testContravariant 70 | ++ testFoldable 71 | ++ testFunctor 72 | ++ testMonad 73 | ++ testMonadIO 74 | ++ testMonadPlus 75 | ++ testMonadZip 76 | ++ testTraversable 77 | 78 | allBinaryLaws :: [(String, [Laws])] 79 | allBinaryLaws = testArrow 80 | ++ testBifoldable 81 | ++ testBifoldableFunctor 82 | ++ testBifunctor 83 | ++ testBitraversable 84 | ++ testCategory 85 | ++ testCommutativeCategory 86 | 87 | allLaws :: [(String, [Laws])] 88 | allLaws = allNullaryLaws ++ allUnaryLaws ++ allBinaryLaws 89 | -------------------------------------------------------------------------------- /test/Spec/Alternative.hs: -------------------------------------------------------------------------------- 1 | module Spec.Alternative (testAlternative) where 2 | 3 | import Hedgehog.Classes 4 | 5 | import qualified Hedgehog.Gen as Gen 6 | import qualified Hedgehog.Range as Range 7 | 8 | testAlternative :: [(String, [Laws])] 9 | testAlternative = 10 | [ ("[]", lawsList) 11 | , ("Maybe", lawsMaybe) 12 | ] 13 | 14 | lawsList :: [Laws] 15 | lawsList = [alternativeLaws (Gen.list (Range.linear 0 6))] 16 | 17 | lawsMaybe :: [Laws] 18 | lawsMaybe = [alternativeLaws Gen.maybe] 19 | 20 | -------------------------------------------------------------------------------- /test/Spec/Applicative.hs: -------------------------------------------------------------------------------- 1 | module Spec.Applicative (testApplicative) where 2 | 3 | import Data.Functor.Compose (Compose(..)) 4 | import Data.Functor.Identity (Identity(..)) 5 | 6 | import Hedgehog 7 | import Hedgehog.Classes 8 | 9 | import qualified Hedgehog.Gen as Gen 10 | import qualified Hedgehog.Range as Range 11 | 12 | import Prelude hiding (either) 13 | 14 | testApplicative :: [(String, [Laws])] 15 | testApplicative = 16 | [ ("[]", lawsList) 17 | , ("Maybe", lawsMaybe) 18 | , ("Either e", lawsEither) 19 | , ("Compose", lawsCompose) 20 | -- , ("Bin", lawsBin) 21 | ] 22 | 23 | lawsList :: [Laws] 24 | lawsList = [applicativeLaws (Gen.list (Range.linear 0 6))] 25 | 26 | lawsMaybe :: [Laws] 27 | lawsMaybe = [applicativeLaws Gen.maybe] 28 | 29 | lawsEither :: [Laws] 30 | lawsEither = [applicativeLaws eitherInteger] 31 | 32 | lawsCompose :: [Laws] 33 | lawsCompose = [applicativeLaws genCompose] 34 | 35 | genCompose :: Gen a -> Gen (Compose Identity Identity a) 36 | genCompose = fmap (Compose . Identity . Identity) 37 | 38 | eitherInteger :: MonadGen m => m a -> m (Either Integer a) 39 | eitherInteger = either (Gen.integral (Range.linear 0 20)) 40 | 41 | either :: MonadGen m => m e -> m a -> m (Either e a) 42 | either genE genA = 43 | Gen.sized $ \n -> 44 | Gen.frequency [ 45 | (2, Left <$> genE) 46 | , (1 + fromIntegral n, Right <$> genA) 47 | ] 48 | 49 | {- 50 | data Bin a = Leaf | Node (Bin a) a (Bin a) 51 | deriving (Eq, Show) 52 | 53 | instance Functor Bin where 54 | fmap _ Leaf = Leaf 55 | fmap f (Node l x r) = Node (fmap f l) (f x) (fmap f r) 56 | 57 | instance Applicative Bin where 58 | pure x = Node Leaf x Leaf 59 | Leaf <*> _ = Leaf 60 | _ <*> Leaf = Leaf 61 | Node fl fx fr <*> Node l x r = Node (fl <*> l) (fx x) (fr <*> r) 62 | 63 | genBin' :: Gen a -> Gen (Bin a) 64 | genBin' gen = do 65 | x <- gen 66 | pure $ Node (Node Leaf x (Node Leaf x Leaf)) x (Node (Node Leaf x Leaf) x Leaf) 67 | 68 | genBin :: Gen a -> Gen (Bin a) 69 | genBin gen = Gen.frequency 70 | [ (1, pure Leaf) 71 | , (6, genBin' gen) 72 | ] 73 | 74 | lawsBin :: [Laws] 75 | lawsBin = [applicativeLaws genBin] 76 | -} 77 | -------------------------------------------------------------------------------- /test/Spec/Arrow.hs: -------------------------------------------------------------------------------- 1 | module Spec.Arrow (testArrow) where 2 | 3 | import Hedgehog.Classes 4 | 5 | testArrow :: [(String, [Laws])] 6 | testArrow = [] 7 | -------------------------------------------------------------------------------- /test/Spec/Bifoldable.hs: -------------------------------------------------------------------------------- 1 | module Spec.Bifoldable (testBifoldable, testBifoldableFunctor) where 2 | 3 | import Data.Functor.Const (Const(..)) 4 | import Hedgehog 5 | import Hedgehog.Classes 6 | 7 | import qualified Hedgehog.Gen as Gen 8 | import Prelude hiding (either, const) 9 | 10 | testBifoldable :: [(String, [Laws])] 11 | testBifoldable = 12 | [ ("Either", lawsEither) 13 | , ("Const", lawsConst) 14 | ] 15 | 16 | testBifoldableFunctor :: [(String, [Laws])] 17 | testBifoldableFunctor = 18 | [ ("Either", functorLawsEither) 19 | , ("Const", functorLawsConst) 20 | ] 21 | 22 | lawsConst, functorLawsConst :: [Laws] 23 | lawsConst = [bifoldableLaws const] 24 | functorLawsConst = [bifoldableFunctorLaws const] 25 | 26 | const :: MonadGen m => m a -> m b -> m (Const a b) 27 | const genA _genB = fmap Const genA 28 | 29 | lawsEither, functorLawsEither :: [Laws] 30 | lawsEither = [bifoldableLaws either] 31 | functorLawsEither = [bifoldableFunctorLaws either] 32 | 33 | either :: MonadGen m => m e -> m a -> m (Either e a) 34 | either genE genA = 35 | Gen.sized $ \n -> 36 | Gen.frequency [ 37 | (2, Left <$> genE) 38 | , (1 + fromIntegral n, Right <$> genA) 39 | ] 40 | -------------------------------------------------------------------------------- /test/Spec/Bifunctor.hs: -------------------------------------------------------------------------------- 1 | module Spec.Bifunctor (testBifunctor) where 2 | 3 | import Data.Functor.Const (Const(..)) 4 | import Hedgehog 5 | import Hedgehog.Classes 6 | 7 | import qualified Hedgehog.Gen as Gen 8 | import Prelude hiding (either, const) 9 | 10 | testBifunctor :: [(String, [Laws])] 11 | testBifunctor = 12 | [ ("Either", lawsEither) 13 | , ("Const", lawsConst) 14 | ] 15 | 16 | lawsEither :: [Laws] 17 | lawsEither = [bifunctorLaws either] 18 | 19 | lawsConst :: [Laws] 20 | lawsConst = [bifunctorLaws const] 21 | 22 | const :: MonadGen m => m a -> m b -> m (Const a b) 23 | const genA _genB = fmap Const genA 24 | 25 | either :: MonadGen m => m e -> m a -> m (Either e a) 26 | either genE genA = 27 | Gen.sized $ \n -> 28 | Gen.frequency [ 29 | (2, Left <$> genE) 30 | , (1 + fromIntegral n, Right <$> genA) 31 | ] -------------------------------------------------------------------------------- /test/Spec/Binary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Spec.Binary (testBinary) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes 7 | import qualified Hedgehog.Gen as Gen 8 | import qualified Hedgehog.Range as Range 9 | 10 | import Data.Binary 11 | import GHC.Generics (Generic(..)) 12 | 13 | testBinary :: [(String, [Laws])] 14 | testBinary = 15 | [ ("Person", listPerson) 16 | ] 17 | 18 | data Person = Person { name :: String, age :: Int } 19 | deriving (Eq, Show, Generic) 20 | 21 | instance Binary Person where 22 | 23 | listPerson :: [Laws] 24 | listPerson = [binaryLaws genPerson] 25 | 26 | genPerson :: Gen Person 27 | genPerson = Person <$> (Gen.string (Range.linear 3 7) Gen.alpha) <*> (Gen.int (Range.linear 0 65)) 28 | -------------------------------------------------------------------------------- /test/Spec/Bitraversable.hs: -------------------------------------------------------------------------------- 1 | module Spec.Bitraversable (testBitraversable) where 2 | 3 | import Data.Functor.Const (Const(..)) 4 | import Hedgehog 5 | import Hedgehog.Classes 6 | 7 | import qualified Hedgehog.Gen as Gen 8 | import Prelude hiding (either, const) 9 | 10 | testBitraversable :: [(String, [Laws])] 11 | testBitraversable = 12 | [ ("Either", lawsEither) 13 | , ("Const", lawsConst) 14 | ] 15 | 16 | lawsEither :: [Laws] 17 | lawsEither = [bitraversableLaws either] 18 | 19 | lawsConst :: [Laws] 20 | lawsConst = [bitraversableLaws const] 21 | 22 | const :: MonadGen m => m a -> m b -> m (Const a b) 23 | const genA _genB = fmap Const genA 24 | 25 | either :: MonadGen m => m e -> m a -> m (Either e a) 26 | either genE genA = 27 | Gen.sized $ \n -> 28 | Gen.frequency [ 29 | (2, Left <$> genE) 30 | , (1 + fromIntegral n, Right <$> genA) 31 | ] -------------------------------------------------------------------------------- /test/Spec/Bits.hs: -------------------------------------------------------------------------------- 1 | module Spec.Bits (testBits) where 2 | 3 | import Hedgehog.Classes 4 | 5 | import qualified Hedgehog.Gen as Gen 6 | import qualified Hedgehog.Range as Range 7 | 8 | ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b 9 | ranged f = f (Range.constantBounded) 10 | 11 | testBits :: [(String, [Laws])] 12 | testBits = 13 | [ ("Int", listInt) 14 | , ("Int8", listInt8) 15 | , ("Int16", listInt16) 16 | , ("Int32", listInt32) 17 | , ("Int64", listInt64) 18 | , ("Word", listWord) 19 | , ("Word8", listWord8) 20 | , ("Word16", listWord16) 21 | , ("Word32", listWord32) 22 | , ("Word64", listWord64) 23 | ] 24 | 25 | listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] 26 | listInt = [bitsLaws (ranged Gen.int)] 27 | listInt8 = [bitsLaws (ranged Gen.int8)] 28 | listInt16 = [bitsLaws (ranged Gen.int16)] 29 | listInt32 = [bitsLaws (ranged Gen.int32)] 30 | listInt64 = [bitsLaws (ranged Gen.int64)] 31 | 32 | listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] 33 | listWord = [bitsLaws (ranged Gen.word)] 34 | listWord8 = [bitsLaws (ranged Gen.word8)] 35 | listWord16 = [bitsLaws (ranged Gen.word16)] 36 | listWord32 = [bitsLaws (ranged Gen.word32)] 37 | listWord64 = [bitsLaws (ranged Gen.word64)] 38 | -------------------------------------------------------------------------------- /test/Spec/Category.hs: -------------------------------------------------------------------------------- 1 | module Spec.Category (testCategory, testCommutativeCategory) where 2 | 3 | import Control.Category 4 | import Hedgehog 5 | import Hedgehog.Classes 6 | import Prelude hiding ((.), id) 7 | 8 | testCategory :: [(String, [Laws])] 9 | testCategory = 10 | [ ("ProxyC", [categoryLaws genProxyC]) 11 | ] 12 | 13 | testCommutativeCategory :: [(String, [Laws])] 14 | testCommutativeCategory = 15 | [ ("ProxyC", [commutativeCategoryLaws genProxyC]) 16 | ] 17 | 18 | data ProxyC a b = ProxyC 19 | deriving (Eq, Show) 20 | 21 | instance Category ProxyC where 22 | id = ProxyC 23 | _ . _ = ProxyC 24 | 25 | genProxyC :: Gen a -> Gen b -> Gen (ProxyC a b) 26 | genProxyC _ _ = pure ProxyC 27 | -------------------------------------------------------------------------------- /test/Spec/Comonad.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | DerivingStrategies 3 | , GeneralizedNewtypeDeriving 4 | #-} 5 | 6 | {-# options_ghc -fno-warn-orphans #-} 7 | 8 | module Spec.Comonad 9 | ( testComonad 10 | ) where 11 | 12 | import Data.List.NonEmpty 13 | import qualified Control.Applicative as App (liftA2) 14 | import Control.Comonad 15 | import Control.Comonad.Store hiding (store) 16 | import Data.Functor.Identity (Identity(..)) 17 | import Hedgehog 18 | import Hedgehog.Classes 19 | import Prelude hiding (either) 20 | import qualified Hedgehog.Gen as Gen 21 | import qualified Hedgehog.Range as Range 22 | 23 | testComonad :: [(String, [Laws])] 24 | testComonad = 25 | [ ("Identity", [comonadLaws identity]) 26 | , ("NonEmpty", [comonadLaws nonempty]) 27 | , ("(,) e", [comonadLaws tup]) 28 | , ("StoreT Integer Identity", [comonadLaws store]) 29 | ] 30 | 31 | store :: MonadGen m => m a -> m (StoreT Integer Identity a) 32 | store gen = do 33 | a <- gen 34 | pure $ StoreT (Identity (const a)) 20 35 | 36 | instance (Comonad w, Show s, Show a) => Show (StoreT s w a) where 37 | show (StoreT wf s) = show $ "StoreT { s = " ++ show s ++ ", extract stuff = " ++ show (extract wf s) ++ "}" 38 | 39 | instance (Comonad w, Eq a) => Eq (StoreT s w a) where 40 | StoreT wf s == StoreT wf' s' = extract wf s == extract wf' s' 41 | 42 | identity :: MonadGen m => m a -> m (Identity a) 43 | identity = fmap Identity 44 | 45 | nonempty :: MonadGen m => m a -> m (NonEmpty a) 46 | nonempty gen = App.liftA2 (:|) gen (list gen) 47 | 48 | tup :: MonadGen m => m a -> m (Integer, a) 49 | tup gen = (,) 50 | <$> Gen.integral (Range.linear 20 50) 51 | <*> gen 52 | 53 | list :: MonadGen m => m a -> m [a] 54 | list = Gen.list $ Range.linear 0 6 55 | -------------------------------------------------------------------------------- /test/Spec/Contravariant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | 3 | module Spec.Contravariant (testContravariant) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes 7 | 8 | --import Data.Functor.Contravariant -- lol 9 | import Data.Functor.Const (Const(..)) 10 | import Data.Functor.Sum (Sum(..)) 11 | import Data.Functor.Product (Product(..)) 12 | import Data.Proxy (Proxy(..)) 13 | 14 | import qualified Hedgehog.Gen as Gen 15 | import qualified Hedgehog.Range as Range 16 | 17 | testContravariant :: [(String, [Laws])] 18 | testContravariant = 19 | [ ("Proxy", listProxy) 20 | , ("Const", listConst) 21 | , ("Sum", listSum) 22 | , ("Product", listProduct) 23 | -- , ("Bad Contravariant", listBadContravariant) 24 | ] 25 | 26 | listProxy :: [Laws] 27 | listProxy = [contravariantLaws genProxy] 28 | 29 | listConst :: [Laws] 30 | listConst = [contravariantLaws genConst] 31 | 32 | listSum :: [Laws] 33 | listSum = [contravariantLaws genSum] 34 | 35 | listProduct :: [Laws] 36 | listProduct = [contravariantLaws genProduct] 37 | 38 | --listBadContravariant :: [Laws] 39 | --listBadContravariant = [contravariantLaws genBadContravariant] 40 | 41 | genProxy :: Gen a -> Gen (Proxy a) 42 | genProxy = const (pure Proxy) 43 | 44 | genConst :: Gen b -> Gen (Const Integer b) 45 | genConst _ = fmap Const (Gen.integral (Range.linear 0 20)) 46 | 47 | genSum :: Gen a -> Gen (Sum (Const ()) (Const ()) a) 48 | genSum _genA = 49 | Gen.sized $ \n -> 50 | Gen.frequency [ 51 | (2, pure $ InL (Const ())) 52 | , (1 + fromIntegral n, pure $ InR (Const ())) 53 | ] 54 | 55 | genProduct :: Gen a -> Gen (Product (Const ()) (Const ()) a) 56 | genProduct _genA = do 57 | pure (Pair (Const ()) (Const ())) 58 | 59 | {- 60 | newtype BadContravariant a = BadContravariant (a -> a) 61 | 62 | instance Show (BadContravariant a) where 63 | show _ = "BadContravariant <>" 64 | 65 | instance Eq a => Eq (BadContravariant a) where 66 | BadContravariant f == BadContravariant g = False 67 | 68 | instance Contravariant BadContravariant where 69 | contramap f _ = BadContravariant id 70 | 71 | genBadContravariant :: Gen a -> Gen (BadContravariant a) 72 | genBadContravariant = fmap (BadContravariant . const) 73 | -} 74 | 75 | -------------------------------------------------------------------------------- /test/Spec/Enum.hs: -------------------------------------------------------------------------------- 1 | module Spec.Enum (testEnum, testBoundedEnum) where 2 | 3 | import Hedgehog 4 | import Hedgehog.Classes 5 | 6 | import Data.Int (Int64) 7 | import Data.Word (Word64) 8 | import qualified Hedgehog.Gen as Gen 9 | import qualified Hedgehog.Range as Range 10 | import Numeric.Natural (Natural) 11 | 12 | testEnum :: [(String, [Laws])] 13 | testEnum = 14 | [ ("Integer", listInteger) 15 | , ("Natural", listNatural) 16 | ] 17 | 18 | testBoundedEnum :: [(String, [Laws])] 19 | testBoundedEnum = 20 | [ ("E", listE) 21 | , ("Int", listInt) 22 | , ("Int8", listInt8) 23 | , ("Int16", listInt16) 24 | , ("Int32", listInt32) 25 | , ("Int64", listInt64) 26 | , ("Word", listWord) 27 | , ("Word8", listWord8) 28 | , ("Word16", listWord16) 29 | , ("Word32", listWord32) 30 | , ("Word64", listWord64) 31 | ] 32 | 33 | listE :: [Laws] 34 | listE = [boundedEnumLaws genE] 35 | 36 | data E = E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8 37 | deriving (Eq, Show, Enum, Bounded) 38 | 39 | genE :: Gen E 40 | genE = Gen.frequency 41 | [ (1, pure E1) 42 | , (1, pure E2) 43 | , (1, pure E3) 44 | , (1, pure E4) 45 | , (1, pure E5) 46 | , (1, pure E6) 47 | , (1, pure E7) 48 | , (1, pure E8) 49 | ] 50 | 51 | ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b 52 | ranged f = f (Range.constantBounded) 53 | 54 | listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] 55 | listInt = [boundedEnumLaws (ranged Gen.int)] 56 | listInt8 = [boundedEnumLaws (ranged Gen.int8)] 57 | listInt16 = [boundedEnumLaws (ranged Gen.int16)] 58 | listInt32 = [boundedEnumLaws (ranged Gen.int32)] 59 | listInt64 = [boundedEnumLaws (ranged Gen.int64)] 60 | 61 | listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] 62 | listWord = [boundedEnumLaws (ranged Gen.word)] 63 | listWord8 = [boundedEnumLaws (ranged Gen.word8)] 64 | listWord16 = [boundedEnumLaws (ranged Gen.word16)] 65 | listWord32 = [boundedEnumLaws (ranged Gen.word32)] 66 | listWord64 = [boundedEnumLaws (ranged Gen.word64)] 67 | 68 | listInteger, listNatural :: [Laws] 69 | listInteger = [enumLaws (Gen.integral $ Range.constantFrom 70 | (0 :: Integer) 71 | (2 * fromIntegral (minBound :: Int64)) 72 | (2 * fromIntegral (maxBound :: Int64)))] 73 | listNatural = [enumLaws (Gen.integral $ Range.constant 74 | (0 :: Natural) 75 | (2 * fromIntegral (maxBound :: Word64)))] 76 | -------------------------------------------------------------------------------- /test/Spec/Eq.hs: -------------------------------------------------------------------------------- 1 | module Spec.Eq (testEq) where 2 | 3 | import Hedgehog.Classes 4 | 5 | import qualified Hedgehog.Gen as Gen 6 | import qualified Hedgehog.Range as Range 7 | 8 | ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b 9 | ranged f = f (Range.constantBounded) 10 | 11 | testEq :: [(String, [Laws])] 12 | testEq = 13 | [ ("Int", listInt) 14 | , ("Int8", listInt8) 15 | , ("Int16", listInt16) 16 | , ("Int32", listInt32) 17 | , ("Int64", listInt64) 18 | , ("Word", listWord) 19 | , ("Word8", listWord8) 20 | , ("Word16", listWord16) 21 | , ("Word32", listWord32) 22 | , ("Word64", listWord64) 23 | -- , ("BadEq", listBadEq) 24 | ] 25 | 26 | listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] 27 | listInt = [eqLaws (ranged Gen.int)] 28 | listInt8 = [eqLaws (ranged Gen.int8)] 29 | listInt16 = [eqLaws (ranged Gen.int16)] 30 | listInt32 = [eqLaws (ranged Gen.int32)] 31 | listInt64 = [eqLaws (ranged Gen.int64)] 32 | 33 | listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] 34 | listWord = [eqLaws (ranged Gen.word)] 35 | listWord8 = [eqLaws (ranged Gen.word8)] 36 | listWord16 = [eqLaws (ranged Gen.word16)] 37 | listWord32 = [eqLaws (ranged Gen.word32)] 38 | listWord64 = [eqLaws (ranged Gen.word64)] 39 | 40 | {- 41 | listBadEq :: [Laws] 42 | listBadEq = [ eqLaws $ pure BadReflexive ] 43 | ++ [ eqLaws $ Gen.frequency [(1, pure BadSymmetric1),(1,pure BadSymmetric2)] ] 44 | 45 | data BadReflexive = BadReflexive 46 | deriving (Show) 47 | 48 | instance Eq BadReflexive where 49 | _ == _ = False 50 | 51 | data BadSymmetric = BadSymmetric1 | BadSymmetric2 52 | deriving (Show) 53 | 54 | instance Eq BadSymmetric where 55 | BadSymmetric1 == BadSymmetric1 = True 56 | BadSymmetric2 == BadSymmetric2 = True 57 | BadSymmetric2 == BadSymmetric1 = True 58 | BadSymmetric1 == BadSymmetric2 = False 59 | -} 60 | -------------------------------------------------------------------------------- /test/Spec/Foldable.hs: -------------------------------------------------------------------------------- 1 | module Spec.Foldable (testFoldable) where 2 | 3 | import Hedgehog 4 | import Hedgehog.Classes 5 | 6 | import Data.Set (Set) 7 | import qualified Data.Set as Set 8 | 9 | --import qualified Data.List as List 10 | --import qualified Hedgehog.Gen as Gen 11 | --import qualified Hedgehog.Range as Range 12 | 13 | testFoldable :: [(String, [Laws])] 14 | testFoldable = 15 | [ ("Set", listSet) 16 | -- , ("BadList", listBadList) 17 | ] 18 | 19 | listSet :: [Laws] 20 | listSet = [foldableLaws genSet] 21 | 22 | genSet :: Gen a -> Gen (Set a) 23 | genSet gen = do 24 | x <- gen 25 | pure (Set.singleton x) 26 | 27 | {- 28 | listBadList :: [Laws] 29 | listBadList = [foldableLaws genBadList] 30 | 31 | genBadList :: Gen a -> Gen (BadList a) 32 | genBadList gen = BadList <$> Gen.list (Range.linear 0 20) gen 33 | 34 | newtype BadList a = BadList [a] 35 | deriving (Eq, Show) 36 | 37 | instance Foldable BadList where 38 | foldMap f (BadList x) = foldMap f x 39 | foldl' = List.foldl 40 | -} 41 | -------------------------------------------------------------------------------- /test/Spec/Functor.hs: -------------------------------------------------------------------------------- 1 | module Spec.Functor (testFunctor) where 2 | 3 | import Data.Functor.Compose (Compose(..)) 4 | import Data.Functor.Identity (Identity(..)) 5 | 6 | import Hedgehog 7 | import Hedgehog.Classes 8 | 9 | import qualified Hedgehog.Gen as Gen 10 | import qualified Hedgehog.Range as Range 11 | 12 | import Prelude hiding (either) 13 | 14 | testFunctor :: [(String, [Laws])] 15 | testFunctor = 16 | [ ("[]", lawsList) 17 | , ("Maybe", lawsMaybe) 18 | , ("Either e", lawsEither) 19 | , ("Compose", lawsCompose) 20 | ] 21 | 22 | lawsList :: [Laws] 23 | lawsList = [functorLaws (Gen.list (Range.linear 0 6))] 24 | 25 | lawsMaybe :: [Laws] 26 | lawsMaybe = [functorLaws Gen.maybe] 27 | 28 | lawsEither :: [Laws] 29 | lawsEither = [functorLaws eitherInteger] 30 | 31 | lawsCompose :: [Laws] 32 | lawsCompose = [functorLaws genCompose] 33 | 34 | genCompose :: Gen a -> Gen (Compose Identity Identity a) 35 | genCompose = fmap (Compose . Identity . Identity) 36 | 37 | eitherInteger :: MonadGen m => m a -> m (Either Integer a) 38 | eitherInteger = either (Gen.integral (Range.linear 0 20)) 39 | 40 | either :: MonadGen m => m e -> m a -> m (Either e a) 41 | either genE genA = 42 | Gen.sized $ \n -> 43 | Gen.frequency [ 44 | (2, Left <$> genE) 45 | , (1 + fromIntegral n, Right <$> genA) 46 | ] 47 | -------------------------------------------------------------------------------- /test/Spec/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Spec.Generic (testGeneric) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes 7 | import qualified Hedgehog.Gen as Gen 8 | 9 | import GHC.Generics (Generic(..)) 10 | 11 | testGeneric :: [(String, [Laws])] 12 | testGeneric = 13 | [ ("E", listE) 14 | , ("Bool", listBool) 15 | , ("Maybe Bool", listMaybe) 16 | ] 17 | 18 | listE :: [Laws] 19 | listE = [genericLaws genE (genRep genE)] 20 | 21 | listBool :: [Laws] 22 | listBool = [genericLaws Gen.bool (genRep Gen.bool)] 23 | 24 | listMaybe :: [Laws] 25 | listMaybe = [genericLaws (Gen.maybe Gen.bool) (genRep (Gen.maybe Gen.bool))] 26 | 27 | data E = E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8 28 | deriving (Eq, Show, Generic) 29 | 30 | genRep :: Generic a => Gen a -> Gen (Rep a ()) 31 | genRep gen = do 32 | x <- gen 33 | pure (from x) 34 | 35 | genE :: Gen E 36 | genE = Gen.frequency 37 | [ (1, pure E1) 38 | , (1, pure E2) 39 | , (1, pure E3) 40 | , (1, pure E4) 41 | , (1, pure E5) 42 | , (1, pure E6) 43 | , (1, pure E7) 44 | , (1, pure E8) 45 | ] 46 | -------------------------------------------------------------------------------- /test/Spec/Integral.hs: -------------------------------------------------------------------------------- 1 | module Spec.Integral (testIntegral) where 2 | 3 | import Hedgehog.Classes 4 | 5 | import qualified Hedgehog.Gen as Gen 6 | import qualified Hedgehog.Range as Range 7 | 8 | ranged :: (Bounded a, Integral a) => (Range.Range a -> b) -> b 9 | ranged f = f (Range.linear 1 maxBound) 10 | 11 | testIntegral :: [(String, [Laws])] 12 | testIntegral = 13 | [ ("Int", listInt) 14 | , ("Int8", listInt8) 15 | , ("Int16", listInt16) 16 | , ("Int32", listInt32) 17 | , ("Int64", listInt64) 18 | , ("Word", listWord) 19 | , ("Word8", listWord8) 20 | , ("Word16", listWord16) 21 | , ("Word32", listWord32) 22 | , ("Word64", listWord64) 23 | ] 24 | 25 | listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] 26 | listInt = [integralLaws (ranged Gen.int)] 27 | listInt8 = [integralLaws (ranged Gen.int8)] 28 | listInt16 = [integralLaws (ranged Gen.int16)] 29 | listInt32 = [integralLaws (ranged Gen.int32)] 30 | listInt64 = [integralLaws (ranged Gen.int64)] 31 | 32 | listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] 33 | listWord = [integralLaws (ranged Gen.word)] 34 | listWord8 = [integralLaws (ranged Gen.word8)] 35 | listWord16 = [integralLaws (ranged Gen.word16)] 36 | listWord32 = [integralLaws (ranged Gen.word32)] 37 | listWord64 = [integralLaws (ranged Gen.word64)] 38 | -------------------------------------------------------------------------------- /test/Spec/Ix.hs: -------------------------------------------------------------------------------- 1 | module Spec.Ix (testIx) where 2 | 3 | import Hedgehog.Classes 4 | 5 | import qualified Hedgehog.Gen as Gen 6 | import qualified Hedgehog.Range as Range 7 | 8 | ranged :: Integral a => (Range.Range a -> b) -> b 9 | ranged f = f (Range.linear 0 20) 10 | 11 | testIx :: [(String, [Laws])] 12 | testIx = 13 | [ ("Int", listInt) 14 | , ("Int8", listInt8) 15 | , ("Int16", listInt16) 16 | , ("Int32", listInt32) 17 | , ("Int64", listInt64) 18 | , ("Word", listWord) 19 | , ("Word8", listWord8) 20 | , ("Word16", listWord16) 21 | , ("Word32", listWord32) 22 | , ("Word64", listWord64) 23 | , ("Bool", listBool) 24 | ] 25 | 26 | listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] 27 | listInt = [ixLaws (ranged Gen.int)] 28 | listInt8 = [ixLaws (ranged Gen.int8)] 29 | listInt16 = [ixLaws (ranged Gen.int16)] 30 | listInt32 = [ixLaws (ranged Gen.int32)] 31 | listInt64 = [ixLaws (ranged Gen.int64)] 32 | 33 | listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] 34 | listWord = [ixLaws (ranged Gen.word)] 35 | listWord8 = [ixLaws (ranged Gen.word8)] 36 | listWord16 = [ixLaws (ranged Gen.word16)] 37 | listWord32 = [ixLaws (ranged Gen.word32)] 38 | listWord64 = [ixLaws (ranged Gen.word64)] 39 | 40 | listBool :: [Laws] 41 | listBool = [ixLaws Gen.bool] 42 | -------------------------------------------------------------------------------- /test/Spec/Json.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Spec.Json (testJson) where 4 | 5 | import Hedgehog 6 | import Hedgehog.Classes 7 | import qualified Hedgehog.Gen as Gen 8 | import qualified Hedgehog.Range as Range 9 | 10 | import GHC.Generics (Generic) 11 | 12 | import Data.Aeson (FromJSON, ToJSON) 13 | 14 | testJson :: [(String, [Laws])] 15 | testJson = 16 | [ ("Person", listPerson) 17 | ] 18 | 19 | data Person = Person { name :: String, age :: Int } 20 | deriving (Eq, Show, Generic) 21 | 22 | instance FromJSON Person where 23 | instance ToJSON Person where 24 | 25 | listPerson :: [Laws] 26 | listPerson = [jsonLaws genPerson] 27 | 28 | genPerson :: Gen Person 29 | genPerson = Person <$> (Gen.string (Range.linear 3 7) Gen.alpha) <*> (Gen.int (Range.linear 0 65)) 30 | -------------------------------------------------------------------------------- /test/Spec/MVector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | #if !HAVE_VECTOR 4 | 5 | module Spec.MVector (testMUVector) where 6 | 7 | testMUVector :: [a] 8 | testMUVector = [] 9 | 10 | #else 11 | 12 | module Spec.MVector (testMUVector) where 13 | 14 | import qualified Hedgehog.Gen as Gen 15 | import qualified Hedgehog.Range as Range 16 | 17 | import Hedgehog.Classes (Laws, muvectorLaws) 18 | 19 | testMUVector :: [(String, [Laws])] 20 | testMUVector = 21 | [ ("Word8", [muvectorLaws (Gen.word8 Range.constantBounded)]) 22 | , ("(Int, Word)", [muvectorLaws ((,) <$> Gen.int Range.constantBounded <*> Gen.word Range.constantBounded)]) 23 | ] 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /test/Spec/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# language 2 | DerivingStrategies 3 | , GeneralizedNewtypeDeriving 4 | #-} 5 | 6 | module Spec.Monad 7 | ( testMonad 8 | , testMonadIO 9 | , testMonadPlus 10 | , testMonadZip 11 | ) where 12 | 13 | import qualified Control.Applicative as App (liftA2) 14 | import Control.Applicative (Alternative(..)) 15 | import Control.Monad.IO.Class (MonadIO(..)) 16 | 17 | import Data.Functor.Identity (Identity(..)) 18 | 19 | import Hedgehog 20 | import Hedgehog.Classes 21 | 22 | import qualified Hedgehog.Gen as Gen 23 | import qualified Hedgehog.Range as Range 24 | 25 | import System.IO.Unsafe (unsafePerformIO) 26 | 27 | import Prelude hiding (either) 28 | 29 | testMonad :: [(String, [Laws])] 30 | testMonad = 31 | [ ("[]", lawsList) 32 | , ("Either e", lawsEither) 33 | , ("Identity", lawsIdentity) 34 | , ("IO", lawsIO) 35 | , ("Maybe", lawsMaybe) 36 | ] 37 | 38 | {- 39 | testMonadFix :: [(String, [Laws])] 40 | testMonadFix = 41 | [ ("[]", fixLawsList) 42 | , ("Either e", fixLawsEither) 43 | , ("Identity", fixLawsIdentity) 44 | , ("IO", fixLawsIO) 45 | , ("Maybe", fixLawsMaybe) 46 | ] 47 | -} 48 | 49 | testMonadIO :: [(String, [Laws])] 50 | testMonadIO = 51 | [ ("IO", ioLawsIO) 52 | ] 53 | 54 | testMonadPlus :: [(String, [Laws])] 55 | testMonadPlus = 56 | [ ("[]", plusLawsList) 57 | , ("Maybe", plusLawsMaybe) 58 | ] 59 | 60 | testMonadZip :: [(String, [Laws])] 61 | testMonadZip = 62 | [ ("[]", zipLawsList) 63 | , ("Identity", zipLawsIdentity) 64 | , ("Maybe", zipLawsMaybe) 65 | ] 66 | 67 | lawsEither :: [Laws] 68 | lawsEither = [monadLaws eitherInteger] 69 | 70 | eitherInteger :: MonadGen m => m a -> m (Either Integer a) 71 | eitherInteger = either (Gen.integral (Range.linear 0 20)) 72 | 73 | either :: MonadGen m => m e -> m a -> m (Either e a) 74 | either genE genA = 75 | Gen.sized $ \n -> 76 | Gen.frequency [ 77 | (2, Left <$> genE) 78 | , (1 + fromIntegral n, Right <$> genA) 79 | ] 80 | 81 | lawsIdentity, zipLawsIdentity :: [Laws] 82 | lawsIdentity = [monadLaws identity] 83 | zipLawsIdentity = [monadZipLaws identity] 84 | 85 | identity :: MonadGen m => m a -> m (Identity a) 86 | identity = fmap Identity 87 | 88 | lawsList, plusLawsList, zipLawsList :: [Laws] 89 | lawsList = [monadLaws list] 90 | plusLawsList = [monadPlusLaws list] 91 | zipLawsList = [monadZipLaws list] 92 | 93 | list :: MonadGen m => m a -> m [a] 94 | list = Gen.list $ Range.linear 0 6 95 | 96 | lawsMaybe, plusLawsMaybe, zipLawsMaybe :: [Laws] 97 | lawsMaybe = [monadLaws Gen.maybe] 98 | plusLawsMaybe = [monadPlusLaws Gen.maybe] 99 | zipLawsMaybe = [monadZipLaws Gen.maybe] 100 | 101 | lawsIO, ioLawsIO :: [Laws] 102 | lawsIO = [monadLaws io] 103 | ioLawsIO = [monadIOLaws io] 104 | 105 | newtype TestIO a = TestIO (IO a) 106 | deriving newtype (Functor, Applicative, Monad, Alternative) 107 | 108 | -- | Unsafe! 109 | instance Eq a => Eq (TestIO a) where 110 | TestIO a == TestIO b = unsafePerformIO $ App.liftA2 (==) a b 111 | {-# noinline (==) #-} 112 | -- | Unsafe! 113 | instance Show a => Show (TestIO a) where 114 | showsPrec d (TestIO a) = unsafePerformIO $ fmap (showsPrec d) a 115 | instance MonadIO TestIO where 116 | liftIO = TestIO 117 | 118 | io :: MonadGen m => m a -> m (TestIO a) 119 | io = fmap pure 120 | -------------------------------------------------------------------------------- /test/Spec/Monoid.hs: -------------------------------------------------------------------------------- 1 | module Spec.Monoid (testMonoid, testCommutativeMonoid) where 2 | 3 | import Hedgehog (Gen) 4 | import Hedgehog.Classes 5 | 6 | import Data.Coerce (coerce) 7 | import qualified Hedgehog.Gen as Gen 8 | import qualified Hedgehog.Range as Range 9 | import Data.Monoid 10 | 11 | testMonoid :: [(String, [Laws])] 12 | testMonoid = 13 | [ ("Sum Integer", lawsSum) 14 | , ("Product Integer", lawsProduct) 15 | , ("Maybe Integer", lawsMaybe) 16 | , ("Ap Maybe Integer", lawsAp) 17 | ] 18 | 19 | testCommutativeMonoid :: [(String, [Laws])] 20 | testCommutativeMonoid = 21 | [ ("Sum Integer", commutativeLawsSum) 22 | , ("Product Integer", commutativeLawsProduct) 23 | , ("Maybe Integer", commutativeLawsMaybe) 24 | ] 25 | 26 | genInteger :: Gen Integer 27 | genInteger = Gen.integral (Range.linear (-3) 20) 28 | 29 | lawsSum, commutativeLawsSum :: [Laws] 30 | lawsSum = [monoidLaws genSum] 31 | commutativeLawsSum = [commutativeMonoidLaws genSum] 32 | 33 | genSum :: Gen (Sum Integer) 34 | genSum = fmap coerce genInteger 35 | 36 | lawsProduct, commutativeLawsProduct :: [Laws] 37 | lawsProduct = [monoidLaws genProduct] 38 | commutativeLawsProduct = [commutativeMonoidLaws genProduct] 39 | 40 | genProduct :: Gen (Product Integer) 41 | genProduct = fmap coerce genInteger 42 | 43 | lawsMaybe, commutativeLawsMaybe :: [Laws] 44 | lawsMaybe = [monoidLaws genMaybe] 45 | commutativeLawsMaybe = [commutativeMonoidLaws genMaybe] 46 | 47 | genMaybe :: Gen (Maybe (Sum Integer)) 48 | genMaybe = Gen.maybe genSum 49 | 50 | lawsAp :: [Laws] 51 | lawsAp = [monoidLaws genAp] 52 | 53 | genAp :: Gen (Ap Maybe (Sum Integer)) 54 | genAp = fmap coerce genMaybe 55 | -------------------------------------------------------------------------------- /test/Spec/Ord.hs: -------------------------------------------------------------------------------- 1 | {-# language TypeApplications #-} 2 | 3 | module Spec.Ord (testOrd) where 4 | 5 | import Hedgehog.Classes 6 | import Hedgehog (Gen) 7 | import GHC.Natural 8 | 9 | import qualified Hedgehog.Range as Range 10 | import qualified Hedgehog.Gen as Gen 11 | 12 | testOrd :: [(String, [Laws])] 13 | testOrd = 14 | [ ("Int", listInt) 15 | , ("Int8", listInt8) 16 | , ("Int16", listInt16) 17 | , ("Int32", listInt32) 18 | , ("Int64", listInt64) 19 | , ("Word", listWord) 20 | , ("Word8", listWord8) 21 | , ("Word16", listWord16) 22 | , ("Word32", listWord32) 23 | , ("Word64", listWord64) 24 | , ("Natural", listNatural) 25 | , ("Pair", listPair) 26 | ] 27 | 28 | ranged :: (Integral a) => (Range.Range a -> b) -> b 29 | ranged f = f (Range.linear 0 100) 30 | 31 | listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws] 32 | listInt = [ordLaws (ranged Gen.int)] 33 | listInt8 = [ordLaws (ranged Gen.int8)] 34 | listInt16 = [ordLaws (ranged Gen.int16)] 35 | listInt32 = [ordLaws (ranged Gen.int32)] 36 | listInt64 = [ordLaws (ranged Gen.int64)] 37 | 38 | listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws] 39 | listWord = [ordLaws (ranged Gen.word)] 40 | listWord8 = [ordLaws (ranged Gen.word8)] 41 | listWord16 = [ordLaws (ranged Gen.word16)] 42 | listWord32 = [ordLaws (ranged Gen.word32)] 43 | listWord64 = [ordLaws (ranged Gen.word64)] 44 | 45 | listNatural :: [Laws] 46 | listNatural = [ordLaws (ranged @Natural Gen.integral)] 47 | 48 | listPair :: [Laws] 49 | listPair = [ordLaws (genPair (ranged Gen.int) (ranged Gen.int8))] 50 | 51 | data Pair a b = Pair a b 52 | deriving (Eq, Ord, Show) 53 | 54 | genPair :: Gen a -> Gen b -> Gen (Pair a b) 55 | genPair genA genB = Pair <$> genA <*> genB 56 | -------------------------------------------------------------------------------- /test/Spec/Prim.hs: -------------------------------------------------------------------------------- 1 | {-# language TypeApplications #-} 2 | 3 | module Spec.Prim (testPrim) where 4 | 5 | import qualified Hedgehog.Gen as Gen 6 | import qualified Hedgehog.Range as Range 7 | 8 | import Hedgehog.Classes (Laws, primLaws) 9 | 10 | testPrim :: [(String, [Laws])] 11 | testPrim = 12 | [ ("Int", [primLaws (Gen.int Range.constantBounded)]) 13 | , ("Int8", [primLaws (Gen.int8 Range.constantBounded)]) 14 | , ("Int16", [primLaws (Gen.int16 Range.constantBounded)]) 15 | , ("Int32", [primLaws (Gen.int32 Range.constantBounded)]) 16 | , ("Int64", [primLaws (Gen.int64 Range.constantBounded)]) 17 | , ("Word", [primLaws (Gen.word Range.constantBounded)]) 18 | , ("Word8", [primLaws (Gen.word8 Range.constantBounded)]) 19 | , ("Word16", [primLaws (Gen.word16 Range.constantBounded)]) 20 | , ("Word32", [primLaws (Gen.word32 Range.constantBounded)]) 21 | , ("Word64", [primLaws (Gen.word64 Range.constantBounded)]) 22 | ] 23 | 24 | -------------------------------------------------------------------------------- /test/Spec/Semigroup.hs: -------------------------------------------------------------------------------- 1 | module Spec.Semigroup 2 | ( testSemigroup 3 | , testCommutativeSemigroup 4 | , testExponentialSemigroup 5 | , testIdempotentSemigroup 6 | , testRectangularBandSemigroup 7 | ) where 8 | 9 | import Hedgehog.Classes 10 | 11 | import Data.Monoid (Sum(..)) 12 | import Data.Semigroup (Last(..)) 13 | import Hedgehog (Gen) 14 | import qualified Hedgehog.Gen as Gen 15 | import qualified Hedgehog.Range as Range 16 | 17 | testSemigroup :: [(String, [Laws])] 18 | testSemigroup = 19 | [ ("Last", lawsLast) 20 | , ("Maybe", lawsMaybe) 21 | ] 22 | 23 | testCommutativeSemigroup :: [(String, [Laws])] 24 | testCommutativeSemigroup = 25 | [ ("Maybe", commutativeLawsMaybe) 26 | ] 27 | 28 | testExponentialSemigroup :: [(String, [Laws])] 29 | testExponentialSemigroup = 30 | [ ("Last", exponentialLawsLast) 31 | , ("Maybe", exponentialLawsMaybe) 32 | ] 33 | 34 | testIdempotentSemigroup :: [(String, [Laws])] 35 | testIdempotentSemigroup = 36 | [ ("Last", idempotentLawsLast) 37 | ] 38 | 39 | testRectangularBandSemigroup :: [(String, [Laws])] 40 | testRectangularBandSemigroup = 41 | [ ("Last", rectangularBandLawsLast) 42 | ] 43 | 44 | genInteger :: Gen Integer 45 | genInteger = Gen.integral (Range.linear (-3) 20) 46 | 47 | lawsLast, exponentialLawsLast, idempotentLawsLast, rectangularBandLawsLast :: [Laws] 48 | lawsLast = [semigroupLaws genLast] 49 | exponentialLawsLast = [exponentialSemigroupLaws genLast] 50 | idempotentLawsLast = [idempotentSemigroupLaws genLast] 51 | rectangularBandLawsLast = [rectangularBandSemigroupLaws genLast] 52 | 53 | genLast :: Gen (Last Integer) 54 | genLast = Last <$> genInteger 55 | 56 | lawsMaybe, commutativeLawsMaybe, exponentialLawsMaybe :: [Laws] 57 | lawsMaybe = [semigroupLaws genMaybe] 58 | commutativeLawsMaybe = [commutativeSemigroupLaws genMaybe] 59 | exponentialLawsMaybe = [exponentialSemigroupLaws genMaybe] 60 | 61 | genMaybe :: Gen (Maybe (Sum Integer)) 62 | genMaybe = Gen.maybe (Sum <$> genInteger) 63 | -------------------------------------------------------------------------------- /test/Spec/Semiring.hs: -------------------------------------------------------------------------------- 1 | module Spec.Semiring 2 | ( testSemiring 3 | , testRing 4 | , testStar 5 | ) where 6 | 7 | import Hedgehog.Classes 8 | 9 | import qualified Hedgehog.Gen as Gen 10 | import qualified Hedgehog.Range as Range 11 | 12 | testSemiring :: [(String, [Laws])] 13 | testSemiring = 14 | [ ("Bool", lawsBool) 15 | , ("Int", lawsInt) 16 | , ("Int8", lawsInt8) 17 | , ("Int16", lawsInt16) 18 | , ("Int32", lawsInt32) 19 | , ("Int64", lawsInt64) 20 | , ("Word", lawsWord) 21 | , ("Word8", lawsWord8) 22 | , ("Word16", lawsWord16) 23 | , ("Word32", lawsWord32) 24 | , ("Word64", lawsWord64) 25 | ] 26 | 27 | testRing :: [(String, [Laws])] 28 | testRing = 29 | [ ("Int", ringLawsInt) 30 | , ("Int8", ringLawsInt8) 31 | , ("Int16", ringLawsInt16) 32 | , ("Int32", ringLawsInt32) 33 | , ("Int64", ringLawsInt64) 34 | , ("Word", ringLawsWord) 35 | , ("Word8", ringLawsWord8) 36 | , ("Word16", ringLawsWord16) 37 | , ("Word32", ringLawsWord32) 38 | , ("Word64", ringLawsWord64) 39 | ] 40 | 41 | testStar :: [(String, [Laws])] 42 | testStar = 43 | [ ("Bool", starLawsBool) 44 | ] 45 | 46 | ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b 47 | ranged f = f Range.constantBounded 48 | 49 | lawsBool, starLawsBool :: [Laws] 50 | lawsBool = [semiringLaws Gen.bool] 51 | starLawsBool = [starLaws Gen.bool] 52 | 53 | lawsInt, lawsInt8, lawsInt16, lawsInt32, lawsInt64 :: [Laws] 54 | lawsInt = [semiringLaws (ranged Gen.int)] 55 | lawsInt8 = [semiringLaws (ranged Gen.int8)] 56 | lawsInt16 = [semiringLaws (ranged Gen.int16)] 57 | lawsInt32 = [semiringLaws (ranged Gen.int32)] 58 | lawsInt64 = [semiringLaws (ranged Gen.int64)] 59 | 60 | lawsWord, lawsWord8, lawsWord16, lawsWord32, lawsWord64 :: [Laws] 61 | lawsWord = [semiringLaws (ranged Gen.word)] 62 | lawsWord8 = [semiringLaws (ranged Gen.word8)] 63 | lawsWord16 = [semiringLaws (ranged Gen.word16)] 64 | lawsWord32 = [semiringLaws (ranged Gen.word32)] 65 | lawsWord64 = [semiringLaws (ranged Gen.word64)] 66 | 67 | ringLawsInt, ringLawsInt8, ringLawsInt16, ringLawsInt32, ringLawsInt64 :: [Laws] 68 | ringLawsInt = [ringLaws (ranged Gen.int)] 69 | ringLawsInt8 = [ringLaws (ranged Gen.int8)] 70 | ringLawsInt16 = [ringLaws (ranged Gen.int16)] 71 | ringLawsInt32 = [ringLaws (ranged Gen.int32)] 72 | ringLawsInt64 = [ringLaws (ranged Gen.int64)] 73 | 74 | ringLawsWord, ringLawsWord8, ringLawsWord16, ringLawsWord32, ringLawsWord64 :: [Laws] 75 | ringLawsWord = [ringLaws (ranged Gen.word)] 76 | ringLawsWord8 = [ringLaws (ranged Gen.word8)] 77 | ringLawsWord16 = [ringLaws (ranged Gen.word16)] 78 | ringLawsWord32 = [ringLaws (ranged Gen.word32)] 79 | ringLawsWord64 = [ringLaws (ranged Gen.word64)] 80 | -------------------------------------------------------------------------------- /test/Spec/Show.hs: -------------------------------------------------------------------------------- 1 | module Spec.Show 2 | ( testShow 3 | , testShowRead 4 | ) where 5 | 6 | import Hedgehog 7 | import Hedgehog.Classes 8 | 9 | import qualified Hedgehog.Gen as Gen 10 | import qualified Hedgehog.Range as Range 11 | 12 | testShow :: [(String, [Laws])] 13 | testShow = 14 | [ ("E", lawsE) 15 | , ("Int", lawsInt) 16 | , ("Int8", lawsInt8) 17 | , ("Int16", lawsInt16) 18 | , ("Int32", lawsInt32) 19 | , ("Int64", lawsInt64) 20 | , ("Word", lawsWord) 21 | , ("Word8", lawsWord8) 22 | , ("Word16", lawsWord16) 23 | , ("Word32", lawsWord32) 24 | , ("Word64", lawsWord64) 25 | ] 26 | 27 | testShowRead :: [(String, [Laws])] 28 | testShowRead = 29 | [ ("E", readLawsE) 30 | , ("Int", readLawsInt) 31 | , ("Int8", readLawsInt8) 32 | , ("Int16", readLawsInt16) 33 | , ("Int32", readLawsInt32) 34 | , ("Int64", readLawsInt64) 35 | , ("Word", readLawsWord) 36 | , ("Word8", readLawsWord8) 37 | , ("Word16", readLawsWord16) 38 | , ("Word32", readLawsWord32) 39 | , ("Word64", readLawsWord64) 40 | ] 41 | 42 | lawsE, readLawsE :: [Laws] 43 | lawsE = [showLaws genE] 44 | readLawsE = [showReadLaws genE] 45 | 46 | data E = E1 | E2 | E3 | E4 | E5 | E6 | E7 | E8 47 | deriving (Eq, Show, Read, Enum, Bounded) 48 | 49 | genE :: Gen E 50 | genE = Gen.enumBounded 51 | 52 | ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b 53 | ranged f = f (Range.constantBounded) 54 | 55 | lawsInt, lawsInt8, lawsInt16, lawsInt32, lawsInt64 :: [Laws] 56 | lawsInt = [showLaws (ranged Gen.int)] 57 | lawsInt8 = [showLaws (ranged Gen.int8)] 58 | lawsInt16 = [showLaws (ranged Gen.int16)] 59 | lawsInt32 = [showLaws (ranged Gen.int32)] 60 | lawsInt64 = [showLaws (ranged Gen.int64)] 61 | 62 | lawsWord, lawsWord8, lawsWord16, lawsWord32, lawsWord64 :: [Laws] 63 | lawsWord = [showLaws (ranged Gen.word)] 64 | lawsWord8 = [showLaws (ranged Gen.word8)] 65 | lawsWord16 = [showLaws (ranged Gen.word16)] 66 | lawsWord32 = [showLaws (ranged Gen.word32)] 67 | lawsWord64 = [showLaws (ranged Gen.word64)] 68 | 69 | readLawsInt, readLawsInt8, readLawsInt16, readLawsInt32, readLawsInt64 :: [Laws] 70 | readLawsInt = [showReadLaws (ranged Gen.int)] 71 | readLawsInt8 = [showReadLaws (ranged Gen.int8)] 72 | readLawsInt16 = [showReadLaws (ranged Gen.int16)] 73 | readLawsInt32 = [showReadLaws (ranged Gen.int32)] 74 | readLawsInt64 = [showReadLaws (ranged Gen.int64)] 75 | 76 | readLawsWord, readLawsWord8, readLawsWord16, readLawsWord32, readLawsWord64 :: [Laws] 77 | readLawsWord = [showReadLaws (ranged Gen.word)] 78 | readLawsWord8 = [showReadLaws (ranged Gen.word8)] 79 | readLawsWord16 = [showReadLaws (ranged Gen.word16)] 80 | readLawsWord32 = [showReadLaws (ranged Gen.word32)] 81 | readLawsWord64 = [showReadLaws (ranged Gen.word64)] 82 | -------------------------------------------------------------------------------- /test/Spec/Storable.hs: -------------------------------------------------------------------------------- 1 | module Spec.Storable (testStorable) where 2 | 3 | import Foreign.C.String (CString, newCString, peekCString) 4 | import Foreign.C.Types (CInt) 5 | import Foreign.Ptr (nullPtr, castPtr, plusPtr, minusPtr, alignPtr) 6 | import Foreign.Storable (Storable, sizeOf, alignment, peek, peekByteOff, poke, pokeByteOff) 7 | 8 | import Hedgehog (Gen) 9 | import Hedgehog.Classes 10 | 11 | import qualified Hedgehog.Gen as Gen 12 | import qualified Hedgehog.Range as Range 13 | 14 | testStorable :: [(String, [Laws])] 15 | testStorable = 16 | [ ("Int", lawsInt) 17 | , ("Int8", lawsInt8) 18 | , ("Int16", lawsInt16) 19 | , ("Int32", lawsInt32) 20 | , ("Int64", lawsInt64) 21 | , ("Word", lawsWord) 22 | , ("Word8", lawsWord8) 23 | , ("Word16", lawsWord16) 24 | , ("Word32", lawsWord32) 25 | , ("Word64", lawsWord64) 26 | , ("complex struct", lawsStruct) 27 | ] 28 | 29 | ranged :: (Bounded a, Num a) => (Range.Range a -> b) -> b 30 | ranged f = f (Range.constantBounded) 31 | 32 | lawsInt, lawsInt8, lawsInt16, lawsInt32, lawsInt64 :: [Laws] 33 | lawsInt = [storableLaws (ranged Gen.int)] 34 | lawsInt8 = [storableLaws (ranged Gen.int8)] 35 | lawsInt16 = [storableLaws (ranged Gen.int16)] 36 | lawsInt32 = [storableLaws (ranged Gen.int32)] 37 | lawsInt64 = [storableLaws (ranged Gen.int64)] 38 | 39 | lawsWord, lawsWord8, lawsWord16, lawsWord32, lawsWord64 :: [Laws] 40 | lawsWord = [storableLaws (ranged Gen.word)] 41 | lawsWord8 = [storableLaws (ranged Gen.word8)] 42 | lawsWord16 = [storableLaws (ranged Gen.word16)] 43 | lawsWord32 = [storableLaws (ranged Gen.word32)] 44 | lawsWord64 = [storableLaws (ranged Gen.word64)] 45 | 46 | lawsStruct :: [Laws] 47 | lawsStruct = [storableLaws genStruct] 48 | 49 | genStruct :: Gen TestStruct 50 | genStruct = TestStruct 51 | <$> fmap fromIntegral (Gen.integral Range.linearBounded :: Gen CInt) 52 | <*> Gen.string (Range.linear 0 16) (Gen.filter (/= '\NUL') Gen.latin1) 53 | 54 | data TestStruct = TestStruct 55 | { testPadding :: Int 56 | , testString :: String 57 | } 58 | deriving (Eq, Show) 59 | instance Storable TestStruct where 60 | sizeOf _ = offsetTest + (sizeOf (undefined :: Int) `max` sizeOf (undefined :: CString)) 61 | alignment _ = alignment (undefined :: Int) `lcm` alignment (undefined :: CString) 62 | peek ptr = do 63 | pad <- peek $ castPtr ptr 64 | strPtr <- peekByteOff ptr offsetTest 65 | str <- if strPtr == nullPtr 66 | then return "" 67 | else peekCString strPtr 68 | return $ TestStruct 69 | { testPadding = pad 70 | , testString = str 71 | } 72 | poke ptr x = do 73 | poke (castPtr ptr) $ testPadding x 74 | strPtr <- newCString $ testString x 75 | pokeByteOff ptr offsetTest strPtr 76 | 77 | offsetTest :: Int 78 | offsetTest = (nullPtr `plusPtr` sizeOf int) `alignPtr` alignment string `minusPtr` nullPtr 79 | where int = undefined :: Int 80 | string = undefined :: CString 81 | -------------------------------------------------------------------------------- /test/Spec/Traversable.hs: -------------------------------------------------------------------------------- 1 | module Spec.Traversable (testTraversable) where 2 | 3 | import Hedgehog.Classes 4 | 5 | import qualified Hedgehog.Gen as Gen 6 | import qualified Hedgehog.Range as Range 7 | 8 | testTraversable :: [(String, [Laws])] 9 | testTraversable = 10 | [ ("[]", lawsList) 11 | ] 12 | 13 | lawsList :: [Laws] 14 | lawsList = [traversableLaws (Gen.list (Range.linear 0 6))] 15 | --------------------------------------------------------------------------------