├── .editorconfig ├── .github ├── linters │ ├── .ecrc │ └── .markdown-lint.yml └── workflows │ ├── ci-hedgehog.yml │ └── ci-super-linter.yml ├── .gitignore ├── LICENSE ├── README.md ├── docs ├── docs.ipkg └── src │ └── Docs │ ├── Intro.md │ └── Smiles.md ├── hedgehog.ipkg ├── pack.toml ├── src ├── Data │ ├── Bounded.idr │ ├── Cotree.idr │ └── Tree.idr ├── Derive │ └── Cogen.idr ├── Hedgehog.idr └── Hedgehog │ ├── Internal │ ├── Config.idr │ ├── Function.idr │ ├── Gen.idr │ ├── Options.idr │ ├── Property.idr │ ├── Range.idr │ ├── Report.idr │ ├── Runner.idr │ ├── Shrink.idr │ ├── Terminal.idr │ └── Util.idr │ └── Meta.idr └── tests ├── Basic.idr ├── Coverage.idr ├── Functions ├── DeriveCogen.idr ├── NoShrink.idr └── Shrink.idr ├── Tests.idr └── tests.ipkg /.editorconfig: -------------------------------------------------------------------------------- 1 | # top-most EditorConfig file 2 | root = true 3 | 4 | # Defaults for every file 5 | [*] 6 | end_of_line = lf 7 | insert_final_newline = true 8 | trim_trailing_whitespace = true 9 | charset = utf-8 10 | 11 | # Idris source files 12 | [*.{idr,ipkg,tex,yaff,lidr}] 13 | indent_style = space 14 | indent_size = 2 15 | 16 | # Various configuration files 17 | [{*.yml,.ecrc}] 18 | indent_style = space 19 | indent_size = 2 20 | 21 | [*.py] 22 | indent_style = space 23 | indent_size = 4 24 | 25 | [*.{c,h}] 26 | indent_style = space 27 | indent_size = 4 28 | 29 | [*.{md,rst}] 30 | indent_style = space 31 | indent_size = 2 32 | 33 | [*.sh] 34 | indent_style = space 35 | indent_size = 4 36 | shell_variant = posix 37 | switch_case_indent = true 38 | 39 | [*.bat] 40 | indent_style = space 41 | indent_size = 4 42 | 43 | [{Makefile,*.mk}] 44 | indent_style = tab 45 | 46 | [*.nix] 47 | indent_style = space 48 | indent_size = 2 49 | 50 | [expected] 51 | trim_trailing_whitespace = false 52 | -------------------------------------------------------------------------------- /.github/linters/.ecrc: -------------------------------------------------------------------------------- 1 | { 2 | "Disable": { 3 | "IndentSize": true 4 | } 5 | } 6 | -------------------------------------------------------------------------------- /.github/linters/.markdown-lint.yml: -------------------------------------------------------------------------------- 1 | --- 2 | ########################### 3 | ########################### 4 | ## Markdown Linter rules ## 5 | ########################### 6 | ########################### 7 | 8 | # Linter rules doc: 9 | # - https://github.com/DavidAnson/markdownlint 10 | # 11 | # Note: 12 | # To comment out a single error: 13 | # 14 | # any violations you want 15 | # 16 | # 17 | 18 | ############### 19 | # Rules by id # 20 | ############### 21 | MD007: 22 | start_indented: true # Unordered lists are fully indented 23 | MD013: 24 | line_length: 200 # Line length 80 is far to short 25 | 26 | ################# 27 | # Rules by tags # 28 | ################# 29 | blank_lines: false # Error on blank lines 30 | -------------------------------------------------------------------------------- /.github/workflows/ci-hedgehog.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Build 3 | 4 | on: 5 | push: 6 | branches: 7 | - '**' 8 | tags: 9 | - '**' 10 | pull_request: 11 | branches: 12 | - main 13 | 14 | defaults: 15 | run: 16 | shell: bash 17 | 18 | jobs: 19 | build: 20 | name: Build ${{ github.repository }} with Idris2 latest 21 | runs-on: ubuntu-latest 22 | env: 23 | PACK_DIR: /root/.pack 24 | strategy: 25 | fail-fast: false 26 | container: ghcr.io/stefan-hoeck/idris2-pack:latest 27 | steps: 28 | - name: Checkout 29 | uses: actions/checkout@v2 30 | - name: Build lib 31 | run: pack install hedgehog 32 | - name: Build docs 33 | run: pack typecheck hedgehog-docs 34 | - name: Test lib 35 | run: pack test hedgehog 36 | -------------------------------------------------------------------------------- /.github/workflows/ci-super-linter.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Lint 3 | 4 | on: 5 | push: 6 | branches: 7 | - '*' 8 | tags: 9 | - '*' 10 | pull_request: 11 | branches: 12 | - main 13 | - master 14 | 15 | jobs: 16 | build: 17 | name: Lint Code Base 18 | runs-on: ubuntu-latest 19 | steps: 20 | 21 | - name: Checkout 22 | uses: actions/checkout@v2 23 | with: 24 | # Full git history is needed to get a proper list of changed files within `super-linter` 25 | fetch-depth: 0 26 | 27 | - name: Lint Code Base 28 | uses: github/super-linter/slim@v4 29 | env: 30 | VALIDATE_ALL_CODEBASE: false 31 | DEFAULT_BRANCH: main 32 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 33 | IGNORE_GENERATED_FILES: true 34 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | build/ 2 | *.*~ 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 2-Clause License 2 | 3 | Copyright (c) 2021, Stefan Höck 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 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. 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 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 17 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 18 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 20 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 21 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 22 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 23 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 24 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 25 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # idris2-hedgehog 2 | An Idris port of the [Haskell Hedgehog library](https://hackage.haskell.org/package/hedgehog), 3 | a property-based testing library in the spirit of QuickCheck. 4 | 5 | This is still work in progress but the core functionality is already 6 | there and a [tutorial](docs/src/Docs/Intro.md) is in the making. 7 | 8 | ## Features 9 | 10 | * Monadic random value generators with integrated shrinking. 11 | 12 | * Numeric ranges with well-defined scaling and shrinking 13 | behavior. 14 | 15 | * Colorized test output with pretty printing of value 16 | diffs in case of failed tests (right now, colorize output 17 | has to be enabled by setting environment variable 18 | `HEDGEHOG_COLOR="1"`). 19 | 20 | * Conveniently define generators for regular 21 | algebraic data types via their generic representations 22 | as sums of products 23 | ([see idris2-sop](https://github.com/stefan-hoeck/idris2-sop)). 24 | 25 | * Provably total core: While the Haskell library allows us 26 | to define (and consume) infinite shrink trees, this 27 | is not possible here due to the codata nature of the 28 | trees we use for shrinking. 29 | 30 | * Classify generated values and verify test coverage. 31 | 32 | ## Limitations (compared to the Haskell version) 33 | 34 | * No filtering of generators: In my experience, generators 35 | should create random values constructively. Filtering 36 | values makes it too easy to write generators, the combination 37 | of which fails most of the time. 38 | 39 | * `Gen` is not a monad transformer right now, therefore 40 | it cannot be combined with additional monadic effects. 41 | The main reason for this is 42 | that we use a `Cotree` codata type for shrinking, and it 43 | is hard to combine this with monadic effects in a 44 | provably total way. 45 | 46 | * No support for state machine testing (yet). 47 | 48 | * No automatic detection of properties in source files (yet). 49 | 50 | * No parallel test execution (yet). 51 | 52 | ## Differences compared to QuickCheck 53 | 54 | There are two main differences: First, there is no `Arbitrary` interface 55 | and therefore, generators have typically to be hand-written. However, using 56 | a sums of products approach (tutorial yet to be added) makes 57 | it very easy to write generators for regular algebraic data types. 58 | Second, shrinking is integrated, which makes it very easy to write 59 | generators with good shrinking behavior, especially when using 60 | an applicative style for writing generators, in which case shrinking 61 | is completely free 62 | (see also [integrated vs manual shrinkig](https://www.well-typed.com/blog/2019/05/integrated-shrinking/)). 63 | 64 | ## Prerequisites 65 | 66 | Starting from Idris2 version 0.5.1, tagged releases of the same 67 | minor version number (e.g. 0.5.x) will be made available, while the main 68 | branch keeps following the Idris2 main branch. 69 | 70 | In addition, the following external dependencies are 71 | required: 72 | 73 | * [elab-util](https://github.com/stefan-hoeck/idris2-elab-util) 74 | * [sop](https://github.com/stefan-hoeck/idris2-sop) 75 | * [pretty-show](https://github.com/stefan-hoeck/idris2-pretty-show) 76 | 77 | The latest commit is daily tested to build against the current 78 | HEAD of the Idris compiler. Since Idris2 releases are happening 79 | rather infrequently at the moment, it is suggested to use 80 | a package manager like [pack](https://github.com/stefan-hoeck/idris2-pack) 81 | to install and maintain matching versions of the Idris compiler 82 | and this library. Pack will also automatically install all 83 | required dependencies. 84 | -------------------------------------------------------------------------------- /docs/docs.ipkg: -------------------------------------------------------------------------------- 1 | package hedgehog-docs 2 | 3 | authors = "stefan-hoeck" 4 | version = 0.6.0 5 | sourcedir = "src" 6 | depends = hedgehog 7 | 8 | modules = Docs.Intro 9 | , Docs.Smiles 10 | -------------------------------------------------------------------------------- /docs/src/Docs/Intro.md: -------------------------------------------------------------------------------- 1 | # An Introduction to Hedgehog 2 | 3 | The Haskell library [Hedgehog](https://hedgehog.qa/) is a powerful property 4 | based testing framework in the spirit of 5 | [Quickcheck](https://hackage.haskell.org/package/QuickCheck), but with 6 | integrated shrinking and pretty diff printing. 7 | 8 | This is an Idris2 port of the Haskell library with some slight adjustments 9 | (and some limitations). Since this is a literate Idris2 file: 10 | 11 | ```idris 12 | module Docs.Intro 13 | 14 | import Data.List 15 | import Data.SOP 16 | import Data.String 17 | import Data.Vect 18 | import Hedgehog 19 | 20 | %default total 21 | ``` 22 | 23 | ## A First Example 24 | To give a first example of the capabilities of this library, 25 | we verify that reversing a list twice will lead to the original 26 | list. This is - of course - completely pointless in Idris, since 27 | Idris can prove this at compile time. However, we will soon enough 28 | start with some more real-worldish examples. 29 | 30 | First, we need a generator for lists. Generators are defined in 31 | module `Hedgehog.Internal.Gen`, which is reexported by the main `Hedgehog` 32 | module. 33 | 34 | ```idris 35 | charGen : Gen (List Char) 36 | charGen = list (linear 0 30) alphaNum 37 | ``` 38 | 39 | The above defines a generator for random lists of alpha numeric 40 | characters of length up to 30. For numeric values, 41 | we typically define generators in terms of `Range`s (defined in 42 | module `Hedgehog.Internal.Range`). They scale according to a given 43 | `Size` parameter and shrink towards a predefined origin in case 44 | of a failed test. 45 | 46 | We can now specify the property we'd like to proof 47 | and verify by calling `check`: 48 | 49 | ```idris 50 | propReverse : Property 51 | propReverse = property $ do 52 | xs <- forAll charGen 53 | xs === reverse (reverse xs) 54 | 55 | checkReverse : IO Bool 56 | checkReverse = check propReverse 57 | ``` 58 | 59 | Running `:exec checkReverse` in the REPL produces the following output: 60 | 61 | ```repl 62 | > ✓ passed 100 tests. 63 | ``` 64 | 65 | ## Property Groups 66 | 67 | OK, let's try something (slightly) more realistic. Property 68 | based testing can be useful in Idris when we are dealing with 69 | functions that are not reduced during unification. The behavior 70 | of such functions cannot be verified at compile time. An example 71 | for this are functions `fastPack` and `fastUnpack` from `Data.String`. 72 | We'd like to verify that the two functions do not modify their 73 | input. String generators are derived from the one for lists, 74 | so their definition is very similar: 75 | 76 | ```idris 77 | unicodeGen : Gen String 78 | unicodeGen = string (linear 0 30) unicode 79 | 80 | propertyFastPack : Property 81 | propertyFastPack = property $ do 82 | s <- forAll unicodeGen 83 | s === fastPack (fastUnpack s) 84 | ``` 85 | 86 | We could also check that `fastUnpack` and `unpack` yield the 87 | same result: 88 | 89 | ```idris 90 | propertyFastUnpack : Property 91 | propertyFastUnpack = property $ do 92 | s <- forAll unicodeGen 93 | unpack s === fastUnpack s 94 | ``` 95 | 96 | To generate some nice output, we define a property group 97 | and run these tests together: 98 | 99 | ```idris 100 | checkPack : IO Bool 101 | checkPack = 102 | checkGroup $ 103 | MkGroup 104 | "Fast String Functions" 105 | [ ("fastPack . fastUnpack = id", propertyFastPack) 106 | , ("unpack = fastUnpack", propertyFastUnpack) 107 | ] 108 | ``` 109 | 110 | Running `:exec checkPack` in the REPL results in the following output: 111 | 112 | ```repl 113 | > ━━━ Fast String Functions ━━━ 114 | > ✓ fastPack . fastUnpack = id passed 100 tests. 115 | > ✓ unpack = fastUnpack passed 100 tests. 116 | > ✓ 2 succeeded. 117 | ``` 118 | 119 | ## Failing Tests and Shrinking 120 | 121 | Next, we will write a property that does not hold: 122 | 123 | ```idris 124 | propAddInts : Property 125 | propAddInts = 126 | let int20 := int $ linear 0 20 127 | in property $ do 128 | [a,b,c,d] <- forAll $ np [int20,int20,int20,int20] 129 | (a + b) === (c + d) 130 | ``` 131 | 132 | Before we look at what happens when we check this property, 133 | I'd like to quickly explain the `np` generator. 134 | The Idris version of Hedgehog supports the heterogeneous 135 | sums of products from the [idris2-sop](https://github.com/stefan-hoeck/idris2-sop) 136 | library via generators `np`, `ns`, and `sop`. 137 | These generators work as expected with good out-of-the box 138 | shrinking. It is therefore advisable to use one of these 139 | when generating several unrelated values in parallel. 140 | As an alternative, we could also have used `vect 4 int20` 141 | in this case. 142 | 143 | ```idris 144 | checkFailing1 : IO Bool 145 | checkFailing1 = checkNamed "propAddInts" propAddInts 146 | ``` 147 | 148 | Running `:exec checkFailing1` in the REPL results in 149 | an output similar to this: 150 | 151 | ```repl 152 | > ✗ propAddInts failed after 7 tests. 153 | > 154 | > forAll 0 = 155 | > [ 0 , 0 , 0 , 1 ] 156 | > 157 | > ━━━ Failed (- lhs) (+ rhs) ━━━ 158 | > - 0 159 | > + 1 160 | > 161 | > This failure can be reproduced by running: 162 | > > recheck 6 (rawStdGen 13575607214039863170 538475183012815285) propAddInts 163 | ``` 164 | 165 | Here, we are informed about the failed test together with a 166 | properly shrunk minimal test case plus the `Size` and 167 | `Seed` required to rerun the failing test. 168 | 169 | ## The (broken) Gen Monad 170 | 171 | There is a (minor, in my opinion) inconsistency between 172 | `Gen`s `Applicative` and `Monad` implementations. This is the 173 | same in the original Hedgehog, and it is not yet sure whether it 174 | is worth fixing by using either a newtype wrapper for `Gen` 175 | or providing an additional named `Applicative` instance. 176 | 177 | In order to understand this inconsistency, we will write the 178 | same failing test twice: 179 | 180 | ```idris 181 | int1000 : Gen Int 182 | int1000 = int $ constant 0 1000 183 | 184 | propIntGreaterApp : Property 185 | propIntGreaterApp = property $ do 186 | [a,b] <- forAll $ vect 2 int1000 187 | assert (a < b) 188 | 189 | propIntGreaterMonad : Property 190 | propIntGreaterMonad = property $ do 191 | a <- forAll int1000 192 | b <- forAll int1000 193 | assert (a < b) 194 | 195 | checkIntGreater : IO () 196 | checkIntGreater = 197 | checkNamed "propIntGreaterApp" propIntGreaterApp 198 | *> checkNamed "propIntGreaterMonad" propIntGreaterMonad 199 | $> () 200 | ``` 201 | 202 | Both tests fail, but their shrinking behavior is different. 203 | In the first case, we get output similar to the following: 204 | 205 | ```repl 206 | > ✗ propIntGreaterApp failed after 1 test. 207 | > 208 | > forAll 0 = 209 | > [ 0 , 0 ] 210 | > 211 | > This failure can be reproduced by running: 212 | > > recheck 0 (rawStdGen 6832087575862183383 12092602541466451199) propIntGreaterApp 213 | ``` 214 | 215 | As can be seen, the failing test is properly shrunk to the minimal 216 | counter example. 217 | 218 | In the second case, however, the output is most likely similar to this: 219 | 220 | ```repl 221 | > ✗ propIntGreaterMonad failed after 4 tests. 222 | > 223 | > forAll 0 = 224 | > 188 225 | > 226 | > forAll 1 = 227 | > 0 228 | > 229 | > This failure can be reproduced by running: 230 | > > recheck 0 (rawStdGen 9029460602319538061 261492196152102529) propIntGreaterMonad 231 | ``` 232 | 233 | As can be seen, the first value is not properly shrunk to the minimal 234 | counter example. The reason for this is explained in detail in 235 | [this blog post](https://www.well-typed.com/blog/2019/05/integrated-shrinking/). 236 | The important message is: For optimal shrinking, combine generators using 237 | `Gen`s applicative implementation whenever possible. 238 | 239 | ## Debugging Generators: Classifiers and Test Coverage 240 | 241 | It is often useful to make sure that generators behave correctly. 242 | There are several facilities for this. In the most simple case, we 243 | classify generated values according to one or more criteria, 244 | generating some pretty output. The following runs 10000 tests, 245 | putting generated integers into one of five classes. 246 | 247 | ```idris 248 | propTwice : Property 249 | propTwice = 250 | withTests 10000 . property $ do 251 | n <- forAll int1000 252 | classify "zero" (n == 0) 253 | classify "one" (n == 1) 254 | classify "below 10" (n > 1 && n < 10) 255 | classify "below 100" (n >= 10 && n < 100) 256 | classify "above 100" (n >= 100) 257 | (2 * n) === (n + n) 258 | 259 | checkTwice : IO Bool 260 | checkTwice = checkNamed "propTwice" propTwice 261 | ``` 262 | 263 | Eventually, the output will look similar to the one below: 264 | 265 | ```repl 266 | > ✓ propTwice passed 10000 tests. 267 | > above 100 90.1% ██████████████████·· 268 | > below 10 0.8% ▏··················· 269 | > below 100 8.9% █▊·················· 270 | > one 0.1% ···················· 271 | > zero 0.1% ···················· 272 | 273 | ``` 274 | 275 | Sometimes, however, we'd like to have stronger guarantees. 276 | In the following example, the test fails if not at least 277 | five percent of the generated values are in the interval [10,100) 278 | or if not at least eighty percent are in the interval [100,1000]: 279 | 280 | ```idris 281 | propTwice2 : Property 282 | propTwice2 = 283 | withTests 10000 . property $ do 284 | n <- forAll int1000 285 | cover 5 "[10,100)" (n >= 10 && n < 100) 286 | cover 80 "[100,1000]" (n >= 100) 287 | (2 * n) === (n + n) 288 | 289 | checkTwice2 : IO Bool 290 | checkTwice2 = checkNamed "propTwice2" propTwice2 291 | ``` 292 | 293 | The output will look similar to this: 294 | 295 | ```repl 296 | > ✓ propTwice2 passed 10000 tests. 297 | > [10,100) 9.1% █▊·················· ✓ 5.0% 298 | > [100,1000] 89.9% █████████████████▉·· ✓ 80.0% 299 | ``` 300 | 301 | 303 | -------------------------------------------------------------------------------- /docs/src/Docs/Smiles.md: -------------------------------------------------------------------------------- 1 | # Writing a SMILES Parser 2 | 3 | In this tutorial, we look at a real world example. 4 | We are going to write a (simplified) parser for SMILES strings 5 | ([OpenSMILES specification](http://opensmiles.org/opensmiles.html)) 6 | testing its behavior on the run. SMILES is a compact string encoding 7 | for molecular graphs in Cheminformatics. We are going to keep things 8 | simple here, dealing only with the organic subset atoms, thus ignoring 9 | the possibility to specify concrete isotopes, charged atoms, 10 | and stereochemic information. 11 | 12 | ```idris 13 | module Docs.Smiles 14 | 15 | import Data.String 16 | import Data.Cotree 17 | import Data.Vect 18 | import Derive.Prelude 19 | import Text.Lex 20 | 21 | import Hedgehog 22 | 23 | %default total 24 | %language ElabReflection 25 | ``` 26 | 27 | ## Bonds and Atoms 28 | 29 | We first need to define the necessary data types. 30 | To keep things simple, we only support the most common 31 | bond types: 32 | 33 | ```idris 34 | public export 35 | data Bond = Sngl | Dbl | Trpl 36 | 37 | %runElab derive "Bond" [Show,Eq,Ord] 38 | 39 | namespace Bond 40 | public export 41 | encode : Bond -> String 42 | encode Sngl = "-" 43 | encode Dbl = "=" 44 | encode Trpl = "#" 45 | ``` 46 | 47 | In terms of chemical elements, we only support the *organic subset* 48 | as per the specification: 49 | 50 | 51 | ```idris 52 | data Elem = B | C | N | O | F | S | Cl | P | Br | I 53 | 54 | %runElab derive "Docs.Smiles.Elem" [Show,Eq,Ord] 55 | ``` 56 | 57 | ## Writing the Lexer 58 | 59 | We use the utilities from `Text.Lexer` to cut a SMILES string into 60 | appropriate tokens. In addition to a data type for SMILES tokens, 61 | we also write a function for encoding lists of tokens back into 62 | SMILES representation. 63 | 64 | ```idris 65 | data Token : Type where 66 | Organic : (elem : Elem) -> (aromatic : Bool) -> Token 67 | SBond : (bond : Bond) -> Token 68 | POpen : Token 69 | PClose : Token 70 | Ring : Int -> Token 71 | Invalid : String -> Token 72 | 73 | %runElab derive "Smiles.Token" [Eq,Show] 74 | 75 | encode : Token -> String 76 | encode (Organic elem True) = toLower $ show elem 77 | encode (Organic elem False) = show elem 78 | encode (SBond bond) = encode bond 79 | encode POpen = "(" 80 | encode PClose = ")" 81 | encode (Invalid x) = "Invalid " ++ x 82 | encode (Ring x) = if x >= 10 then "%" ++ show x else show x 83 | ``` 84 | 85 | We are now ready to implement the lexer itself: 86 | 87 | ```idris 88 | bond : String -> Token 89 | bond "-" = SBond Sngl 90 | bond "=" = SBond Dbl 91 | bond "#" = SBond Trpl 92 | bond s = Invalid $ "Bond: " ++ s 93 | 94 | aromaticOrganic : String -> Token 95 | aromaticOrganic "b" = Organic B True 96 | aromaticOrganic "c" = Organic C True 97 | aromaticOrganic "n" = Organic N True 98 | aromaticOrganic "o" = Organic O True 99 | aromaticOrganic "s" = Organic S True 100 | aromaticOrganic "p" = Organic P True 101 | aromaticOrganic s = Invalid $ "Subset Atom: " ++ s 102 | 103 | organic : String -> Token 104 | organic "B" = Organic B False 105 | organic "C" = Organic C False 106 | organic "N" = Organic N False 107 | organic "O" = Organic O False 108 | organic "S" = Organic S False 109 | organic "P" = Organic P False 110 | organic "F" = Organic F False 111 | organic "Cl" = Organic Cl False 112 | organic "Br" = Organic Br False 113 | organic "I" = Organic I False 114 | organic s = aromaticOrganic s 115 | 116 | 117 | ring : String -> Token 118 | ring s = 119 | case fastUnpack s of 120 | [a] => Ring $ calc a 121 | ['%',a,b] => Ring $ calc a * 10 + calc b 122 | _ => Invalid $ "Ring: " ++ s 123 | 124 | where 125 | calc : Char -> Int 126 | calc c = ord c - 48 127 | 128 | smiles1 : Tokenizer Char Token 129 | smiles1 = 130 | Direct $ 131 | first 132 | [ (pred isLower <|> (pred isUpper <+> opt (pred isLower)), organic . cast) 133 | , (oneOf (unpack "-=#"), bond . cast) 134 | , (digit <|> (is '%' <+> digit <+> digit), ring . cast) 135 | , (is '(', const POpen) 136 | , (is ')', const PClose) 137 | ] 138 | 139 | export 140 | lexSmiles1 : (s : String) -> List (Bounded Token) 141 | lexSmiles1 s = (<>> []) . toks $ lex smiles1 s 142 | ``` 143 | 144 | ## Testing the Lexer 145 | 146 | Since the functions from `Text.Lexer` are not publicly exported, 147 | we cannot test the lexer at compile time. We will therefore 148 | write a simple Hedgehog test to verify the lexer's correct behavior. 149 | First, we are going to need a bunch of generators: 150 | 151 | ```idris 152 | genBond : Gen Bond 153 | genBond = element [Sngl,Dbl,Trpl] 154 | 155 | -- element paired with aromaticity 156 | genAtom : Gen (Elem,Bool) 157 | genAtom = 158 | element $ 159 | map (,False) [B,C,N,O,F,S,Cl,P,Br,I] ++ map (,True) [B,C,N,O,S,P] 160 | 161 | -- this does not generate Invalid tokens 162 | token : Gen Token 163 | token = 164 | frequency 165 | [ (10, uncurry Organic <$> genAtom) 166 | , (2, SBond <$> genBond) 167 | , (1, Ring <$> int (linear 1 99)) 168 | , (1, pure POpen) 169 | , (1, pure PClose) 170 | ] 171 | 172 | tokens : Gen (List Token) 173 | tokens = list (linear 1 50) token 174 | ``` 175 | 176 | For token we use the `frequency` generator, which 177 | allows us to specify, how often a generator in the list will be 178 | chosen. All generators used above shrink towards the first elements 179 | in the given vectors. 180 | 181 | We can now specify the actual property. We'd like to verify, that 182 | roundtripping via `lex` and `encode` gives back the original 183 | list of valid tokens. 184 | 185 | ```idris 186 | prop_lex1 : Property 187 | prop_lex1 = property $ do 188 | ts <- forAll tokens 189 | 190 | let enc : String 191 | enc = concatMap encode ts 192 | 193 | lexed : List Token 194 | lexed = map val $ lexSmiles1 enc 195 | 196 | footnote $ "Encoded: " ++ enc 197 | lexed === ts 198 | ``` 199 | 200 | We annotate the property with a footnote of the encoded 201 | SMILES string. This will help us understand what's going on 202 | in case of a test failure. 203 | 204 | Running `:exec check prop_lex1` will lead to output similar 205 | to the following (if in a Unix shell, use `export HEDGEHOG_COLOR="1"` to 206 | enable nicely colorized output): 207 | 208 | ```repl 209 | > ✗ failed after 11 tests. 210 | 211 | > forAll 0 = 212 | > [ Organic { elem = B , aromatic = False } 213 | > , Organic { elem = B , aromatic = True } 214 | > ] 215 | 216 | > Encoded: Bb 217 | > ━━━ Failed (- lhs) (+ rhs) ━━━ 218 | > - [ Invalid "Subset Atom: Bb" ] 219 | > + [ Organic { elem = B , aromatic = False } 220 | > + , Organic { elem = B , aromatic = True } 221 | > + ] 222 | 223 | > This failure can be reproduced by running: 224 | > > recheck 10 (rawStdGen 17955597067191004859 1876035156183501547) 225 | ``` 226 | 227 | So, there is a problem with our lexer. Note, how Hedgehog yields a properly 228 | shrunk minimal example. The problem at hand: The string "Bb" is 229 | treated as a single chemical element instead of two atoms of boron 230 | (one aliphatic, the other aromatic). 231 | 232 | The following version fixes this issue, as can be shown by 233 | checking `prop_lex`: 234 | 235 | ```idris 236 | smiles : Tokenizer Char Token 237 | smiles = 238 | Direct $ 239 | first 240 | [ (exact "Cl" <|> exact "Br" <|> pred isAlpha, organic . cast) 241 | , (oneOf (unpack "-=#"), bond . cast) 242 | , (digit <|> (is '%' <+> digit <+> digit), ring . cast) 243 | , (is '(', const POpen) 244 | , (is ')', const PClose) 245 | ] 246 | 247 | lexSmiles : (s : String) -> List (Bounded Token) 248 | lexSmiles s = (<>> []) . toks $ lex smiles s 249 | 250 | prop_lex : Property 251 | prop_lex = property $ do 252 | ts <- forAll tokens 253 | 254 | let enc : String 255 | enc = concatMap encode ts 256 | 257 | lexed : List Token 258 | lexed = map val $ lexSmiles enc 259 | 260 | footnote $ "Encoded: " ++ enc 261 | lexed === ts 262 | ``` 263 | 264 | 266 | -------------------------------------------------------------------------------- /hedgehog.ipkg: -------------------------------------------------------------------------------- 1 | package hedgehog 2 | 3 | authors = "stefan-hoeck" 4 | brief = "A property based testing library with integrated shrinking" 5 | version = 0.6.0 6 | sourcedir = "src" 7 | depends = base >= 0.6.0 8 | , ansi 9 | , elab-pretty 10 | , elab-util 11 | , getopts 12 | , prettier-ansi 13 | , pretty-show 14 | , random-pure 15 | , sop 16 | , summary-stat 17 | 18 | modules = Data.Bounded 19 | , Data.Cotree 20 | , Data.Tree 21 | 22 | , Derive.Cogen 23 | 24 | , Hedgehog 25 | , Hedgehog.Internal.Config 26 | , Hedgehog.Internal.Function 27 | , Hedgehog.Internal.Gen 28 | , Hedgehog.Internal.Property 29 | , Hedgehog.Internal.Options 30 | , Hedgehog.Internal.Range 31 | , Hedgehog.Internal.Report 32 | , Hedgehog.Internal.Runner 33 | , Hedgehog.Internal.Shrink 34 | , Hedgehog.Internal.Terminal 35 | , Hedgehog.Internal.Util 36 | , Hedgehog.Meta 37 | -------------------------------------------------------------------------------- /pack.toml: -------------------------------------------------------------------------------- 1 | [custom.all.hedgehog] 2 | type = "local" 3 | path = "." 4 | ipkg = "hedgehog.ipkg" 5 | test = "tests/tests.ipkg" 6 | 7 | [custom.all.hedgehog-docs] 8 | type = "local" 9 | path = "docs" 10 | ipkg = "docs.ipkg" 11 | -------------------------------------------------------------------------------- /src/Data/Bounded.idr: -------------------------------------------------------------------------------- 1 | module Data.Bounded 2 | 3 | import Data.Fin 4 | 5 | %default total 6 | 7 | public export 8 | interface Ord b => MinBound b where 9 | ||| The lower bound for the type 10 | minBound : b 11 | 12 | public export 13 | interface Ord b => MaxBound b where 14 | ||| The upper bound for the type 15 | maxBound : b 16 | 17 | public export %inline 18 | MinBound Bits8 where 19 | minBound = 0x0 20 | 21 | public export %inline 22 | MaxBound Bits8 where 23 | maxBound = 0xff 24 | 25 | public export %inline 26 | MinBound Bits16 where 27 | minBound = 0x0 28 | 29 | public export %inline 30 | MaxBound Bits16 where 31 | maxBound = 0xffff 32 | 33 | public export %inline 34 | MinBound Bits32 where 35 | minBound = 0x0 36 | 37 | public export %inline 38 | MaxBound Bits32 where 39 | maxBound = 0xffffffff 40 | 41 | public export %inline 42 | MinBound Bits64 where 43 | minBound = 0x0 44 | 45 | public export %inline 46 | MaxBound Bits64 where 47 | maxBound = 0xffffffffffffffff 48 | 49 | public export %inline 50 | MinBound Int8 where 51 | minBound = (- 0x80) 52 | 53 | public export %inline 54 | MaxBound Int8 where 55 | maxBound = 0x7f 56 | 57 | public export %inline 58 | MinBound Int16 where 59 | minBound = (- 0x8000) 60 | 61 | public export %inline 62 | MaxBound Int16 where 63 | maxBound = 0x7fff 64 | 65 | public export %inline 66 | MinBound Int32 where 67 | minBound = (- 0x80000000) 68 | 69 | public export %inline 70 | MaxBound Int32 where 71 | maxBound = 0x7fffffff 72 | 73 | public export %inline 74 | MinBound Int64 where 75 | minBound = (- 0x8000000000000000) 76 | 77 | public export %inline 78 | MaxBound Int64 where 79 | maxBound = 0x7fffffffffffffff 80 | 81 | public export %inline 82 | MinBound Int where 83 | minBound = (- 0x8000000000000000) 84 | 85 | public export %inline 86 | MaxBound Int where 87 | maxBound = 0x7fffffffffffffff 88 | 89 | public export %inline 90 | MinBound (Fin (S n)) where 91 | minBound = 0 92 | 93 | public export %inline 94 | {n : _} -> MaxBound (Fin (S n)) where 95 | maxBound = last 96 | -------------------------------------------------------------------------------- /src/Data/Cotree.idr: -------------------------------------------------------------------------------- 1 | module Data.Cotree 2 | 3 | import Data.Colist 4 | import Data.Maybe 5 | import Data.Tree 6 | 7 | %default total 8 | 9 | -------------------------------------------------------------------------------- 10 | -- Cotrees: Potentially infinte trees 11 | -------------------------------------------------------------------------------- 12 | 13 | ||| A potentially finite stream of trees 14 | public export 15 | Coforest : Type -> Type 16 | 17 | ||| A potentially infinite rose tree 18 | public export 19 | record Cotree (a : Type) where 20 | constructor MkCotree 21 | value : a 22 | forest : Inf (Coforest a) 23 | 24 | Coforest = Colist . Cotree 25 | 26 | public export 27 | singleton : a -> Cotree a 28 | singleton a = MkCotree a Nil 29 | 30 | public export 31 | unfold : (f : b -> (a,Colist b)) -> b -> Cotree a 32 | unfold f vb = 33 | let (va,bs) := f vb 34 | in MkCotree va $ unfoldF bs 35 | 36 | where 37 | unfoldF : Colist b -> Coforest a 38 | unfoldF [] = [] 39 | unfoldF (h :: t) = unfold f h :: unfoldF t 40 | 41 | public export 42 | iterate : (f : a -> Colist a) -> a -> Cotree a 43 | iterate f a = unfold (\v => (v, f v)) a 44 | 45 | public export 46 | expand : (a -> Colist a) -> Cotree a -> Cotree a 47 | expand f (MkCotree v vs) = 48 | let MkCotree v2 vs2 := iterate f v 49 | in MkCotree v2 (run vs vs2) 50 | 51 | where 52 | run : Coforest a -> Coforest a -> Coforest a 53 | run [] ys = ys 54 | run (x :: xs) ys = expand f x :: run xs ys 55 | 56 | -------------------------------------------------------------------------------- 57 | -- To and from Tree 58 | -------------------------------------------------------------------------------- 59 | 60 | public export 61 | fromTree : Tree a -> Cotree a 62 | fromTree (MkTree v fo) = MkCotree v (fromForest fo) 63 | 64 | where 65 | fromForest : Forest a -> Coforest a 66 | fromForest [] = [] 67 | fromForest (x :: xs) = fromTree x :: fromForest xs 68 | 69 | ||| Converts a Cotree to a tree of the given maximum depth and width. 70 | ||| The maximum numbers of elements in the tree will be 71 | ||| maxWidth ^ maxDepth. 72 | public export 73 | toTree : (maxDepth : Nat) -> (maxWidth : Nat) -> Cotree a -> Tree a 74 | toTree 0 _ (MkCotree v fo) = MkTree v [] 75 | toTree (S k) mw (MkCotree v fo) = MkTree v (toForest mw fo) 76 | 77 | where 78 | toForest : Nat -> Coforest a -> Forest a 79 | toForest 0 _ = [] 80 | toForest (S n) [] = [] 81 | toForest (S n) (t :: ts) = toTree k mw t :: toForest n ts 82 | 83 | -------------------------------------------------------------------------------- 84 | -- Functor and Applicative 85 | -------------------------------------------------------------------------------- 86 | 87 | public export 88 | mapCotree : (a -> b) -> Cotree a -> Cotree b 89 | mapCotree f (MkCotree v vs) = MkCotree (f v) (mapForest vs) 90 | 91 | where 92 | mapForest : Coforest a -> Coforest b 93 | mapForest [] = [] 94 | mapForest (h :: t) = mapCotree f h :: mapForest t 95 | 96 | public export 97 | interleave : Cotree (a -> b) -> Cotree a -> Cotree b 98 | interleave tf@(MkCotree vf fs) ta@(MkCotree va as) = 99 | MkCotree (vf va) (interleaveFs fs) 100 | 101 | where 102 | interleaveAs : Coforest a -> Coforest b 103 | interleaveAs [] = [] 104 | interleaveAs (h :: t) = interleave tf h :: interleaveAs t 105 | 106 | interleaveFs : Coforest (a -> b) -> Coforest b 107 | interleaveFs [] = interleaveAs as 108 | interleaveFs (h :: t) = interleave h ta :: interleaveFs t 109 | 110 | public export 111 | bind : Cotree a -> (a -> Cotree b) -> Cotree b 112 | bind (MkCotree v vs) f = 113 | let MkCotree w ws := f v 114 | in MkCotree w (run vs ws) 115 | 116 | where 117 | run : Coforest a -> Coforest b -> Coforest b 118 | run [] ys = ys 119 | run (x :: xs) ys = bind x f :: run xs ys 120 | 121 | public export 122 | bindMaybe : Cotree (Maybe a) -> (a -> Cotree (Maybe b)) -> Cotree (Maybe b) 123 | bindMaybe (MkCotree mv tas) f = 124 | case map f mv of 125 | Nothing => MkCotree Nothing (run tas Nil) 126 | Just (MkCotree mb tbs) => MkCotree mb (run tas tbs) 127 | 128 | where 129 | run : Coforest (Maybe a) -> Coforest (Maybe b) -> Coforest (Maybe b) 130 | run [] ys = ys 131 | run (x :: xs) ys = bindMaybe x f :: run xs ys 132 | 133 | -------------------------------------------------------------------------------- 134 | -- Shrinking 135 | -------------------------------------------------------------------------------- 136 | 137 | public export 138 | shrink : (maxSteps : Nat) -> Cotree (Maybe a) -> List a 139 | shrink maxSteps x = run maxSteps [x] 140 | 141 | where 142 | run : Nat -> Coforest (Maybe a) -> List a 143 | run _ Nil = Nil 144 | run 0 _ = Nil 145 | run (S k) (h :: t) = 146 | case h.value of 147 | Just a => a :: run k h.forest 148 | Nothing => run k t 149 | 150 | public export 151 | mapShrink : (maxSteps : Nat) -> (a -> Maybe b) -> Cotree a -> List b 152 | mapShrink ms f = shrink ms . mapCotree f 153 | 154 | public export 155 | shrinkIf : (maxSteps : Nat) -> (a -> Bool) -> Cotree a -> List a 156 | shrinkIf ms p = mapShrink ms (\a => if p a then Just a else Nothing) 157 | 158 | ||| Prunes a cotree up to the given depth and width. 159 | public export 160 | pruneTo : (width : Nat) -> (depth : Nat) -> Cotree a -> Cotree a 161 | pruneTo _ 0 (MkCotree v _ ) = MkCotree v Nil 162 | pruneTo w (S d) (MkCotree v vs) = MkCotree v $ (map (pruneTo w d) $ keep w vs) 163 | 164 | where 165 | keep : Nat -> Colist t -> Colist t 166 | keep _ [] = [] 167 | keep 0 _ = [] 168 | keep (S k) (x :: xs) = x :: keep k xs 169 | 170 | ||| Removes all children from a cotree 171 | public export 172 | prune : Cotree a -> Cotree a 173 | prune = pruneTo 0 0 174 | 175 | -------------------------------------------------------------------------------- 176 | -- Interfaces 177 | -------------------------------------------------------------------------------- 178 | 179 | public export 180 | Functor Cotree where 181 | map = mapCotree 182 | 183 | public export 184 | Applicative Cotree where 185 | pure = singleton 186 | (<*>) = interleave 187 | 188 | -------------------------------------------------------------------------------- 189 | -- Filtering 190 | -------------------------------------------------------------------------------- 191 | 192 | public export 193 | takeUntil : (a -> Bool) -> Cotree a -> Cotree a 194 | takeUntil f (MkCotree v vs) = 195 | if f v 196 | then MkCotree v [] 197 | else MkCotree v (takeUntilF vs) 198 | 199 | where 200 | takeUntilF : Coforest a -> Coforest a 201 | takeUntilF [] = vs 202 | takeUntilF (MkCotree x xs :: ts) = 203 | if f x 204 | then [MkCotree x []] 205 | else MkCotree x (takeUntilF xs) :: takeUntilF ts 206 | 207 | public export 208 | takeBeforeNothing : Cotree (Maybe a) -> Maybe (Cotree a) 209 | takeBeforeNothing (MkCotree Nothing _) = Nothing 210 | takeBeforeNothing (MkCotree (Just v) vs) = Just (MkCotree v (run vs)) 211 | 212 | where 213 | run : Coforest (Maybe a) -> Coforest a 214 | run [] = [] 215 | run ((MkCotree Nothing _) :: _) = [] 216 | run ((MkCotree (Just v) vs) :: ts) = MkCotree v (run vs) :: run ts 217 | 218 | public export 219 | takeBefore : (a -> Bool) -> Cotree a -> Maybe (Cotree a) 220 | takeBefore f = takeBeforeNothing . map (\a => toMaybe (f a) a) 221 | 222 | public export %inline 223 | takeWhile : (a -> Bool) -> Cotree a -> Maybe (Cotree a) 224 | takeWhile f = takeBefore (not . f) 225 | 226 | public export %inline 227 | mapMaybe : (a -> Maybe b) -> Cotree a -> Maybe (Cotree b) 228 | mapMaybe f = takeBeforeNothing . map f 229 | -------------------------------------------------------------------------------- /src/Data/Tree.idr: -------------------------------------------------------------------------------- 1 | module Data.Tree 2 | 3 | import Data.List 4 | import Data.List1 5 | import Data.String 6 | 7 | import Derive.Prelude 8 | 9 | %language ElabReflection 10 | %default total 11 | 12 | -------------------------------------------------------------------------------- 13 | -- Finite Trees 14 | -------------------------------------------------------------------------------- 15 | 16 | ||| A finite rose tree 17 | public export 18 | record Tree (a : Type) where 19 | constructor MkTree 20 | value : a 21 | forest : List (Tree a) 22 | 23 | ||| A finite forest of trees 24 | public export 25 | Forest : Type -> Type 26 | Forest = List . Tree 27 | 28 | %runElab derive "Tree" [Show,Eq] 29 | 30 | -------------------------------------------------------------------------------- 31 | -- Creating Trees 32 | -------------------------------------------------------------------------------- 33 | 34 | public export 35 | singleton : a -> Tree a 36 | singleton a = MkTree a [] 37 | 38 | public export 39 | replicate : (width : Nat) -> (depth : Nat) -> a -> Tree a 40 | replicate _ 0 x = MkTree x [] 41 | replicate width (S k) x = MkTree x $ replicate width (replicate width k x) 42 | 43 | ||| Unfold a tree up to the given depth. 44 | public export 45 | unfold : (depth : Nat) -> (f : s -> (a,List s)) -> s -> Tree a 46 | unfold 0 f s = MkTree (fst $ f s) [] 47 | unfold (S k) f s = 48 | let (a,ss) := f s 49 | in MkTree a (map (unfold k f) ss) 50 | 51 | -------------------------------------------------------------------------------- 52 | -- Flattening Trees 53 | -------------------------------------------------------------------------------- 54 | 55 | zipWithKeep : (a -> a -> a) -> List a -> List a -> List a 56 | zipWithKeep f [] ys = ys 57 | zipWithKeep f xs [] = xs 58 | zipWithKeep f (x :: xs) (y :: ys) = f x y :: zipWithKeep f xs ys 59 | 60 | public export 61 | flatten : Tree a -> List a 62 | flatten (MkTree v vs) = v :: flattenF vs 63 | 64 | where 65 | flattenF : Forest a -> List a 66 | flattenF [] = Nil 67 | flattenF (x :: xs) = flatten x ++ flattenF xs 68 | 69 | public export 70 | layers : Tree a -> List (List a) 71 | layers (MkTree v vs) = [v] :: layersF vs 72 | 73 | where 74 | layersF : Forest a -> List (List a) 75 | layersF [] = Nil 76 | layersF (x :: xs) = zipWithKeep (++) (layers x) (layersF xs) 77 | 78 | -------------------------------------------------------------------------------- 79 | -- Accessing Elements 80 | -------------------------------------------------------------------------------- 81 | 82 | public export 83 | index : List Nat -> Tree a -> Maybe a 84 | index [] x = Just x.value 85 | index (y :: ys) x = ix y x.forest >>= index ys 86 | 87 | where 88 | ix : Nat -> List b -> Maybe b 89 | ix _ [] = Nothing 90 | ix 0 (z :: _) = Just z 91 | ix (S k) (_ :: zs) = ix k zs 92 | 93 | -------------------------------------------------------------------------------- 94 | -- Functor and Monad Implementations 95 | -------------------------------------------------------------------------------- 96 | 97 | -- All implementations are boilerplaty to satisfy the totality checker. 98 | foldlTree : (a -> e -> a) -> a -> Tree e -> a 99 | foldlTree f acc (MkTree v vs) = foldlF (f acc v) vs 100 | 101 | where 102 | foldlF : a -> Forest e -> a 103 | foldlF y [] = y 104 | foldlF y (x :: xs) = foldlF (foldlTree f y x) xs 105 | 106 | foldrTree : (e -> a -> a) -> a -> Tree e -> a 107 | foldrTree f acc (MkTree v vs) = f v (foldrF acc vs) 108 | 109 | where 110 | foldrF : a -> Forest e -> a 111 | foldrF y [] = y 112 | foldrF y (x :: xs) = foldrTree f (foldrF y xs) x 113 | 114 | traverseTree : Applicative f => (a -> f b) -> Tree a -> f (Tree b) 115 | traverseTree fun (MkTree v vs) = [| MkTree (fun v) (traverseF vs) |] 116 | 117 | where 118 | traverseF : Forest a -> f (Forest b) 119 | traverseF [] = pure [] 120 | traverseF (x :: xs) = [| traverseTree fun x :: traverseF xs |] 121 | 122 | mapTree : (a -> b) -> Tree a -> Tree b 123 | mapTree f (MkTree v vs) = MkTree (f v) (mapF vs) 124 | 125 | where 126 | mapF : Forest a -> Forest b 127 | mapF [] = [] 128 | mapF (h :: t) = mapTree f h :: mapF t 129 | 130 | bindTree : Tree a -> (a -> Tree b) -> Tree b 131 | bindTree (MkTree va tas) f = 132 | let MkTree vb tbs := f va 133 | in MkTree vb (tbs ++ bindF tas) 134 | 135 | where 136 | bindF : Forest a -> Forest b 137 | bindF [] = [] 138 | bindF (x :: xs) = bindTree x f :: bindF xs 139 | 140 | apTree : Tree (a -> b) -> Tree a -> Tree b 141 | apTree tf ta = bindTree tf $ \f => mapTree (apply f) ta 142 | 143 | joinTree : Tree (Tree a) -> Tree a 144 | joinTree (MkTree (MkTree va tas) ftas) = 145 | MkTree va $ tas ++ joinF ftas 146 | 147 | where 148 | joinF : Forest (Tree a) -> Forest a 149 | joinF [] = [] 150 | joinF (x :: xs) = joinTree x :: joinF xs 151 | 152 | -------------------------------------------------------------------------------- 153 | -- Visualizing Trees 154 | -------------------------------------------------------------------------------- 155 | 156 | export 157 | drawTree : Tree String -> String 158 | drawTree = unlines . draw 159 | 160 | where 161 | drawForest : Forest String -> String 162 | drawForest = unlines . map drawTree 163 | 164 | draw : Tree String -> List String 165 | draw (MkTree x ts0) = lines x ++ subTrees ts0 166 | 167 | where 168 | shift : String -> String -> List String -> List String 169 | shift first other tails = 170 | zipWith (++) (first :: replicate (length tails) other) tails 171 | 172 | subTrees : Forest String -> List String 173 | subTrees [] = [] 174 | subTrees [t] = "│" :: shift "└╼" " " (draw t) 175 | subTrees (t::ts) = "│" :: shift "├╼" "│ " (draw t) ++ subTrees ts 176 | 177 | -------------------------------------------------------------------------------- 178 | -- Interfaces 179 | -------------------------------------------------------------------------------- 180 | 181 | public export %inline 182 | Foldable Tree where 183 | foldl = foldlTree 184 | foldr = foldrTree 185 | null _ = False 186 | 187 | public export %inline 188 | Functor Tree where 189 | map = mapTree 190 | 191 | public export %inline 192 | Applicative Tree where 193 | pure a = MkTree a Nil 194 | (<*>) = apTree 195 | 196 | public export %inline 197 | Monad Tree where 198 | (>>=) = bindTree 199 | join = joinTree 200 | 201 | public export %inline 202 | Traversable Tree where 203 | traverse = traverseTree 204 | -------------------------------------------------------------------------------- /src/Derive/Cogen.idr: -------------------------------------------------------------------------------- 1 | module Derive.Cogen 2 | 3 | import public Hedgehog.Internal.Function as Hedgehog 4 | 5 | import public Language.Reflection.Util 6 | 7 | %default total 8 | 9 | ||| Derivation facility for `Gogen` interface 10 | ||| 11 | ||| Use `derive`, `deriveIndexed` or `derivePattern` from 12 | ||| `Language.Reflection.Derive` for simple, purely indexed or mixed data types 13 | export 14 | CogenVis : Visibility -> List Name -> ParamTypeInfo -> Res (List TopLevel) 15 | CogenVis vis nms p = do 16 | let fun := funName p "perturb" 17 | let impl := implName p "Cogen" 18 | Right 19 | [ TL (perturbClaim fun p) (perturbDef fun p.info) 20 | , TL (cogenImplClaim impl p) (cogenImplDef fun impl) 21 | ] 22 | 23 | where 24 | perturbClaim : Name -> ParamTypeInfo -> Decl 25 | perturbClaim fun p = 26 | simpleClaim vis fun $ 27 | piAll `(~(p.applied) -> StdGen -> StdGen) $ allImplicits p "Cogen" 28 | 29 | perturbDef : Name -> TypeInfo -> Decl 30 | perturbDef fun ti = 31 | def fun $ map clause $ [0 .. length ti.cons] `zip` ti.cons where 32 | 33 | clause : (Nat, Con _ _) -> Clause 34 | clause (idx, con) = 35 | accumArgs unerased (\x => `(~(var fun) ~x)) rhs arg con where 36 | 37 | arg : BoundArg 1 Unerased -> TTImp 38 | arg $ BA g [x] _ = 39 | assertIfRec nms g.type 40 | `(Function.perturb ~(varStr x) . Function.shiftArg) 41 | 42 | rhs : SnocList TTImp -> TTImp 43 | rhs = foldr (\l, r => `(~l . ~r)) 44 | `(System.Random.Pure.variant (fromInteger ~(primVal $ BI $ cast idx))) 45 | 46 | cogenImplClaim : Name -> ParamTypeInfo -> Decl 47 | cogenImplClaim impl p = implClaimVis vis impl $ implType "Cogen" p 48 | 49 | cogenImplDef : (fun, impl : Name) -> Decl 50 | cogenImplDef fun impl = 51 | def impl $ pure $ patClause (var impl) (var "MkCogen" `app` var fun) 52 | 53 | 54 | ||| Alias for `CogenVis Public` 55 | export %inline 56 | Cogen : List Name -> ParamTypeInfo -> Res (List TopLevel) 57 | Cogen = CogenVis Public 58 | -------------------------------------------------------------------------------- /src/Hedgehog.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog 2 | 3 | import public Control.Monad.Either 4 | import public Control.Monad.Writer 5 | import public Hedgehog.Internal.Config as Hedgehog 6 | import public Hedgehog.Internal.Gen as Hedgehog 7 | import public Hedgehog.Internal.Function as Hedgehog 8 | import public Hedgehog.Internal.Property as Hedgehog 9 | import public Hedgehog.Internal.Range as Hedgehog 10 | import public Hedgehog.Internal.Runner as Hedgehog 11 | import public Hedgehog.Internal.Shrink as Hedgehog 12 | import public Hedgehog.Internal.Terminal as Hedgehog 13 | import public Hedgehog.Internal.Util as Hedgehog 14 | 15 | import public System.Random.Pure.StdGen 16 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Config.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Config 2 | 3 | import Derive.Prelude 4 | import System 5 | 6 | %language ElabReflection 7 | 8 | %default total 9 | 10 | -------------------------------------------------------------------------------- 11 | -- Config 12 | -------------------------------------------------------------------------------- 13 | 14 | ||| Whether to render output using ANSI colors or not. 15 | public export 16 | data UseColor = DisableColor | EnableColor 17 | 18 | %runElab derive "UseColor" [Show,Eq,Ord] 19 | 20 | ||| How verbose should the report output be. 21 | public export 22 | data Verbosity = Quiet | Normal 23 | 24 | %runElab derive "Verbosity" [Show,Eq,Ord] 25 | 26 | -------------------------------------------------------------------------------- 27 | -- Detecting Config Settings 28 | -------------------------------------------------------------------------------- 29 | 30 | ||| Defines points of an global configuration for a Hedgehog run 31 | public export 32 | interface HasConfig m where 33 | constructor MkHasConfig 34 | detectColor : m UseColor 35 | detectVerbosity : m Verbosity 36 | 37 | export 38 | resolveColor : HasConfig m => Applicative m => Maybe UseColor -> m UseColor 39 | resolveColor = maybe detectColor pure 40 | 41 | export 42 | resolveVerbosity : HasConfig m => Applicative m => Maybe Verbosity -> m Verbosity 43 | resolveVerbosity = maybe detectVerbosity pure 44 | 45 | lookupBool : HasIO io => String -> io (Maybe Bool) 46 | lookupBool key = 47 | getEnv key >>= 48 | \case 49 | Just "0" => pure $ Just False 50 | Just "no" => pure $ Just False 51 | Just "false" => pure $ Just False 52 | 53 | Just "1" => pure $ Just True 54 | Just "yes" => pure $ Just True 55 | Just "true" => pure $ Just True 56 | 57 | _ => pure Nothing 58 | 59 | ||| Reads the global configuration from environment variables 60 | export 61 | HasIO io => HasConfig io where 62 | detectColor = do 63 | Just True <- lookupBool "HEDGEHOG_COLOR" | _ => pure DisableColor 64 | pure EnableColor 65 | 66 | detectVerbosity = do 67 | Just "0" <- getEnv "HEDGEHOG_VERBOSITY" | _ => pure Normal 68 | pure Quiet 69 | 70 | ||| Uses the most conservative configuration 71 | ||| 72 | ||| This implementation is applicable for any applicative context, 73 | ||| including pure ones. 74 | export %defaulthint 75 | DefaultConfig : Applicative m => HasConfig m 76 | DefaultConfig = D where 77 | [D] HasConfig m where 78 | detectColor = pure DisableColor 79 | detectVerbosity = pure Normal 80 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Function.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Function 2 | 3 | import Data.Colist 4 | import Data.Cotree 5 | import Data.Either 6 | import Data.Nat 7 | import Data.String 8 | 9 | import Hedgehog.Internal.Gen 10 | import Hedgehog.Internal.Range 11 | import Hedgehog.Internal.Util 12 | 13 | import System.Random.Pure.StdGen 14 | 15 | %default total 16 | 17 | ||| An interface for co-generators, somewhat an inverse of a generator 18 | ||| 19 | ||| Generators, roughly, using a random seed produce a value of a certain type. 20 | ||| Co-generators conversly, roughtly speaking, produce a random seed using 21 | ||| a value of a certain type. 22 | ||| 23 | ||| Due to technical properties of a seed type, instead of generating a seed 24 | ||| value from stratch we perturb some existing value. 25 | ||| Thus, a function of this interface produces a `StdGen -> StdGen` function 26 | ||| being given a value of an appropriate type. 27 | ||| 28 | ||| In some understanding, co-generators classify values of a given type, which 29 | ||| allow to tune generators of other types. 30 | ||| This gives an ability to generate functions of type `a -> b` being given 31 | ||| a generator of type `b` and a co-generator of type `a`. 32 | ||| Having a value of type `a`, co-generator can deterministically tune 33 | ||| the generator of type `b` by perturbing a random seed that is used by the 34 | ||| generator and use its output as an output for a function. 35 | public export 36 | interface Cogen a where 37 | constructor MkCogen 38 | perturb : a -> StdGen -> StdGen 39 | 40 | ||| This function perturbs the given seed both with `variant` and `split`. 41 | ||| 42 | ||| This function is meant to be used between successive perturbations 43 | ||| of different arguments of the same constructor. 44 | ||| 45 | ||| It is designed to not commute when perturbation actions of a constructor's 46 | ||| arguments do the same. 47 | ||| Consider if `Cogen` interface is implemented for `Maybe a` and `Bool` 48 | ||| in the following way: 49 | ||| 50 | ||| ``` 51 | ||| Cogen a => Cogen (Maybe a) where 52 | ||| perturb (Just x) = perturb x . variant 0 53 | ||| perturb Nothing = variant 1 54 | ||| 55 | ||| Cogen Bool where 56 | ||| perturb False = variant 0 57 | ||| perturb True = variant 1 58 | ||| ``` 59 | ||| 60 | ||| In this case values `Nothing` and `Just True` would give the same 61 | ||| perturbation to a seed, which is not optimal. Insertion of `shiftArg` 62 | ||| before each call for `perturb` of a constructor argument would give 63 | ||| different perturbations for different combinations of constructors and 64 | ||| their arguments (unless you are very unlucky). 65 | ||| Combination of both `variant` and `split` in the `shiftArg` function 66 | ||| gives relative independence on how `perturb` of a constructor argument 67 | ||| type is implemented. 68 | export 69 | shiftArg : StdGen -> StdGen 70 | shiftArg = variant 33 . snd . split . variant 31 71 | 72 | ||| Changes random distribution of a generator of type `b` 73 | ||| based on a value of type `a` 74 | ||| 75 | ||| Change of distribution is done by a perturbation of a random seed, 76 | ||| which is based on a `Cogen` implementation for the type `a`. 77 | export 78 | cogen : Cogen a => a -> Gen b -> Gen b 79 | cogen x g = MkGen $ \sz, sd => unGen g sz $ perturb x sd 80 | 81 | export 82 | Cogen Unit where 83 | perturb _ = id 84 | 85 | export 86 | Cogen (Equal x y) where 87 | perturb Refl = id 88 | 89 | export 90 | Cogen Bool where 91 | perturb True = variant 0 92 | perturb False = variant 1 93 | 94 | export 95 | Cogen Nat where 96 | perturb = variant 97 | 98 | export 99 | Cogen Integer where 100 | perturb = variant . cast 101 | 102 | export 103 | Cogen Bits64 where 104 | perturb = variant . cast 105 | 106 | export 107 | Cogen Bits16 where perturb = variant . cast 108 | 109 | export 110 | Cogen Bits8 where perturb = variant . cast 111 | 112 | export 113 | Cogen Int64 where perturb = variant . cast 114 | 115 | export 116 | Cogen Int16 where perturb = variant . cast 117 | 118 | export 119 | Cogen Int8 where perturb = variant . cast 120 | 121 | export 122 | Cogen Int where perturb = variant . cast 123 | 124 | export 125 | Cogen Char where perturb = variant . cast 126 | 127 | export 128 | Cogen Void where 129 | perturb _ impossible 130 | 131 | export 132 | Cogen a => Cogen b => Cogen (a, b) where 133 | perturb (x, y) = perturb x . shiftArg . perturb y . shiftArg 134 | 135 | export 136 | Cogen a => Cogen b => Cogen (Either a b) where 137 | perturb $ Left x = perturb x . shiftArg . variant 0 138 | perturb $ Right y = perturb y . shiftArg . variant 1 139 | 140 | export 141 | Cogen a => Cogen (Maybe a) where 142 | perturb Nothing = variant 0 143 | perturb (Just x) = perturb x . shiftArg . variant 1 144 | 145 | export 146 | Cogen a => Cogen (List a) where 147 | perturb [] = variant 0 148 | perturb (x::xs) = perturb xs . shiftArg . perturb x . shiftArg . variant 1 149 | 150 | export 151 | Cogen String where 152 | perturb = perturb . fastUnpack 153 | 154 | ||| Generates a random function being given a generator of codomain type 155 | ||| 156 | ||| This function takes a co-generator of domain type using `auto`-argument 157 | ||| based on the type. 158 | ||| This generator does not shrink. 159 | ||| 160 | ||| Notice that this generator returns a non-showable value (unless you invent 161 | ||| your own implementation). 162 | ||| If you need a showable function, you have to use a shrinkable version, 163 | ||| which requires more strict implementation on the domain type. 164 | export 165 | function_ : Cogen a => Gen b -> Gen (a -> b) 166 | function_ bg = 167 | MkGen $ \sz, sd => singleton $ \x => value $ unGen bg sz $ perturb x sd 168 | 169 | ||| Generates a random dependently typed function being given a generator 170 | ||| of codomain type family 171 | ||| 172 | ||| This function takes a co-generator of domain type using `auto`-argument 173 | ||| based on the type. 174 | ||| This generator does not shrink. 175 | ||| 176 | ||| Notice that this generator returns a non-showable value (unless you invent 177 | ||| your own implementation). 178 | export 179 | depfun_ : 180 | {auto _ : Cogen a} 181 | -> {0 b : a -> Type} 182 | -> ((x : a) -> Gen $ b x) 183 | -> Gen ((x : a) -> b x) 184 | depfun_ bg = 185 | MkGen $ \sz, sd => singleton $ \x => value $ unGen (bg x) sz $ perturb x sd 186 | 187 | ||| Generates a random function with dependently typed domain being given a 188 | ||| generator of codomain type 189 | ||| 190 | ||| This function takes a co-generator of domain type family using 191 | ||| `auto`-argument based on the type. 192 | ||| This generator does not shrink. 193 | ||| 194 | ||| Notice that this generator returns a non-showable value (unless you invent 195 | ||| your own implementation). 196 | export 197 | dargfun_ : 198 | {0 b : a -> Type} 199 | -> {auto _ : {0 x : a} -> Cogen (b x)} 200 | -> Gen c 201 | -> Gen ({0 x : a} -> b x -> c) 202 | dargfun_ bg = 203 | MkGen $ \sz, sd => singleton $ \x => value $ unGen bg sz $ perturb x sd 204 | 205 | ||| Generates a random dependently typed function with dependently typed domain 206 | ||| being given a generator of codomain type family 207 | ||| 208 | ||| This function takes a co-generator of domain type family using 209 | ||| `auto`-argument based on the type. 210 | ||| This generator does not shrink. 211 | ||| 212 | ||| Notice that this generator returns a non-showable value (unless you invent 213 | ||| your own implementation). 214 | export 215 | dargdepfun_ : 216 | {0 b : a -> Type} 217 | -> {0 c : {0 x : a} -> b x -> Type} 218 | -> {auto _ : {0 x : a} -> Cogen (b x)} 219 | -> ({0 x : a} -> (y : b x) -> Gen (c y)) 220 | -> Gen ({0 x : a} -> (y : b x) -> c y) 221 | dargdepfun_ bg = 222 | MkGen $ \sz, sd => singleton $ \x => value $ unGen (bg x) sz $ perturb x sd 223 | 224 | ---------------------------- 225 | --- Shrinkable functions --- 226 | ---------------------------- 227 | 228 | -- Claessen, K. Shrinking and showing functions:(functional pearl). 229 | -- In ACM SIGPLAN Notices (Vol. 47, No. 12, pp. 73-80). ACM. 2012, September 230 | 231 | export infixr 5 :-> 232 | 233 | ||| A type of reified partial functions that can be represented isomorphic 234 | ||| to a function defined by pattern matching of an ADT 235 | ||| or any type that *can* implement `Generic` (but does not have to). 236 | ||| 237 | ||| This type describes internal structure of such functions, 238 | ||| e.g. storing separately "vertical" and "horizontal" matching, 239 | ||| thus allowing to inspect, modify and simplify them, 240 | ||| for example, for showing and shrinking. 241 | public export 242 | data (:->) : Type -> Type -> Type where 243 | FUnit : c -> () :-> c 244 | FNil : a :-> c 245 | FPair : Lazy (a :-> b :-> c) -> (a, b) :-> c 246 | FSum : Lazy (a :-> c) -> Lazy (b :-> c) -> Either a b :-> c 247 | FMap : (a -> b) -> (b -> a) -> Lazy (b :-> c) -> a :-> c 248 | 249 | export 250 | Functor ((:->) a) where 251 | map f $ FUnit c = FUnit $ f c 252 | map _ $ FNil = FNil 253 | map f $ FPair a = FPair $ map (assert_total $ map f) a 254 | map f $ FSum a b = FSum (map f a) (map f b) 255 | map f $ FMap a b c = FMap a b $ map f c 256 | 257 | table : a :-> c -> List (a, c) 258 | table (FUnit c) = [((), c)] 259 | table FNil = [] 260 | table (FPair f) = do 261 | (a, bc) <- table f 262 | (b, c) <- assert_total table bc 263 | pure ((a, b), c) 264 | table (FSum a b) = 265 | [(Left x, c) | (x, c) <- table a] 266 | ++ [(Right x, c) | (x, c) <- table b] 267 | table (FMap _ g a) = mapFst g <$> table a 268 | 269 | public export 270 | interface Cogen a => ShrCogen a where 271 | constructor MkShrCogen 272 | build : (a -> c) -> a :-> c 273 | 274 | export 275 | ShrCogen Void where 276 | build _ = FNil 277 | 278 | export 279 | ShrCogen Unit where 280 | build f = FUnit $ f () 281 | 282 | export 283 | ShrCogen a => ShrCogen b => ShrCogen (a, b) where 284 | build f = FPair $ build $ \a => build $ \b => f (a, b) 285 | 286 | export 287 | ShrCogen a => ShrCogen b => ShrCogen (Either a b) where 288 | build f = FSum (build $ f . Left) (build $ f . Right) 289 | 290 | ||| Implements `build` function for a type through isomorphism 291 | ||| to a type that implements `ShrCogen` 292 | ||| 293 | ||| Notice that `via f g` will only be well-behaved if 294 | ||| `g . f` and `f . g` are both identity functions. 295 | export 296 | via : ShrCogen b => (a -> b) -> (b -> a) -> (a -> c) -> a :-> c 297 | via a b f = FMap a b $ build $ f . b 298 | 299 | export 300 | ShrCogen a => ShrCogen (Maybe a) where 301 | build = via (maybeToEither ()) eitherToMaybe 302 | 303 | export 304 | ShrCogen Bool where 305 | build = via toEither fromEither 306 | 307 | where 308 | toEither : Bool -> Either Unit Unit 309 | toEither True = Left () 310 | toEither False = Right () 311 | fromEither : Either Unit Unit -> Bool 312 | fromEither $ Left () = True 313 | fromEither $ Right () = False 314 | 315 | export 316 | ShrCogen a => ShrCogen (List a) where 317 | build = assert_total via toEither fromEither 318 | 319 | where 320 | toEither : List a -> Either Unit (a, List a) 321 | toEither [] = Left () 322 | toEither (x::xs) = Right (x, xs) 323 | fromEither : Either Unit (a, List a) -> List a 324 | fromEither (Left ()) = [] 325 | fromEither (Right (x, xs)) = x::xs 326 | 327 | export 328 | ShrCogen (Equal x x) where 329 | build = via (const ()) (const Refl) 330 | 331 | export 332 | ShrCogen Integer where 333 | build = via toBits fromBits 334 | 335 | where 336 | toBits : Integer -> (Bool, List Bool) 337 | toBits n = if n >= 0 then (True, go [] n) else (False, go [] $ -n - 1) 338 | 339 | where 340 | go : List Bool -> Integer -> List Bool 341 | go bits x = 342 | if x == 0 343 | then bits 344 | else go ((mod x 2 == 1) :: bits) (assert_smaller x $ div x 2) 345 | 346 | fromBits : (Bool, List Bool) -> Integer 347 | fromBits (sign, bits) = do 348 | let body = foldl (\acc, b => acc * the Integer 2 + if b then 1 else 0) 0 bits 349 | if sign then body else negate $ body + 1 350 | 351 | export 352 | ShrCogen Nat where build = via {b=Integer} cast cast 353 | 354 | export 355 | ShrCogen Int where build = via {b=Integer} cast cast 356 | 357 | export 358 | ShrCogen Int8 where build = via {b=Integer} cast cast 359 | 360 | export 361 | ShrCogen Int16 where build = via {b=Integer} cast cast 362 | 363 | export 364 | ShrCogen Int64 where build = via {b=Integer} cast cast 365 | 366 | export 367 | ShrCogen Bits8 where build = via {b=Nat} cast cast 368 | 369 | export 370 | ShrCogen Bits16 where build = via {b=Nat} cast cast 371 | 372 | export 373 | ShrCogen Bits64 where build = via {b=Nat} cast cast 374 | 375 | export 376 | ShrCogen Char where build = via {b=Nat} cast cast 377 | 378 | export 379 | ShrCogen String where build = via fastUnpack fastPack 380 | 381 | apply' : a :-> b -> a -> Maybe b 382 | apply' (FUnit c) () = Just c 383 | apply' FNil _ = Nothing 384 | apply' (FPair f) (a, b) = assert_total $ apply' !(apply' f a) b 385 | apply' (FSum f _) (Left a) = apply' f a 386 | apply' (FSum _ g) (Right a) = apply' g a 387 | apply' (FMap f _ g) a = apply' g (f a) 388 | 389 | shrinkFn : (b -> Inf (Colist b)) -> a :-> b -> Colist $ a :-> b 390 | shrinkFn shr (FUnit a) = FUnit <$> shr a 391 | shrinkFn _ FNil = [] 392 | shrinkFn shr (FPair f) = 393 | shrinkFn (delay . assert_total (shrinkFn shr)) f <&> 394 | \case FNil => FNil; a => FPair a 395 | shrinkFn shr (FSum a b) = 396 | map (\case FSum FNil FNil => FNil; x => x) $ 397 | (if notFNil b then [ FSum a FNil ] else []) ++ 398 | (if notFNil a then [ FSum FNil b ] else []) ++ 399 | map (`FSum` b) (shrinkFn shr a) ++ 400 | map (a `FSum`) (shrinkFn shr b) 401 | 402 | where 403 | (++) : forall a. Colist a -> Inf (Colist a) -> Colist a 404 | [] ++ ys = ys 405 | (x::xs) ++ ys = x :: (xs ++ ys) 406 | 407 | notFNil : forall a, b. a :-> b -> Bool 408 | notFNil FNil = False 409 | notFNil _ = True 410 | shrinkFn shr (FMap f g a) = 411 | shrinkFn shr a <&> \case FNil => FNil; x => FMap f g x 412 | 413 | ||| The type for a total randomly-generated function 414 | export 415 | data Fn a b = MkFn b (a :-> Cotree b) 416 | 417 | export 418 | Show a => Show b => Show (Fn a b) where 419 | show (MkFn xb xa) = unlines $ (table xa <&> showCase) ++ ["_ -> " ++ show xb] 420 | 421 | where 422 | showCase : (a, Cotree b) -> String 423 | showCase (lhs, rhs) = show lhs ++ " -> " ++ show rhs.value 424 | 425 | ||| Generates a random function being given a generator of codomain type 426 | ||| 427 | ||| The generated function is returned in a showable type `Fn a b`. 428 | ||| 429 | ||| This function takes a co-generator of domain type using `auto`-argument 430 | ||| based on the type. 431 | ||| This generator is shrinkable. For this, it requires additional `Arg` 432 | ||| argument. 433 | export 434 | function : ShrCogen a => Gen b -> Gen (Fn a b) 435 | function gb = [| MkFn gb (genFn $ \a => cogen a gb) |] 436 | 437 | where 438 | genFn : (a -> Gen b) -> Gen (a :-> Cotree b) 439 | genFn g = MkGen $ \sz, sd => 440 | iterate (shrinkFn forest) . map (runGen sz sd) $ build g 441 | 442 | ||| Coverts a showable randomly generated function to an actual function 443 | export 444 | apply : Fn a b -> a -> b 445 | apply (MkFn b f) = maybe b value . apply' f 446 | 447 | ||| Generates a random function being given a generator of codomain type 448 | ||| 449 | ||| This generator is shrinkable 450 | ||| 451 | ||| This is a wrapper of a `function` generator. 452 | ||| It may be useful sometimes, however, it returnes a non-showable type. 453 | ||| To use functions generator in `forAll` in a property, use `function` 454 | ||| generator. 455 | public export 456 | function' : ShrCogen a => Gen b -> Gen (a -> b) 457 | function' = map apply . function 458 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Gen.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Gen 2 | 3 | import Data.Bounded 4 | import Data.Colist 5 | import Data.Cotree 6 | import Data.Fin 7 | import Data.List 8 | import Data.List.Quantifiers 9 | import Data.List1 10 | import Data.Nat 11 | import Data.SOP 12 | import Data.String 13 | import Data.Tree 14 | import Data.Vect 15 | import Data.Vect.Quantifiers 16 | 17 | import Control.Monad.Maybe 18 | 19 | import Hedgehog.Internal.Range 20 | import Hedgehog.Internal.Shrink 21 | import Hedgehog.Internal.Util 22 | 23 | import System.Random.Pure.StdGen 24 | 25 | %hide Prelude.Range 26 | 27 | %default total 28 | 29 | -------------------------------------------------------------------------------- 30 | -- Random Value Generator with Integrated Shrinking 31 | -------------------------------------------------------------------------------- 32 | 33 | ||| Generates random values of type `a` 34 | public export 35 | record Gen (a : Type) where 36 | constructor MkGen 37 | unGen : Size -> StdGen -> Cotree a 38 | 39 | public export %inline 40 | runGen : Size -> StdGen -> Gen a -> Cotree a 41 | runGen si se g = unGen g si se 42 | 43 | public export 44 | mapGen : (f : Cotree a -> Cotree b) -> Gen a -> Gen b 45 | mapGen f (MkGen run) = MkGen $ \si,se => f (run si se) 46 | 47 | ||| Lift a predefined shrink tree in to a generator, ignoring the seed and the 48 | ||| size. 49 | public export 50 | fromTree : Cotree a -> Gen a 51 | fromTree ct = MkGen $ \_,_ => ct 52 | 53 | ||| Observe a generator's shrink tree. 54 | public export 55 | toTree : Gen a -> Gen (Cotree a) 56 | toTree (MkGen unGen) = MkGen $ \si,se => pure (unGen si se) 57 | 58 | -------------------------------------------------------------------------------- 59 | -- Interface Implementations 60 | -------------------------------------------------------------------------------- 61 | 62 | public export 63 | Functor Gen where 64 | map f (MkGen g) = MkGen $ \si,se => map f (g si se) 65 | 66 | public export 67 | Applicative Gen where 68 | pure a = MkGen $ \_,_ => pure a 69 | 70 | MkGen ff <*> MkGen fa = 71 | MkGen $ \si,se => 72 | let (se1,se2) := split se 73 | in interleave (ff si se1) (fa si se2) 74 | 75 | public export 76 | Monad Gen where 77 | MkGen run >>= f = 78 | MkGen $ \si,se => 79 | let (se1,se2) := split se 80 | ta := run si se1 81 | in bind ta (runGen si se2 . f) 82 | 83 | -------------------------------------------------------------------------------- 84 | -- Combinators 85 | -------------------------------------------------------------------------------- 86 | 87 | public export 88 | generate : (Size -> StdGen -> a) -> Gen a 89 | generate f = MkGen $ \si,se => pure (f si se) 90 | 91 | -------------------------------------------------------------------------------- 92 | -- Shrinking 93 | -------------------------------------------------------------------------------- 94 | 95 | public export 96 | shrink : (a -> Colist a) -> Gen a -> Gen a 97 | shrink f = mapGen (expand f) 98 | 99 | public export %inline 100 | prune : Gen a -> Gen a 101 | prune = mapGen prune 102 | 103 | -------------------------------------------------------------------------------- 104 | -- Size 105 | -------------------------------------------------------------------------------- 106 | 107 | ||| Construct a generator that depends on the size parameter. 108 | public export 109 | sized : (Size -> Gen a) -> Gen a 110 | sized f = generate (\si,_ => si) >>= f 111 | 112 | ||| Adjust the size parameter by transforming it with the given function. 113 | public export 114 | scale : (Size -> Size) -> Gen a -> Gen a 115 | scale f (MkGen run) = MkGen $ \si,se => run (f si) se 116 | 117 | ||| Override the size parameter. Returns a generator which uses the given size 118 | ||| instead of the runtime-size parameter. 119 | public export %inline 120 | resize : Size -> Gen a -> Gen a 121 | resize size = scale (const size) 122 | 123 | ||| Scale a size using the golden ratio. 124 | ||| 125 | ||| > golden x = x / φ 126 | ||| > golden x = x / 1.61803.. 127 | public export 128 | golden : Size -> Size 129 | golden = resize $ \n => round (0.61803398875 * cast n) 130 | 131 | ||| Make a generator smaller by scaling its size parameter. 132 | public export %inline 133 | small : Gen a -> Gen a 134 | small = scale golden 135 | 136 | -------------------------------------------------------------------------------- 137 | -- Integral 138 | -------------------------------------------------------------------------------- 139 | 140 | ||| Generates a random integral number in the [inclusive,inclusive] range. 141 | ||| 142 | ||| This generator does not shrink. 143 | public export 144 | integral_ : ToInteger a => Range a -> Gen a 145 | integral_ range = generate $ \si,se => 146 | let (x, y) := bounds si range 147 | in fromInteger . snd $ randomR (toInteger x, toInteger y) se 148 | 149 | ||| Generates a random integral number in the given @[inclusive,inclusive]@ range. 150 | ||| 151 | ||| When the generator tries to shrink, it will shrink towards the 152 | ||| 'Range.origin' of the specified 'Range'. 153 | ||| 154 | ||| For example, the following generator will produce a number between @1970@ 155 | ||| and @2100@, but will shrink towards @2000@: 156 | ||| 157 | ||| ``` 158 | ||| integral (Range.'Range.constantFrom' 2000 1970 2100) :: 'Gen' 'Int' 159 | ||| ``` 160 | ||| 161 | ||| Some sample outputs from this generator might look like: 162 | ||| 163 | ||| > === Outcome === 164 | ||| > 1973 165 | ||| > === Shrinks === 166 | ||| > 2000 167 | ||| > 1987 168 | ||| > 1980 169 | ||| > 1976 170 | ||| > 1974 171 | ||| 172 | ||| > === Outcome === 173 | ||| > 2061 174 | ||| > === Shrinks === 175 | ||| > 2000 176 | ||| > 2031 177 | ||| > 2046 178 | ||| > 2054 179 | ||| > 2058 180 | ||| > 2060 181 | ||| 182 | public export 183 | integral : ToInteger a => Range a -> Gen a 184 | integral range = shrink (towards $ origin range) (integral_ range) 185 | 186 | ||| Generates a random machine integer in the given range. 187 | ||| 188 | ||| This is a specialization of `integral`, offered for convenience. 189 | public export %inline 190 | int : Range Int -> Gen Int 191 | int = integral 192 | 193 | ||| Generates a random 8-bit integer in the given range. 194 | ||| 195 | ||| This is a specialization of `integral`, offered for convenience. 196 | public export %inline 197 | int8 : Range Int8 -> Gen Int8 198 | int8 = integral 199 | 200 | ||| Generates a random 8-bit integer in the full available range. 201 | ||| 202 | ||| This shrinks exponentially towards 0. 203 | public export %inline 204 | anyInt8 : Gen Int8 205 | anyInt8 = int8 (exponentialFrom 0 minBound maxBound) 206 | 207 | ||| Generates a random 16-bit integer in the given range. 208 | ||| 209 | ||| This is a specialization of `integral`, offered for convenience. 210 | public export %inline 211 | int16 : Range Int16 -> Gen Int16 212 | int16 = integral 213 | 214 | ||| Generates a random 16-bit integer in the full available range. 215 | ||| 216 | ||| This shrinks exponentially towards 0. 217 | public export %inline 218 | anyInt16 : Gen Int16 219 | anyInt16 = int16 (exponentialFrom 0 minBound maxBound) 220 | 221 | ||| Generates a random 32-bit integer in the given range. 222 | ||| 223 | ||| This is a specialization of `integral`, offered for convenience. 224 | public export %inline 225 | int32 : Range Int32 -> Gen Int32 226 | int32 = integral 227 | 228 | ||| Generates a random 32-bit integer in the full available range. 229 | ||| 230 | ||| This shrinks exponentially towards 0. 231 | public export %inline 232 | anyInt32 : Gen Int32 233 | anyInt32 = int32 (exponentialFrom 0 minBound maxBound) 234 | 235 | ||| Generates a random 64-bit integer in the given range. 236 | ||| 237 | ||| This is a specialization of `integral`, offered for convenience. 238 | public export %inline 239 | int64 : Range Int64 -> Gen Int64 240 | int64 = integral 241 | 242 | ||| Generates a random 64-bit integer in the full available range. 243 | ||| 244 | ||| This shrinks exponentially towards 0. 245 | public export %inline 246 | anyInt64 : Gen Int64 247 | anyInt64 = int64 (exponentialFrom 0 minBound maxBound) 248 | 249 | ||| Generates a random 8-bit integer in the given range. 250 | ||| 251 | ||| This is a specialization of 'integral', offered for convenience. 252 | public export %inline 253 | bits8 : Range Bits8 -> Gen Bits8 254 | bits8 = integral 255 | 256 | ||| Generates a random 8-bit signed integer in the full available range. 257 | ||| 258 | ||| This shrinks exponentially towards 0. 259 | public export %inline 260 | anyBits8 : Gen Bits8 261 | anyBits8 = bits8 (exponential 0 maxBound) 262 | 263 | ||| Generates a random 16-bit integer in the given range. 264 | ||| 265 | ||| This is a specialization of 'integral', offered for convenience. 266 | public export %inline 267 | bits16 : Range Bits16 -> Gen Bits16 268 | bits16 = integral 269 | 270 | ||| Generates a random 16-bit signed integer in the full available range. 271 | ||| 272 | ||| This shrinks exponentially towards 0. 273 | public export %inline 274 | anyBits16 : Gen Bits16 275 | anyBits16 = bits16 (exponential 0 maxBound) 276 | 277 | ||| Generates a random 32-bit integer in the given range. 278 | ||| 279 | ||| This is a specialization of 'integral', offered for convenience. 280 | public export %inline 281 | bits32 : Range Bits32 -> Gen Bits32 282 | bits32 = integral 283 | 284 | ||| Generates a random 32-bit signed integer in the full available range. 285 | ||| 286 | ||| This shrinks exponentially towards 0. 287 | public export %inline 288 | anyBits32 : Gen Bits32 289 | anyBits32 = bits32 (exponential 0 maxBound) 290 | 291 | ||| Generates a random 64-bit integer in the given range. 292 | ||| 293 | ||| This is a specialization of 'integral', offered for convenience. 294 | public export %inline 295 | bits64 : Range Bits64 -> Gen Bits64 296 | bits64 = integral 297 | 298 | ||| Generates a random 64-bit signed integer in the full available range. 299 | ||| 300 | ||| This shrinks exponentially towards 0. 301 | public export %inline 302 | anyBits64 : Gen Bits64 303 | anyBits64 = bits64 (exponential 0 maxBound) 304 | 305 | ||| Generates a random Integer in the given range. 306 | ||| 307 | ||| This is a specialization of 'integral', offered for convenience. 308 | public export %inline 309 | integer : Range Integer -> Gen Integer 310 | integer = integral 311 | 312 | ||| Generates a random Nat in the given range. 313 | ||| 314 | ||| This is a specialization of 'integral', offered for convenience. 315 | public export %inline 316 | nat : Range Nat -> Gen Nat 317 | nat = integral 318 | 319 | ||| Generates a random Size in the given range. 320 | ||| 321 | ||| This is a specialization of 'integral', offered for convenience. 322 | public export %inline 323 | size : Range Size -> Gen Size 324 | size = integral 325 | 326 | ||| Generates a random (Fin n) in the given range. 327 | public export 328 | fin : {n : _} -> Range (Fin n) -> Gen (Fin n) 329 | fin range = 330 | let rangeInt := map finToInteger range 331 | in map toFin (integer rangeInt) 332 | 333 | where 334 | toFin : Integer -> Fin n 335 | toFin k = fromMaybe range.origin (integerToFin k n) 336 | 337 | -------------------------------------------------------------------------------- 338 | -- Floating Point 339 | -------------------------------------------------------------------------------- 340 | 341 | ||| Generates a random fractional number in the [inclusive,exclusive) range. 342 | ||| 343 | ||| This generator does not shrink. 344 | export 345 | double_ : Range Double -> Gen Double 346 | double_ range = 347 | generate $ \si,se => 348 | let (x, y) := bounds si range 349 | in snd $ randomR (x, y) se 350 | 351 | ||| Generates a random floating-point number in the given range. 352 | ||| 353 | ||| This generator works the same as 'integral', but for floating point numbers. 354 | ||| 355 | export %inline 356 | double : Range Double -> Gen Double 357 | double range = shrink (towardsDouble $ origin range) (double_ range) 358 | 359 | -------------------------------------------------------------------------------- 360 | -- Choice 361 | -------------------------------------------------------------------------------- 362 | 363 | ||| Trivial generator that always produces the same element. 364 | ||| 365 | ||| This is another name for `pure`. 366 | public export %inline 367 | constant : a -> Gen a 368 | constant = pure 369 | 370 | ||| Randomly selects one of the elements in the vector. 371 | ||| 372 | ||| This generator shrinks towards the first element in the vector. 373 | public export 374 | element : {k : _} -> Vect (S k) a -> Gen a 375 | element vs = map (`index` vs) (fin $ constant FZ last) 376 | 377 | ||| Randomly selects one of the elements in the vector. 378 | ||| 379 | ||| This generator does not shrink. 380 | public export %inline 381 | element_ : {k : _} -> Vect (S k) a -> Gen a 382 | element_ = prune . element 383 | 384 | ||| Randomly selects one of the generators in the vector. 385 | ||| 386 | ||| This generator shrinks towards the first generator in the vector. 387 | public export %inline 388 | choice : {k : _} -> Vect (S k) (Gen a) -> Gen a 389 | choice vs = element vs >>= id 390 | 391 | ||| Randomly selects one of the generators in the vector. 392 | ||| 393 | ||| This generator does not shrink towards a particular 394 | ||| generator in the vector 395 | public export %inline 396 | choice_ : {k : _} -> Vect (S k) (Gen a) -> Gen a 397 | choice_ vs = element_ vs >>= id 398 | 399 | ||| Uses a weighted distribution to randomly select one of the generators in 400 | ||| the vector. 401 | ||| 402 | ||| This generator shrinks towards the first generator in the vector. 403 | ||| 404 | ||| Note that if the given frequencies sum up to 0, the first element 405 | ||| of the vector 406 | public export 407 | frequency : Vect (S k) (Nat, Gen a) -> Gen a 408 | frequency ps = 409 | let acc := scanl1 addFst $ map (mapFst toInteger) ps 410 | gen := integral_ . constant 0 . fst $ last acc 411 | lower := \n => takeWhile (< n) (fromFoldable $ map fst acc) 412 | 413 | in shrink lower gen >>= choose acc 414 | 415 | where 416 | addFst : (Integer,x) -> (Integer,x) -> (Integer,x) 417 | addFst (x,_) (y,v) = (x + y,v) 418 | 419 | choose : Vect n (Integer, Gen a) -> Integer -> Gen a 420 | choose [] _ = snd $ head ps 421 | choose ((i, v) :: ps) k = if i >= k then v else choose ps k 422 | 423 | ||| Generates a random boolean. 424 | ||| 425 | ||| This generator shrinks to `False`. 426 | public export %inline 427 | bool : Gen Bool 428 | bool = element [False,True] 429 | 430 | ||| Generates constant values of type `Unit" 431 | export %inline 432 | unit : Gen () 433 | unit = pure () 434 | 435 | -------------------------------------------------------------------------------- 436 | -- Character 437 | -------------------------------------------------------------------------------- 438 | 439 | ||| Generates a character in the given `Range`. 440 | ||| 441 | ||| Shrinks towards the origin of the range. 442 | export 443 | char : Range Char -> Gen Char 444 | char = map chr . int . map ord 445 | 446 | ||| Generates a character in the interval [lower,uppper]. 447 | ||| 448 | ||| Shrinks towards the lower value. 449 | export %inline 450 | charc : (lower : Char) -> (upper : Char) -> Gen Char 451 | charc l u = char $ constant l u 452 | 453 | 454 | ||| Generates an ASCII binit: `'0'..'1'` 455 | export %inline 456 | binit : Gen Char 457 | binit = charc '0' '1' 458 | 459 | ||| Generates an ASCII octit: `'0'..'7'` 460 | export %inline 461 | octit : Gen Char 462 | octit = charc '0' '7' 463 | 464 | ||| Generates an ASCII digit: `'0'..'9'` 465 | export %inline 466 | digit : Gen Char 467 | digit = charc '0' '9' 468 | 469 | ||| Generates an ASCII hexit: `'0'..'9', 'a'..'f', 'A'..'F'` 470 | export 471 | hexit : Gen Char 472 | hexit = frequency [(10, digit),(6, charc 'a' 'f'),(6, charc 'A' 'F')] 473 | 474 | ||| Generates an ASCII lowercase letter: `'a'..'z'` 475 | export %inline 476 | lower : Gen Char 477 | lower = charc 'a' 'z' 478 | 479 | ||| Generates an ASCII uppercase letter: `'A'..'Z'` 480 | export %inline 481 | upper : Gen Char 482 | upper = charc 'A' 'Z' 483 | 484 | ||| Generates an ASCII letter: `'a'..'z', 'A'..'Z'` 485 | export %inline 486 | alpha : Gen Char 487 | alpha = choice [lower,upper] 488 | 489 | ||| Generates an ASCII letter or digit: `'a'..'z', 'A'..'Z', '0'..'9'` 490 | export 491 | alphaNum : Gen Char 492 | alphaNum = frequency [(10,digit),(24,lower),(24,upper)] 493 | 494 | ||| Generates an ASCII character: `'\0'..'\127'` 495 | export %inline 496 | ascii : Gen Char 497 | ascii = charc '\0' '\127' 498 | 499 | ||| Generates an printable ASCII character: `'\32'..'\126'` 500 | ||| Note: This includes the space character but no 501 | ||| line breaks or tabs 502 | export %inline 503 | printableAscii : Gen Char 504 | printableAscii = charc '\32' '\126' 505 | 506 | ||| Generates a latin character: `'\0'..'\255'` 507 | export %inline 508 | latin : Gen Char 509 | latin = charc '\0' '\255' 510 | 511 | ||| Generates a printable latin character: `'\32'..'\126'` and `'\160'..'\255'` 512 | export 513 | printableLatin : Gen Char 514 | printableLatin = frequency [ (95, printableAscii), (96, charc '\160' '\255') ] 515 | 516 | ||| Generates a Unicode character, excluding noncharacters 517 | ||| and invalid standalone surrogates: 518 | ||| `'\0'..'\1114111'` (excluding '\55296'..'\57343', '\65534', '\65535')` 519 | export 520 | unicode : Gen Char 521 | unicode = 522 | frequency 523 | [ (55296, charc '\0' '\55295') 524 | , (8190, charc '\57344' '\65533') 525 | , (1048576, charc '\65536' '\1114111') 526 | ] 527 | 528 | ||| Generates a printable Unicode character, excluding noncharacters 529 | ||| and invalid standalone surrogates: 530 | ||| `'\0'..'\1114111'` (excluding '\0' .. '\31', '\127' .. '\159', 531 | ||| '\55296'..'\57343', and '\65534', '\65535')` 532 | export 533 | printableUnicode : Gen Char 534 | printableUnicode = 535 | frequency 536 | [ (95, printableAscii) 537 | , (55136, charc '\160' '\55295') 538 | , (8190, charc '\57344' '\65533') 539 | , (1048576, charc '\65536' '\1114111') 540 | ] 541 | 542 | ||| Generates a Unicode character, including noncharacters 543 | ||| and invalid standalone surrogates: `'\0'..'\1114111'` 544 | export %inline 545 | unicodeAll : Gen Char 546 | unicodeAll = charc '\0' '\1114111' 547 | 548 | -------------------------------------------------------------------------------- 549 | -- Containers 550 | -------------------------------------------------------------------------------- 551 | 552 | ||| Generates a 'Nothing' some of the time. 553 | export 554 | maybe : Gen a -> Gen (Maybe a) 555 | maybe gen = 556 | sized $ \s => 557 | frequency 558 | [ (2, constant Nothing) 559 | , (S s.size, Just <$> gen) 560 | ] 561 | 562 | ||| Generates either an 'a' or a 'b'. 563 | ||| 564 | ||| As the size grows, this generator generates @Right@s more often than @Left@s. 565 | export 566 | either : Gen a -> Gen b -> Gen (Either a b) 567 | either genA genB = 568 | sized $ \s => 569 | frequency 570 | [ (2, Left <$> genA) 571 | , (S s.size, Right <$> genB) 572 | ] 573 | 574 | ||| Generates either an 'a' or a 'b', without bias. 575 | ||| 576 | ||| This generator generates as many @Right@s as it does @Left@s. 577 | export %inline 578 | either_ : Gen a -> Gen b -> Gen (Either a b) 579 | either_ genA genB = choice [Left <$> genA, Right <$> genB] 580 | 581 | ||| Generates a list using a 'Range' to determine the length. 582 | export 583 | vect : (n : Nat) -> Gen a -> Gen (Vect n a) 584 | vect 0 _ = pure [] 585 | vect (S k) g = [| g :: vect k g |] 586 | 587 | ||| Generates a list using a 'Range' to determine the length. 588 | export 589 | list : Range Nat -> Gen a -> Gen (List a) 590 | list range gen = 591 | sized $ \si => 592 | let minLength := lowerBound si range 593 | in mapGen (interleave minLength . value) $ 594 | integral_ range >>= (\n => map toList (vect n (toTree gen))) 595 | 596 | ||| Generates a non-empty list using a `Range` to determine the length. 597 | export 598 | list1 : Range Nat -> Gen a -> Gen (List1 a) 599 | list1 range gen = [| gen ::: list (map pred range) gen |] 600 | 601 | ||| Generates a string using 'Range' to determine the length. 602 | export 603 | string : Range Nat -> Gen Char -> Gen String 604 | string range = map fastPack . list range 605 | 606 | ||| Generates an heterogeneous list being provided a generator for each element 607 | export 608 | hlist : All Gen ts -> Gen (HList ts) 609 | hlist [] = [| [] |] 610 | hlist (x::xs) = [| x :: hlist xs |] 611 | 612 | ||| Generates an heterogeneous vect being provided a generator for each element 613 | export 614 | hvect : All Gen ts -> Gen (HVect ts) 615 | hvect [] = [| [] |] 616 | hvect (x::xs) = [| x :: hvect xs |] 617 | 618 | -------------------------------------------------------------------------------- 619 | -- SOP 620 | -------------------------------------------------------------------------------- 621 | 622 | collapseNPV : NP (K a) ks -> {auto 0 _ : NonEmpty ks} -> (k ** Vect (S k) a) 623 | collapseNPV {ks = _} [] impossible 624 | collapseNPV {ks = _} (v::[]) = (0 ** [v]) 625 | collapseNPV {ks = t::t2::ts}(v::v2::vs) = 626 | let (k ** vs2) := collapseNPV {ks = t2 :: ts} (v2 :: vs) 627 | in (S k ** (v :: vs2)) 628 | 629 | ||| Turns an n-ary product of generators into a generator 630 | ||| of n-ary products of the same type. 631 | export 632 | np : NP Gen ts -> Gen (NP I ts) 633 | np = sequenceNP 634 | 635 | ||| Turns an n-ary product of generators into a generator 636 | ||| of n-ary sums of the same type. This is a generalisation 637 | ||| of choice and shrinks towards the first sum type 638 | ||| in the list. 639 | export 640 | ns : NP Gen ts -> {auto 0 prf : NonEmpty ts} -> Gen (NS I ts) 641 | ns np = 642 | let (_ ** vs) := collapseNPV (apInjsNP_ np) 643 | in choice (map sequenceNS vs) 644 | 645 | ||| Turns an n-ary product of generators into a generator 646 | ||| of n-ary sums of the same type. This is a generalisation 647 | ||| of `choice_` and does not shrink towards a particular 648 | ||| sum type. 649 | export 650 | ns_ : NP Gen ts -> {auto 0 prf : NonEmpty ts} -> Gen (NS I ts) 651 | ns_ np = 652 | let (_ ** vs) := collapseNPV (apInjsNP_ np) 653 | in choice_ (map sequenceNS vs) 654 | 655 | export 656 | sop : POP Gen tss -> {auto 0 prf : NonEmpty tss} -> Gen (SOP I tss) 657 | sop p = 658 | let (_ ** vs) := collapseNPV {a = SOP Gen tss} (apInjsPOP_ p) 659 | in choice (map sequenceSOP vs) 660 | 661 | -------------------------------------------------------------------------------- 662 | -- Sampling 663 | -------------------------------------------------------------------------------- 664 | 665 | ||| Print the value produced by a generator, and the first level of shrinks, 666 | ||| for the given size and seed. 667 | ||| 668 | ||| Use 'print' to generate a value from a random seed. 669 | export 670 | printWith : (HasIO io, Show a) => Size -> StdGen -> Gen a -> io () 671 | printWith si se gen = 672 | let (MkCotree v fo) := runGen si se gen 673 | shrinks := value <$> take 1000 fo 674 | in do 675 | putStrLn "=== Outcome ===" 676 | putStrLn (show v) 677 | putStrLn "=== Shrinks ===" 678 | traverse_ printLn shrinks 679 | 680 | ||| Run a generator with a random seed and print the outcome, and the first 681 | ||| level of shrinks. 682 | ||| 683 | ||| @ 684 | ||| Gen.print (Gen.'enum' \'a\' \'f\') 685 | ||| @ 686 | ||| 687 | ||| > === Outcome === 688 | ||| > 'd' 689 | ||| > === Shrinks === 690 | ||| > 'a' 691 | ||| > 'b' 692 | ||| > 'c' 693 | export 694 | print : Show a => HasIO io => Gen a -> io () 695 | print gen = initSeed >>= \se => printWith 100 se gen 696 | 697 | ||| Generate a sample from a generator. 698 | export 699 | sample : HasIO io => Gen a -> io a 700 | sample gen = (value . gen.unGen 100) <$> initSeed 701 | 702 | ||| Render the shrink tree produced by a generator, for the given size and 703 | ||| seed up to the given depth and width. 704 | export 705 | renderTree : 706 | {auto _ : Show a} 707 | -> (maxDepth : Nat) 708 | -> (maxWidth : Nat) 709 | -> Size 710 | -> StdGen 711 | -> Gen a 712 | -> String 713 | renderTree md mw si se = drawTree 714 | . map show 715 | . toTree md mw 716 | . runGen si se 717 | 718 | ||| Print the shrink tree produced by a generator, for the given size and 719 | ||| seed. 720 | ||| 721 | ||| Use 'printTree' to generate a value from a random seed. 722 | export 723 | printTreeWith : 724 | {auto _ : Show a} 725 | -> {auto _ : HasIO io} 726 | -> (maxDepth : Nat) 727 | -> (maxWidth : Nat) 728 | -> Size 729 | -> StdGen 730 | -> Gen a 731 | -> io () 732 | printTreeWith md mw si se = putStrLn . renderTree md mw si se 733 | 734 | ||| Run a generator with a random seed and print the resulting shrink tree. 735 | ||| 736 | ||| @ 737 | ||| Gen.printTree (Gen.'enum' \'a\' \'f\') 738 | ||| @ 739 | ||| 740 | ||| > 'd' 741 | ||| > ├╼'a' 742 | ||| > ├╼'b' 743 | ||| > │ └╼'a' 744 | ||| > └╼'c' 745 | ||| > ├╼'a' 746 | ||| > └╼'b' 747 | ||| > └╼'a' 748 | ||| 749 | ||| /This may not terminate when the tree is very large./ 750 | ||| 751 | export 752 | printTree : 753 | {auto _ : Show a} 754 | -> {auto _ : HasIO io} 755 | -> (maxDepth : Nat) 756 | -> (maxWidth : Nat) 757 | -> Gen a 758 | -> io () 759 | printTree md mw gen = initSeed >>= \se => printTreeWith md mw 100 se gen 760 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Options.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Options 2 | 3 | import Data.String 4 | import Decidable.Equality 5 | import Hedgehog.Internal.Property 6 | import System.GetOpts 7 | 8 | %default total 9 | 10 | public export 11 | data NumTest = Relaxed TestLimit | Forced TestLimit 12 | 13 | public export 14 | record Config where 15 | constructor MkConfig 16 | printHelp : Bool 17 | numTests : Maybe NumTest 18 | numShrinks : Maybe ShrinkLimit 19 | confidence : Maybe Confidence 20 | 21 | export 22 | init : Config 23 | init = MkConfig False Nothing Nothing Nothing 24 | 25 | parseNat : String -> Either (List String) Nat 26 | parseNat s = 27 | maybe (Left [#"Not a natural number: \#{s}"#]) Right $ parsePositive s 28 | 29 | toConfidence : Nat -> Either (List String) Confidence 30 | toConfidence n = 31 | let c := cast {to = Bits64} n 32 | in case decEq (c >= 2) True of 33 | (Yes prf) => Right $ MkConfidence c prf 34 | (No contra) => Left [ #"Not a valid confidence value: \#{show n}"# ] 35 | 36 | setTests : String -> Config -> Either (List String) Config 37 | setTests s c = 38 | map 39 | (\n => { numTests := Just $ Relaxed $ MkTagged n} c) 40 | (parseNat s) 41 | 42 | setShrinks : String -> Config -> Either (List String) Config 43 | setShrinks s c = 44 | map 45 | (\n => { numShrinks := Just $ MkTagged n} c) 46 | (parseNat s) 47 | 48 | setConfidence : String -> Config -> Either (List String) Config 49 | setConfidence s c = 50 | map 51 | (\n => { confidence := Just n} c) 52 | (parseNat s >>= toConfidence) 53 | 54 | setTestsForced : String -> Config -> Either (List String) Config 55 | setTestsForced s c = 56 | map 57 | (\n => { numTests := Just $ Forced $ MkTagged n} c) 58 | (parseNat s) 59 | 60 | setHelp : Config -> Either (List String) Config 61 | setHelp = Right . { printHelp := True } 62 | 63 | descs : List $ OptDescr (Config -> Either (List String) Config) 64 | descs = 65 | [ MkOpt ['n'] ["testlimit"] (ReqArg setTests "") 66 | "number of tests to be passed by each property" 67 | , MkOpt ['N'] ["testlimit!"] (ReqArg setTestsForced "") 68 | "like -n but includes tests that are only run once" 69 | , MkOpt ['s'] ["shrinklimit"] (ReqArg setShrinks "") 70 | "maximal number of shrinks in case of a failed test" 71 | , MkOpt ['c'] ["confidence"] (ReqArg setConfidence "") 72 | "acceptable occurence of false positives" 73 | , MkOpt [] ["--help"] (NoArg setHelp) 74 | "print this help text" 75 | ] 76 | 77 | export 78 | info : String 79 | info = usageInfo "Hedgehog command line args:\n" descs 80 | 81 | export 82 | applyArgs : List String -> Either (List String) Config 83 | applyArgs args = 84 | case getOpt Permute descs args of 85 | MkResult opts _ _ [] => foldl (>>=) (Right init) opts 86 | MkResult _ _ _ e => Left e 87 | 88 | export 89 | applyConfig : Config -> Group -> Group 90 | applyConfig (MkConfig _ nt ns c) = 91 | maybe id adjTests nt . maybe id withShrinks ns . maybe id withConfidence c 92 | 93 | where 94 | adjPropTests : NumTest -> Property -> Property 95 | adjPropTests (Forced x) = withTests x 96 | adjPropTests (Relaxed x) = mapTests $ \n => if n > 1 then x else n 97 | 98 | adjTests : NumTest -> Group -> Group 99 | adjTests = mapProperty . adjPropTests 100 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Property.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Property 2 | 3 | import Control.Monad.Either 4 | import Control.Monad.Identity 5 | import Control.Monad.Trans 6 | import Control.Monad.Writer 7 | import Data.Lazy 8 | import Data.List.Quantifiers 9 | import public Data.Double.Bounded 10 | import Data.DPair 11 | import Derive.Prelude 12 | import Hedgehog.Internal.Gen 13 | import Hedgehog.Internal.Range 14 | import Hedgehog.Internal.Util 15 | import Statistics.Confidence 16 | import Text.Show.Diff 17 | import Text.Show.Pretty 18 | 19 | %language ElabReflection 20 | 21 | %default total 22 | 23 | -------------------------------------------------------------------------------- 24 | -- Tagged Primitives 25 | -------------------------------------------------------------------------------- 26 | 27 | public export 28 | data Tag = 29 | ConfidenceTag 30 | | CoverCountTag 31 | | GroupNameTag 32 | | LabelNameTag 33 | | PropertyCountTag 34 | | PropertyNameTag 35 | | ShrinkCountTag 36 | | ShrinkLimitTag 37 | | TestCountTag 38 | | TestLimitTag 39 | | EarlyTermLowerBoundTag 40 | 41 | %runElab derive "Tag" [Show,Eq,Ord] 42 | 43 | public export 44 | record Tagged (tag : Tag) (t : Type) where 45 | constructor MkTagged 46 | unTag : t 47 | 48 | %runElab derivePattern "Tagged" [I,P] 49 | [Show,Eq,Ord,Num,FromString,Semigroup,Monoid] 50 | 51 | public export %inline 52 | Semigroup (Tagged t Nat) where (<+>) = (+) 53 | 54 | public export %inline 55 | Monoid (Tagged t Nat) where neutral = 0 56 | 57 | public export %inline 58 | Show a => Interpolation (Tagged t a) where 59 | interpolate (MkTagged x) = show x 60 | 61 | ||| The total number of tests which are covered by a classifier. 62 | ||| 63 | ||| Can be constructed using numeric literals. 64 | public export 65 | 0 CoverCount : Type 66 | CoverCount = Tagged CoverCountTag Nat 67 | 68 | ||| The name of a group of properties. 69 | public export 70 | 0 GroupName : Type 71 | GroupName = Tagged GroupNameTag String 72 | 73 | ||| The number of properties in a group. 74 | public export 75 | 0 PropertyCount : Type 76 | PropertyCount = Tagged PropertyCountTag Nat 77 | 78 | ||| The numbers of times a property was able to shrink after a failing test. 79 | public export 80 | 0 ShrinkCount : Type 81 | ShrinkCount = Tagged ShrinkCountTag Nat 82 | 83 | ||| The number of shrinks to try before giving up on shrinking. 84 | ||| 85 | ||| Can be constructed using numeric literals: 86 | public export 87 | 0 ShrinkLimit : Type 88 | ShrinkLimit = Tagged ShrinkLimitTag Nat 89 | 90 | ||| The number of tests a property ran successfully. 91 | public export 92 | 0 TestCount : Type 93 | TestCount = Tagged TestCountTag Nat 94 | 95 | ||| The number of successful tests that need to be run before a property test 96 | ||| is considered successful. 97 | ||| 98 | ||| Can be constructed using numeric literals. 99 | public export 100 | 0 TestLimit : Type 101 | TestLimit = Tagged TestLimitTag Nat 102 | 103 | ||| The number of successful tests that need to be run before the first check 104 | ||| of a confidence interval at the early termination mode. 105 | ||| 106 | ||| Can be constructed using numeric literals. 107 | public export 108 | 0 EarlyTermLowerBound : Type 109 | EarlyTermLowerBound = Tagged EarlyTermLowerBoundTag Nat 110 | 111 | ||| The name of a property. 112 | public export 113 | 0 PropertyName : Type 114 | PropertyName = Tagged PropertyNameTag String 115 | 116 | ||| The acceptable occurrence of false positives 117 | ||| 118 | ||| Example, `the Confidence 1000000000` would mean that 119 | ||| you'd accept a false positive 120 | ||| for 1 in 10^9 tests. 121 | public export 122 | record Confidence where 123 | constructor MkConfidence 124 | confidence : Bits64 125 | 0 inBound : confidence >= 2 = True 126 | 127 | %runElab derive "Confidence" [Show,Eq,Ord] 128 | 129 | namespace Confidence 130 | public export 131 | fromInteger : 132 | (n : Integer) 133 | -> {auto 0 prf : the Bits64 (fromInteger n) >= 2 = True} 134 | -> Confidence 135 | fromInteger n = MkConfidence (fromInteger n) prf 136 | 137 | export 138 | toProbability : Confidence -> Probability 139 | toProbability $ MkConfidence c _ = 140 | -- we can do `ratio` because `c` is `>= 2` due to `prf` 141 | ratio 1 (cast c) @{believe_me Oh} @{believe_me Oh} 142 | 143 | ||| The relative number of tests which are covered by a classifier. 144 | public export 145 | 0 CoverPercentage : Type 146 | CoverPercentage = DoubleBetween 0 100 147 | 148 | ||| The name of a classifier. 149 | public export 150 | 0 LabelName : Type 151 | LabelName = Tagged LabelNameTag String 152 | 153 | -------------------------------------------------------------------------------- 154 | -- Journal 155 | -------------------------------------------------------------------------------- 156 | 157 | ||| The difference between some expected and actual value. 158 | public export 159 | record Diff where 160 | constructor MkDiff 161 | diffPrefix : String 162 | diffRemoved : String 163 | diffInfix : String 164 | diffAdded : String 165 | diffSuffix : String 166 | diffValue : ValueDiff 167 | 168 | %runElab derive "Hedgehog.Internal.Property.Diff" [Show,Eq] 169 | 170 | ||| Whether a test is covered by a classifier, and therefore belongs to a 171 | ||| 'Class'. 172 | public export 173 | data Cover = NotCovered | Covered 174 | 175 | %runElab derive "Cover" [Show,Eq,Ord] 176 | 177 | public export 178 | Semigroup Cover where 179 | NotCovered <+> NotCovered = NotCovered 180 | _ <+> _ = Covered 181 | 182 | public export 183 | Monoid Cover where 184 | neutral = NotCovered 185 | 186 | public export 187 | toCoverCount : Cover -> CoverCount 188 | toCoverCount NotCovered = 0 189 | toCoverCount Covered = 1 190 | 191 | ||| The extent to which a test is covered by a classifier. 192 | ||| 193 | ||| When a classifier's coverage does not exceed the required minimum, the 194 | ||| test will be failed. 195 | public export 196 | record Label a where 197 | constructor MkLabel 198 | labelName : LabelName 199 | labelMinimum : CoverPercentage 200 | labelAnnotation : a 201 | 202 | %runElab derive "Label" [Show,Eq] 203 | 204 | public export 205 | Functor Label where 206 | map f = {labelAnnotation $= f} 207 | 208 | public export 209 | Foldable Label where 210 | foldl f a l = f a l.labelAnnotation 211 | foldr f a l = f l.labelAnnotation a 212 | null _ = False 213 | 214 | public export 215 | Traversable Label where 216 | traverse f l = 217 | (\v => {labelAnnotation := v} l) <$> f l.labelAnnotation 218 | 219 | ||| This semigroup is right biased. The name, location and percentage from the 220 | ||| rightmost `Label` will be kept. This shouldn't be a problem since the 221 | ||| library doesn't allow setting multiple classes with the same 'ClassifierName'. 222 | export 223 | Semigroup a => Semigroup (Label a) where 224 | ll <+> lr = { labelAnnotation $= (ll.labelAnnotation <+>) } lr 225 | 226 | ||| Log messages which are recorded during a test run. 227 | public export 228 | data Log : Type where 229 | Annotation : Lazy String -> Log 230 | Footnote : Lazy String -> Log 231 | LogLabel : Label Cover -> Log 232 | 233 | %runElab derive "Log" [Show,Eq] 234 | 235 | ||| A record containing the details of a test run. 236 | public export 237 | record Journal where 238 | constructor MkJournal 239 | journalLogs : List (Lazy Log) 240 | 241 | %runElab derive "Journal" [Show,Eq,Semigroup,Monoid] 242 | 243 | ||| Details on where and why a test failed. 244 | public export 245 | record Failure where 246 | constructor MkFailure 247 | message : String 248 | diff : Maybe Diff 249 | 250 | %runElab derive "Failure" [Show,Eq] 251 | 252 | ||| The extent to which all classifiers cover a test. 253 | ||| 254 | ||| When a given classification's coverage does not exceed the required/ 255 | ||| minimum, the test will be failed. 256 | export 257 | record Coverage a where 258 | constructor MkCoverage 259 | coverageLabels : List (LabelName, Label a) 260 | 261 | %runElab derive "Coverage" [Show,Eq] 262 | 263 | export %inline 264 | names : Coverage a -> List LabelName 265 | names = map fst . coverageLabels 266 | 267 | export %inline 268 | labels : Coverage a -> List (Label a) 269 | labels = map snd . coverageLabels 270 | 271 | export %inline 272 | annotations : Coverage a -> List a 273 | annotations = map (labelAnnotation . snd) . coverageLabels 274 | 275 | mergeWith : 276 | {auto _ : Ord k} 277 | -> SnocList (k,v) 278 | -> (v -> v -> v) 279 | -> List (k,v) 280 | -> List (k,v) 281 | -> List (k,v) 282 | mergeWith sp _ [] ys = sp <>> ys 283 | mergeWith sp _ xs [] = sp <>> xs 284 | mergeWith sp f (x :: xs) (y :: ys) = case compare (fst x) (fst y) of 285 | LT => mergeWith (sp :< x) f xs (y :: ys) 286 | EQ => mergeWith (sp :< (fst x, f (snd x) (snd y))) f xs ys 287 | GT => mergeWith (sp :< y) f (x::xs) ys 288 | 289 | export %inline 290 | Semigroup a => Semigroup (Coverage a) where 291 | MkCoverage x <+> MkCoverage y = 292 | MkCoverage $ mergeWith [<] (<+>) x y 293 | 294 | export %inline 295 | Semigroup a => Monoid (Coverage a) where 296 | neutral = MkCoverage [] 297 | 298 | export 299 | Functor Coverage where 300 | map f = {coverageLabels $= map (mapSnd $ map f) } 301 | 302 | export 303 | Foldable Coverage where 304 | foldl f acc = foldl f acc . annotations 305 | foldr f acc = foldr f acc . annotations 306 | null = null . coverageLabels 307 | 308 | export 309 | Traversable Coverage where 310 | traverse f (MkCoverage sm) = 311 | MkCoverage <$> traverse ((traverse . traverse) f) sm 312 | 313 | -------------------------------------------------------------------------------- 314 | -- Config 315 | -------------------------------------------------------------------------------- 316 | 317 | public export 318 | data TerminationCriteria : Type where 319 | EarlyTermination : Confidence -> TestLimit -> EarlyTermLowerBound -> TerminationCriteria 320 | NoEarlyTermination : Confidence -> TestLimit -> TerminationCriteria 321 | NoConfidenceTermination : TestLimit -> TerminationCriteria 322 | 323 | %runElab derive "TerminationCriteria" [Show,Eq] 324 | 325 | ||| Returns main paramters of the termination criteria 326 | ||| 327 | ||| Returned size is the minimal starting size according to the criteria. 328 | ||| For confidence-checking criteria it is important to start with maximal size 329 | ||| to achieve correct distribution. 330 | public export 331 | unCriteria : TerminationCriteria -> (Maybe Confidence, TestLimit, Size) 332 | unCriteria (EarlyTermination c t _) = (Just c, t, maxSize) 333 | unCriteria (NoEarlyTermination c t) = (Just c, t, maxSize) 334 | unCriteria (NoConfidenceTermination t) = (Nothing, t, minSize) 335 | 336 | ||| Configuration for a property test. 337 | public export 338 | record PropertyConfig where 339 | constructor MkPropertyConfig 340 | shrinkLimit : ShrinkLimit 341 | terminationCriteria : TerminationCriteria 342 | 343 | %runElab derive "PropertyConfig" [Show,Eq] 344 | 345 | ||| The minimum amount of tests to run for a 'Property' 346 | public export 347 | defaultMinTests : TestLimit 348 | defaultMinTests = 100 349 | 350 | public export 351 | defaultLowerBound : EarlyTermLowerBound 352 | defaultLowerBound = MkTagged $ unTag defaultMinTests 353 | 354 | ||| The default confidence allows one false positive in 10^9 tests 355 | public export 356 | defaultConfidence : Confidence 357 | defaultConfidence = Confidence.fromInteger 1000000000 358 | 359 | ||| The default configuration for a property test. 360 | public export 361 | defaultConfig : PropertyConfig 362 | defaultConfig = 363 | MkPropertyConfig 364 | { shrinkLimit = 1000 365 | , terminationCriteria = NoConfidenceTermination defaultMinTests 366 | } 367 | 368 | -------------------------------------------------------------------------------- 369 | -- Test 370 | -------------------------------------------------------------------------------- 371 | 372 | ||| A test monad transformer allows the assertion of expectations. 373 | public export 374 | 0 TestT : (Type -> Type) -> Type -> Type 375 | TestT m = EitherT Failure (WriterT Journal m) 376 | 377 | public export 378 | 0 Test : Type -> Type 379 | Test = TestT Identity 380 | 381 | export 382 | mkTestT : Functor m => m (Either Failure a, Journal) -> TestT m a 383 | mkTestT = MkEitherT . writerT 384 | 385 | export 386 | mkTest : (Either Failure a, Journal) -> Test a 387 | mkTest = mkTestT . Id 388 | 389 | export 390 | runTestT : TestT m a -> m (Either Failure a, Journal) 391 | runTestT = runWriterT . runEitherT 392 | 393 | export 394 | runTest : Test a -> (Either Failure a, Journal) 395 | runTest = runIdentity . runTestT 396 | 397 | ||| Log some information which might be relevant to a potential test failure. 398 | export 399 | writeLog : Applicative m => Lazy Log -> TestT m () 400 | writeLog x = mkTestT $ pure (Right (), MkJournal [x]) 401 | 402 | ||| Fail the test with an error message, useful for building other failure 403 | ||| combinators. 404 | export 405 | failWith : Applicative m => Maybe Diff -> String -> TestT m a 406 | failWith diff msg = mkTestT $ pure (Left $ MkFailure msg diff, neutral) 407 | 408 | ||| Annotates the source code with a message that might be useful for 409 | ||| debugging a test failure. 410 | export %inline 411 | annotate : Applicative m => Lazy String -> TestT m () 412 | annotate v = writeLog $ Annotation v 413 | 414 | ||| Annotates the source code with a value that might be useful for 415 | ||| debugging a test failure. 416 | export %inline 417 | annotateShow : Show a => Applicative m => a -> TestT m () 418 | annotateShow v = annotate $ ppShow v 419 | 420 | ||| Annotates the source code with all values separately. 421 | export 422 | annotateAllShow : All Show ts => Monad m => HList ts -> TestT m () 423 | annotateAllShow [] = pure () 424 | annotateAllShow @{_::_} [x] = annotateShow x 425 | annotateAllShow @{_::_} (x::xs) = annotateShow x >> annotateAllShow xs 426 | 427 | ||| Logs a message to be displayed as additional information in the footer of 428 | ||| the failure report. 429 | export %inline 430 | footnote : Applicative m => Lazy String -> TestT m () 431 | footnote v = writeLog $ Footnote v 432 | 433 | ||| Logs a value to be displayed as additional information in the footer of 434 | ||| the failure report. 435 | export %inline 436 | footnoteShow : Show a => Applicative m => a -> TestT m () 437 | footnoteShow v = writeLog (Footnote $ ppShow v) 438 | 439 | ||| Fails with an error that shows the difference between two values. 440 | export %inline 441 | failDiff : Show a => Show b => Applicative m => a -> b -> TestT m () 442 | failDiff x y = 443 | case valueDiff <$> reify x <*> reify y of 444 | Nothing => 445 | failWith Nothing $ 446 | unlines 447 | [ "Failed" 448 | , "━━ lhs ━━" 449 | , ppShow x 450 | , "━━ rhs ━━" 451 | , ppShow y 452 | ] 453 | 454 | Just vdiff@(Same _) => 455 | failWith 456 | (Just $ MkDiff "━━━ Failed (" "" "no differences" "" ") ━━━" vdiff) 457 | "" 458 | 459 | Just vdiff => 460 | failWith 461 | (Just $ MkDiff "━━━ Failed (" "- lhs" ") (" "+ rhs" ") ━━━" vdiff) 462 | "" 463 | 464 | ||| Causes a test to fail. 465 | export %inline 466 | failure : Applicative m => TestT m a 467 | failure = failWith Nothing "" 468 | 469 | ||| Another name for `pure ()`. 470 | export %inline 471 | success : Monad m => TestT m () 472 | success = pure () 473 | 474 | ||| Fails the test if the condition provided is 'False'. 475 | export %inline 476 | assert : Monad m => Bool -> TestT m () 477 | assert ok = if ok then success else failure 478 | 479 | ||| Fails the test and shows a git-like diff if the comparison operation 480 | ||| evaluates to 'False' when applied to its arguments. 481 | ||| 482 | ||| The comparison function is the second argument, which may be 483 | ||| counter-intuitive to Haskell programmers. However, it allows operators to 484 | ||| be written infix for easy reading: 485 | ||| 486 | ||| This function behaves like the unix @diff@ tool, which gives a 0 exit 487 | ||| code if the compared files are identical, or a 1 exit code code 488 | ||| otherwise. Like unix @diff@, if the arguments fail the comparison, a 489 | ||| /diff is shown. 490 | ||| 491 | export %inline 492 | diff : 493 | {auto _ : Show a} 494 | -> {auto _ : Show b} 495 | -> {auto _ : Monad m} 496 | -> a -> (a -> b -> Bool) -> b -> TestT m () 497 | diff x op y = if x `op` y then success else failDiff x y 498 | 499 | export infix 6 === 500 | 501 | ||| Fails the test if the two arguments provided are not equal. 502 | export %inline 503 | (===) : Eq a => Show a => Monad m => a -> a -> TestT m () 504 | (===) x y = diff x (==) y 505 | 506 | export infix 4 /== 507 | 508 | ||| Fails the test if the two arguments provided are equal. 509 | export %inline 510 | (/==) : Eq a => Show a => Monad m => a -> a -> TestT m () 511 | (/==) x y = diff x (/=) y 512 | 513 | 514 | ||| Fails the test if the 'Either' is 'Left', otherwise returns the value in 515 | ||| the 'Right'. 516 | export 517 | evalEither : Show x => Monad m => Either x a -> TestT m a 518 | evalEither (Left x) = failWith Nothing (ppShow x) 519 | evalEither (Right x) = pure x 520 | 521 | ||| Fails the test if the 'Maybe' is 'Nothing', otherwise returns the value in 522 | ||| the 'Just'. 523 | export 524 | evalMaybe : Monad m => Maybe a -> TestT m a 525 | evalMaybe Nothing = failWith Nothing "the value was Nothing" 526 | evalMaybe (Just x) = pure x 527 | 528 | -------------------------------------------------------------------------------- 529 | -- PropertyT 530 | -------------------------------------------------------------------------------- 531 | 532 | ||| The property monad allows both the generation of test inputs 533 | ||| and the assertion of expectations. 534 | public export 535 | 0 PropertyT : Type -> Type 536 | PropertyT = TestT Gen 537 | 538 | ||| Generates a random input for the test by running the provided generator. 539 | ||| 540 | ||| This is a the same as 'forAll' but allows the user to provide a custom 541 | ||| rendering function. This is useful for values which don't have a 542 | ||| 'Show' instance. 543 | export 544 | forAllWith : (a -> String) -> Gen a -> PropertyT a 545 | forAllWith render gen = do 546 | x <- lift (lift gen) 547 | annotate (render x) 548 | pure x 549 | 550 | ||| Generates a random input for the test by running the provided generator. 551 | export %inline 552 | forAll : Show a => Gen a -> PropertyT a 553 | forAll = forAllWith ppShow 554 | 555 | ||| Generates a random input provided a bunch of generators. 556 | ||| 557 | ||| This function is an easy way to write several foralls in a row. 558 | ||| `[a, b, c] <- forAlls [x, y, z]` prints error message like 559 | ||| `(a, b, c) <- [| (forAll x, forAll y, forAll z) |]` but shrinks like 560 | ||| `(a, b, c) <- forAll [| (x, y, z) |]`. 561 | export 562 | forAlls : All Show ts => All Gen ts -> PropertyT (HList ts) 563 | forAlls gens = do 564 | xs <- lift $ lift $ hlist gens 565 | annotateAllShow xs 566 | pure xs 567 | 568 | ||| Lift a test in to a property. 569 | export 570 | test : Test a -> PropertyT a 571 | test = mapEitherT $ mapWriterT (pure . runIdentity) 572 | 573 | -------------------------------------------------------------------------------- 574 | -- Property 575 | -------------------------------------------------------------------------------- 576 | 577 | ||| A property test, along with some configurable limits like how many times 578 | ||| to run the test. 579 | public export 580 | record Property where 581 | constructor MkProperty 582 | config : PropertyConfig 583 | test : PropertyT () 584 | 585 | namespace Property 586 | ||| Map a config modification function over a property. 587 | export 588 | mapConfig : (PropertyConfig -> PropertyConfig) -> Property -> Property 589 | mapConfig f p = { config $= f } p 590 | 591 | export 592 | verifiedTermination : 593 | {default defaultLowerBound min : EarlyTermLowerBound} 594 | -> Property -> Property 595 | verifiedTermination = mapConfig { terminationCriteria $= setEarlyTermination } 596 | 597 | where 598 | setEarlyTermination : TerminationCriteria -> TerminationCriteria 599 | setEarlyTermination (NoEarlyTermination c n) = EarlyTermination c n min 600 | setEarlyTermination (NoConfidenceTermination n) = EarlyTermination defaultConfidence n min 601 | setEarlyTermination (EarlyTermination c n lb) = EarlyTermination c n min 602 | 603 | export 604 | noVerifiedTermination : Property -> Property 605 | noVerifiedTermination = mapConfig { terminationCriteria $= setNoConfidence } 606 | 607 | where 608 | setNoConfidence : TerminationCriteria -> TerminationCriteria 609 | setNoConfidence (NoEarlyTermination _ n) = NoConfidenceTermination n 610 | setNoConfidence (NoConfidenceTermination n) = NoConfidenceTermination n 611 | setNoConfidence (EarlyTermination _ n _) = NoConfidenceTermination n 612 | 613 | ||| Adjust the number of times a property should be executed before it is considered 614 | ||| successful. 615 | export 616 | mapTests : (TestLimit -> TestLimit) -> Property -> Property 617 | mapTests f = mapConfig {terminationCriteria $= setLimit} 618 | 619 | where 620 | setLimit : TerminationCriteria -> TerminationCriteria 621 | setLimit (NoEarlyTermination c n) = NoEarlyTermination c (f n) 622 | setLimit (NoConfidenceTermination n) = NoConfidenceTermination (f n) 623 | setLimit (EarlyTermination c n lb) = EarlyTermination c (f n) lb 624 | 625 | ||| Set the number of times a property should be executed before it is considered 626 | ||| successful. 627 | ||| 628 | ||| If you have a test that does not involve any generators and thus does not 629 | ||| need to run repeatedly, you can use @withTests 1@ to define a property that 630 | ||| will only be checked once. 631 | export 632 | withTests : TestLimit -> Property -> Property 633 | withTests = mapTests . const 634 | 635 | ||| Set the number of times a property is allowed to shrink before the test 636 | ||| runner gives up and prints the counterexample. 637 | export 638 | withShrinks : ShrinkLimit -> Property -> Property 639 | withShrinks n = mapConfig { shrinkLimit := n } 640 | 641 | ||| Make sure that the result is statistically significant in accordance to 642 | ||| the passed 'Confidence' 643 | export 644 | withConfidence : Confidence -> Property -> Property 645 | withConfidence c = mapConfig { terminationCriteria $= setConfidence } 646 | 647 | where 648 | setConfidence : TerminationCriteria -> TerminationCriteria 649 | setConfidence (NoEarlyTermination _ n) = NoEarlyTermination c n 650 | setConfidence (NoConfidenceTermination n) = NoEarlyTermination c n 651 | setConfidence (EarlyTermination _ n lb) = EarlyTermination c n lb 652 | 653 | ||| Creates a property with the default configuration. 654 | export 655 | property : PropertyT () -> Property 656 | property = MkProperty defaultConfig 657 | 658 | ||| Creates a property, that is tested exactly once. 659 | ||| 660 | ||| Use this for tests that are not based on randomly generated 661 | ||| inputs. 662 | ||| 663 | ||| This is an alias for `withTests 1 . property`. 664 | export %inline 665 | property1 : PropertyT () -> Property 666 | property1 = withTests 1 . property 667 | 668 | ||| A named collection of property tests. 669 | public export 670 | record Group where 671 | constructor MkGroup 672 | name : GroupName 673 | properties : List (PropertyName, Property) 674 | 675 | namespace Group 676 | export 677 | mapProperty : (Property -> Property) -> Group -> Group 678 | mapProperty f = { properties $= map (mapSnd f) } 679 | 680 | ||| Map a config modification function over all 681 | ||| properties in a `Group`. 682 | export 683 | mapConfig : (PropertyConfig -> PropertyConfig) -> Group -> Group 684 | mapConfig = mapProperty . mapConfig 685 | 686 | ||| Set the number of times the properties in a `Group` 687 | ||| should be executed before they are considered 688 | ||| successful. 689 | export 690 | withTests : TestLimit -> Group -> Group 691 | withTests = mapProperty . withTests 692 | 693 | ||| Set the number of times the properties in a `Group` 694 | ||| are allowed to shrink before the test 695 | ||| runner gives up and prints the counterexample. 696 | export 697 | withShrinks : ShrinkLimit -> Group -> Group 698 | withShrinks = mapProperty . withShrinks 699 | 700 | ||| Make sure that the results of a `Group` are statistically 701 | ||| significant in accordance to the passed 'Confidence' 702 | export 703 | withConfidence : Confidence -> Group -> Group 704 | withConfidence = mapProperty . withConfidence 705 | 706 | -------------------------------------------------------------------------------- 707 | -- Coverage 708 | -------------------------------------------------------------------------------- 709 | 710 | export 711 | coverPercentage : TestCount -> CoverCount -> CoverPercentage 712 | coverPercentage (MkTagged tests) (MkTagged count) = 713 | roughlyFit $ (cast count / cast tests) * 100 714 | 715 | export 716 | labelCovered : TestCount -> Label CoverCount -> Bool 717 | labelCovered tests (MkLabel _ min population) = 718 | coverPercentage tests population >= min 719 | 720 | export 721 | coverageFailures : TestCount -> Coverage CoverCount -> List $ Label CoverCount 722 | coverageFailures tests kvs = 723 | filter (not . labelCovered tests) (labels kvs) 724 | 725 | ||| All labels are covered 726 | export 727 | coverageSuccess : TestCount -> Coverage CoverCount -> Bool 728 | coverageSuccess tests c = null $ coverageFailures tests c 729 | 730 | ||| Require a certain percentage of the tests to be covered by the 731 | ||| classifier. 732 | ||| 733 | ||| ```idris 734 | ||| prop_with_coverage : Property 735 | ||| prop_with_coverage = 736 | ||| property $ do 737 | ||| match <- forAll Gen.bool 738 | ||| cover 30 "True" $ match 739 | ||| cover 30 "False" $ not match 740 | ||| ``` 741 | ||| 742 | ||| The example above requires a minimum of 30% coverage for both 743 | ||| classifiers. If these requirements are not met, it will fail the test. 744 | export 745 | cover : Monad m => CoverPercentage -> LabelName -> Bool -> TestT m () 746 | cover min name covered = 747 | let cover := if covered then Covered else NotCovered 748 | in writeLog $ LogLabel (MkLabel name min cover) 749 | 750 | ||| Records the proportion of tests which satisfy a given condition. 751 | ||| 752 | ||| ```idris example 753 | ||| prop_with_classifier : Property 754 | ||| prop_with_classifier = 755 | ||| property $ do 756 | ||| xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha 757 | ||| for_ xs $ \\x -> do 758 | ||| classify "newborns" $ x == 0 759 | ||| classify "children" $ x > 0 && x < 13 760 | ||| classify "teens" $ x > 12 && x < 20 761 | ||| ``` 762 | export 763 | classify : Monad m => LabelName -> Bool -> TestT m () 764 | classify name covered = cover 0 name covered 765 | 766 | ||| Add a label for each test run. It produces a table showing the percentage 767 | ||| of test runs that produced each label. 768 | export 769 | label : Monad m => LabelName -> TestT m () 770 | label name = cover 0 name True 771 | 772 | ||| Like 'label', but uses 'Show' to render its argument for display. 773 | export 774 | collect : Show a => Monad m => a -> TestT m () 775 | collect x = cover 0 (MkTagged $ show x) True 776 | 777 | 778 | fromLabel : Label a -> Coverage a 779 | fromLabel x = MkCoverage $ [(labelName x, x)] 780 | 781 | unionsCoverage : Semigroup a => List (Coverage a) -> Coverage a 782 | unionsCoverage = MkCoverage . concatMap coverageLabels 783 | 784 | export 785 | journalCoverage : Journal -> Coverage CoverCount 786 | journalCoverage = 787 | map toCoverCount 788 | . unionsCoverage 789 | . (>>= fromLog) 790 | . journalLogs 791 | 792 | where 793 | fromLog : Lazy Log -> List (Coverage Cover) 794 | fromLog (LogLabel x) = [fromLabel x] 795 | fromLog (Footnote _) = [] 796 | fromLog (Annotation _) = [] 797 | 798 | -------------------------------------------------------------------------------- 799 | -- Confidence 800 | -------------------------------------------------------------------------------- 801 | 802 | boundsForLabel : 803 | TestCount 804 | -> Confidence 805 | -> Label CoverCount 806 | -> (Probability, Probability) 807 | boundsForLabel (MkTagged tests) c lbl = do 808 | let (tests ** _) : (k ** IsSucc k) = case tests of 809 | Z => (1 ** ItIsSucc) 810 | k@(S n) => (k ** ItIsSucc) 811 | let succ = P $ roughlyFit $ cast (unTag lbl.labelAnnotation) / cast tests 812 | wilsonBounds (toProbability c) tests succ 813 | 814 | ||| Is true when the test coverage satisfies the specified 'Confidence' 815 | ||| contstraint for all 'Coverage CoverCount's 816 | export 817 | confidenceSuccess : TestCount -> Confidence -> Coverage CoverCount -> Bool 818 | confidenceSuccess tests confidence = 819 | all assertLow . labels 820 | 821 | where 822 | assertLow : Label CoverCount -> Bool 823 | assertLow cc = 824 | fst (boundsForLabel tests confidence cc) >= cc.labelMinimum.percent 825 | 826 | ||| Is true when there exists a label that is sure to have failed according to 827 | ||| the 'Confidence' constraint 828 | export 829 | confidenceFailure : TestCount -> Confidence -> Coverage CoverCount -> Bool 830 | confidenceFailure tests confidence = 831 | any assertHigh . labels 832 | 833 | where 834 | assertHigh : Label CoverCount -> Bool 835 | assertHigh cc = 836 | snd (boundsForLabel tests confidence cc) < cc.labelMinimum.percent 837 | 838 | export 839 | multOf100 : TestCount -> Bool 840 | multOf100 (MkTagged n) = natToInteger n `mod` 100 == 0 841 | 842 | export 843 | failureVerified : TestCount -> Coverage CoverCount -> Maybe Confidence -> Bool 844 | failureVerified count cover conf = 845 | multOf100 count && 846 | maybe False (\c => confidenceFailure count c cover) conf 847 | 848 | export 849 | successVerified : TestCount -> Coverage CoverCount -> Maybe Confidence -> Bool 850 | successVerified count cover conf = 851 | multOf100 count && 852 | maybe False (\c => confidenceSuccess count c cover) conf 853 | 854 | export 855 | abortEarly : 856 | TerminationCriteria 857 | -> TestCount 858 | -> Coverage CoverCount 859 | -> Maybe Confidence 860 | -> Bool 861 | abortEarly (EarlyTermination _ _ etMinTests) tests cover conf = 862 | let coverageReached := successVerified tests cover conf 863 | coverageUnreachable := failureVerified tests cover conf 864 | in unTag tests >= unTag etMinTests && 865 | (coverageReached || coverageUnreachable) 866 | 867 | abortEarly _ _ _ _ = False 868 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Range.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Range 2 | 3 | import Data.Bounded 4 | import Data.Fin 5 | import Data.Maybe 6 | import Decidable.Equality 7 | import Derive.Prelude 8 | import Derive.Pretty 9 | 10 | import Hedgehog.Internal.Util 11 | 12 | %hide Prelude.Range 13 | 14 | %language ElabReflection 15 | %default total 16 | 17 | public export 18 | MaxSizeNat : Nat 19 | MaxSizeNat = 100 20 | 21 | ||| A wrapper of a natural number plus an erased proof that 22 | ||| the value is within its bounds. 23 | ||| 24 | ||| Unlike the original Hedgehog, we allow values in the range [0,100] 25 | ||| treating size as a proper percentage. 26 | public export 27 | record Size where 28 | constructor MkSize 29 | size : Nat 30 | 0 sizeOk : size <= MaxSizeNat = True 31 | 32 | %runElab derive "Size" [Show,Eq,Ord] 33 | 34 | export 35 | Pretty Size where 36 | prettyPrec _ (MkSize n _) = line $ show n 37 | 38 | public export 39 | mkSize : (n : Nat) -> {auto 0 ok : n <= MaxSizeNat = True} -> Size 40 | mkSize n = MkSize n ok 41 | 42 | public export 43 | minSize : Size 44 | minSize = mkSize 0 45 | 46 | public export 47 | maxSize : Size 48 | maxSize = mkSize MaxSizeNat 49 | 50 | export 51 | mkSizeMay : Nat -> Maybe Size 52 | mkSizeMay n with (decEq (n <= MaxSizeNat) True) 53 | mkSizeMay n | Yes _ = Just $ mkSize n 54 | mkSizeMay n | No c = Nothing 55 | 56 | export 57 | mkSizeOrZero : Nat -> Size 58 | mkSizeOrZero = fromMaybe minSize . mkSizeMay 59 | 60 | export 61 | mkSizeOrMax : Nat -> Size 62 | mkSizeOrMax = fromMaybe maxSize . mkSizeMay 63 | 64 | public export 65 | resize : (Nat -> Nat) -> Size -> Size 66 | resize f s = mkSizeOrMax (f s.size) 67 | 68 | -------------------------------------------------------------------------------- 69 | -- Interface Implementations 70 | -------------------------------------------------------------------------------- 71 | 72 | export 73 | MinBound Size where 74 | minBound = minSize 75 | 76 | export 77 | MaxBound Size where 78 | maxBound = maxSize 79 | 80 | export 81 | Num Size where 82 | a + b = mkSizeOrMax $ size a + size b 83 | a * b = mkSizeOrMax $ size a * size b 84 | fromInteger = mkSizeOrMax . fromInteger 85 | 86 | public export 87 | ToInteger Size where toInteger = toInteger . size 88 | 89 | -------------------------------------------------------------------------------- 90 | -- Range 91 | -------------------------------------------------------------------------------- 92 | 93 | public export 94 | record Range a where 95 | constructor MkRange 96 | origin : a 97 | bounds' : Size -> (a,a) 98 | 99 | export 100 | bounds : Size -> Range a -> (a,a) 101 | bounds s r = r.bounds' s 102 | 103 | ||| Get the lower bound of a range for the given size. 104 | export 105 | lowerBound : Ord a => Size -> Range a -> a 106 | lowerBound sz = uncurry min . bounds sz 107 | 108 | ||| Get the lower bound of a range for the given size. 109 | export 110 | upperBound : Ord a => Size -> Range a -> a 111 | upperBound sz = uncurry max . bounds sz 112 | 113 | export 114 | Functor Range where 115 | map f (MkRange origin bounds') = 116 | MkRange 117 | (f origin) 118 | (\si => let (x,y) := bounds' si in (f x, f y)) 119 | 120 | -------------------------------------------------------------------------------- 121 | -- Constant Ranges 122 | -------------------------------------------------------------------------------- 123 | 124 | ||| Construct a range which represents a constant single value. 125 | ||| 126 | ||| >>> bounds x $ singleton 5 127 | ||| (5,5) 128 | ||| 129 | ||| >>> origin $ singleton 5 130 | ||| 5 131 | export 132 | singleton : a -> Range a 133 | singleton x = MkRange x $ \_ => (x, x) 134 | 135 | ||| Construct a range which is unaffected by the size parameter with a origin 136 | ||| point which may differ from the bounds. 137 | ||| 138 | ||| A range from @-10@ to @10@, with the origin at @0@: 139 | ||| 140 | ||| >>> bounds x $ constantFrom 0 (-10) 10 141 | ||| (-10,10) 142 | ||| 143 | ||| >>> origin $ constantFrom 0 (-10) 10 144 | ||| 0 145 | ||| 146 | ||| A range from @1970@ to @2100@, with the origin at @2000@: 147 | ||| 148 | ||| >>> bounds x $ constantFrom 2000 1970 2100 149 | ||| (1970,2100) 150 | ||| 151 | ||| >>> origin $ constantFrom 2000 1970 2100 152 | ||| 2000 153 | export 154 | constantFrom : (origin,lower,upper : a) -> Range a 155 | constantFrom o l u = MkRange o $ \_ => (l, u) 156 | 157 | ||| Construct a range which is unaffected by the size parameter. 158 | ||| 159 | ||| A range from @0@ to @10@, with the origin at @0@: 160 | ||| 161 | ||| >>> bounds x $ constant 0 10 162 | ||| (0,10) 163 | ||| 164 | ||| >>> origin $ constant 0 10 165 | ||| 0 166 | ||| 167 | export 168 | constant : a -> a -> Range a 169 | constant x y = constantFrom x x y 170 | 171 | ||| Construct a range which is unaffected by the size parameter using the full 172 | ||| range of a data type. 173 | ||| 174 | ||| A range from @-128@ to @127@, with the origin at @0@: 175 | ||| 176 | ||| >>> bounds x (constantBounded :: Range Int8) 177 | ||| (-128,127) 178 | ||| 179 | ||| >>> origin (constantBounded :: Range Int8) 180 | ||| 0 181 | export 182 | constantBounded : (MinBound a, MaxBound a) => Num a => Range a 183 | constantBounded = constantFrom 0 minBound maxBound 184 | 185 | -------------------------------------------------------------------------------- 186 | -- Linear Ranges 187 | -------------------------------------------------------------------------------- 188 | 189 | ||| Truncate a value so it stays within some range. 190 | ||| 191 | ||| >>> clamp 5 10 15 192 | ||| 10 193 | ||| 194 | ||| >>> clamp 5 10 0 195 | ||| 5 196 | export 197 | clamp : Ord a => (lower,upper,val : a) -> a 198 | clamp l u v = 199 | if l > u 200 | then min l (max u v) 201 | else min u (max l v) 202 | 203 | ||| Scales an integral value linearly with the size parameter. 204 | export 205 | scaleLinear : ToInteger a => Size -> (origin,bound : a) -> a 206 | scaleLinear sz o0 b0 = 207 | let o := toInteger o0 208 | b := toInteger b0 209 | rng := b - o 210 | diff := (rng * toInteger sz) `safeDiv` 100 211 | in fromInteger $ o + diff 212 | 213 | ||| Scales a fractional value linearly with the size parameter. 214 | export 215 | scaleLinearFrac : Fractional a => Neg a => Size -> (origin,bound : a) -> a 216 | scaleLinearFrac sz o b = 217 | let diff = (b - o) * (fromIntegral sz / 100) 218 | in o + diff 219 | 220 | export %inline 221 | scaled : 222 | {auto _ : Ord a} 223 | -> (scale : Size -> (origin,bound : a) -> a) 224 | -> (origin,lower,upper : a) 225 | -> Range a 226 | scaled f o l u = 227 | MkRange o $ \sz => 228 | let x_sized := clamp l u $ f sz o l 229 | y_sized := clamp l u $ f sz o u 230 | in (x_sized, y_sized) 231 | 232 | ||| Construct a range which scales the bounds relative to the size parameter. 233 | ||| 234 | ||| >>> bounds 0 $ linearFrom 0 (-10) 10 235 | ||| (0,0) 236 | ||| 237 | ||| >>> bounds 50 $ linearFrom 0 (-10) 20 238 | ||| (-5,10) 239 | ||| 240 | ||| >>> bounds 100 $ linearFrom 0 (-10) 20 241 | ||| (-10,20) 242 | export 243 | linearFrom : Ord a => ToInteger a => (origin,lower,upper : a) -> Range a 244 | linearFrom = scaled scaleLinear 245 | 246 | export 247 | linear : Ord a => ToInteger a => (origin,upper : a) -> Range a 248 | linear origin upper = linearFrom origin origin upper 249 | 250 | export 251 | linearFin : (n : Nat) -> Range (Fin $ S n) 252 | linearFin n = map toFin $ linearFrom 0 0 (natToInteger n) 253 | 254 | where 255 | toFin : Integer -> Fin (S n) 256 | toFin k = fromMaybe FZ (integerToFin k (S n)) 257 | 258 | ||| Construct a range which scales the bounds relative to the size parameter. 259 | ||| 260 | ||| This works the same as 'linearFrom', but for fractional values. 261 | export 262 | linearFracFrom : 263 | {auto _ : Ord a} 264 | -> {auto _ : Fractional a} 265 | -> {auto _ : Neg a} 266 | -> (origin,lower,uppder : a) -> Range a 267 | linearFracFrom = scaled scaleLinearFrac 268 | 269 | ||| Construct a range which is scaled relative to the size parameter and uses 270 | ||| the full range of a data type. 271 | ||| 272 | ||| >>> bounds 0 (linearBounded :: Range Int8) 273 | ||| (0,0) 274 | ||| 275 | ||| >>> bounds 50 (linearBounded :: Range Int8) 276 | ||| (-64,64) 277 | ||| 278 | ||| >>> bounds 99 (linearBounded :: Range Int8) 279 | ||| (-128,127) 280 | export 281 | linearBounded : (MinBound a, MaxBound a) => Ord a => ToInteger a => Range a 282 | linearBounded = linearFrom minBound minBound maxBound 283 | 284 | -------------------------------------------------------------------------------- 285 | -- Exponential Ranges 286 | -------------------------------------------------------------------------------- 287 | 288 | EulerMinus1 : Double 289 | EulerMinus1 = euler - 1 290 | 291 | ||| Scale a floating-point number exponentially with the size parameter. 292 | ||| 293 | ||| Note : This scales the difference between the two values exponentially. 294 | export 295 | scaleExponentialDouble : Size -> (origin,bound : Double) -> Double 296 | scaleExponentialDouble sz o b = 297 | let e := fromIntegral sz / 100.0 298 | delta := b - o 299 | diff := pow (abs delta + 1) e - 1 300 | in o + diff * signum delta 301 | 302 | ||| Scale an integral exponentially with the size parameter. 303 | export 304 | scaleExponential : ToInteger a => Size -> (origin,bound : a) -> a 305 | scaleExponential sz o b = 306 | round (scaleExponentialDouble sz (fromIntegral o) (fromIntegral b)) 307 | 308 | export 309 | exponentialDoubleFrom : (origin,lower,upper : Double) -> Range Double 310 | exponentialDoubleFrom = scaled scaleExponentialDouble 311 | 312 | export 313 | exponentialDouble : (lower,upper : Double) -> Range Double 314 | exponentialDouble l u = exponentialDoubleFrom l l u 315 | 316 | export 317 | exponentialFrom : Ord a => ToInteger a => (origin,lower,upper : a) -> Range a 318 | exponentialFrom = scaled scaleExponential 319 | 320 | export 321 | exponential : Ord a => ToInteger a => (lower,upper : a) -> Range a 322 | exponential l u = exponentialFrom l l u 323 | 324 | export 325 | exponentialFin : (n : Nat) -> Range (Fin $ S n) 326 | exponentialFin n = map toFin $ exponentialFrom 0 0 (natToInteger n) 327 | 328 | where 329 | toFin : Integer -> Fin (S n) 330 | toFin k = fromMaybe FZ (integerToFin k (S n)) 331 | 332 | -------------------------------------------------------------------------------- 333 | -- Tests and Proofs 334 | -------------------------------------------------------------------------------- 335 | 336 | singletonOriginId : origin (singleton x) = x 337 | singletonOriginId = Refl 338 | 339 | singletonBoundsId : bounds s (singleton x) = (x,x) 340 | singletonBoundsId = Refl 341 | 342 | constantFromOrigin : origin (constantFrom o l u) = o 343 | constantFromOrigin = Refl 344 | 345 | constantFromBounds : bounds s (constantFrom o l u) = (l,u) 346 | constantFromBounds = Refl 347 | 348 | constantOrigin : origin (constant o u) = o 349 | constantOrigin = Refl 350 | 351 | constantBounds : bounds s (constant o u) = (o,u) 352 | constantBounds = Refl 353 | 354 | One : Int 355 | One = 1 356 | 357 | Zero : Int 358 | Zero = 0 359 | 360 | clamp1_100_0 : clamp One 100 0 = One 361 | clamp1_100_0 = Refl 362 | 363 | clamp100_1_0 : clamp 100 One 0 = One 364 | clamp100_1_0 = Refl 365 | 366 | clamp1_100_150 : clamp One 100 150 = 100 367 | clamp1_100_150 = Refl 368 | 369 | clamp100_1_150 : clamp 100 One 150 = 100 370 | clamp100_1_150 = Refl 371 | 372 | clamp1_100_50 : clamp One 100 50 = 50 373 | clamp1_100_50 = Refl 374 | 375 | clamp100_1_50 : clamp 100 One 50 = 50 376 | clamp100_1_50 = Refl 377 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Report.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Report 2 | 3 | import Data.Lazy 4 | import Data.Nat 5 | import Derive.Prelude 6 | import Hedgehog.Internal.Config 7 | import Hedgehog.Internal.Property 8 | import Hedgehog.Internal.Range 9 | import Hedgehog.Internal.Util 10 | import System.Random.Pure.StdGen 11 | import Text.Show.Diff 12 | import Text.PrettyPrint.Bernardy.ANSI 13 | 14 | %default total 15 | 16 | %language ElabReflection 17 | 18 | -------------------------------------------------------------------------------- 19 | -- Reporting 20 | -------------------------------------------------------------------------------- 21 | 22 | public export 23 | record FailedAnnotation where 24 | constructor MkFailedAnnotation 25 | failedValue : String 26 | 27 | %runElab derive "FailedAnnotation" [Show,Eq] 28 | 29 | public export 30 | record FailureReport where 31 | constructor MkFailureReport 32 | size : Size 33 | seed : StdGen 34 | shrinks : ShrinkCount 35 | coverage : Maybe (Coverage CoverCount) 36 | annotations : List (Lazy FailedAnnotation) 37 | message : String 38 | diff : Maybe Diff 39 | footnotes : List (Lazy String) 40 | 41 | %runElab derive "FailureReport" [Show,Eq] 42 | 43 | ||| The status of a running property test. 44 | public export 45 | data Progress = Running | Shrinking FailureReport 46 | 47 | %runElab derive "Progress" [Show,Eq] 48 | 49 | ||| The status of a completed property test. 50 | ||| 51 | ||| In the case of a failure it provides the seed used for the test, the 52 | ||| number of shrinks, and the execution log. 53 | public export 54 | data Result = Failed FailureReport | OK 55 | 56 | %runElab derive "Result" [Show,Eq] 57 | 58 | public export 59 | isFailure : Result -> Bool 60 | isFailure (Failed _) = True 61 | isFailure OK = False 62 | 63 | public export 64 | isSuccess : Result -> Bool 65 | isSuccess = not . isFailure 66 | 67 | ||| A report on a running or completed property test. 68 | public export 69 | record Report a where 70 | constructor MkReport 71 | tests : TestCount 72 | coverage : Coverage CoverCount 73 | status : a 74 | 75 | %runElab derive "Report" [Show,Eq] 76 | 77 | export 78 | Functor Report where 79 | map f = {status $= f} 80 | 81 | export 82 | Foldable Report where 83 | foldl f acc = f acc . status 84 | foldr f acc r = f r.status acc 85 | null _ = False 86 | 87 | export 88 | Traversable Report where 89 | traverse f (MkReport t c a) = MkReport t c <$> f a 90 | 91 | ||| A summary of all the properties executed. 92 | public export 93 | record Summary where 94 | constructor MkSummary 95 | waiting : PropertyCount 96 | running : PropertyCount 97 | failed : PropertyCount 98 | ok : PropertyCount 99 | 100 | %runElab derive "Summary" [Show,Eq,Semigroup,Monoid] 101 | 102 | record ColumnWidth where 103 | constructor MkColumnWidth 104 | widthPercentage : Nat 105 | widthMinimum : Nat 106 | widthName : Nat 107 | widthNameFail : Nat 108 | 109 | Semigroup ColumnWidth where 110 | MkColumnWidth p0 m0 n0 f0 <+> MkColumnWidth p1 m1 n1 f1 = 111 | MkColumnWidth (max p0 p1) (max m0 m1) (max n0 n1) (max f0 f1) 112 | 113 | Monoid ColumnWidth where 114 | neutral = MkColumnWidth 0 0 0 0 115 | 116 | ||| Construct a summary from a single result. 117 | export 118 | fromResult : Result -> Summary 119 | fromResult (Failed _) = { failed := 1} neutral 120 | fromResult OK = { ok := 1} neutral 121 | 122 | export 123 | summaryCompleted : Summary -> PropertyCount 124 | summaryCompleted (MkSummary _ _ x3 x4) = x3 + x4 125 | 126 | export 127 | summaryTotal : Summary -> PropertyCount 128 | summaryTotal (MkSummary x1 x2 x3 x4) = x1 + x2 + x3 + x4 129 | 130 | export 131 | takeAnnotation : Lazy Log -> Maybe $ Lazy FailedAnnotation 132 | takeAnnotation (Annotation x) = Just $ MkFailedAnnotation x 133 | takeAnnotation (Footnote _ ) = Nothing 134 | takeAnnotation (LogLabel _ ) = Nothing 135 | 136 | export 137 | takeFootnote : Lazy Log -> Maybe $ Lazy String 138 | takeFootnote (Footnote x) = Just x 139 | takeFootnote (Annotation _) = Nothing 140 | takeFootnote (LogLabel _) = Nothing 141 | 142 | export 143 | mkFailure : 144 | Size 145 | -> StdGen 146 | -> ShrinkCount 147 | -> Maybe (Coverage CoverCount) 148 | -> String 149 | -> Maybe Diff 150 | -> List (Lazy Log) 151 | -> FailureReport 152 | mkFailure size seed shrinks mcoverage message diff logs = 153 | let inputs := mapMaybe takeAnnotation logs 154 | footnotes := mapMaybe takeFootnote logs 155 | in MkFailureReport size seed shrinks mcoverage inputs message diff footnotes 156 | 157 | -------------------------------------------------------------------------------- 158 | -- Pretty Printing 159 | -------------------------------------------------------------------------------- 160 | 161 | public export 162 | data MarkupStyle = StyleDefault | StyleAnnotation | StyleFailure 163 | 164 | export 165 | Semigroup MarkupStyle where 166 | StyleFailure <+> _ = StyleFailure 167 | _ <+> StyleFailure = StyleFailure 168 | StyleAnnotation <+> _ = StyleAnnotation 169 | _ <+> StyleAnnotation = StyleAnnotation 170 | StyleDefault <+> _ = StyleDefault 171 | 172 | %runElab derive "MarkupStyle" [Show,Eq,Ord] 173 | 174 | public export 175 | data Markup = 176 | WaitingIcon 177 | | WaitingHeader 178 | | RunningIcon 179 | | RunningHeader 180 | | ShrinkingIcon 181 | | ShrinkingHeader 182 | | FailedIcon 183 | | FailedText 184 | | SuccessIcon 185 | | SuccessText 186 | | CoverageIcon 187 | | CoverageText 188 | | CoverageFill 189 | | StyledBorder MarkupStyle 190 | | AnnotationValue 191 | | DiffPrefix 192 | | DiffInfix 193 | | DiffSuffix 194 | | DiffSame 195 | | DiffRemoved 196 | | DiffAdded 197 | | ReproduceHeader 198 | | ReproduceGutter 199 | | ReproduceSource 200 | 201 | %runElab derive "Markup" [Show,Eq,Ord] 202 | 203 | color : Color -> List SGR 204 | color c = [SetForeground c] 205 | 206 | toAnsi : Markup -> List SGR 207 | toAnsi (StyledBorder StyleAnnotation) = [] 208 | toAnsi (StyledBorder StyleDefault) = [] 209 | toAnsi (StyledBorder StyleFailure) = [] 210 | toAnsi AnnotationValue = color Magenta 211 | toAnsi CoverageFill = color BrightBlack 212 | toAnsi CoverageIcon = color Yellow 213 | toAnsi CoverageText = color Yellow 214 | toAnsi DiffAdded = color Green 215 | toAnsi DiffInfix = [] 216 | toAnsi DiffPrefix = [] 217 | toAnsi DiffRemoved = color Red 218 | toAnsi DiffSame = [] 219 | toAnsi DiffSuffix = [] 220 | toAnsi FailedIcon = color BrightRed 221 | toAnsi FailedText = color BrightRed 222 | toAnsi ReproduceGutter = [] 223 | toAnsi ReproduceHeader = [] 224 | toAnsi ReproduceSource = [] 225 | toAnsi RunningHeader = [] 226 | toAnsi RunningIcon = [] 227 | toAnsi ShrinkingHeader = color BrightRed 228 | toAnsi ShrinkingIcon = color BrightRed 229 | toAnsi SuccessIcon = color Green 230 | toAnsi SuccessText = color Green 231 | toAnsi WaitingHeader = [] 232 | toAnsi WaitingIcon = [] 233 | 234 | testCount : TestCount -> String 235 | testCount (MkTagged 1) = "1 test" 236 | testCount (MkTagged n) = show n ++ " tests" 237 | 238 | shrinkCount : ShrinkCount -> String 239 | shrinkCount (MkTagged 1) = "1 shrink" 240 | shrinkCount (MkTagged n) = show n ++ " shrinks" 241 | 242 | %inline propertyCount : PropertyCount -> String 243 | propertyCount (MkTagged n) = show n 244 | 245 | renderCoverPercentage : CoverPercentage -> String 246 | renderCoverPercentage p = 247 | show (round {a = Double} (p.asDouble * 10.0) / 10.0) ++ "%" 248 | 249 | labelWidth : TestCount -> Label CoverCount -> ColumnWidth 250 | labelWidth tests x = 251 | let percentage := 252 | length . renderCoverPercentage $ 253 | coverPercentage tests x.labelAnnotation 254 | 255 | minimum := 256 | if x.labelMinimum == 0 257 | then the Nat 0 258 | else length . renderCoverPercentage $ x.labelMinimum 259 | 260 | name := length . unTag $ x.labelName 261 | 262 | nameFail = if labelCovered tests x then the Nat 0 else name 263 | 264 | in MkColumnWidth percentage minimum name nameFail 265 | 266 | coverageWidth : TestCount -> Coverage CoverCount -> ColumnWidth 267 | coverageWidth tests = concatMap (labelWidth tests) . labels 268 | 269 | full : Char 270 | full = '█' 271 | 272 | parts : List Char 273 | parts = ['·', '▏','▎','▍','▌','▋','▊','▉'] 274 | 275 | parameters {opts : LayoutOpts} (useColor : UseColor) 276 | markup : Markup -> Doc opts -> Doc opts 277 | markup m d = case useColor of 278 | DisableColor => d 279 | EnableColor => decorate (toAnsi m) d 280 | 281 | %inline markupLine : Markup -> String -> Doc opts 282 | markupLine m = markup m . line 283 | 284 | gutter : Markup -> Doc opts -> Doc opts 285 | gutter m x = markup m rangle <++> x 286 | 287 | icon : Markup -> Char -> Doc opts -> Doc opts 288 | icon m i x = markup m (symbol i) <++> x 289 | 290 | lineDiff : LineDiff -> Doc opts 291 | lineDiff (LineSame x) = markup DiffSame $ " " <+> pretty x 292 | lineDiff (LineRemoved x) = markup DiffRemoved $ "- " <+> pretty x 293 | lineDiff (LineAdded x) = markup DiffAdded $ "+ " <+> pretty x 294 | 295 | diff : Diff -> List (Doc opts) 296 | diff (MkDiff pre removed inf added suffix df) = 297 | ( markup DiffPrefix (line pre) <+> 298 | markup DiffRemoved (line removed) <+> 299 | markup DiffInfix (line inf) <+> 300 | markup DiffAdded (line added) <+> 301 | markup DiffSuffix (line suffix) 302 | ) :: map lineDiff (toLineDiff df) 303 | 304 | reproduce : Maybe PropertyName -> Size -> StdGen -> Doc opts 305 | reproduce name size seed = 306 | let prop := line $ maybe "" unTag name 307 | instr := prettyCon Open "recheck" [prettyArg size, prettyArg seed, prop] 308 | in vsep 309 | [ markupLine ReproduceHeader "This failure can be reproduced by running:" 310 | , gutter ReproduceGutter $ markup ReproduceSource instr 311 | ] 312 | 313 | textLines : String -> List (Doc opts) 314 | textLines = map line . lines 315 | 316 | failedInput : Nat -> FailedAnnotation -> Doc opts 317 | failedInput ix (MkFailedAnnotation val) = 318 | vsep 319 | [ line "forAll \{show ix} =" 320 | , indent 2 . vsep . map (markup AnnotationValue . line) $ lines val 321 | ] 322 | 323 | failureReport : 324 | Maybe PropertyName 325 | -> TestCount 326 | -> FailureReport 327 | -> List (Doc opts) 328 | failureReport nm tests (MkFailureReport si se _ mcover inputs msg mdiff msgs0) = 329 | whenSome (empty ::) 330 | . whenSome (++ [empty]) 331 | . intersperse empty 332 | . map (vsep . map (indent 2)) 333 | . filter (\xs => not $ null xs) 334 | $ [intersperse empty args, coverage, docs, bottom] 335 | 336 | where 337 | whenSome : Foldable t => (t a -> t a) -> t a -> t a 338 | whenSome f xs = if null xs then xs else f xs 339 | 340 | bottom : List (Doc opts) 341 | bottom = maybe [reproduce nm si se] (const Nil) mcover 342 | 343 | docs : List (Doc opts) 344 | docs = 345 | concatMap 346 | textLines 347 | (map force msgs0 ++ if msg == "" then [] else [msg]) 348 | <+> maybe [] diff mdiff 349 | 350 | args : List (Doc opts) 351 | args = zipWith failedInput [0 .. length inputs] (reverse $ map force inputs) 352 | 353 | coverage : List (Doc opts) 354 | coverage = 355 | case mcover of 356 | Nothing => [] 357 | Just c => do 358 | MkLabel _ _ count <- coverageFailures tests c 359 | pure $ 360 | line "Failed (" 361 | <+> markupLine CoverageText 362 | (renderCoverPercentage (coverPercentage tests count)) 363 | <+> " coverage)" 364 | 365 | ppName : Maybe PropertyName -> Doc opts 366 | ppName Nothing = "" 367 | ppName (Just $ MkTagged name) = text name 368 | 369 | leftPad : Nat -> Doc opts -> Doc opts 370 | leftPad n doc = doc >>= \l => pure $ indent (n `minus` width l) l 371 | 372 | coverBar : CoverPercentage -> CoverPercentage -> Doc opts 373 | coverBar percentage minimum = 374 | let barWidth := the Nat 20 375 | coverageRatio := percentage.asDouble / 100.0 376 | coverageWidth := toNat . floor $ coverageRatio * cast barWidth 377 | minimumRatio := minimum.asDouble / 100.0 378 | minimumWidth := toNat . floor $ minimumRatio * cast barWidth 379 | fillWidth := barWidth `minus` S coverageWidth 380 | fillErrorWidth := minimumWidth `minus` S coverageWidth 381 | fillSurplusWidth := fillWidth `minus` fillErrorWidth 382 | 383 | ix := 384 | toNat . floor $ 385 | ((coverageRatio * cast barWidth) - cast coverageWidth) * 386 | cast (length parts) 387 | 388 | part := 389 | symbol $ 390 | case inBounds ix parts of 391 | Yes ib => index ix parts 392 | No _ => head parts 393 | 394 | in hcat [ line $ replicate coverageWidth full 395 | , if coverageWidth < barWidth then 396 | if ix == 0 then 397 | if fillErrorWidth > 0 then markup FailedText part 398 | else markup CoverageFill part 399 | else part 400 | else empty 401 | , markupLine FailedText $ replicate fillErrorWidth (head parts) 402 | , markupLine CoverageFill $ replicate fillSurplusWidth (head parts) 403 | ] 404 | 405 | label : TestCount -> ColumnWidth -> Label CoverCount -> Doc opts 406 | label tests w x@(MkLabel name minimum count) = 407 | let covered := labelCovered tests x 408 | ltext := if not covered then markup CoverageText else id 409 | lborder := markup (StyledBorder StyleDefault) 410 | licon := if not covered then markup CoverageText "⚠ " else " " 411 | lname := padRight (cast w.widthName) ' ' (unTag name) 412 | wminimum := leftPad w.widthMinimum . line $ renderCoverPercentage minimum 413 | lcover := wcover 414 | 415 | lminimum = 416 | if w.widthMinimum == 0 then empty 417 | else if not covered then " ✗ " <+> wminimum 418 | else if minimum == 0 then " " <+> leftPad w.widthMinimum "" 419 | else " ✓ " <+> wminimum 420 | 421 | 422 | in hcat 423 | [ licon 424 | , ltext (line lname) 425 | , lborder " " 426 | , ltext lcover 427 | , lborder " " 428 | , ltext $ coverBar (coverPercentage tests count) minimum 429 | , lborder "" 430 | , ltext lminimum 431 | ] 432 | 433 | 434 | where wcover : Doc opts 435 | wcover = 436 | leftPad w.widthPercentage . line $ 437 | renderCoverPercentage (coverPercentage tests count) 438 | 439 | coverage : TestCount -> Coverage CoverCount -> List (Doc opts) 440 | coverage tests x = map (label tests (coverageWidth tests x)) $ labels x 441 | 442 | whenNonZero : Doc opts -> PropertyCount -> Maybe (Doc opts) 443 | whenNonZero _ 0 = Nothing 444 | whenNonZero suffix n = Just $ line (propertyCount n) <++> suffix 445 | 446 | export 447 | ppProgress : Maybe PropertyName -> Report Progress -> Doc opts 448 | ppProgress name (MkReport tests cov status) = 449 | case status of 450 | Running => 451 | vsep $ 452 | [ icon RunningIcon '●' . markup RunningHeader $ 453 | ppName name <++> line "passed \{testCount tests} (running)" 454 | ] ++ coverage tests cov 455 | 456 | Shrinking failure => 457 | icon ShrinkingIcon '↯' . markup ShrinkingHeader $ 458 | ppName name <++> line "failed after \{testCount tests}" 459 | 460 | annotateSummary : Summary -> Doc opts -> Doc opts 461 | annotateSummary summary = 462 | if summary.failed > 0 then 463 | icon FailedIcon '✗' . markup FailedText 464 | else if summary.waiting > 0 || summary.running > 0 then 465 | icon WaitingIcon '○' . markup WaitingHeader 466 | else 467 | icon SuccessIcon '✓' . markup SuccessText 468 | 469 | ppResult : Maybe PropertyName -> Report Result -> Doc opts 470 | ppResult name (MkReport tests cov result) = 471 | case result of 472 | Failed failure => 473 | vsep $ 474 | [ icon FailedIcon '✗' . markup FailedText $ 475 | ppName name <++> 476 | line "failed after \{testCount tests}." 477 | ] ++ 478 | coverage tests cov ++ 479 | failureReport name tests failure 480 | 481 | OK => 482 | vsep $ 483 | [ icon SuccessIcon '✓' . markup SuccessText $ 484 | ppName name <++> line "passed \{testCount tests}." 485 | ] ++ 486 | coverage tests cov 487 | 488 | export 489 | ppSummary : Summary -> Doc opts 490 | ppSummary summary = 491 | let complete := summaryCompleted summary == summaryTotal summary 492 | suffix := if complete then line "." else line " (running)" 493 | 494 | in annotateSummary summary . 495 | (<+> suffix) 496 | . hcat 497 | . addPrefix complete 498 | . intersperse (line ", ") 499 | $ catMaybes [ 500 | whenNonZero "failed" summary.failed 501 | , if complete then 502 | whenNonZero "succeeded" summary.ok 503 | else 504 | Nothing 505 | ] 506 | 507 | where 508 | doPrefix : Bool -> Doc opts -> Doc opts 509 | doPrefix True _ = empty 510 | doPrefix False end = 511 | let pc1 := propertyCount (summaryCompleted summary) 512 | pc2 := propertyCount (summaryTotal summary) 513 | in line "\{pc1} / \{pc2} complete" <+> end 514 | 515 | addPrefix : Bool -> List (Doc opts) -> List (Doc opts) 516 | addPrefix complete [] = [doPrefix complete empty] 517 | addPrefix complete xs = doPrefix complete ": " :: xs 518 | 519 | public export 520 | LL80 : LayoutOpts 521 | LL80 = Opts 80 522 | 523 | export 524 | renderDoc : Doc LL80 -> String 525 | renderDoc = render LL80 . indent 2 526 | 527 | export 528 | renderProgress : UseColor -> Maybe PropertyName -> Report Progress -> String 529 | renderProgress color name = renderDoc . ppProgress color name 530 | 531 | export 532 | renderResult : UseColor -> Maybe PropertyName -> Report Result -> String 533 | renderResult color name = renderDoc . ppResult color name 534 | 535 | export 536 | renderSummary : UseColor -> Summary -> String 537 | renderSummary color = renderDoc . ppSummary color 538 | 539 | -------------------------------------------------------------------------------- 540 | -- Test Report 541 | -------------------------------------------------------------------------------- 542 | 543 | export 544 | report : 545 | (aborted : Bool) 546 | -> TestCount 547 | -> Size 548 | -> StdGen 549 | -> Coverage CoverCount 550 | -> Maybe Confidence 551 | -> Report Result 552 | report aborted tests size seed cover conf = 553 | let failureReport := \msg => 554 | MkReport tests cover . Failed $ 555 | mkFailure size seed 0 (Just cover) msg Nothing [] 556 | 557 | coverageReached := successVerified tests cover conf 558 | 559 | labelsCovered := coverageSuccess tests cover 560 | 561 | successReport := MkReport tests cover OK 562 | 563 | confidenceReport = 564 | if coverageReached && labelsCovered 565 | then successReport 566 | else 567 | failureReport 568 | "Test coverage cannot be reached after \{tests} tests" 569 | 570 | in if aborted then confidenceReport 571 | else if labelsCovered then successReport 572 | else 573 | failureReport $ 574 | "Labels not sufficently covered after \{tests} tests" 575 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Runner.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Runner 2 | 3 | import Data.Colist 4 | import Data.Cotree 5 | import Data.Maybe 6 | import Hedgehog.Internal.Config 7 | import Hedgehog.Internal.Gen 8 | import Hedgehog.Internal.Options 9 | import Hedgehog.Internal.Property 10 | import Hedgehog.Internal.Range 11 | import Hedgehog.Internal.Report 12 | import Hedgehog.Internal.Terminal 13 | import System 14 | import System.Random.Pure.StdGen 15 | 16 | %default total 17 | 18 | public export 19 | TestRes : Type 20 | TestRes = (Either Failure (), Journal) 21 | 22 | -------------------------------------------------------------------------------- 23 | -- Shrinking 24 | -------------------------------------------------------------------------------- 25 | 26 | -- Shrinking 27 | shrink : Monad m => Nat -> Coforest a -> b -> (Nat -> a -> m (Maybe b)) -> m b 28 | shrink _ [] b _ = pure b 29 | shrink 0 _ b _ = pure b 30 | shrink (S k) (t :: ts) b f = do 31 | Just b2 <- f (S k) t.value | Nothing => shrink k ts b f 32 | shrink k t.forest b2 f 33 | 34 | takeSmallest : 35 | {auto _ : Monad m} 36 | -> Size 37 | -> StdGen 38 | -> ShrinkLimit 39 | -> (Progress -> m ()) 40 | -> Cotree TestRes 41 | -> m Result 42 | takeSmallest si se (MkTagged slimit) updateUI t = do 43 | res <- run 0 t.value 44 | if isFailure res 45 | then shrink slimit t.forest res runMaybe 46 | else pure res 47 | 48 | where 49 | -- calc number of shrinks from the remaining 50 | -- allowed numer and the shrink limit 51 | calcShrinks : Nat -> ShrinkCount 52 | calcShrinks rem = MkTagged $ (slimit `minus` rem) + 1 53 | 54 | run : ShrinkCount -> TestRes -> m Result 55 | run shrinks t = 56 | case t of 57 | (Left $ MkFailure err diff, MkJournal logs) => 58 | let fail = mkFailure si se shrinks Nothing err diff (reverse logs) 59 | in updateUI (Shrinking fail) $> Failed fail 60 | 61 | (Right x, _) => pure OK 62 | 63 | runMaybe : Nat -> TestRes -> m (Maybe Result) 64 | runMaybe shrinksLeft testRes = do 65 | res <- run (calcShrinks shrinksLeft) testRes 66 | if isFailure res then pure (Just res) else pure Nothing 67 | 68 | -------------------------------------------------------------------------------- 69 | -- Test Runners 70 | -------------------------------------------------------------------------------- 71 | 72 | -- main test runner 73 | checkReport : 74 | {auto _ : Monad m} 75 | -> PropertyConfig 76 | -> Maybe Size 77 | -> StdGen 78 | -> PropertyT () 79 | -> (Report Progress -> m ()) 80 | -> m (Report Result) 81 | checkReport cfg si0 se0 test updateUI = 82 | let (conf, MkTagged numTests, initSz) := unCriteria cfg.terminationCriteria 83 | in loop numTests 0 (fromMaybe initSz si0) se0 neutral conf 84 | 85 | where 86 | loop : 87 | Nat 88 | -> TestCount 89 | -> Size 90 | -> StdGen 91 | -> Coverage CoverCount 92 | -> Maybe Confidence 93 | -> m (Report Result) 94 | loop n tests si se cover conf = do 95 | updateUI (MkReport tests cover Running) 96 | case n of 97 | 0 => 98 | -- required number of tests run 99 | pure $ report False tests si se cover conf 100 | S k => 101 | if abortEarly cfg.terminationCriteria tests cover conf 102 | then 103 | -- at this point we know that enough 104 | -- tests have been run due to early termination 105 | pure $ report True tests si se cover conf 106 | else 107 | -- run another test 108 | let (s0,s1) := split se 109 | tr := runGen si s0 $ runTestT test 110 | nextSize = if si < maxSize then (si + 1) else 0 111 | in case tr.value of 112 | -- the test failed, so we abort and shrink 113 | (Left x, _) => 114 | let upd := updateUI . MkReport (tests+1) cover 115 | in map (MkReport (tests+1) cover) $ 116 | takeSmallest si se cfg.shrinkLimit upd tr 117 | 118 | -- the test succeeded, so we accumulate results 119 | -- and loop once more 120 | (Right x, journal) => 121 | let cover1 := journalCoverage journal <+> cover 122 | in loop k (tests + 1) nextSize s1 cover1 conf 123 | 124 | checkTerm : 125 | {auto _ : HasTerminal m} 126 | -> {auto _ : Monad m} 127 | -> Terminal m 128 | -> UseColor 129 | -> Maybe PropertyName 130 | -> Maybe Size 131 | -> StdGen 132 | -> Property 133 | -> m (Report Result) 134 | checkTerm term color name si se prop = do 135 | result <- checkReport {m} prop.config si se prop.test $ 136 | \prog => 137 | when (multOf100 prog.tests) $ 138 | let ppprog := renderProgress color name prog 139 | in case prog.status of 140 | Running => putTmp term ppprog 141 | Shrinking _ => putTmp term ppprog 142 | 143 | putOut term (renderResult color name result) 144 | pure result 145 | 146 | checkWith : 147 | {auto _ : CanInitSeed StdGen m} 148 | -> {auto _ : HasTerminal m} 149 | -> {auto _ : Monad m} 150 | -> Terminal m 151 | -> UseColor 152 | -> Maybe PropertyName 153 | -> Property 154 | -> m (Report Result) 155 | checkWith term color name prop = 156 | initSeed >>= \se => checkTerm term color name Nothing se prop 157 | 158 | ||| Check a property. 159 | export 160 | checkNamed : 161 | {auto _ : CanInitSeed StdGen m} 162 | -> {auto _ : HasConfig m} 163 | -> {auto _ : HasTerminal m} 164 | -> {auto _ : Monad m} 165 | -> PropertyName 166 | -> Property 167 | -> m Bool 168 | checkNamed name prop = do 169 | color <- detectColor 170 | term <- console 171 | rep <- checkWith term color (Just name) prop 172 | pure $ rep.status == OK 173 | 174 | ||| Check a property. 175 | export 176 | check : 177 | {auto _ : CanInitSeed StdGen m} 178 | -> {auto _ : HasConfig m} 179 | -> {auto _ : HasTerminal m} 180 | -> {auto _ : Monad m} 181 | -> Property 182 | -> m Bool 183 | check prop = do 184 | color <- detectColor 185 | term <- console 186 | rep <- checkWith term color Nothing prop 187 | pure $ rep.status == OK 188 | 189 | ||| Check a property using a specific size and seed. 190 | export 191 | recheck : 192 | {auto _ : HasConfig m} 193 | -> {auto _ : HasTerminal m} 194 | -> {auto _ : Monad m} 195 | -> Size 196 | -> StdGen 197 | -> Property 198 | -> m () 199 | recheck si se prop = do 200 | color <- detectColor 201 | term <- console 202 | let prop = noVerifiedTermination $ withTests 1 prop 203 | _ <- checkTerm term color Nothing (Just si) se prop 204 | pure () 205 | 206 | checkGroupWith : 207 | {auto _ : CanInitSeed StdGen m} 208 | -> {auto _ : HasTerminal m} 209 | -> {auto _ : Monad m} 210 | -> Terminal m 211 | -> UseColor 212 | -> List (PropertyName, Property) 213 | -> m Summary 214 | checkGroupWith term color = run neutral 215 | 216 | where 217 | run : Summary -> List (PropertyName, Property) -> m Summary 218 | run s [] = pure s 219 | run s ((pn,p) :: ps) = do 220 | rep <- checkWith term color (Just pn) p 221 | run (s <+> fromResult rep.status) ps 222 | 223 | export 224 | checkGroup : 225 | {auto _ : CanInitSeed StdGen m} 226 | -> {auto _ : HasConfig m} 227 | -> {auto _ : HasTerminal m} 228 | -> {auto _ : Monad m} 229 | -> Group 230 | -> m Bool 231 | checkGroup (MkGroup group props) = do 232 | term <- console 233 | putOut term $ "━━━ " ++ unTag group ++ " ━━━\n" 234 | color <- detectColor 235 | summary <- checkGroupWith term color props 236 | putOut term (renderSummary color summary) 237 | pure $ summary.failed == 0 238 | 239 | ||| Simple test runner. 240 | ||| 241 | ||| Use this in a `main` function in order to test a list of 242 | ||| property groups. The runner will take into account several 243 | ||| command line arguments in order to adjust the number of 244 | ||| tests to be run for each property, the maximal number of 245 | ||| shrinks and the confidence value to use. 246 | ||| 247 | ||| ```idris example 248 | ||| main : IO () 249 | ||| main = test myGroups 250 | ||| ``` 251 | ||| 252 | ||| The resulting executable can then be run as follows: 253 | ||| 254 | ||| ```sh 255 | ||| build/exec/runTests -n 1000 256 | ||| ``` 257 | ||| 258 | ||| It will fail with an exit code of 1 if at least one property 259 | ||| fails. 260 | export 261 | test : HasIO io => List Group -> io () 262 | test gs = do 263 | args <- getArgs 264 | Right c <- pure $ applyArgs args 265 | | Left errs => do 266 | putStrLn "Errors when parsing command line args:" 267 | traverse_ putStrLn errs 268 | exitFailure 269 | if c.printHelp 270 | then putStrLn info >> exitSuccess 271 | else 272 | let gs2 := map (applyConfig c) gs 273 | in do 274 | res <- foldlM (\b,g => map (b &&) (checkGroup g)) True gs2 275 | if res 276 | then exitSuccess 277 | else putStrLn "\n\nSome tests failed" >> exitFailure 278 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Shrink.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Shrink 2 | 3 | import Data.Colist 4 | import Data.Cotree 5 | import Data.Nat 6 | 7 | import Hedgehog.Internal.Util 8 | 9 | %default total 10 | 11 | public export 12 | halvesInteger : Integer -> Colist Integer 13 | halvesInteger = iterateBefore0 (`safeDiv` 2) 14 | 15 | public export 16 | halves : ToInteger a => a -> Colist a 17 | halves = map fromInteger . halvesInteger . toInteger 18 | 19 | public export 20 | towardsInteger : (destination, val : Integer) -> Colist Integer 21 | towardsInteger dest x = 22 | if dest == x 23 | then [] 24 | else 25 | let diff := (x `safeDiv` 2) - (dest `safeDiv` 2) 26 | in dest `consNub` map (x -) (halvesInteger diff) 27 | 28 | ||| Shrink an integral number by edging towards a destination. 29 | ||| 30 | ||| >>> towards 0 100 31 | ||| [0,50,75,88,94,97,99] 32 | ||| 33 | ||| >>> towards 500 1000 34 | ||| [500,750,875,938,969,985,993,997,999] 35 | ||| 36 | ||| >>> towards (-50) (-26) 37 | ||| [-50,-38,-32,-29,-27] 38 | ||| 39 | ||| Note we always try the destination first, as that is the optimal shrink. 40 | public export 41 | towards : ToInteger a => (destination, val : a) -> Colist a 42 | towards dest x = 43 | map 44 | fromInteger 45 | (towardsInteger (toInteger dest) (toInteger x)) 46 | 47 | public export 48 | towardsDouble : Double -> Double -> Colist Double 49 | towardsDouble destination x = 50 | if destination == x 51 | then [] 52 | else 53 | let diff := x - destination 54 | ok := (/= x) 55 | in takeWhile ok . map (x -) $ iterate (/ 2) diff 56 | 57 | public export 58 | removes : Nat -> List a -> Colist $ List a 59 | removes 0 _ = [] 60 | removes (S n) x = run (S n) [] x 61 | 62 | where 63 | run : Nat -> List a -> List a -> Colist $ List a 64 | run 0 _ [] = [[]] 65 | run 0 xs (y :: ys) = 66 | let rest := run n [y] ys 67 | in (y :: ys) :: map (prepRev xs) rest 68 | run (S k) _ [] = [] 69 | run (S k) xs (y :: ys) = run k (y :: xs) ys 70 | 71 | ||| All ways a list can be split 72 | ||| 73 | ||| Note: The first list in the triple will be in reverse order 74 | public export 75 | splits : (a -> b) -> List a -> List (List a, b, List a) 76 | splits _ [] = [] 77 | splits f (x :: xs) = run [] x xs 78 | 79 | where 80 | run : List a -> a -> List a -> List (List a, b, List a) 81 | run xs x [] = [(xs,f x,[])] 82 | run xs x l@(y :: ys) = (xs,f x,l) :: run (x::xs) y ys 83 | 84 | ||| Shrink a list by edging towards the empty list. 85 | ||| 86 | ||| >>> list [1,2,3] 87 | ||| [[],[2,3],[1,3],[1,2]] 88 | ||| 89 | ||| >>> list "abcd" 90 | ||| ["","cd","ab","bcd","acd","abd","abc"] 91 | ||| 92 | ||| Note we always try the empty list first, as that is the optimal shrink. 93 | public export 94 | list : (minLength : Nat) -> List a -> Colist $ List a 95 | list ml xs = let diff = length xs `minus` ml 96 | in concatMapColist (`removes` xs) (halves diff) 97 | 98 | public export 99 | interleave : (minLength : Nat) -> List (Cotree a) -> Cotree (List a) 100 | interleave ml ts = MkCotree (map value ts) $ dropThenShrink (list ml ts) 101 | 102 | where 103 | shrinkOne : 104 | List (List (Cotree a), Coforest a, List (Cotree a)) 105 | -> Coforest (List a) 106 | shrinkOne [] = [] 107 | shrinkOne ((xs,[] ,ys) :: rest) = shrinkOne rest 108 | shrinkOne ((xs,t::ts,ys) :: rest) = 109 | interleave ml (prepRev xs (t::ys)) :: shrinkOne ((xs,ts,ys) :: rest) 110 | 111 | dropThenShrink : Colist (List $ Cotree a) -> Coforest (List a) 112 | dropThenShrink [] = shrinkOne (splits (\t => t.forest) ts) 113 | dropThenShrink (x :: xs) = interleave ml x :: dropThenShrink xs 114 | 115 | -------------------------------------------------------------------------------- 116 | -- Tests 117 | -------------------------------------------------------------------------------- 118 | 119 | HalvesFrom10 : List Int 120 | HalvesFrom10 = take 10 $ halves 10 121 | 122 | halvesFrom10Test : HalvesFrom10 = [10,5,2,1] 123 | halvesFrom10Test = Refl 124 | 125 | Towards0_100 : List Int 126 | Towards0_100 = take 10 $ towards 0 100 127 | 128 | Towards500_1000 : List Int 129 | Towards500_1000 = take 10 $ towards 500 1000 130 | 131 | Towards50_26 : List Int 132 | Towards50_26 = take 10 $ towards (-50) (-26) 133 | 134 | towards0_100Test : Towards0_100 = [0,50,75,88,94,97,99] 135 | towards0_100Test = Refl 136 | 137 | towards500_1000Test : Towards500_1000 = [500,750,875,938,969,985,993,997,999] 138 | towards500_1000Test = Refl 139 | 140 | towards50_26Test : Towards50_26 = [-50,-38,-32,-29,-27] 141 | towards50_26Test = Refl 142 | 143 | TowardsFloat0_100 : List Double 144 | TowardsFloat0_100 = take 7 $ towardsDouble 0.0 100 145 | 146 | TowardsFloat1_5 : List Double 147 | TowardsFloat1_5 = take 7 $ towardsDouble 1 0.5 148 | 149 | towardsFloat0_100Test : TowardsFloat0_100 = [0.0,50.0,75.0,87.5,93.75,96.875,98.4375] 150 | towardsFloat0_100Test = Refl 151 | 152 | towardsFloat1_5Test : TowardsFloat1_5 = [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125] 153 | towardsFloat1_5Test = Refl 154 | 155 | Removes2_2 : List $ List Int 156 | Removes2_2 = take 10 $ removes 2 [1,2] 157 | 158 | removes2_2Test : Removes2_2 = [[]] 159 | removes2_2Test = Refl 160 | 161 | Removes2_3 : List $ List Int 162 | Removes2_3 = take 10 $ removes 2 [1,2,3] 163 | 164 | removes2_3Test : Removes2_3 = [[3]] 165 | removes2_3Test = Refl 166 | 167 | Removes2_4 : List $ List Int 168 | Removes2_4 = take 10 $ removes 2 [1,2,3,4] 169 | 170 | removes2_4Test : Removes2_4 = [[3,4],[1,2]] 171 | removes2_4Test = Refl 172 | 173 | Removes2_5 : List $ List Int 174 | Removes2_5 = take 10 $ removes 2 [1,2,3,4,5] 175 | 176 | removes2_5Test : Removes2_5 = [[3,4,5],[1,2,5]] 177 | removes2_5Test = Refl 178 | 179 | Removes2_6 : List $ List Int 180 | Removes2_6 = take 10 $ removes 2 [1,2,3,4,5,6] 181 | 182 | removes2_6Test : Removes2_6 = [[3,4,5,6],[1,2,5,6],[1,2,3,4]] 183 | removes2_6Test = Refl 184 | 185 | Removes3_10 : List $ List Int 186 | Removes3_10 = take 10 $ removes 3 [1,2,3,4,5,6,7,8,9,10] 187 | 188 | removes3_10Test : Removes3_10 = [[4,5,6,7,8,9,10],[1,2,3,7,8,9,10],[1,2,3,4,5,6,10]] 189 | removes3_10Test = Refl 190 | 191 | List3 : List $ List Int 192 | List3 = take 10 $ list 0 [1,2,3] 193 | 194 | List4 : List $ List Int 195 | List4 = take 10 $ list 0 [1,2,3,4] 196 | 197 | List5 : List $ List Int 198 | List5 = take 10 $ list 2 [1,2,3,4,5] 199 | 200 | list3Test : List3 = [[],[2,3],[1,3],[1,2]] 201 | list3Test = Refl 202 | 203 | list4Test : List4 = [[],[3,4],[1,2],[2,3,4],[1,3,4],[1,2,4],[1,2,3]] 204 | list4Test = Refl 205 | 206 | list5Test : List5 = [[4,5],[2,3,4,5],[1,3,4,5],[1,2,4,5],[1,2,3,5],[1,2,3,4]] 207 | list5Test = Refl 208 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Terminal.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Terminal 2 | 3 | import Control.Monad.Writer.Interface 4 | 5 | import Text.ANSI.CSI 6 | import Data.IORef 7 | import Data.String 8 | import System.File 9 | 10 | ||| Interface showing that in the given monadic context `m` user can 11 | ||| initialise terminal and use it for printing temporary and permanent info. 12 | public export 13 | interface HasTerminal m where 14 | 15 | ||| Type of initialised terminal 16 | 0 TermTy : Type 17 | 18 | ||| Return new initialised terminal 19 | ||| 20 | ||| Notice that usage of several initalised terminals is not supposed 21 | ||| and may lead to unexpected behaviour. 22 | console : m TermTy 23 | 24 | ||| Put temporary info into the terminal 25 | ||| 26 | ||| Any successive putting temporary or permanent info into the terminal 27 | ||| makes any previously put temporary info disappear. 28 | putTmp : TermTy -> String -> m () 29 | 30 | ||| Put permanent info into the terminal 31 | ||| 32 | ||| This action makes previously put temporary info disappear 33 | putOut : TermTy -> String -> m () 34 | 35 | ||| Returns the type of initialised terminal 36 | ||| for the explicitly given context `m` 37 | public export 38 | 0 Terminal : (0 m : _) -> HasTerminal m => Type 39 | Terminal m = TermTy {m} 40 | 41 | putStrErr : HasIO io => String -> io () 42 | putStrErr s = fPutStr stderr s $> () 43 | 44 | replicate : Monoid m => Nat -> m -> m 45 | replicate Z x = neutral 46 | replicate (S n) x = x <+> replicate n x 47 | 48 | clearIOTmp : IORef Nat -> IO () 49 | clearIOTmp tmp = do 50 | linesCnt <- readIORef tmp 51 | putStrErr $ Terminal.replicate linesCnt $ cursorUp1 <+> eraseLine End 52 | writeIORef tmp 0 53 | 54 | ||| Uses system stdout for permanent printing and stderr for temporary printing 55 | export 56 | HasIO io => HasTerminal io where 57 | TermTy = IORef Nat 58 | console = liftIO $ newIORef 0 59 | putTmp t str = liftIO $ do 60 | clearIOTmp t 61 | writeIORef t $ length $ lines str 62 | putStrErr str 63 | putOut t str = liftIO $ clearIOTmp t *> putStr str 64 | 65 | ||| Uses monadic writer to remember everything 66 | ||| written permanently to the terminal 67 | ||| 68 | ||| This implementation does not use any type of actual printing to any 69 | ||| real terminal, this is completely pure. 70 | export 71 | [StdoutOnly] MonadWriter (List String) m => HasTerminal m where 72 | TermTy = Unit 73 | console = pure () 74 | putTmp _ _ = pure () 75 | putOut _ str = tell [str] 76 | 77 | public export 78 | data StdoutOrTmp = Stdout | Tmp 79 | 80 | ||| Uses monadic writer to remember everything 81 | ||| written temporarily and permanently to the terminal 82 | ||| 83 | ||| The order of writes is completely preserved. 84 | ||| Type of the write is determined by the `StdoutOrTmp` discriminator. 85 | ||| 86 | ||| This implementation does not use any type of actual printing to any 87 | ||| real terminal, this is completely pure. 88 | export 89 | [StdoutAndTmp] MonadWriter (List (StdoutOrTmp, String)) m => HasTerminal m where 90 | TermTy = Unit 91 | console = pure () 92 | putTmp _ str = tell [(Tmp, str)] 93 | putOut _ str = tell [(Stdout, str)] 94 | -------------------------------------------------------------------------------- /src/Hedgehog/Internal/Util.idr: -------------------------------------------------------------------------------- 1 | module Hedgehog.Internal.Util 2 | 3 | import Data.DPair 4 | import Data.List 5 | import Data.Colist 6 | 7 | %default total 8 | 9 | -------------------------------------------------------------------------------- 10 | -- SafeDiv 11 | -------------------------------------------------------------------------------- 12 | 13 | ||| Interface providing a safe (total) division operation 14 | ||| by proving that the divisor is non-zero. 15 | public export 16 | interface Neg a => SafeDiv (0 a : Type) (0 pred : a -> Type) | a where 17 | total safeDiv' : (n,d : a) -> (0 prf : pred d) -> a 18 | 19 | public export 20 | SafeDiv Int (\d => d == 0 = False) where 21 | safeDiv' n d _ = n `div` d 22 | 23 | public export 24 | SafeDiv Integer (\d => d == 0 = False) where 25 | safeDiv' n d _ = n `div` d 26 | 27 | public export 28 | SafeDiv Double (\d => d == 0 = False) where 29 | safeDiv' n d _ = n / d 30 | 31 | public export total 32 | safeDiv : SafeDiv a pred => (n,d : a) -> {auto 0 ok : pred d} -> a 33 | safeDiv n d = safeDiv' n d ok 34 | 35 | public export total 36 | fromPred : (a -> Bool) -> a -> Maybe a 37 | fromPred p a = guard (p a) $> a 38 | 39 | -------------------------------------------------------------------------------- 40 | -- ToInteger 41 | -------------------------------------------------------------------------------- 42 | 43 | public export 44 | interface Num a => ToInteger a where 45 | toInteger : a -> Integer 46 | 47 | toNat : a -> Nat 48 | toNat = integerToNat . toInteger 49 | 50 | public export 51 | ToInteger Integer where toInteger = id 52 | 53 | public export 54 | ToInteger Int8 where toInteger = cast 55 | 56 | public export 57 | ToInteger Int16 where toInteger = cast 58 | 59 | public export 60 | ToInteger Int32 where toInteger = cast 61 | 62 | public export 63 | ToInteger Int64 where toInteger = cast 64 | 65 | public export 66 | ToInteger Int where toInteger = cast 67 | 68 | public export 69 | ToInteger Bits8 where toInteger = cast 70 | 71 | public export 72 | ToInteger Bits16 where toInteger = cast 73 | 74 | public export 75 | ToInteger Bits32 where toInteger = cast 76 | 77 | public export 78 | ToInteger Bits64 where toInteger = cast 79 | 80 | public export 81 | ToInteger Nat where 82 | toInteger = cast 83 | toNat = id 84 | 85 | public export 86 | ToInteger Double where toInteger = cast 87 | 88 | public export 89 | fromIntegral : ToInteger a => Num b => a -> b 90 | fromIntegral = fromInteger . toInteger 91 | 92 | public export 93 | round : Num a => Double -> a 94 | round v = 95 | let f := floor v 96 | v' := if v - f < 0.5 then f else ceiling v 97 | in fromInteger $ cast v' 98 | 99 | -------------------------------------------------------------------------------- 100 | -- (Lazy) List Utilities 101 | -------------------------------------------------------------------------------- 102 | 103 | public export 104 | iterateBefore : (p : a -> Bool) -> (a -> a) -> (v : a) -> Colist a 105 | iterateBefore p f = takeBefore p . iterate f 106 | 107 | public export 108 | iterateBefore0 : Eq a => Num a => (a -> a) -> (start : a) -> Colist a 109 | iterateBefore0 = iterateBefore (0 ==) 110 | 111 | ||| Prepends the first list in reverse order to the 112 | ||| second list. 113 | public export 114 | prepRev : List a -> List a -> List a 115 | prepRev [] ys = ys 116 | prepRev (x :: xs) ys = prepRev xs (x :: ys) 117 | 118 | public export 119 | signum : Ord a => Neg a => a -> a 120 | signum x = 121 | if x < 0 then (-1) else if x == 0 then 0 else 1 122 | 123 | -------------------------------------------------------------------------------- 124 | -- Colists 125 | -------------------------------------------------------------------------------- 126 | 127 | ||| Cons an element on to the front of a list unless it is already there. 128 | public export total 129 | consNub : Eq a => a -> Colist a -> Colist a 130 | consNub x [] = [x] 131 | consNub x l@(y :: xs) = if x == y then l else x :: l 132 | 133 | public export 134 | concatColist : Colist (Colist a) -> Colist a 135 | concatColist ((x :: xs) :: ys) = x :: concatColist (xs :: ys) 136 | concatColist ([] :: (x :: xs) :: ys) = x :: concatColist (xs :: ys) 137 | concatColist _ = [] 138 | 139 | public export 140 | concatMapColist : (a -> Colist b) -> Colist a -> Colist b 141 | concatMapColist f = concatColist . map f 142 | 143 | public export 144 | fromFoldable : Foldable f => f a -> Colist a 145 | fromFoldable = fromList . toList 146 | -------------------------------------------------------------------------------- /src/Hedgehog/Meta.idr: -------------------------------------------------------------------------------- 1 | ||| Facilities for testing Hedgehog using Hedgehog 2 | ||| 3 | ||| Module contains properties to check how Hedgehog behaves on given properties 4 | module Hedgehog.Meta 5 | 6 | import Control.Monad.Identity 7 | import Control.Monad.Writer 8 | 9 | import Data.List 10 | import Data.String 11 | 12 | import public Hedgehog 13 | 14 | %default total 15 | 16 | trimDeep : List String -> List String 17 | trimDeep = filter (not . null) . map trim 18 | 19 | annotateSeedIfNeeded : List String -> PropertyT () 20 | annotateSeedIfNeeded outs = do 21 | let seeds = filter (isInfixOf "rawStdGen") outs 22 | for_ seeds $ footnote . delay 23 | 24 | containsEach : 25 | (checkPrefixOnly : Bool) 26 | -> (actual, expected : List String) 27 | -> Bool 28 | containsEach _ [] (_::_) = False 29 | containsEach checkPrefixOnly (_::_) [] = checkPrefixOnly 30 | containsEach _ [] [] = True 31 | containsEach checkPrefixOnly (o::os) (i::is) = 32 | (i `isInfixOf` o) && containsEach checkPrefixOnly os is 33 | 34 | doCheck : 35 | (checkPrefixOnly : Bool) 36 | -> (expected : String) 37 | -> (forall m. HasTerminal m => Monad m => m ()) 38 | -> PropertyT () 39 | doCheck checkPrefixOnly expected checker = do 40 | let actual = trimDeep $ (>>= lines) $ execWriter $ checker @{StdoutOnly} 41 | annotateSeedIfNeeded actual 42 | diff actual (containsEach checkPrefixOnly) (trimDeep $ lines expected) 43 | 44 | ||| A property checking that Hedgehog being run on a particular property 45 | ||| with particular configuration prints expected string. 46 | ||| 47 | ||| The check passes if every line of Hedgehog's output contains a corresponding 48 | ||| line of `expected` string as a substring. Empty lines, leading and traling 49 | ||| spaces are ignored in both the `expected` string, and Hedgehog's output. 50 | export 51 | recheckGivenOutput : 52 | {default False checkPrefixOnly : Bool} 53 | -> (expected : String) 54 | -> (prop : Property) 55 | -> Size 56 | -> StdGen 57 | -> Property 58 | recheckGivenOutput expected prop sz sd = property $ 59 | doCheck checkPrefixOnly expected $ recheck sz sd prop 60 | 61 | ||| A property checking that Hedgehog being run on a default configuration 62 | ||| and a random seed prints expected string. 63 | ||| 64 | ||| The check passes if every line of Hedgehog's output contains a corresponding 65 | ||| line of `expected` string as a substring. Empty lines, leading and traling 66 | ||| spaces are ignored in both the `expected` string, and Hedgehog's output. 67 | export 68 | checkGivenOutput : 69 | {default False checkPrefixOnly : Bool} 70 | -> (expected : String) 71 | -> (prop : Property) 72 | -> Property 73 | checkGivenOutput expected prop = property $ do 74 | initSeed <- forAll anyBits64 75 | doCheck checkPrefixOnly expected $ 76 | ignore $ check @{ConstSeed $ mkStdGen initSeed} prop 77 | -------------------------------------------------------------------------------- /tests/Basic.idr: -------------------------------------------------------------------------------- 1 | module Basic 2 | 3 | import Data.List.Quantifiers 4 | import Hedgehog.Meta 5 | 6 | %default total 7 | 8 | namespace Assert 9 | 10 | export 11 | simplePosAssert : Property 12 | simplePosAssert = checkGivenOutput expected prop 13 | 14 | where 15 | prop : Property 16 | prop = property $ assert $ 4 == 4 17 | expected : String 18 | expected = "✓ passed 100 tests." 19 | 20 | export 21 | simpleNegAssert : Property 22 | simpleNegAssert = checkGivenOutput expected prop 23 | 24 | where 25 | prop : Property 26 | prop = property $ assert $ 5 == 4 27 | expected : String 28 | expected = 29 | """ 30 | ✗ failed after 1 test. 31 | This failure can be reproduced by running: 32 | > recheck 33 | """ 34 | 35 | namespace NoShrinkGen 36 | 37 | export 38 | simplePosGeneration : Property 39 | simplePosGeneration = checkGivenOutput expected prop 40 | 41 | where 42 | prop : Property 43 | prop = property $ do 44 | n <- forAll $ integral_ $ constant 1 999 45 | let _ : Integer := n 46 | assert $ n >= 1 && n <= 999 47 | expected : String 48 | expected = "✓ passed 100 tests." 49 | 50 | export 51 | simpleNegGeneration : Property 52 | simpleNegGeneration = 53 | recheckGivenOutput {checkPrefixOnly=True} expected prop 22 seed 54 | 55 | where 56 | seed : StdGen 57 | seed = rawStdGen 16892461356434811776 15079690130578850725 58 | prop : Property 59 | prop = property $ do 60 | n <- forAll $ integral_ $ constant 1 999 61 | let _ : Integer := n 62 | assert $ n >= 20 63 | expected : String 64 | expected = 65 | """ 66 | ✗ failed after 1 test. 67 | forAll 0 = 68 | 17 69 | This failure can be reproduced by running: 70 | > recheck 71 | """ 72 | 73 | export 74 | forallsPosGeneration : Property 75 | forallsPosGeneration = checkGivenOutput expected prop 76 | 77 | where 78 | prop : Property 79 | prop = property $ do 80 | let g = integral_ $ constant 1 999 81 | [n, m] <- forAlls [g, g] 82 | let _ : Integer := n 83 | let _ : Integer := m 84 | assert $ n >= 1 && n <= 999 85 | assert $ m >= 1 && m <= 999 86 | expected : String 87 | expected = "✓ passed 100 tests." 88 | 89 | export 90 | forallsNegGeneration : Property 91 | forallsNegGeneration = 92 | recheckGivenOutput {checkPrefixOnly=True} expected prop 7 seed 93 | 94 | where 95 | seed : StdGen 96 | seed = rawStdGen 17390955263926595516 17173145979079339501 97 | prop : Property 98 | prop = property $ do 99 | let g = integral_ $ constant 1 999 100 | [n, m] <- forAlls [g, g] 101 | let _ : Integer := n 102 | let _ : Integer := m 103 | assert $ n >= 20 && m >= 20 104 | expected : String 105 | expected = 106 | """ 107 | ✗ failed after 1 test. 108 | forAll 0 = 109 | 5 110 | forAll 1 = 111 | 798 112 | This failure can be reproduced by running: 113 | > recheck 114 | """ 115 | 116 | namespace ShrinkGen 117 | 118 | export 119 | simplePosGeneration : Property 120 | simplePosGeneration = checkGivenOutput expected prop 121 | 122 | where 123 | prop : Property 124 | prop = property $ do 125 | n <- forAll $ integral $ constant 1 999 126 | let _ : Integer := n 127 | assert $ n >= 1 && n <= 999 128 | expected : String 129 | expected = "✓ passed 100 tests." 130 | 131 | export 132 | simpleNegGeneration : Property 133 | simpleNegGeneration = 134 | recheckGivenOutput {checkPrefixOnly=True} expected prop 22 seed 135 | 136 | where 137 | seed : StdGen 138 | seed = rawStdGen 16892461356434811776 15079690130578850725 139 | 140 | prop : Property 141 | prop = property $ do 142 | n <- forAll $ integral $ constant 1 999 143 | let _ : Integer := n 144 | assert $ n >= 20 145 | expected : String 146 | expected = 147 | """ 148 | ✗ failed after 1 test. 149 | forAll 0 = 150 | 1 151 | This failure can be reproduced by running: 152 | > recheck 153 | """ 154 | 155 | export 156 | forallsPosGeneration : Property 157 | forallsPosGeneration = checkGivenOutput expected prop 158 | 159 | where 160 | prop : Property 161 | prop = property $ do 162 | let g = integral $ constant 1 999 163 | [n, m, k] <- forAlls [g, g, g] 164 | let _ : Integer := n 165 | let _ : Integer := m 166 | let _ : Integer := k 167 | assert $ n >= 1 && n <= 999 168 | assert $ m >= 1 && m <= 999 169 | assert $ k >= 1 && k <= 999 170 | expected : String 171 | expected = "✓ passed 100 tests." 172 | 173 | export 174 | forallsNegGeneration : Property 175 | forallsNegGeneration = 176 | recheckGivenOutput {checkPrefixOnly=True} expected prop 7 seed 177 | 178 | where 179 | seed : StdGen 180 | seed = rawStdGen 17390955263926595516 17173145979079339501 181 | 182 | prop : Property 183 | prop = property $ do 184 | let g = integral $ constant 1 999 185 | [n, m, k] <- forAlls [g, g, g] 186 | let _ : Integer := n 187 | let _ : Integer := m 188 | let _ : Integer := k 189 | assert $ n >= 20 190 | assert $ m >= 20 191 | assert $ k >= 20 192 | expected : String 193 | expected = 194 | """ 195 | ✗ failed after 1 test. 196 | forAll 0 = 197 | 1 198 | forAll 1 = 199 | 1 200 | forAll 2 = 201 | 1 202 | This failure can be reproduced by running: 203 | > recheck 204 | """ 205 | -------------------------------------------------------------------------------- /tests/Coverage.idr: -------------------------------------------------------------------------------- 1 | module Coverage 2 | 3 | import Hedgehog.Meta 4 | 5 | %default total 6 | 7 | export 8 | simpleCoverage : Property 9 | simpleCoverage = checkGivenOutput expected prop 10 | 11 | where 12 | prop : Property 13 | prop = verifiedTermination $ property $ do 14 | n <- forAll $ integral $ constantFrom 0 (-100) 100 15 | cover 30 "positive" $ n > 0 16 | cover 30 "negative" $ n < 0 17 | 18 | expected : String 19 | expected = """ 20 | ✓ passed 21 | 30.0% 22 | 30.0% 23 | """ 24 | 25 | failing "Can't find an implementation for So" 26 | badSimpleCoverage : Property 27 | badSimpleCoverage = checkGivenOutput expected prop 28 | 29 | where 30 | prop : Property 31 | prop = verifiedTermination $ property $ do 32 | n <- forAll $ integral $ constantFrom 0 (-100) 100 33 | cover 45 "positive" $ n > 0 34 | cover 120 "negative" $ n < 0 -- too big value for percentage 35 | 36 | expected : String 37 | expected = """ 38 | ✓ passed 39 | 30.0% 40 | 30.0% 41 | """ 42 | 43 | -------------------------------------------------------------------------------- /tests/Functions/DeriveCogen.idr: -------------------------------------------------------------------------------- 1 | module Functions.DeriveCogen 2 | 3 | import Derive.Cogen 4 | 5 | import Hedgehog.Meta 6 | 7 | %language ElabReflection 8 | 9 | data X = A | B Nat | C String 10 | 11 | %runElab derive "X" [Cogen] 12 | 13 | data Y a = YA a | YB X | YC (Y a) (Y Nat) 14 | 15 | %runElab derive "Y" [Cogen] 16 | 17 | %runElab derivePattern "Vect" [I, P] [Cogen] 18 | 19 | data Z : Nat -> Type -> Type where 20 | Z1 : Z 1 a 21 | Z2 : Y a -> Vect n (Z n a) -> Z (S n) a 22 | 23 | %runElab derivePattern "Z" [I, P] [Cogen] 24 | 25 | export 26 | printZFun : Property 27 | printZFun = recheckGivenOutput expected prop 0 seed where 28 | seed : StdGen 29 | seed = rawStdGen 15646808624686066109 7037936686351694591 30 | prop : Property 31 | prop = property $ do 32 | fn <- 33 | forAllWith (const "") $ 34 | dargfun_ {b = \n => Z n String} $ nat $ constant 0 100 35 | annotate "fn Z1 = \{show $ fn Z1}" 36 | annotate "fn (Z2 (YA \"foo\") [Z1]) = \{show $ fn (Z2 (YA "foo") [Z1])}" 37 | annotate "fn (Z2 (YA \"lala\") [Z1]) = \{show $ fn (Z2 (YA "lala") [Z1])}" 38 | assert $ fn Z1 == 0 || fn (Z2 (YA "lala") [Z1]) == 0 39 | expected : String 40 | expected = 41 | """ 42 | ✗ failed after 1 test. 43 | forAll 0 = 44 | 45 | forAll 1 = 46 | fn Z1 = 89 47 | forAll 2 = 48 | fn (Z2 (YA "foo") [Z1]) = 49 49 | forAll 3 = 50 | fn (Z2 (YA "lala") [Z1]) = 56 51 | This failure can be reproduced by running: 52 | > recheck 53 | """ 54 | -------------------------------------------------------------------------------- /tests/Functions/NoShrink.idr: -------------------------------------------------------------------------------- 1 | module Functions.NoShrink 2 | 3 | import Hedgehog.Meta 4 | 5 | [FnStub] Show (Nat -> Nat) where 6 | show _ = "" 7 | 8 | export 9 | simpleFunPrint : Property 10 | simpleFunPrint = recheckGivenOutput expected prop 4 (mkStdGen 100) 11 | 12 | where 13 | prop : Property 14 | prop = property $ do 15 | fn <- forAll @{FnStub} $ function_ $ nat $ constant 0 999 16 | let domain : List _ := 17 | [0, 1, 2, 3, 100, 1000, 10000, 100000, 10000000, 100000000] 18 | let codomain := fn <$> domain 19 | annotate "args: \{show domain}" 20 | annotate "vals: \{show codomain}" 21 | assert False -- to print annotations 22 | expected : String 23 | expected = 24 | """ 25 | ✗ failed after 1 test. 26 | forAll 0 = 27 | 28 | forAll 1 = 29 | args: [0, 1, 2, 3, 100, 1000, 10000, 100000, 10000000, 100000000] 30 | forAll 2 = 31 | vals: [617, 730, 81, 100, 616, 76, 835, 404, 943, 729] 32 | This failure can be reproduced by running: 33 | > recheck 34 | """ 35 | 36 | export 37 | simpleFunNeg : Property 38 | simpleFunNeg = recheckGivenOutput expected prop 0 seed 39 | 40 | where 41 | seed : StdGen 42 | seed = rawStdGen 9961102074462960391 5599095101378422999 43 | prop : Property 44 | prop = property $ do 45 | fn <- forAll @{FnStub} $ function_ $ nat $ constant 0 999 46 | n <- forAll $ nat $ constant 0 1000000000 47 | assert $ fn n >= 100 48 | expected : String 49 | expected = 50 | """ 51 | ✗ failed after 1 test. 52 | forAll 0 = 53 | 54 | forAll 1 = 55 | 86056943 56 | This failure can be reproduced by running: 57 | > recheck 58 | """ 59 | 60 | export 61 | simpleFunPos : Property 62 | simpleFunPos = checkGivenOutput expected prop 63 | 64 | where 65 | prop : Property 66 | prop = property $ do 67 | natList <- forAll $ list (constant 1 10) $ nat $ constant 0 99 68 | fn <- forAll @{FnStub} $ function_ $ nat $ constant 100 999 69 | let newList = map fn natList 70 | annotate $ show newList 71 | assert $ all (>= 100) newList 72 | expected : String 73 | expected = 74 | """ 75 | ✓ passed 100 tests. 76 | """ 77 | -------------------------------------------------------------------------------- /tests/Functions/Shrink.idr: -------------------------------------------------------------------------------- 1 | module Functions.Shrink 2 | 3 | import Hedgehog.Meta 4 | 5 | export 6 | simpleFunPrint : Property 7 | simpleFunPrint = checkGivenOutput expected prop 8 | 9 | where 10 | prop : Property 11 | prop = property $ do 12 | fn <- forAll $ function $ nat $ constant 0 999 13 | let domain : List Nat = 14 | [0, 1, 2, 3, 100, 1000, 10000, 100000, 10000000, 100000000] 15 | let codomain = apply fn <$> domain 16 | annotate "args: \{show domain}" 17 | annotate "vals: \{show codomain}" 18 | assert False -- to print annotations 19 | expected : String 20 | expected = 21 | """ 22 | ✗ failed after 23 | forAll 0 = 24 | _ -> 0 25 | forAll 1 = 26 | args: [0, 1, 2, 3, 100, 1000, 10000, 100000, 10000000, 100000000] 27 | forAll 2 = 28 | vals: [0, 0, 0, 0, 0, 0, 0, 0, 0, 0] 29 | This failure can be reproduced by running: 30 | > recheck 31 | """ 32 | 33 | export 34 | fancyFunPrint : Property 35 | fancyFunPrint = checkGivenOutput expected prop 36 | 37 | where 38 | prop : Property 39 | prop = property $ do 40 | fn <- forAll $ function $ nat $ constant 0 999 41 | let fn = apply fn 42 | let domain : List Nat = 43 | [0, 1, 2, 3, 100, 1000, 10000, 100000, 10000000, 100000000] 44 | let codomain := fn <$> domain 45 | annotate "args: \{show domain}" 46 | annotate "vals: \{show codomain}" 47 | assert (fn 0 == 0) 48 | expected : String 49 | expected = 50 | """ 51 | ✗ failed after 52 | forAll 0 = 53 | 0 -> 1 54 | _ -> 0 55 | forAll 1 = 56 | args: [0, 1, 2, 3, 100, 1000, 10000, 100000, 10000000, 100000000] 57 | forAll 2 = 58 | vals: [1, 0, 0, 0, 0, 0, 0, 0, 0, 0] 59 | This failure can be reproduced by running: 60 | > recheck 61 | """ 62 | 63 | export 64 | fancyListFunPrint : Property 65 | fancyListFunPrint = checkGivenOutput expected prop 66 | 67 | where 68 | prop : Property 69 | prop = property $ do 70 | fn <- forAll $ function $ nat $ constant 0 999 71 | let fn = apply fn 72 | let domain : List (List Nat) = [[], [0], [1], [0, 1], [1, 0]] 73 | let codomain = fn <$> domain 74 | annotate "args: \{show domain}" 75 | annotate "vals: \{show codomain}" 76 | assert (fn [1] == 0) 77 | expected : String 78 | expected = 79 | """ 80 | ✗ failed after 81 | forAll 0 = 82 | [1] -> 1 83 | _ -> 0 84 | forAll 1 = 85 | args: [[], [0], [1], [0, 1], [1, 0]] 86 | forAll 2 = 87 | vals: [0, 0, 1, 0, 0] 88 | This failure can be reproduced by running: 89 | > recheck 90 | """ 91 | 92 | export 93 | simpleFunPos : Property 94 | simpleFunPos = checkGivenOutput expected prop 95 | 96 | where 97 | prop : Property 98 | prop = property $ do 99 | natList <- forAll $ list (constant 1 10) $ nat $ constant 0 99 100 | fn <- forAll $ function $ nat $ constant 100 999 101 | let newList = map (apply fn) natList 102 | annotate $ show newList 103 | assert $ all (>= 100) newList 104 | expected : String 105 | expected = 106 | """ 107 | ✓ passed 100 tests. 108 | """ 109 | 110 | export 111 | simpleFunNeg : Property 112 | simpleFunNeg = checkGivenOutput {checkPrefixOnly=True} expected prop 113 | 114 | where 115 | prop : Property 116 | prop = property $ do 117 | fn <- forAll $ function $ nat $ constant 0 999 118 | n <- forAll $ nat $ constant 0 1000000000 119 | assert $ apply fn n >= 100 120 | expected : String 121 | expected = 122 | """ 123 | ✗ failed after 124 | 125 | forAll 0 = 126 | _ -> 0 127 | 128 | forAll 1 = 129 | 0 130 | 131 | This failure can be reproduced by running: 132 | > recheck 133 | """ 134 | -------------------------------------------------------------------------------- /tests/Tests.idr: -------------------------------------------------------------------------------- 1 | module Tests 2 | 3 | import Hedgehog 4 | 5 | -- Modules with particluar tests: 6 | 7 | import Basic 8 | import Coverage 9 | import Functions.NoShrink 10 | import Functions.Shrink 11 | import Functions.DeriveCogen 12 | 13 | main : IO Unit 14 | main = 15 | test 16 | [ "very basic tests" `MkGroup` 17 | [ ("simplePosAssert", Basic.Assert.simplePosAssert) 18 | , ("simpleNegAssert", Basic.Assert.simpleNegAssert) 19 | ] 20 | , "basic non-shrinking generation" `MkGroup` 21 | [ ("simplePosGeneration", Basic.NoShrinkGen.simplePosGeneration) 22 | , ("simpleNegGeneration", Basic.NoShrinkGen.simpleNegGeneration) 23 | , ("forallsPosGeneration", Basic.NoShrinkGen.forallsPosGeneration) 24 | , ("forallsNegGeneration", Basic.NoShrinkGen.forallsNegGeneration) 25 | ] 26 | , "basic shrinking generation" `MkGroup` 27 | [ ("simplePosGeneration", Basic.ShrinkGen.simplePosGeneration) 28 | , ("simpleNegGeneration", Basic.ShrinkGen.simpleNegGeneration) 29 | , ("forallsPosGeneration", Basic.ShrinkGen.forallsPosGeneration) 30 | , ("forallsNegGeneration", Basic.ShrinkGen.forallsNegGeneration) 31 | ] 32 | , "coverage checking" `MkGroup` 33 | [ ("simpleCoverage", Coverage.simpleCoverage) 34 | ] 35 | , "non-shrinking function generaton" `MkGroup` 36 | [ ("simpleFunPrint", Functions.NoShrink.simpleFunPrint) 37 | , ("simpleFunPos" , Functions.NoShrink.simpleFunPos) 38 | , ("simpleFunNeg" , Functions.NoShrink.simpleFunNeg) 39 | ] 40 | , "shrinking function generaton" `MkGroup` 41 | [ ("simpleFunPrint" , Functions.Shrink.simpleFunPrint) 42 | , ("fancyFunPrint" , Functions.Shrink.fancyFunPrint) 43 | , ("fancyListFunPrint", Functions.Shrink.fancyListFunPrint) 44 | , ("simpleFunPos" , Functions.Shrink.simpleFunPos) 45 | , ("simpleFunNeg" , Functions.Shrink.simpleFunNeg) 46 | ] 47 | , "cogen derivation" `MkGroup` 48 | [ ("printZFun", Functions.DeriveCogen.printZFun) 49 | ] 50 | ] 51 | -------------------------------------------------------------------------------- /tests/tests.ipkg: -------------------------------------------------------------------------------- 1 | package hedgehog-tests 2 | version = 0.1.0 3 | executable = runtests 4 | 5 | depends = hedgehog 6 | main = Tests 7 | --------------------------------------------------------------------------------