├── .ghcid ├── .gitignore ├── .hlint.yaml ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── ROADMAP.md ├── apropos.cabal ├── cabal.project ├── examples ├── Main.hs └── Spec │ ├── IntCompact.hs │ └── IntSimple.hs ├── flake.lock ├── flake.nix ├── fourmolu.yaml ├── hie.yaml └── src ├── Apropos.hs └── Apropos ├── Description.hs ├── Generator.hs └── Runner.hs /.ghcid: -------------------------------------------------------------------------------- 1 | --command="stack repl --ghc-options='-j'" --allow-eval -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Node artifact files 2 | node_modules/ 3 | .stack-work/ 4 | dist/ 5 | dist-newstyle/ 6 | 7 | # nix-build results 8 | result 9 | result-* 10 | 11 | # direnv 12 | #.envrc 13 | 14 | .swp 15 | 16 | 17 | #vscode 18 | .vscode/ 19 | 20 | nohup.out 21 | 22 | # JetBrains IDE 23 | .idea/ 24 | 25 | # Generated by MacOS 26 | .DS_Store 27 | 28 | # Generated by Windows 29 | Thumbs.db 30 | 31 | # Applications 32 | *.app 33 | *.exe 34 | *.war 35 | 36 | # Large media files 37 | *.mp4 38 | *.tiff 39 | *.avi 40 | *.flv 41 | *.mov 42 | *.wmv 43 | 44 | # Neovim local configuration 45 | .nvimrc 46 | 47 | # Local configuration files 48 | cabal.project.local* 49 | 50 | # direnv 51 | .envrc 52 | .direnv 53 | 54 | # Hoogle 55 | .hoogle/ 56 | .haddock/ 57 | 58 | weeder.dhall 59 | 60 | cabal.project.local 61 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | - ignore: {name: "Use <$>"} 2 | - warn: {name: Use explicit module import list} 3 | - warn: {name: Use module export list} 4 | - ignore: {name: "Use newtype instead of data"} -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for `apropos-tx` 2 | 3 | This format is based on [Keep A Changelog](https://keepachangelog.com/en/1.0.0). 4 | 5 | ## 1.0 -- 6 | 7 | * Initial release. 8 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | APPENDIX: How to apply the Apache License to your work. 179 | 180 | To apply the Apache License to your work, attach the following 181 | boilerplate notice, with the fields enclosed by brackets "[]" 182 | replaced with your own identifying information. (Don't include 183 | the brackets!) The text should be enclosed in the appropriate 184 | comment syntax for the file format. We also recommend that a 185 | file or class name and description of purpose be included on the 186 | same "printed page" as the copyright notice for easier 187 | identification within third-party archives. 188 | 189 | Copyright [yyyy] [name of copyright owner] 190 | 191 | Licensed under the Apache License, Version 2.0 (the "License"); 192 | you may not use this file except in compliance with the License. 193 | You may obtain a copy of the License at 194 | 195 | http://www.apache.org/licenses/LICENSE-2.0 196 | 197 | Unless required by applicable law or agreed to in writing, software 198 | distributed under the License is distributed on an "AS IS" BASIS, 199 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 200 | See the License for the specific language governing permissions and 201 | limitations under the License. 202 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # The plutus-pab commands, contracts and hoogle environment 2 | # are made availible by the nix shell defined in shell.nix. 3 | # In most cases you should execute Make after entering nix-shell. 4 | 5 | .PHONY: hoogle build test watch ghci readme_contents \ 6 | format lint refactor requires_nix_shell haddock 7 | 8 | usage: 9 | @echo "usage: make [OPTIONS]" 10 | @echo 11 | @echo "Available options:" 12 | @echo " FLAGS -- Additional options passed to --ghc-options" 13 | @echo 14 | @echo "Available commands:" 15 | @echo " hoogle -- Start local hoogle" 16 | @echo " build -- Run cabal v2-build" 17 | @echo " watch -- Track files and run 'make build' on change" 18 | @echo " test -- Run cabal v2-test" 19 | @echo " costing -- Run cost-estimation benchmark" 20 | @echo " coverage -- Generate a coverage report of the tests" 21 | @echo " ghci -- Run stack ghci" 22 | @echo " format -- Apply source code formatting with fourmolu" 23 | @echo " format_check -- Check source code formatting without making changes" 24 | @echo " cabalfmt -- Apply cabal formatting with cabal-fmt" 25 | @echo " cabalfmt_check -- Check cabal files for formatting errors without making changes" 26 | @echo " nixpkgsfmt -- Apply nix formatting with nixfmt" 27 | @echo " nixpkgsfmt_check -- Check nix files for format errors" 28 | @echo " lint -- Check the sources with hlint" 29 | @echo " refactor -- Automatically apply hlint refactors, with prompt" 30 | @echo " readme_contents -- Add table of contents to README" 31 | @echo " update_plutus -- Update plutus version with niv" 32 | 33 | hoogle: requires_nix_shell 34 | pkill hoogle || true 35 | hoogle generate --local=.haddock --database=.hoogle/local.hoo 36 | hoogle server --local -p 8080 >> /dev/null & 37 | hoogle server --local --database=.hoogle/local.hoo -p 8081 >> /dev/null & 38 | 39 | STACK_EXE_PATH = $(shell stack $(STACK_FLAGS) path --local-install-root)/bin 40 | 41 | ifdef FLAGS 42 | GHC_FLAGS = --ghc-options "$(FLAGS)" 43 | endif 44 | 45 | build: requires_nix_shell apropos.cabal 46 | cabal v2-build $(GHC_FLAGS) 47 | 48 | watch: requires_nix_shell apropos.cabal 49 | while sleep 1; do find plutus-extra.cabal src test | entr -cd make build; done 50 | 51 | test: requires_nix_shell apropos.cabal 52 | cabal v2-test 53 | 54 | ghci: requires_nix_shell apropos.cabal 55 | cabal v2-repl $(GHC_FLAGS) 56 | 57 | coverage: apropos.cabal 58 | nix-build --arg doCoverage true -A projectCoverageReport 59 | 60 | # Source dirs to run fourmolu on 61 | FORMAT_SOURCES := $(shell find -name '*.hs' -not -path './dist-*/*') 62 | 63 | # Extensions we need to tell fourmolu about 64 | FORMAT_EXTENSIONS := -o -XTypeApplications -o -XImportQualifiedPost -o -XPatternSynonyms -o -XBangPatterns 65 | 66 | # Run fourmolu formatter 67 | format: requires_nix_shell 68 | fourmolu --mode inplace --check-idempotence $(FORMAT_EXTENSIONS) $(FORMAT_SOURCES) 69 | 70 | # Check formatting (without making changes) 71 | format_check: requires_nix_shell 72 | fourmolu --mode check --check-idempotence $(FORMAT_EXTENSIONS) $(FORMAT_SOURCES) 73 | 74 | CABAL_SOURCES := $(shell fd -e cabal) 75 | 76 | cabalfmt: requires_nix_shell 77 | cabal-fmt --inplace $(CABAL_SOURCES) 78 | 79 | cabalfmt_check: requires_nix_shell 80 | cabal-fmt --check $(CABAL_SOURCES) 81 | 82 | # Nix files to format 83 | NIX_SOURCES := $(shell fd -e nix) 84 | 85 | nixpkgsfmt: requires_nix_shell 86 | nixpkgs-fmt $(NIX_SOURCES) 87 | 88 | nixpkgsfmt_check: requires_nix_shell 89 | nixpkgs-fmt --check $(NIX_SOURCES) 90 | 91 | # Check with hlint, currently I couldn't get --refactor to work 92 | lint: requires_nix_shell 93 | hlint $(FORMAT_SOURCES) 94 | 95 | # Apply automatic hlint refactors, with prompt 96 | refactor: requires_nix_shell 97 | for src in $(FORMAT_SOURCES) ; do hlint --refactor --refactor-options='-i -s' $$src ; done 98 | 99 | readme_contents: 100 | echo "this command is not nix-ified, you may receive an error from npx" 101 | npx markdown-toc ./README.md --no-firsth1 102 | 103 | # Target to use as dependency to fail if not inside nix-shell 104 | requires_nix_shell: 105 | @ [ -v IN_NIX_SHELL ] || echo "The $(MAKECMDGOALS) target must be run from inside nix-shell" 106 | @ [ -v IN_NIX_SHELL ] || (echo " run 'nix-shell --pure' first" && false) 107 | 108 | 109 | PLUTUS_BRANCH = $(shell jq '.plutus.branch' ./nix/sources.json ) 110 | PLUTUS_REPO = $(shell jq '.plutus.owner + "/" + .plutus.repo' ./nix/sources.json ) 111 | PLUTUS_REV = $(shell jq '.plutus.rev' ./nix/sources.json ) 112 | PLUTUS_SHA256 = $(shell jq '.plutus.sha256' ./nix/sources.json ) 113 | 114 | update_plutus: 115 | @echo "Updating plutus version to latest commit at $(PLUTUS_REPO) $(PLUTUS_BRANCH)" 116 | niv update plutus 117 | @echo "Latest commit: $(PLUTUS_REV)" 118 | @echo "Sha256: $(PLUTUS_SHA256)" 119 | @echo "Make sure to update the plutus rev in cabal.project with:" 120 | @echo " commit: $(PLUTUS_REV)" 121 | @echo "This may require further resolution of dependency versions." 122 | 123 | haddock: requires_nix_shell 124 | cabal haddock --haddock-html --haddock-hoogle --builddir=.haddock 125 | 126 | format_apply_all: format cabalfmt nixpkgsfmt lint refactor 127 | 128 | faa: format_apply_all 129 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `apropos` 2 | 3 | Hedgehog generation that sniffs out edge cases. 4 | 5 | ## Why `apropos`? 6 | 7 | Traditionally, Haskell programmers have used property testing, starting with the 8 | legendary [QuickCheck](https://hackage.haskell.org/package/QuickCheck), to test 9 | their code. This entails writing properties that should hold about your program, 10 | essentially as functions from arbitrary types to `Bool`, and the library tests 11 | that against random data, trying to find counterexamples that would represent 12 | incorrect code. 13 | 14 | The problem with this is, property testing uses relatively simple data 15 | distributions, and there are many bugs that are activated only by very specific 16 | values - so-called 'edge cases', that these generators are very unlikely to find. 17 | 18 | We can motivate this with an example, based on : 19 | 20 | The [abs](https://hackage.haskell.org/package/base/docs/Prelude.html#v:abs) 21 | function from Prelude is supposed to return the absolute value of a number. 22 | 23 | Therefore, this function should always hold: 24 | 25 | ```haskell 26 | absIsAlwaysPositive :: Int -> Bool 27 | absIsAlwaysPositive n = abs n >= 0 28 | ``` 29 | 30 | Unfortunately, due to two's complement arithmetic, the negation of 31 | `minBound :: Int` is not representable as an `Int`. Prelude's `abs` function just 32 | gives up and returns `minBound`. Hence: 33 | 34 | ```haskell 35 | >>> abs minBound :: Int 36 | -9223372036854775808 37 | >>> absIsAlwaysPositive minBound 38 | False 39 | ``` 40 | 41 | Property testing is unlikely to catch this, though: 42 | ```haskell 43 | >>> quickCheck absIsAlwaysPositive 44 | +++ OK, passed 100 tests. 45 | ``` 46 | 47 | The solution is to write additional unit or property tests for any edge cases you 48 | can think of. This quickly becomes tedious. As the complexity of your code grows, 49 | this can become more and more of a problem, and you won't know if you've 50 | missed something. 51 | 52 | ## What is `apropos`? 53 | `apropos` integrates with the [Hedgehog]() testing library and attempts to solve this problem using 'description types', which describe and automatically test against 54 | edge cases. 55 | 56 | The core of `apropos` is the `Description` typeclass. You define an instance of 57 | this class to start testing your code. 58 | 59 | ```haskell 60 | class Description d a | d -> a where 61 | describe :: a -> d 62 | 63 | refineDescription :: Formula (Attribute d) 64 | refineDescription = Yes 65 | 66 | genDescribed :: (MonadGen m) => d -> m a 67 | ``` 68 | 69 | `a` is the type of your test data. At present, only one value can be tested 70 | against at a time, but you can work around this by using a product type. 71 | 72 | `d` is a type you define describing the interesting properties of `a`. This is 73 | known as the 'description type'. 74 | 75 | You begin by defining a function `describe` that generates a description from a 76 | value. 77 | 78 | Whilst it is theoretically possible to define an ADT that precisely captures any 79 | set of properties, in practice this may be difficult or unergonomic to do. Instead, 80 | You may restrict which descriptions are valid using the optional `refineDescription` 81 | method, using a logical formula. See the Haddocks for `Attribute` for more details. 82 | 83 | Finally, you write a `Hedgehog` generator that generates a value of type `a` matching 84 | a given description. 85 | 86 | This allows `apropos`, using the magic of SAT solvers, to run a given test over 87 | all combinations of properties, hopefully testing against all relevant edge cases. 88 | 89 | Let's use this to find our bug in `abs`. 90 | 91 | First, let's capture the interesting properties and possible edge cases of `Int`: 92 | ```haskell 93 | data IntDescr = IntDescr 94 | { sign :: Sign 95 | , size :: Size 96 | , isBound :: Bool -- Is this equal to `minBound` or `maxBound`? 97 | } 98 | deriving stock (Generic, Eq, Ord, Show) 99 | 100 | data Sign = Positive | Negative | Zero 101 | deriving stock (Generic, Eq, Ord, Show) 102 | 103 | data Size = Large | Small 104 | deriving stock (Generic, Eq, Ord, Show) 105 | ``` 106 | 107 | We need `Ord` for the implementation of `apropos`. `Show` is needed by `Hedgehog`. 108 | `Generic` (from `GHC.Generics`) is required 109 | for all description types, including the types of their fields recursively. 110 | 111 | Now let's define our `Description` instance, asserting that `IntDescr` describes 112 | `Int`: 113 | 114 | ```haskell 115 | instance Description IntDescr Int where 116 | ``` 117 | 118 | Next, we derive desciptions: 119 | 120 | ```haskell 121 | describe :: Int -> IntDescr 122 | describe i = 123 | IntDescr 124 | { sign = 125 | case compare i 0 of 126 | GT -> Positive 127 | EQ -> Zero 128 | LT -> Negative 129 | , size = 130 | if i > 10 || i < -10 131 | then Large 132 | else Small 133 | , isBound = i == minBound || i == maxBound 134 | } 135 | ``` 136 | 137 | Not all constructible `IntDescr` values are valid descriptions - You can't have 138 | a `Large` `Zero` or a `Small` `isBound`. So we implement `refineDescription` to 139 | exclude these: 140 | 141 | ```haskell 142 | refineDescription :: Formula (Attribute IntDescr) 143 | refineDescription = 144 | All 145 | [ attr [("IntDescr", "sign")] "Zero" :->: attr [("IntDescr", "size")] "Small" 146 | , attr [("IntDescr", "isBound")] "True" :->: attr [("IntDescr", "size")] "Large" 147 | ] 148 | ``` 149 | 150 | We now write a Hedgehog generator that generates an `Int` matching a given 151 | description: 152 | 153 | ```haskell 154 | genDescribed :: (MonadGen m) => IntDescr -> m Int 155 | genDescribed s = 156 | case sign s of 157 | Zero -> pure 0 158 | s' -> intGen s' 159 | where 160 | bound :: Sign -> Int 161 | bound Positive = maxBound 162 | bound Negative = minBound 163 | bound Zero = 0 164 | 165 | sig :: Sign -> Int -> Int 166 | sig Negative = negate 167 | sig _ = id 168 | 169 | intGen :: (MonadGen m) => Sign -> m Int 170 | intGen s' = 171 | if isBound s 172 | then pure (bound s') 173 | else case size s of 174 | Small -> int (linear (sig s' 1) (sig s' 10)) 175 | Large -> int (linear (sig s' 11) (bound s' - sig s' 1)) 176 | ``` 177 | 178 | The `Description` typeclass is lawful: 179 | 180 | ```haskell 181 | -- Given a value `a` generated from a generator for a description `d` 182 | -- (genDescribed d), the description of `a` (describe a) equals `d`. 183 | forall d. forAll (genDescribed d) >>= (\a -> describe a === d) 184 | ``` 185 | 186 | A `selfTest` method is provided to test that this law holds, and build confidence 187 | that our `Description` instance is correct. 188 | 189 | ```haskell 190 | intSimpleSelfTest :: Group 191 | intSimpleSelfTest = 192 | Group 193 | "self test" 194 | (selfTest @IntDescr) 195 | ``` 196 | 197 | ```haskell 198 | self test 199 | IntDescr {sign = Positive, size = Large, isBound = False}: OK (0.03s) 200 | ✓ IntDescr {sign = Positive, size = Large, isBound = False} passed 100 tests. 201 | IntDescr {sign = Positive, size = Large, isBound = True}: OK (0.03s) 202 | ✓ IntDescr {sign = Positive, size = Large, isBound = True} passed 100 tests. 203 | IntDescr {sign = Positive, size = Small, isBound = False}: OK (0.04s) 204 | ✓ IntDescr {sign = Positive, size = Small, isBound = False} passed 100 tests. 205 | IntDescr {sign = Negative, size = Large, isBound = False}: OK (0.05s) 206 | ✓ IntDescr {sign = Negative, size = Large, isBound = False} passed 100 tests. 207 | IntDescr {sign = Negative, size = Large, isBound = True}: OK (0.03s) 208 | ✓ IntDescr {sign = Negative, size = Large, isBound = True} passed 100 tests. 209 | IntDescr {sign = Negative, size = Small, isBound = False}: OK (0.03s) 210 | ✓ IntDescr {sign = Negative, size = Small, isBound = False} passed 100 tests. 211 | IntDescr {sign = Zero, size = Small, isBound = False}: OK (0.03s) 212 | ✓ IntDescr {sign = Zero, size = Small, isBound = False} passed 100 tests. 213 | ``` 214 | 215 | Now let's test our function! 216 | 217 | We use the `runTests` function and the `AproposTest` type to define our test: 218 | 219 | ```haskell 220 | runTests :: AproposTest d a -> [(s, Property)] 221 | 222 | data AproposTest d a = AproposTest 223 | { expect :: d -> Bool 224 | , aproposTest :: a -> PropertyT IO () 225 | } 226 | ``` 227 | 228 | `expect` is a predicate that defines whether the given description should cause 229 | the test to pass or fail. `apropos` by default also tests the negation of each 230 | property to ensure it fails. You can filter out properties you don't want to 231 | test at all using `runTestsWhere`. 232 | 233 | `aproposTest` is a `Hedgehog` property test that tests agains the given value `a`. 234 | 235 | The return type of `runTests` is `IsString s => [(s, Property)]`, which can be 236 | plugged straight into Hedgehog's `Group`. 237 | 238 | So our `abs` test looks like this: 239 | 240 | ```haskell 241 | absTest :: Group 242 | absTest = 243 | Group 244 | "apropos testing" 245 | $ runTests @IntDescr 246 | AproposTest 247 | { expect = const True -- should hold for all negative integers 248 | , aproposTest = \n -> assert $ abs n >= 0 249 | } 250 | ``` 251 | 252 | And we find the bug! 253 | 254 | ```haskell 255 | apropos testing 256 | IntDescr {sign = Positive, size = Large, isBound = False}: OK (0.04s) 257 | ✓ IntDescr {sign = Positive, size = Large, isBound = False} passed 100 tests. 258 | IntDescr {sign = Positive, size = Large, isBound = True}: OK (0.02s) 259 | ✓ IntDescr {sign = Positive, size = Large, isBound = True} passed 100 tests. 260 | IntDescr {sign = Positive, size = Small, isBound = False}: OK (0.04s) 261 | ✓ IntDescr {sign = Positive, size = Small, isBound = False} passed 100 tests. 262 | IntDescr {sign = Negative, size = Large, isBound = False}: OK (0.04s) 263 | ✓ IntDescr {sign = Negative, size = Large, isBound = False} passed 100 tests. 264 | IntDescr {sign = Negative, size = Large, isBound = True}: FAIL (0.03s) 265 | ✗ IntDescr {sign = Negative, size = Large, isBound = True} failed at src/Apropos/Runner.hs:25:9 266 | after 1 test. 267 | 268 | ┏━━ src/Apropos/Generator.hs ━━━ 269 | 15 ┃ runTest :: (Show a, Description d a) => (a -> PropertyT IO ()) -> d -> Property 270 | 16 ┃ runTest cond d = property $ forAll (genDescribed d) >>= cond 271 | ┃ │ -9223372036854775808 272 | 273 | ┏━━ src/Apropos/Runner.hs ━━━ 274 | 20 ┃ runAproposTest :: forall d a. (Description d a, Show a) => AproposTest d a -> d -> Property 275 | 21 ┃ runAproposTest atest d = 276 | 22 ┃ runTest 277 | 23 ┃ ( \a -> do 278 | 24 ┃ b <- passes (aproposTest atest a) 279 | 25 ┃ expect atest d === b 280 | ┃ ^^^^^^^^^^^^^^^^^^^^ 281 | ┃ │ ━━━ Failed (- lhs) (+ rhs) ━━━ 282 | ┃ │ - True 283 | ┃ │ + False 284 | 26 ┃ ) 285 | 27 ┃ d 286 | 28 ┃ where 287 | 29 ┃ passes :: PropertyT IO () -> PropertyT IO Bool 288 | 30 ┃ passes = 289 | 31 ┃ PropertyT 290 | 32 ┃ . TestT 291 | 33 ┃ . ExceptT 292 | 34 ┃ . fmap (Right . isRight) 293 | 35 ┃ . runExceptT 294 | 36 ┃ . unTest 295 | 37 ┃ . unPropertyT 296 | 297 | This failure can be reproduced by running: 298 | > recheck (Size 0) (Seed 17184365450024726384 16839839501823744203) IntDescr {sign = Negative, size = Large, isBound = True} 299 | 300 | Use '--hedgehog-replay "Size 0 Seed 17184365450024726384 16839839501823744203"' to reproduce. 301 | 302 | Use -p '/apropos testing.IntDescr {sign = Negative, size = Large, isBound = True}/' to rerun this test only. 303 | IntDescr {sign = Negative, size = Small, isBound = False}: OK (0.06s) 304 | ✓ IntDescr {sign = Negative, size = Small, isBound = False} passed 100 tests. 305 | IntDescr {sign = Zero, size = Small, isBound = False}: OK (0.01s) 306 | ✓ IntDescr {sign = Zero, size = Small, isBound = False} passed 100 tests. 307 | ``` 308 | 309 | Given `minBound` (`IntDescr {sign = Negative, size = Large, isBound = True}`), 310 | the test suite shows that the function return is incorrect. 311 | 312 | Happy testing! -------------------------------------------------------------------------------- /ROADMAP.md: -------------------------------------------------------------------------------- 1 | Apropos is a project whose goal is intended to allow effective testing of Plutus contracts. This spans running Plutus dApps as full transactions in test suites, as well as generating appropriate test data. 2 | 3 | The Apropos approach to testing is ‘description tests’ - property testing, but reusing tests for input data meeting different properties. 4 | 5 | ## Project scope 6 | 7 | The Apropos project (Apropos-the-project) enompasses at core two repos: 8 | 9 | - [`apropos`](https://github.com/mlabs-haskell/apropos) (apropos-the-repo) 10 | Description-type based testing. apropos-the-repo is *Plutus-free* - see below. 11 | - [`hedgehog-plutus-simple`](https://github.com/mlabs-haskell/hedgehog-plutus-simple) 12 | Harnesses to test contracts using `hedgehog` and [`plutus-simple-model`](https://github.com/mlabs-haskell/plutus-simple-model). 13 | 14 | Together, these items intend to provide usable and credible end-to-end testing of Plutus contract flows - not just individual scripts. 15 | 16 | In addition, the following repo is a dependency of [`hedgehog-plutus-simple`](https://github.com/mlabs-haskell/hedgehog-plutus-simple). Since its developer and hitherto maintainer is not currently at the company, its maintenance has been subsumed into Apropos-the-project: 17 | 18 | - [`plutus-simple-model`](https://github.com/mlabs-haskell/plutus-simple-model) 19 | 20 | ## Plutus-free 21 | 22 | The Apropos development philosophy divides projects between *Plutus-specific* - functionality relevant only to Plutus development - and *Plutus-free* - functionality that is also useful for pure Haskell development, and as such is kept free of Plutus dependency. As such, Apropos-the project supplies a way of specifying Plutus contract flows as Hedgehog tests ([`hedgehog-plutus-simple`](https://github.com/mlabs-haskell/hedgehog-plutus-simple)), as well as description-based testing ([`apropos`](https://github.com/mlabs-haskell/apropos)-the-repo), which combined, constitute an end-to-end testing solution for Plutus contracts. 23 | 24 | ## Project board 25 | 26 | The project board for Apropos is here: -------------------------------------------------------------------------------- /apropos.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: apropos 3 | version: 1.0 4 | extra-source-files: CHANGELOG.md 5 | 6 | common lang 7 | default-language: Haskell2010 8 | default-extensions: 9 | BangPatterns 10 | BinaryLiterals 11 | ConstraintKinds 12 | DataKinds 13 | DefaultSignatures 14 | DeriveAnyClass 15 | DeriveFunctor 16 | DeriveGeneric 17 | DeriveTraversable 18 | DerivingStrategies 19 | DerivingVia 20 | DuplicateRecordFields 21 | EmptyCase 22 | FlexibleContexts 23 | FlexibleInstances 24 | FunctionalDependencies 25 | GADTs 26 | GeneralizedNewtypeDeriving 27 | HexFloatLiterals 28 | ImportQualifiedPost 29 | InstanceSigs 30 | KindSignatures 31 | LambdaCase 32 | MultiParamTypeClasses 33 | NumericUnderscores 34 | OverloadedStrings 35 | ScopedTypeVariables 36 | StandaloneDeriving 37 | StandaloneKindSignatures 38 | TupleSections 39 | TypeApplications 40 | TypeOperators 41 | TypeSynonymInstances 42 | UndecidableInstances 43 | OverloadedRecordDot 44 | 45 | build-depends: 46 | , base >=4.15 47 | , containers 48 | , exceptions 49 | , free 50 | , generics-sop 51 | , hedgehog 52 | , ilist 53 | , lens 54 | , minisat-solver 55 | , mtl 56 | , pretty 57 | , pretty-show 58 | , tagged 59 | , text 60 | , transformers 61 | , vector 62 | 63 | ghc-options: 64 | -Wall -Wcompat -Wincomplete-uni-patterns -Wredundant-constraints 65 | -Wmissing-export-lists -Werror -Wincomplete-record-updates 66 | -Wmissing-deriving-strategies 67 | 68 | library 69 | import: lang 70 | exposed-modules: Apropos 71 | other-modules: 72 | Apropos.Description 73 | Apropos.Generator 74 | Apropos.Runner 75 | 76 | hs-source-dirs: src 77 | 78 | executable examples 79 | import: lang 80 | type: exitcode-stdio-1.0 81 | main-is: Main.hs 82 | hs-source-dirs: examples 83 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 84 | other-modules: 85 | Spec.IntCompact 86 | Spec.IntSimple 87 | 88 | build-depends: 89 | , apropos 90 | , base 91 | , containers 92 | , hedgehog 93 | , mtl 94 | , tasty 95 | , tasty-hedgehog 96 | , tasty-hunit 97 | , text 98 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | index-state: 2022-09-23T00:00:00Z 2 | 3 | packages: ./apropos.cabal 4 | 5 | -- Always build tests and benchmarks. 6 | tests: true 7 | benchmarks: true 8 | 9 | -- The only sensible test display option 10 | test-show-details: direct 11 | 12 | source-repository-package 13 | type: git 14 | location: https://github.com/mlabs-haskell/digraph 15 | tag: 32afdad81d02301c6c6f37f2a2e6e9e7f3bdc9eb 16 | -------------------------------------------------------------------------------- /examples/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Spec.IntCompact ( 4 | intCompactAproposExample, 5 | intCompactExampleUnit, 6 | intCompactSelfTest, 7 | ) 8 | import Spec.IntSimple ( 9 | intSimpleAproposExample, 10 | intSimpleBadProperty, 11 | intSimpleExampleUnit, 12 | intSimpleSelfTest, 13 | ) 14 | 15 | import Test.Tasty (TestTree, defaultMain, testGroup) 16 | import Test.Tasty.HUnit (testCase) 17 | import Test.Tasty.Hedgehog (fromGroup, testProperty) 18 | 19 | main :: IO () 20 | main = defaultMain tests 21 | 22 | tests :: TestTree 23 | tests = 24 | testGroup 25 | "all tests" 26 | [ testGroup 27 | "Simple Int types with logic" 28 | [ testProperty 29 | "Bad property test: this should fail!" 30 | intSimpleBadProperty 31 | , testCase "This is why:" intSimpleExampleUnit 32 | , fromGroup intSimpleSelfTest 33 | , fromGroup intSimpleAproposExample 34 | ] 35 | , testGroup 36 | "Compact Int types" 37 | [ fromGroup intCompactSelfTest 38 | , testCase "Failing example" intCompactExampleUnit 39 | , fromGroup intCompactAproposExample 40 | ] 41 | ] 42 | -------------------------------------------------------------------------------- /examples/Spec/IntCompact.hs: -------------------------------------------------------------------------------- 1 | module Spec.IntCompact ( 2 | intCompactSelfTest, 3 | intCompactExampleUnit, 4 | intCompactAproposExample, 5 | ) where 6 | 7 | import Apropos ( 8 | Description (describe, genDescribed), 9 | Outcome (Fail, Pass), 10 | runTests, 11 | selfTest, 12 | ) 13 | import Data.Kind (Type) 14 | import Data.Proxy (Proxy (Proxy)) 15 | import GHC.Generics (Generic) 16 | import Hedgehog (Group (Group), assert) 17 | import Hedgehog.Gen (int) 18 | import Hedgehog.Range (linear) 19 | import Test.Tasty.HUnit (Assertion, assertBool) 20 | 21 | -- This is a variant of 'IntSimple', demonstrating a different way of building 22 | -- description types. Also, for variety, we switched the test up to show 23 | -- conditional testing. 24 | 25 | -- We've worked a bit harder defining the description, and can capture all the 26 | -- logic in the type. It's now impossible to construct a Large Zero or Small 27 | -- isBound. 28 | type IntDescr :: Type 29 | data IntDescr 30 | = Zero 31 | | Positive Size 32 | | Negative Size 33 | deriving stock (Show, Eq, Ord, Generic) 34 | 35 | type Size :: Type 36 | data Size = Small | Large {isBound :: Bool} 37 | deriving stock (Show, Eq, Ord, Generic) 38 | 39 | instance Description IntDescr Int where 40 | -- 'describe' is arguably simpler. 41 | describe :: Int -> IntDescr 42 | describe 0 = Zero 43 | describe i 44 | | i > 0 = Positive size 45 | | otherwise = Negative size 46 | where 47 | size :: Size 48 | size 49 | | i < 11 && i > -111 = Small 50 | | otherwise = Large {isBound = i == minBound || i == maxBound} 51 | 52 | -- no need for 'refineDescription' here! 53 | 54 | -- Also maybe a bit more straightforward. 55 | genDescribed = \case 56 | Zero -> pure 0 57 | Positive (Large True) -> pure maxBound 58 | Positive (Large False) -> int (linear 11 (maxBound - 1)) 59 | Positive Small -> int (linear 1 10) 60 | Negative (Large True) -> pure minBound 61 | Negative (Large False) -> int (linear (minBound + 1) (-11)) 62 | Negative Small -> int (linear (-10) (-1)) 63 | 64 | -- This should hold for all positive integers, but no negative integers or zero. 65 | hasNegativeNegation :: Int -> Bool 66 | hasNegativeNegation n = negate n < 0 67 | 68 | -- it doesn't, unfortunately. 69 | intCompactExampleUnit :: Assertion 70 | intCompactExampleUnit = 71 | assertBool "negate minBound >= 0" (not $ hasNegativeNegation minBound) 72 | 73 | intCompactSelfTest :: Group 74 | intCompactSelfTest = 75 | Group 76 | "self test" 77 | (selfTest $ Proxy @IntDescr) 78 | 79 | -- Not only does 'apropos' test for values that have the given properties, it 80 | -- also ensures that those without them fail the test. 81 | intCompactAproposExample :: Group 82 | intCompactAproposExample = 83 | Group 84 | "apropos testing" 85 | $ runTests @IntDescr 86 | ( \case 87 | Positive _ -> Pass -- all positive values should pass. 88 | _ -> Fail -- all other values should fail! 89 | ) 90 | (assert . hasNegativeNegation) 91 | -------------------------------------------------------------------------------- /examples/Spec/IntSimple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | 3 | module Spec.IntSimple ( 4 | intSimpleSelfTest, 5 | intSimpleBadProperty, 6 | intSimpleExampleUnit, 7 | intSimpleAproposExample, 8 | ) where 9 | 10 | import Apropos ( 11 | Description (describe, genDescribed, refineDescription), 12 | Formula (All, (:->:)), 13 | Outcome (Pass), 14 | attr, 15 | runTests, 16 | selfTest, 17 | ) 18 | 19 | import Data.Proxy (Proxy (Proxy)) 20 | import GHC.Generics (Generic) 21 | import Hedgehog (Group (Group), MonadGen, Property, assert, forAll, property) 22 | import Hedgehog.Gen (int) 23 | import Hedgehog.Range (linear) 24 | import Test.Tasty.HUnit (Assertion, assertBool) 25 | 26 | -- This example is based on https://github.com/nick8325/quickcheck/issues/98, 27 | -- and is due to our very own Baldur Blöndal. 28 | 29 | -- This should always return true. But it has a bug! 30 | absIsAlwaysPositive :: Int -> Bool 31 | absIsAlwaysPositive n = abs n >= 0 32 | 33 | -- abs minBound == minBound :-( 34 | intSimpleExampleUnit :: Assertion 35 | intSimpleExampleUnit = 36 | assertBool "abs minBound >= 0" (absIsAlwaysPositive minBound) 37 | 38 | -- A naive property test is unlikely to catch this. 39 | intSimpleBadProperty :: Property 40 | intSimpleBadProperty = 41 | property $ forAll (int (linear 0 minBound)) >>= assert . absIsAlwaysPositive 42 | 43 | -- Let's define a type that captures the interesting properties of 'Int's. 44 | data IntDescr = IntDescr 45 | { sign :: Sign 46 | , size :: Size 47 | , isBound :: Bool -- Is this equsl to 'minBound' or 'maxBound'? 48 | } 49 | deriving stock (Generic, Eq, Ord, Show) -- These are required, unfortunately. 50 | 51 | data Sign = Positive | Negative | Zero 52 | deriving stock (Generic, Eq, Ord, Show) 53 | 54 | data Size = Large | Small 55 | deriving stock (Generic, Eq, Ord, Show) 56 | 57 | instance Description IntDescr Int where 58 | -- Describe an 'Int' 59 | describe :: Int -> IntDescr 60 | describe i = 61 | IntDescr 62 | { sign = 63 | case compare i 0 of 64 | GT -> Positive 65 | EQ -> Zero 66 | LT -> Negative 67 | , size = 68 | if i > 10 || i < -10 69 | then Large 70 | else Small 71 | , isBound = i == minBound || i == maxBound 72 | } 73 | 74 | -- Not all 'IntDescr's are valid. Let's define which ones are. 75 | refineDescription :: Formula IntDescr 76 | refineDescription = 77 | All 78 | [ attr [("IntDescr", "sign")] "Zero" 79 | :->: attr [("IntDescr", "size")] "Small" 80 | , attr [("IntDescr", "isBound")] "True" 81 | :->: attr [("IntDescr", "size")] "Large" 82 | ] 83 | 84 | -- We define how to generate values matching a given description. 85 | genDescribed :: (MonadGen m) => IntDescr -> m Int 86 | genDescribed s = 87 | case sign s of 88 | Zero -> pure 0 89 | s' -> intGen s' 90 | where 91 | bound :: Sign -> Int 92 | bound Positive = maxBound 93 | bound Negative = minBound 94 | bound Zero = 0 95 | 96 | sig :: Sign -> Int -> Int 97 | sig Negative = negate 98 | sig _ = id 99 | 100 | intGen :: (MonadGen m) => Sign -> m Int 101 | intGen s' = 102 | if isBound s 103 | then pure (bound s') 104 | else case size s of 105 | Small -> int (linear (sig s' 1) (sig s' 10)) 106 | Large -> int (linear (sig s' 11) (bound s' - sig s' 1)) 107 | 108 | -- Let's first test that our instance is lawful. 109 | intSimpleSelfTest :: Group 110 | intSimpleSelfTest = 111 | Group 112 | "self test" 113 | (selfTest $ Proxy @IntDescr) 114 | 115 | -- And we catch our bug! 116 | intSimpleAproposExample :: Group 117 | intSimpleAproposExample = 118 | Group 119 | "apropos testing" 120 | $ runTests @IntDescr 121 | (const Pass) -- should hold for all negative integers 122 | (assert . absIsAlwaysPositive) 123 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "HTTP": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1451647621, 7 | "narHash": "sha256-oHIyw3x0iKBexEo49YeUDV1k74ZtyYKGR2gNJXXRxts=", 8 | "owner": "phadej", 9 | "repo": "HTTP", 10 | "rev": "9bc0996d412fef1787449d841277ef663ad9a915", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "phadej", 15 | "repo": "HTTP", 16 | "type": "github" 17 | } 18 | }, 19 | "cabal-32": { 20 | "flake": false, 21 | "locked": { 22 | "lastModified": 1603716527, 23 | "narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=", 24 | "owner": "haskell", 25 | "repo": "cabal", 26 | "rev": "48bf10787e27364730dd37a42b603cee8d6af7ee", 27 | "type": "github" 28 | }, 29 | "original": { 30 | "owner": "haskell", 31 | "ref": "3.2", 32 | "repo": "cabal", 33 | "type": "github" 34 | } 35 | }, 36 | "cabal-34": { 37 | "flake": false, 38 | "locked": { 39 | "lastModified": 1640353650, 40 | "narHash": "sha256-N1t6M3/wqj90AEdRkeC8i923gQYUpzSr8b40qVOZ1Rk=", 41 | "owner": "haskell", 42 | "repo": "cabal", 43 | "rev": "942639c18c0cd8ec53e0a6f8d120091af35312cd", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "haskell", 48 | "ref": "3.4", 49 | "repo": "cabal", 50 | "type": "github" 51 | } 52 | }, 53 | "cabal-36": { 54 | "flake": false, 55 | "locked": { 56 | "lastModified": 1641652457, 57 | "narHash": "sha256-BlFPKP4C4HRUJeAbdembX1Rms1LD380q9s0qVDeoAak=", 58 | "owner": "haskell", 59 | "repo": "cabal", 60 | "rev": "f27667f8ec360c475027dcaee0138c937477b070", 61 | "type": "github" 62 | }, 63 | "original": { 64 | "owner": "haskell", 65 | "ref": "3.6", 66 | "repo": "cabal", 67 | "type": "github" 68 | } 69 | }, 70 | "cardano-shell": { 71 | "flake": false, 72 | "locked": { 73 | "lastModified": 1608537748, 74 | "narHash": "sha256-PulY1GfiMgKVnBci3ex4ptk2UNYMXqGjJOxcPy2KYT4=", 75 | "owner": "input-output-hk", 76 | "repo": "cardano-shell", 77 | "rev": "9392c75087cb9a3d453998f4230930dea3a95725", 78 | "type": "github" 79 | }, 80 | "original": { 81 | "owner": "input-output-hk", 82 | "repo": "cardano-shell", 83 | "type": "github" 84 | } 85 | }, 86 | "flake-compat": { 87 | "flake": false, 88 | "locked": { 89 | "lastModified": 1650374568, 90 | "narHash": "sha256-Z+s0J8/r907g149rllvwhb4pKi8Wam5ij0st8PwAh+E=", 91 | "owner": "edolstra", 92 | "repo": "flake-compat", 93 | "rev": "b4a34015c698c7793d592d66adbab377907a2be8", 94 | "type": "github" 95 | }, 96 | "original": { 97 | "owner": "edolstra", 98 | "repo": "flake-compat", 99 | "type": "github" 100 | } 101 | }, 102 | "flake-compat-ci": { 103 | "locked": { 104 | "lastModified": 1646664117, 105 | "narHash": "sha256-AX2VewPcS9eRsoirVHfnk07MHAOH6CTDiD10XtRaZbk=", 106 | "owner": "hercules-ci", 107 | "repo": "flake-compat-ci", 108 | "rev": "e588637b2eec4261ed0d36335c83a117f2744dea", 109 | "type": "github" 110 | }, 111 | "original": { 112 | "owner": "hercules-ci", 113 | "repo": "flake-compat-ci", 114 | "type": "github" 115 | } 116 | }, 117 | "flake-compat_2": { 118 | "flake": false, 119 | "locked": { 120 | "lastModified": 1635892615, 121 | "narHash": "sha256-harGbMZr4hzat2BWBU+Y5OYXlu+fVz7E4WeQzHi5o8A=", 122 | "owner": "input-output-hk", 123 | "repo": "flake-compat", 124 | "rev": "eca47d3377946315596da653862d341ee5341318", 125 | "type": "github" 126 | }, 127 | "original": { 128 | "owner": "input-output-hk", 129 | "repo": "flake-compat", 130 | "type": "github" 131 | } 132 | }, 133 | "flake-utils": { 134 | "locked": { 135 | "lastModified": 1644229661, 136 | "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", 137 | "owner": "numtide", 138 | "repo": "flake-utils", 139 | "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", 140 | "type": "github" 141 | }, 142 | "original": { 143 | "owner": "numtide", 144 | "repo": "flake-utils", 145 | "type": "github" 146 | } 147 | }, 148 | "ghc-8.6.5-iohk": { 149 | "flake": false, 150 | "locked": { 151 | "lastModified": 1600920045, 152 | "narHash": "sha256-DO6kxJz248djebZLpSzTGD6s8WRpNI9BTwUeOf5RwY8=", 153 | "owner": "input-output-hk", 154 | "repo": "ghc", 155 | "rev": "95713a6ecce4551240da7c96b6176f980af75cae", 156 | "type": "github" 157 | }, 158 | "original": { 159 | "owner": "input-output-hk", 160 | "ref": "release/8.6.5-iohk", 161 | "repo": "ghc", 162 | "type": "github" 163 | } 164 | }, 165 | "hackage": { 166 | "flake": false, 167 | "locked": { 168 | "lastModified": 1666487502, 169 | "narHash": "sha256-7RitrI4u1gE4Z5XLF7fDstjagad0T68x/0G79UfeR6E=", 170 | "owner": "input-output-hk", 171 | "repo": "hackage.nix", 172 | "rev": "159b4498c1b4c5054308c7aaac25dd80ccfbfce0", 173 | "type": "github" 174 | }, 175 | "original": { 176 | "owner": "input-output-hk", 177 | "repo": "hackage.nix", 178 | "type": "github" 179 | } 180 | }, 181 | "haskell-nix": { 182 | "inputs": { 183 | "HTTP": "HTTP", 184 | "cabal-32": "cabal-32", 185 | "cabal-34": "cabal-34", 186 | "cabal-36": "cabal-36", 187 | "cardano-shell": "cardano-shell", 188 | "flake-compat": "flake-compat_2", 189 | "flake-utils": "flake-utils", 190 | "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", 191 | "hackage": "hackage", 192 | "hpc-coveralls": "hpc-coveralls", 193 | "hydra": "hydra", 194 | "nixpkgs": [ 195 | "haskell-nix", 196 | "nixpkgs-unstable" 197 | ], 198 | "nixpkgs-2003": "nixpkgs-2003", 199 | "nixpkgs-2105": "nixpkgs-2105", 200 | "nixpkgs-2111": "nixpkgs-2111", 201 | "nixpkgs-2205": "nixpkgs-2205", 202 | "nixpkgs-unstable": "nixpkgs-unstable", 203 | "old-ghc-nix": "old-ghc-nix", 204 | "stackage": "stackage" 205 | }, 206 | "locked": { 207 | "lastModified": 1666487698, 208 | "narHash": "sha256-vOk9Q9+tu8U69UkXNxfTOqTBWTK0535I+VFOOkVzlo0=", 209 | "owner": "input-output-hk", 210 | "repo": "haskell.nix", 211 | "rev": "b92bb7eea51d8740bcbd3c720f3609407d79e5d7", 212 | "type": "github" 213 | }, 214 | "original": { 215 | "owner": "input-output-hk", 216 | "repo": "haskell.nix", 217 | "type": "github" 218 | } 219 | }, 220 | "hpc-coveralls": { 221 | "flake": false, 222 | "locked": { 223 | "lastModified": 1607498076, 224 | "narHash": "sha256-8uqsEtivphgZWYeUo5RDUhp6bO9j2vaaProQxHBltQk=", 225 | "owner": "sevanspowell", 226 | "repo": "hpc-coveralls", 227 | "rev": "14df0f7d229f4cd2e79f8eabb1a740097fdfa430", 228 | "type": "github" 229 | }, 230 | "original": { 231 | "owner": "sevanspowell", 232 | "repo": "hpc-coveralls", 233 | "type": "github" 234 | } 235 | }, 236 | "hydra": { 237 | "inputs": { 238 | "nix": "nix", 239 | "nixpkgs": [ 240 | "haskell-nix", 241 | "hydra", 242 | "nix", 243 | "nixpkgs" 244 | ] 245 | }, 246 | "locked": { 247 | "lastModified": 1646878427, 248 | "narHash": "sha256-KtbrofMtN8GlM7D+n90kixr7QpSlVmdN+vK5CA/aRzc=", 249 | "owner": "NixOS", 250 | "repo": "hydra", 251 | "rev": "28b682b85b7efc5cf7974065792a1f22203a5927", 252 | "type": "github" 253 | }, 254 | "original": { 255 | "id": "hydra", 256 | "type": "indirect" 257 | } 258 | }, 259 | "lowdown-src": { 260 | "flake": false, 261 | "locked": { 262 | "lastModified": 1633514407, 263 | "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=", 264 | "owner": "kristapsdz", 265 | "repo": "lowdown", 266 | "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8", 267 | "type": "github" 268 | }, 269 | "original": { 270 | "owner": "kristapsdz", 271 | "repo": "lowdown", 272 | "type": "github" 273 | } 274 | }, 275 | "nix": { 276 | "inputs": { 277 | "lowdown-src": "lowdown-src", 278 | "nixpkgs": "nixpkgs", 279 | "nixpkgs-regression": "nixpkgs-regression" 280 | }, 281 | "locked": { 282 | "lastModified": 1643066034, 283 | "narHash": "sha256-xEPeMcNJVOeZtoN+d+aRwolpW8mFSEQx76HTRdlhPhg=", 284 | "owner": "NixOS", 285 | "repo": "nix", 286 | "rev": "a1cd7e58606a41fcf62bf8637804cf8306f17f62", 287 | "type": "github" 288 | }, 289 | "original": { 290 | "owner": "NixOS", 291 | "ref": "2.6.0", 292 | "repo": "nix", 293 | "type": "github" 294 | } 295 | }, 296 | "nixpkgs": { 297 | "locked": { 298 | "lastModified": 1632864508, 299 | "narHash": "sha256-d127FIvGR41XbVRDPVvozUPQ/uRHbHwvfyKHwEt5xFM=", 300 | "owner": "NixOS", 301 | "repo": "nixpkgs", 302 | "rev": "82891b5e2c2359d7e58d08849e4c89511ab94234", 303 | "type": "github" 304 | }, 305 | "original": { 306 | "id": "nixpkgs", 307 | "ref": "nixos-21.05-small", 308 | "type": "indirect" 309 | } 310 | }, 311 | "nixpkgs-2003": { 312 | "locked": { 313 | "lastModified": 1620055814, 314 | "narHash": "sha256-8LEHoYSJiL901bTMVatq+rf8y7QtWuZhwwpKE2fyaRY=", 315 | "owner": "NixOS", 316 | "repo": "nixpkgs", 317 | "rev": "1db42b7fe3878f3f5f7a4f2dc210772fd080e205", 318 | "type": "github" 319 | }, 320 | "original": { 321 | "owner": "NixOS", 322 | "ref": "nixpkgs-20.03-darwin", 323 | "repo": "nixpkgs", 324 | "type": "github" 325 | } 326 | }, 327 | "nixpkgs-2105": { 328 | "locked": { 329 | "lastModified": 1659914493, 330 | "narHash": "sha256-lkA5X3VNMKirvA+SUzvEhfA7XquWLci+CGi505YFAIs=", 331 | "owner": "NixOS", 332 | "repo": "nixpkgs", 333 | "rev": "022caabb5f2265ad4006c1fa5b1ebe69fb0c3faf", 334 | "type": "github" 335 | }, 336 | "original": { 337 | "owner": "NixOS", 338 | "ref": "nixpkgs-21.05-darwin", 339 | "repo": "nixpkgs", 340 | "type": "github" 341 | } 342 | }, 343 | "nixpkgs-2111": { 344 | "locked": { 345 | "lastModified": 1659446231, 346 | "narHash": "sha256-hekabNdTdgR/iLsgce5TGWmfIDZ86qjPhxDg/8TlzhE=", 347 | "owner": "NixOS", 348 | "repo": "nixpkgs", 349 | "rev": "eabc38219184cc3e04a974fe31857d8e0eac098d", 350 | "type": "github" 351 | }, 352 | "original": { 353 | "owner": "NixOS", 354 | "ref": "nixpkgs-21.11-darwin", 355 | "repo": "nixpkgs", 356 | "type": "github" 357 | } 358 | }, 359 | "nixpkgs-2205": { 360 | "locked": { 361 | "lastModified": 1663981975, 362 | "narHash": "sha256-TKaxWAVJR+a5JJauKZqibmaM5e/Pi5tBDx9s8fl/kSE=", 363 | "owner": "NixOS", 364 | "repo": "nixpkgs", 365 | "rev": "309faedb8338d3ae8ad8f1043b3ccf48c9cc2970", 366 | "type": "github" 367 | }, 368 | "original": { 369 | "owner": "NixOS", 370 | "ref": "nixpkgs-22.05-darwin", 371 | "repo": "nixpkgs", 372 | "type": "github" 373 | } 374 | }, 375 | "nixpkgs-regression": { 376 | "locked": { 377 | "lastModified": 1643052045, 378 | "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", 379 | "owner": "NixOS", 380 | "repo": "nixpkgs", 381 | "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", 382 | "type": "github" 383 | }, 384 | "original": { 385 | "id": "nixpkgs", 386 | "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", 387 | "type": "indirect" 388 | } 389 | }, 390 | "nixpkgs-unstable": { 391 | "locked": { 392 | "lastModified": 1663905476, 393 | "narHash": "sha256-0CSwRKaYravh9v6qSlBpM0gNg0UhKT2lL7Yn6Zbx7UM=", 394 | "owner": "NixOS", 395 | "repo": "nixpkgs", 396 | "rev": "e14f9fb57315f0d4abde222364f19f88c77d2b79", 397 | "type": "github" 398 | }, 399 | "original": { 400 | "owner": "NixOS", 401 | "ref": "nixpkgs-unstable", 402 | "repo": "nixpkgs", 403 | "type": "github" 404 | } 405 | }, 406 | "old-ghc-nix": { 407 | "flake": false, 408 | "locked": { 409 | "lastModified": 1631092763, 410 | "narHash": "sha256-sIKgO+z7tj4lw3u6oBZxqIhDrzSkvpHtv0Kki+lh9Fg=", 411 | "owner": "angerman", 412 | "repo": "old-ghc-nix", 413 | "rev": "af48a7a7353e418119b6dfe3cd1463a657f342b8", 414 | "type": "github" 415 | }, 416 | "original": { 417 | "owner": "angerman", 418 | "ref": "master", 419 | "repo": "old-ghc-nix", 420 | "type": "github" 421 | } 422 | }, 423 | "root": { 424 | "inputs": { 425 | "flake-compat": "flake-compat", 426 | "flake-compat-ci": "flake-compat-ci", 427 | "haskell-nix": "haskell-nix", 428 | "nixpkgs": [ 429 | "haskell-nix", 430 | "nixpkgs-unstable" 431 | ] 432 | } 433 | }, 434 | "stackage": { 435 | "flake": false, 436 | "locked": { 437 | "lastModified": 1666487609, 438 | "narHash": "sha256-M5HW69mGNZDUGfpxq3AmG2gY9exitRLqzVKQ2zmQFLE=", 439 | "owner": "input-output-hk", 440 | "repo": "stackage.nix", 441 | "rev": "38fa4a32d75055817736a77112ab1f4f256070b7", 442 | "type": "github" 443 | }, 444 | "original": { 445 | "owner": "input-output-hk", 446 | "repo": "stackage.nix", 447 | "type": "github" 448 | } 449 | } 450 | }, 451 | "root": "root", 452 | "version": 7 453 | } 454 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "apropos"; 3 | 4 | inputs = { 5 | haskell-nix.url = "github:input-output-hk/haskell.nix"; 6 | nixpkgs.follows = "haskell-nix/nixpkgs-unstable"; 7 | haskell-nix.inputs.nixpkgs.follows = "haskell-nix/nixpkgs-unstable"; 8 | flake-compat-ci.url = "github:hercules-ci/flake-compat-ci"; 9 | flake-compat = { 10 | url = "github:edolstra/flake-compat"; 11 | flake = false; 12 | }; 13 | }; 14 | 15 | outputs = { self, nixpkgs, haskell-nix, flake-compat, flake-compat-ci }: 16 | let 17 | supportedSystems = 18 | [ "x86_64-linux" ]; 19 | 20 | perSystem = nixpkgs.lib.genAttrs supportedSystems; 21 | 22 | nixpkgsFor = system: 23 | import nixpkgs { 24 | inherit system; 25 | overlays = [ haskell-nix.overlay ]; 26 | inherit (haskell-nix) config; 27 | }; 28 | nixpkgsFor' = system: import nixpkgs { inherit system; }; 29 | 30 | compiler-nix-name = "ghc924"; 31 | 32 | fourmoluFor = system: (nixpkgsFor system).haskell-nix.tool "ghc924" "fourmolu" { }; 33 | 34 | projectFor = system: 35 | let 36 | deferPluginErrors = true; 37 | pkgs = nixpkgsFor system; 38 | 39 | fakeSrc = pkgs.runCommand "real-source" { } '' 40 | cp -rT ${self} $out 41 | chmod u+w $out/cabal.project 42 | ''; 43 | in 44 | (nixpkgsFor system).haskell-nix.cabalProject' { 45 | inherit compiler-nix-name; 46 | src = fakeSrc.outPath; 47 | cabalProjectFileName = "cabal.project"; 48 | modules = [{ packages = { }; }]; 49 | shell = { 50 | withHoogle = true; 51 | 52 | tools.haskell-language-server = { }; 53 | 54 | exactDeps = true; 55 | 56 | # We use the ones from Nixpkgs, since they are cached reliably. 57 | # Eventually we will probably want to build these with haskell.nix. 58 | nativeBuildInputs = 59 | [ 60 | pkgs.cabal-install 61 | pkgs.hlint 62 | (fourmoluFor system) 63 | pkgs.nixpkgs-fmt 64 | pkgs.haskellPackages.cabal-fmt 65 | pkgs.haskellPackages.apply-refact 66 | pkgs.fd 67 | ]; 68 | additional = ps: [ 69 | ps.digraph 70 | ]; 71 | }; 72 | sha256map = { 73 | "https://github.com/mlabs-haskell/digraph"."32afdad81d02301c6c6f37f2a2e6e9e7f3bdc9eb" = "sha256-eN1wEkd/gAoQHARck/F5US7L4OPJisc9glWxNkvHaF8="; 74 | 75 | }; 76 | }; 77 | 78 | formatCheckFor = system: 79 | let 80 | pkgs = nixpkgsFor system; 81 | in 82 | pkgs.runCommand "format-check" 83 | { 84 | nativeBuildInputs = [ self.devShell.${system}.nativeBuildInputs ]; 85 | } '' 86 | cd ${self} 87 | export LC_CTYPE=C.UTF-8 88 | export LC_ALL=C.UTF-8 89 | export LANG=C.UTF-8 90 | export IN_NIX_SHELL='pure' 91 | make format_check cabalfmt_check nixpkgsfmt_check lint 92 | mkdir $out 93 | ''; 94 | in 95 | { 96 | project = perSystem projectFor; 97 | flake = perSystem (system: (projectFor system).flake { }); 98 | 99 | # this could be done automatically, but would reduce readability 100 | packages = perSystem (system: self.flake.${system}.packages); 101 | checks = perSystem (system: 102 | self.flake.${system}.checks // { 103 | formatCheck = formatCheckFor system; 104 | }); 105 | check = perSystem (system: 106 | (nixpkgsFor system).runCommand "combined-test" 107 | { 108 | nativeBuildInputs = builtins.attrValues self.checks.${system}; 109 | } "touch $out"); 110 | apps = perSystem (system: self.flake.${system}.apps); 111 | devShell = perSystem (system: self.flake.${system}.devShell); 112 | 113 | herculesCI.ciSystems = [ "x86_64-linux" ]; 114 | }; 115 | } 116 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | indentation: 2 2 | comma-style: leading 3 | record-brace-space: true 4 | indent-wheres: true 5 | diff-friendly-import-export: true 6 | respectful: true 7 | haddock-style: multi-line 8 | newlines-between-decls: 1 -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | -------------------------------------------------------------------------------- /src/Apropos.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Description: Hedgehog testing that sniffs out edge cases 3 | 4 | Apropos allows you to describe what test data may trigger edge cases in your 5 | code, and automatically exhaustively test against them. see the 6 | [README](https://github.com/mlabs-haskell/apropos#readme) for a fuller 7 | explanation. 8 | -} 9 | module Apropos ( 10 | Description (describe, refineDescription, genDescribed), 11 | 12 | -- * Formulas 13 | 14 | -- | Numerous Apropos features use 'Formula's to specify subsets of 15 | -- description types. The 'refineDescription' method is a 'Formula', and the 16 | -- 'satisfies' combinator allows using a 'Formula' to create a predicate for 17 | -- passing to the test runners. 18 | -- 19 | -- A 'Formula' is an expression built of attributes, specified using the 20 | -- 'attr' combinator, and operators specified by the constructors of the 21 | -- 'Formula' type. 22 | attr, 23 | FieldSelector, 24 | Formula ( 25 | Yes, 26 | No, 27 | Not, 28 | (:&&:), 29 | (:||:), 30 | (:++:), 31 | (:->:), 32 | (:<->:), 33 | All, 34 | Some, 35 | None, 36 | ExactlyOne, 37 | AtMostOne 38 | ), 39 | allAttributes, 40 | satisfies, 41 | 42 | -- * Test runners 43 | selfTest, 44 | selfTestWhere, 45 | runTests, 46 | runTestsWhere, 47 | Outcome (Pass, Fail), 48 | passIf, 49 | OptOutcome (Run, Ignore), 50 | 51 | -- * Utility type 52 | DeepGeneric, 53 | ) where 54 | 55 | import Apropos.Description ( 56 | DeepGeneric, 57 | Description (describe, genDescribed, refineDescription), 58 | FieldSelector, 59 | Formula ( 60 | All, 61 | AtMostOne, 62 | ExactlyOne, 63 | No, 64 | None, 65 | Not, 66 | Some, 67 | Yes, 68 | (:&&:), 69 | (:++:), 70 | (:->:), 71 | (:<->:), 72 | (:||:) 73 | ), 74 | allAttributes, 75 | attr, 76 | satisfies, 77 | ) 78 | import Apropos.Generator (selfTest, selfTestWhere) 79 | import Apropos.Runner ( 80 | OptOutcome (Ignore, Run), 81 | Outcome (Fail, Pass), 82 | passIf, 83 | runTests, 84 | runTestsWhere, 85 | ) 86 | -------------------------------------------------------------------------------- /src/Apropos/Description.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NamedFieldPuns #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE UndecidableSuperClasses #-} 5 | 6 | module Apropos.Description ( 7 | Description (describe, refineDescription, genDescribed), 8 | Formula ( 9 | Yes, 10 | No, 11 | Not, 12 | (:&&:), 13 | (:||:), 14 | (:++:), 15 | (:->:), 16 | (:<->:), 17 | All, 18 | Some, 19 | None, 20 | ExactlyOne, 21 | AtMostOne 22 | ), 23 | Attribute (Attr), 24 | FieldSelector, 25 | typeLogic, 26 | DeepGeneric, 27 | attr, 28 | variablesToDescription, 29 | logic, 30 | allAttributes, 31 | enumerateScenariosWhere, 32 | scenarios, 33 | satisfies, 34 | ) where 35 | 36 | import Control.Monad.State 37 | 38 | import Data.String (IsString (fromString)) 39 | 40 | import Data.Set (Set) 41 | import Data.Set qualified as Set 42 | 43 | import Data.Tree (Tree) 44 | import Data.Tree qualified as Tree 45 | 46 | import Data.Proxy (Proxy (Proxy)) 47 | 48 | import Data.Semigroup (First (First), getFirst) 49 | 50 | import Data.Vector (Vector) 51 | import Data.Vector qualified as Vector 52 | 53 | import Generics.SOP (All, I, K (K), NP, NS, SOP (SOP), unI, unK, unSOP) 54 | import Generics.SOP qualified as SOP 55 | import Generics.SOP.GGP ( 56 | GCode, 57 | GDatatypeInfo, 58 | GFrom, 59 | GTo, 60 | gdatatypeInfo, 61 | gfrom, 62 | gto, 63 | ) 64 | 65 | import GHC.Generics (Generic) 66 | 67 | import Data.Tagged (Tagged, unproxy, untag) 68 | 69 | import Data.Map (Map) 70 | import Data.Map qualified as Map 71 | import Data.Maybe (fromJust, fromMaybe) 72 | 73 | import Data.Kind (Constraint, Type) 74 | import Hedgehog (MonadGen) 75 | import SAT.MiniSat qualified as MiniSAT 76 | 77 | {- | Define a description type - an ADT that captures interesting properties of 78 | a type. 79 | 80 | Defining an instance of this typeclass is the first step for writing apropos 81 | tests. 82 | 83 | Instances of this typeclass should observe the following law: 84 | 85 | @ 86 | forall d. forAll (genDescribed d) >>= (\\a -> describe a === d) 87 | @ 88 | 89 | 'Apropos.selfTest' is provided for testing adherence to this law. 90 | 91 | The type @d@ and the types of all its fields recursively must derive 'Generic'. 92 | -} 93 | type Description :: Type -> Type -> Constraint 94 | class (DeepGeneric d) => Description d a | d -> a where 95 | -- | Describe a value 96 | -- 97 | -- Generate a description from a value. 98 | describe :: a -> d 99 | 100 | -- | Add logic constraining valid description values 101 | -- 102 | -- Not all constructible description values may be valid. This optional 103 | -- method allows you to specify which. See 'Formula' for more information how 104 | -- to specify these values. 105 | refineDescription :: Formula d 106 | refineDescription = Yes 107 | 108 | -- | Generate test values matching a description. 109 | -- 110 | -- You specify a Hedgehog 'Hedgehog.Gen' that generates a value for a given 111 | -- description. 112 | genDescribed :: forall (m :: Type -> Type). (MonadGen m) => d -> m a 113 | 114 | {- | 115 | 116 | This somewhat strange constraint enforces that description types and all their 117 | fields implement 'GHC.Generic'and are of a suitable shape. This is used by many 118 | Apropos functions. You can probably ignore this, but it may be helful for 119 | building combinators on top of Apropos. 120 | -} 121 | type DeepGeneric :: Type -> Constraint 122 | class 123 | ( Generic a 124 | , GDatatypeInfo a 125 | , GFrom a 126 | , GTo a 127 | , SOP.All2 DeepGeneric (GCode a) 128 | ) => 129 | DeepGeneric a 130 | 131 | instance 132 | ( Generic a 133 | , GDatatypeInfo a 134 | , GFrom a 135 | , GTo a 136 | , SOP.All2 DeepGeneric (GCode a) 137 | ) => 138 | DeepGeneric a 139 | 140 | {- | A datatype-agnostic representation of an object, consisting of a string 141 | representing the constructor and a list of recursive structures representing 142 | the fields. 143 | 144 | The type parameter is unused except to add a bit of type safety. 145 | -} 146 | type FlatPack :: Type -> Type 147 | newtype FlatPack a = FlatPack {unFlatPack :: Tree SOP.ConstructorName} 148 | deriving newtype (Show) 149 | 150 | {- | Generically construct a 'FlatPack'. 151 | 152 | This method operates on any type where it and the types of all its fields 153 | recursively implement @GHC.Generic@. 154 | -} 155 | flatten :: forall (a :: Type). (DeepGeneric a) => a -> FlatPack a 156 | flatten = 157 | FlatPack 158 | . SOP.hcollapse 159 | . SOP.hcliftA2 160 | (Proxy @(All DeepGeneric)) 161 | constr 162 | (SOP.constructorInfo (gdatatypeInfo (Proxy @a))) 163 | . unSOP 164 | . gfrom 165 | where 166 | constr :: 167 | forall (xs :: [Type]). 168 | (All DeepGeneric xs) => 169 | SOP.ConstructorInfo xs -> 170 | NP I xs -> 171 | K (Tree SOP.ConstructorName) xs 172 | constr con = 173 | K 174 | . Tree.Node (SOP.constructorName con) 175 | . SOP.hcollapse 176 | . SOP.hcmap (Proxy @DeepGeneric) (K . unFlatPack . flatten . unI) 177 | 178 | unflatten :: forall (a :: Type). (DeepGeneric a) => FlatPack a -> Maybe a 179 | unflatten fp = 180 | fmap (gto . SOP . getFirst) 181 | . mconcat 182 | . SOP.hcollapse 183 | $ SOP.hcliftA2 184 | (Proxy @(All DeepGeneric)) 185 | (constr (unFlatPack fp)) 186 | (SOP.constructorInfo (gdatatypeInfo (Proxy @a))) 187 | (SOP.injections @(GCode a) @(NP I)) 188 | where 189 | constr :: 190 | forall (xs :: [Type]). 191 | (All DeepGeneric xs) => 192 | Tree SOP.ConstructorName -> 193 | SOP.ConstructorInfo xs -> 194 | SOP.Injection (NP I) (GCode a) xs -> 195 | K (Maybe (First (NS (NP I) (GCode a)))) xs 196 | constr tree con (SOP.Fn inj) 197 | | Tree.rootLabel tree == SOP.constructorName con = K $ do 198 | flds <- SOP.fromList (Tree.subForest tree) 199 | prod <- 200 | SOP.hsequence 201 | . SOP.hcmap (Proxy @DeepGeneric) (unflatten . FlatPack . unK) 202 | $ flds 203 | return . First . unK . inj $ prod 204 | | otherwise = K Nothing 205 | 206 | type Attribute :: Type -> Type -> Type 207 | data Attribute i d = Attr 208 | { attrPath :: Vector (SOP.ConstructorName, i) 209 | , attrConstr :: SOP.ConstructorName 210 | } 211 | deriving stock (Eq, Ord, Generic) 212 | 213 | {- | 214 | Type for specifying a field in a constructor, in an attribute path. 215 | 216 | This type is a little bit magic in that it is an instance of both 'Num' and 217 | 'IsString', allowing you to specify both field names and integer indices using 218 | literal syntax. 219 | 220 | See the examples for 'allAttributes' for more information. 221 | -} 222 | type FieldSelector :: Type 223 | data FieldSelector 224 | = Index Int 225 | | RecordField SOP.FieldName 226 | deriving stock (Eq, Ord) 227 | 228 | instance Show FieldSelector where 229 | show (Index i) = show i 230 | show (RecordField l) = show l 231 | 232 | instance Num FieldSelector where 233 | fromInteger = Index . fromInteger 234 | (+) = undefined 235 | (*) = undefined 236 | abs = undefined 237 | signum = undefined 238 | negate = undefined 239 | 240 | instance IsString FieldSelector where 241 | fromString = RecordField 242 | 243 | rootVarRep :: 244 | forall (i :: Type) (d :: Type). 245 | SOP.ConstructorName -> 246 | Attribute i d 247 | rootVarRep = Attr Vector.empty 248 | 249 | pushVR :: 250 | forall (i :: Type) (d :: Type). 251 | SOP.ConstructorName -> 252 | i -> 253 | Attribute i d -> 254 | Attribute i d 255 | pushVR cn i (Attr vrs cn') = Attr ((cn, i) `Vector.cons` vrs) cn' 256 | 257 | {- The examples are now out of date; there is no 'Show' instance for 258 | 'Attribute'. 259 | 260 | This has not been considered a priority to fix, as these functions (and the 261 | 'Attribute' type) are not currently public. 262 | -} 263 | 264 | {- | Calculate the set of variables for an object. 265 | 266 | This method operates on any type where 267 | it and the types of all its fields recursively implement: 268 | 269 | @ 270 | deriving stock (GHC.Generic) 271 | deriving anyclass (Generics.SOP.Generic, Generics.SOP.HasDatatypeInfo) 272 | @ 273 | = Examples 274 | 275 | >>> descriptionToVariables True 276 | fromList [Attr [] "True"] 277 | 278 | >>> descriptionToVariables False 279 | fromList [Attr [] "False"] 280 | 281 | >>> descriptionToVariables (True, False) 282 | fromList [Attr [] "(,)", Attr [("(,)",0)] "True", Attr [("(,)",1)] "False"] 283 | 284 | >>> descriptionToVariables (Just True) 285 | fromList [Attr [] "Just", Attr [("Just",0)] "True"] 286 | 287 | >>> descriptionToVariables (Nothing @(Maybe Bool)) 288 | fromList [Attr [] "Nothing"] 289 | -} 290 | descriptionToVariables :: 291 | forall (d :: Type). (DeepGeneric d) => d -> Set (Attribute Int d) 292 | descriptionToVariables = 293 | Tree.foldTree 294 | ( \cn flds -> 295 | Set.singleton (rootVarRep cn) 296 | <> Set.unions 297 | (Vector.imap (Set.map . pushVR cn) (Vector.fromList flds)) 298 | ) 299 | . unFlatPack 300 | . flatten 301 | 302 | type MapTree :: Type -> Type -> Type 303 | data MapTree k a = MapNode 304 | { mapRootLabel :: a 305 | , mapSubForest :: Map k (MapTree k a) 306 | } 307 | deriving stock (Show) 308 | 309 | variablesToDescription :: 310 | forall (d :: Type). (DeepGeneric d) => Set (Attribute Int d) -> d 311 | variablesToDescription s = 312 | let tree = collapseMapTree . buildMapTree $ s 313 | in case unflatten . FlatPack $ tree of 314 | Nothing -> error ("Invalid FlatPack " ++ Tree.drawTree tree) 315 | Just a -> a 316 | where 317 | collapseMapTree :: forall (i :: Type) (a :: Type). MapTree i a -> Tree a 318 | collapseMapTree mt = 319 | Tree.Node 320 | { rootLabel = mapRootLabel mt 321 | , subForest = 322 | map snd 323 | . Map.toAscList 324 | . Map.map collapseMapTree 325 | . mapSubForest 326 | $ mt 327 | } 328 | 329 | buildMapTree :: Set (Attribute Int d) -> MapTree Int SOP.ConstructorName 330 | buildMapTree = Set.foldr insertVar emptyMt 331 | 332 | emptyMt :: forall (k :: Type). MapTree k SOP.ConstructorName 333 | emptyMt = 334 | MapNode 335 | { mapRootLabel = "" 336 | , mapSubForest = Map.empty 337 | } 338 | 339 | insertVar :: 340 | Attribute Int d -> 341 | MapTree Int SOP.ConstructorName -> 342 | MapTree Int SOP.ConstructorName 343 | insertVar (Attr v cons) mt 344 | | Nothing <- Vector.uncons v = mt {mapRootLabel = cons} 345 | | Just ((_, i), path) <- Vector.uncons v = 346 | mt 347 | { mapSubForest = 348 | Map.alter 349 | (Just . insertVar (Attr path cons) . fromMaybe emptyMt) 350 | i 351 | (mapSubForest mt) 352 | } 353 | 354 | type Constructor :: Type 355 | data Constructor = Constructor 356 | { constructorInfo :: ConsInfo 357 | , subConstructors :: Vector (Vector Constructor) 358 | } 359 | deriving stock (Show) 360 | 361 | foldConstructor :: 362 | forall (a :: Type). (ConsInfo -> Vector (Vector a) -> a) -> Constructor -> a 363 | foldConstructor f = go 364 | where 365 | go (Constructor x tss) = f x (fmap (fmap go) tss) 366 | 367 | type ConsInfo :: Type 368 | data ConsInfo = ConsInfo 369 | { consName :: SOP.ConstructorName 370 | , consFields :: Maybe (Vector SOP.FieldName) 371 | } 372 | deriving stock (Show) 373 | 374 | toConstructors :: 375 | forall (a :: Type). (DeepGeneric a) => Proxy a -> Vector Constructor 376 | toConstructors _ = untag (toConstructors' @a) 377 | where 378 | toConstructors' :: 379 | forall (a' :: Type). (DeepGeneric a') => Tagged a' (Vector Constructor) 380 | toConstructors' = 381 | unproxy $ 382 | Vector.fromList 383 | . SOP.hcollapse 384 | . SOP.hcmap (Proxy @(All DeepGeneric)) constr 385 | . SOP.constructorInfo 386 | . gdatatypeInfo 387 | 388 | constr :: 389 | forall (xs :: [Type]). 390 | (All DeepGeneric xs) => 391 | SOP.ConstructorInfo xs -> 392 | K Constructor xs 393 | constr ci = 394 | K $ 395 | Constructor 396 | (ConsInfo {consName = SOP.constructorName ci, consFields = fields ci}) 397 | (Vector.fromList . SOP.hcollapse $ aux @xs) 398 | 399 | fields :: 400 | forall (xs :: [Type]). 401 | SOP.ConstructorInfo xs -> 402 | Maybe (Vector SOP.FieldName) 403 | fields (SOP.Record _ flds) = 404 | Just 405 | . Vector.fromList 406 | . SOP.hcollapse 407 | . SOP.hmap (K . SOP.fieldName) 408 | $ flds 409 | fields _ = Nothing 410 | 411 | aux :: 412 | forall (xs :: [Type]). 413 | (All DeepGeneric xs) => 414 | NP (K (Vector Constructor)) xs 415 | aux = SOP.hcpure (Proxy @DeepGeneric) constructorK 416 | 417 | constructorK :: 418 | forall (a' :: Type). DeepGeneric a' => K (Vector Constructor) a' 419 | constructorK = K $ untag (toConstructors' @a') 420 | 421 | {- | Calculate a set of logical constraints governing valid @Set Attribute@s 422 | for a type. 423 | 424 | = Examples (simplified) 425 | >>> typeLogic @Bool 426 | ExactlyOne [Attr Attr [] "False", Attr Attr [] "True"] 427 | 428 | >>> typeLogic @(Bool, Bool) 429 | All [ 430 | ExactlyOne [Attr Attr [("(,)",0)] "False", Attr Attr [("(,)",0)] "True"], 431 | ExactlyOne [Attr Attr [("(,)",1)] "False", Attr Attr [("(,)",1)] "True"] 432 | ] 433 | 434 | >>> typeLogic @(Either Bool Bool) 435 | All [ 436 | ExactlyOne [Attr Attr [] "Left",Attr Attr [] "Right"], 437 | Attr Attr [] "Left" :->: All [ 438 | ExactlyOne [Attr Attr [("Left",0)] "False",Attr Attr [("Left",0)] "True"], 439 | ], 440 | Not (Attr (Attr [] "Left")) :->: 441 | None [Attr Attr [("Left",0)] "False",Attr Attr [("Left",0)] "True"], 442 | Attr Attr [] "Right" :->: All [ 443 | ExactlyOne [Attr Attr [("Right",0)] "False",Attr Attr [("Right",0)] "True"] 444 | ], 445 | Not (Attr (Attr [] "Right")) :->: 446 | None [Attr Attr [("Right",0)] "False",Attr Attr [("Right",0)] "True"] 447 | ] 448 | -} 449 | typeLogic :: forall (d :: Type). (DeepGeneric d) => Formula d 450 | typeLogic = All . sumLogic $ toConstructors (Proxy @d) 451 | where 452 | sumLogic :: Vector Constructor -> Vector (Formula d) 453 | sumLogic cs = 454 | -- Only one of the top-level constructors can be selected 455 | ExactlyOne (subVars cs) 456 | `Vector.cons` 457 | -- apply 'prodLogic' to all the fields 458 | Vector.concatMap prodLogic cs 459 | 460 | prodLogic :: Constructor -> Vector (Formula d) 461 | prodLogic (Constructor (ConsInfo cn _) cs) = 462 | -- for each present constructor, one of the constructors of each of its 463 | -- fields can be selected 464 | ( rootVar cn 465 | :->: (All . Vector.imap (\i -> ExactlyOne . pushedSubvars cn i) $ cs) 466 | ) 467 | `Vector.cons` 468 | -- for each absent constructor, none of the constructors of any of its 469 | -- fields can be selected 470 | ( ( Not (rootVar cn) 471 | :->: (None . join . Vector.imap (pushedSubvars cn) $ cs) 472 | ) 473 | -- recurse 474 | `Vector.cons` join 475 | ( Vector.imap 476 | ( \i -> 477 | fmap (mapFormula $ pushVR cn i) 478 | . Vector.concatMap prodLogic 479 | ) 480 | cs 481 | ) 482 | ) 483 | 484 | pushedSubvars :: 485 | SOP.ConstructorName -> Int -> Vector Constructor -> Vector (Formula d) 486 | pushedSubvars cn i = fmap (mapFormula (pushVR cn i)) . subVars 487 | 488 | subVars :: Vector Constructor -> Vector (Formula d) 489 | subVars = fmap (rootVar . consName . constructorInfo) 490 | 491 | rootVar :: forall (d :: Type). SOP.ConstructorName -> Formula d 492 | rootVar = Var . rootVarRep 493 | 494 | {- | 495 | The full set of valid attributes for a type. 496 | 497 | Call using a type application. 498 | 499 | = Examples 500 | 501 | >>> allAttributes (Proxy @()) 502 | fromList [([],"()")] 503 | 504 | >>> allAttributes (Proxy @Bool) 505 | fromList 506 | [ ([],"False") 507 | , ([],"True") 508 | ] 509 | 510 | >>> allAttributes (Proxy @(Bool,Bool)) 511 | fromList 512 | [ ([],"(,)") 513 | , ([("(,)",0)],"False") 514 | , ([("(,)",0)],"True") 515 | , ([("(,)",1)],"False") 516 | , ([("(,)",1)],"True") 517 | ] 518 | 519 | >>> allAttributes (Proxy @(Either Bool Bool)) 520 | fromList 521 | [ ([],"Left") 522 | , ([],"Right") 523 | , ([("Left",0)],"False") 524 | , ([("Left",0)],"True") 525 | , ([("Right",0)],"False") 526 | , ([("Right",0)],"True") 527 | ] 528 | 529 | >>> allAttributes (Proxy @(Either Bool (Bool,Bool))) 530 | fromList 531 | [ ([],"Left") 532 | , ([],"Right") 533 | , ([("Left",0)],"False") 534 | , ([("Left",0)],"True") 535 | , ([("Right",0)],"(,)") 536 | , ([("Right",0),("(,)",0)],"False") 537 | , ([("Right",0),("(,)",0)],"True") 538 | , ([("Right",0),("(,)",1)],"False") 539 | , ([("Right",0),("(,)",1)],"True") 540 | ] 541 | 542 | >>> allAttributes (Proxy @(Bool, First Bool)) 543 | fromList 544 | [ ([],"(,)") 545 | , ([("(,)",0)],"False") 546 | , ([("(,)",0)],"True") 547 | , ([("(,)",1)],"First") 548 | , ([("(,)",1),("First","getFirst")],"False") 549 | , ([("(,)",1),("First","getFirst")],"True") 550 | ] 551 | -} 552 | allAttributes :: 553 | forall (d :: Type). 554 | (DeepGeneric d) => 555 | Proxy d -> 556 | Set (Vector (SOP.ConstructorName, FieldSelector), SOP.ConstructorName) 557 | allAttributes p = 558 | Set.map 559 | ((\Attr {attrPath, attrConstr} -> (attrPath, attrConstr)) . attrIntToFS) 560 | (allAttributes' p) 561 | 562 | allAttributes' :: 563 | forall (d :: Type). (DeepGeneric d) => Proxy d -> Set (Attribute Int d) 564 | allAttributes' = Set.unions . fmap constructorAttributes . toConstructors 565 | where 566 | constructorAttributes :: Constructor -> Set (Attribute Int d) 567 | constructorAttributes = 568 | foldConstructor 569 | ( \(ConsInfo cn _) flds -> 570 | Set.singleton (rootVarRep cn) 571 | <> Set.unions 572 | (Vector.imap (\i -> Set.map (pushVR cn i) . Set.unions) flds) 573 | ) 574 | 575 | {- | Match against descriptions containing the given attribute. 576 | 577 | An attribute represents a single constructor nested somewhere within an ADT, 578 | and hence a single property captured by a description type. Separate fields of 579 | the same type are represented by different attributes. The 'allAttributes' 580 | function can be used to query the possible attributes of a type. 581 | 582 | 'attr' takes two arguments: 583 | 584 | * the \'path\' to locate the attribute within the ADT, as a list of pairs of the 585 | containing field, and a field selector of type 'FieldSelector'. 586 | 587 | The 'FieldSelector' type is a little bit magic, see its docs for more 588 | details. 589 | 590 | * The name of the constructor representing the attribute. 591 | 592 | See also the examples for 'allAttributes' to see what an attribute looks like. 593 | -} 594 | attr :: 595 | forall (d :: Type). 596 | (DeepGeneric d) => 597 | -- | The \'path\' to the attribute. 598 | Vector (SOP.ConstructorName, FieldSelector) -> 599 | -- | The name of the constructor corresponding to the attribute. 600 | SOP.ConstructorName -> 601 | Formula d 602 | attr p = Var . attrFSToInt . Attr p 603 | 604 | transformAttr :: 605 | forall (d :: Type) (i :: Type) (j :: Type). 606 | (DeepGeneric d) => 607 | (Maybe (Vector SOP.FieldName) -> i -> j) -> 608 | (Maybe (Vector SOP.FieldName) -> i -> Int) -> 609 | Attribute i d -> 610 | Attribute j d 611 | transformAttr trans idx Attr {attrPath, attrConstr} = 612 | Attr (evalState (mapM act attrPath) (toConstructors $ Proxy @d)) attrConstr 613 | where 614 | act :: 615 | (SOP.ConstructorName, i) -> 616 | State (Vector Constructor) (SOP.ConstructorName, j) 617 | act (cn, i) = do 618 | con <- gets (findConstructor cn) 619 | let lab = consFields . constructorInfo $ con 620 | put $ subConstructors con Vector.! idx lab i 621 | return (cn, trans lab i) 622 | 623 | attrFSToInt :: 624 | forall (d :: Type). 625 | (DeepGeneric d) => 626 | Attribute FieldSelector d -> 627 | Attribute Int d 628 | attrFSToInt = transformAttr resolveFS resolveFS 629 | where 630 | resolveFS :: Maybe (Vector SOP.FieldName) -> FieldSelector -> Int 631 | resolveFS _ (Index i) = i 632 | resolveFS con (RecordField fld) = resolveField con fld 633 | 634 | resolveField :: Maybe (Vector SOP.FieldName) -> SOP.FieldName -> Int 635 | resolveField con fld = fromJust $ Vector.elemIndex fld =<< con 636 | 637 | attrIntToFS :: 638 | forall (d :: Type). 639 | (DeepGeneric d) => 640 | Attribute Int d -> 641 | Attribute FieldSelector d 642 | attrIntToFS = transformAttr index (const id) 643 | where 644 | index :: Maybe (Vector SOP.FieldName) -> Int -> FieldSelector 645 | index cons i = 646 | case cons of 647 | Nothing -> Index i 648 | Just flds -> RecordField (flds Vector.! i) 649 | 650 | findConstructor :: SOP.ConstructorName -> Vector Constructor -> Constructor 651 | findConstructor con = 652 | Vector.head . Vector.filter ((== con) . consName . constructorInfo) 653 | 654 | logic :: forall (d :: Type) (a :: Type). (Description d a) => Formula d 655 | logic = typeLogic :&&: refineDescription 656 | 657 | enumerateScenariosWhere :: 658 | forall (d :: Type) (a :: Type). 659 | (Description d a) => 660 | Formula d -> 661 | Set (Set (Attribute Int d)) 662 | enumerateScenariosWhere holds = enumerateSolutions $ logic :&&: holds 663 | 664 | scenarios :: 665 | forall (d :: Type) (a :: Type). 666 | (Description d a) => 667 | Set (Set (Attribute Int d)) 668 | scenarios = enumerateScenariosWhere Yes 669 | 670 | {- | 671 | Whether a description satisfies a formula. 672 | 673 | Use with 'Apropos.Runner.passIf' to create a predicate to pass to a runner from 674 | a 'Formula'. 675 | -} 676 | satisfies :: forall (d :: Type). (DeepGeneric d) => Formula d -> (d -> Bool) 677 | satisfies f s = 678 | satisfiable $ f :&&: All (setToVars set) :&&: None (setToVars unset) 679 | where 680 | set :: Set (Attribute Int d) 681 | set = descriptionToVariables s 682 | 683 | unset :: Set (Attribute Int d) 684 | unset = Set.difference (allAttributes' $ Proxy @d) set 685 | 686 | setToVars :: Set (Attribute Int d) -> Vector (Formula d) 687 | setToVars = fmap Var . Vector.fromList . Set.toList 688 | 689 | infixr 6 :&&: 690 | infixr 5 :||: 691 | infixr 4 :++: 692 | infixr 2 :->: 693 | infix 1 :<->: 694 | 695 | {- | 696 | Logical expressions for matching description types. 697 | -} 698 | type Formula :: Type -> Type 699 | data Formula attr 700 | = Var (Attribute Int attr) 701 | | Yes 702 | | No 703 | | Not (Formula attr) 704 | | Formula attr :&&: Formula attr 705 | | Formula attr :||: Formula attr 706 | | Formula attr :++: Formula attr 707 | | Formula attr :->: Formula attr 708 | | Formula attr :<->: Formula attr 709 | | All (Vector (Formula attr)) 710 | | Some (Vector (Formula attr)) 711 | | None (Vector (Formula attr)) 712 | | ExactlyOne (Vector (Formula attr)) 713 | | AtMostOne (Vector (Formula attr)) 714 | deriving stock (Generic) 715 | 716 | translateToSAT :: 717 | forall (attr :: Type). Formula attr -> MiniSAT.Formula (Attribute Int attr) 718 | translateToSAT (Var var) = MiniSAT.Var var 719 | translateToSAT Yes = MiniSAT.Yes 720 | translateToSAT No = MiniSAT.No 721 | translateToSAT (Not c) = MiniSAT.Not (translateToSAT c) 722 | translateToSAT (a :&&: b) = translateToSAT a MiniSAT.:&&: translateToSAT b 723 | translateToSAT (a :||: b) = translateToSAT a MiniSAT.:||: translateToSAT b 724 | translateToSAT (a :++: b) = translateToSAT a MiniSAT.:++: translateToSAT b 725 | translateToSAT (a :->: b) = translateToSAT a MiniSAT.:->: translateToSAT b 726 | translateToSAT (a :<->: b) = translateToSAT a MiniSAT.:<->: translateToSAT b 727 | translateToSAT (All cs) = MiniSAT.All . Vector.toList $ translateToSAT <$> cs 728 | translateToSAT (Some cs) = MiniSAT.Some . Vector.toList $ translateToSAT <$> cs 729 | translateToSAT (None cs) = MiniSAT.None . Vector.toList $ translateToSAT <$> cs 730 | translateToSAT (ExactlyOne cs) = 731 | MiniSAT.ExactlyOne . Vector.toList $ translateToSAT <$> cs 732 | translateToSAT (AtMostOne cs) = 733 | MiniSAT.AtMostOne . Vector.toList $ translateToSAT <$> cs 734 | 735 | mapFormula :: 736 | forall (a :: Type) (b :: Type). 737 | (Attribute Int a -> Attribute Int b) -> 738 | Formula a -> 739 | Formula b 740 | mapFormula f (Var var) = Var (f var) 741 | mapFormula _ Yes = Yes 742 | mapFormula _ No = No 743 | mapFormula f (Not c) = Not (mapFormula f c) 744 | mapFormula f (a :&&: b) = mapFormula f a :&&: mapFormula f b 745 | mapFormula f (a :||: b) = mapFormula f a :||: mapFormula f b 746 | mapFormula f (a :++: b) = mapFormula f a :++: mapFormula f b 747 | mapFormula f (a :->: b) = mapFormula f a :->: mapFormula f b 748 | mapFormula f (a :<->: b) = mapFormula f a :<->: mapFormula f b 749 | mapFormula f (All cs) = All (mapFormula f <$> cs) 750 | mapFormula f (Some cs) = Some (mapFormula f <$> cs) 751 | mapFormula f (None cs) = None (mapFormula f <$> cs) 752 | mapFormula f (ExactlyOne cs) = ExactlyOne (mapFormula f <$> cs) 753 | mapFormula f (AtMostOne cs) = AtMostOne (mapFormula f <$> cs) 754 | 755 | instance (Eq attr) => Eq (Formula attr) where 756 | a == b = translateToSAT a == translateToSAT b 757 | 758 | instance (Ord attr) => Ord (Formula attr) where 759 | compare a b = compare (translateToSAT a) (translateToSAT b) 760 | 761 | -- instance (Show attr, DeepGeneric attr) => Show (Formula attr) where 762 | -- show a = show (translateToSAT a) 763 | 764 | satisfiable :: forall (attr :: Type). Formula attr -> Bool 765 | satisfiable = MiniSAT.satisfiable . translateToSAT 766 | 767 | solveAll :: 768 | forall (attr :: Type). Formula attr -> Vector (Map (Attribute Int attr) Bool) 769 | solveAll = Vector.fromList . MiniSAT.solve_all . translateToSAT 770 | 771 | enumerateSolutions :: 772 | forall (attr :: Type). Formula attr -> Set (Set (Attribute Int attr)) 773 | enumerateSolutions f = 774 | Set.fromList . Vector.toList $ Map.keysSet . Map.filter id <$> solveAll f 775 | -------------------------------------------------------------------------------- /src/Apropos/Generator.hs: -------------------------------------------------------------------------------- 1 | module Apropos.Generator ( 2 | runTest, 3 | decorateTests, 4 | selfTest, 5 | selfTestWhere, 6 | ) where 7 | 8 | import Apropos.Description ( 9 | Description (describe, genDescribed), 10 | scenarios, 11 | variablesToDescription, 12 | ) 13 | import Data.Bifunctor (first) 14 | import Data.Kind (Type) 15 | import Data.Map (Map) 16 | import Data.Map qualified as Map 17 | import Data.Proxy (Proxy) 18 | import Data.Set qualified as Set 19 | import Data.String (IsString, fromString) 20 | import Hedgehog (Property, PropertyT, forAll, property, (===)) 21 | 22 | runTest :: 23 | forall (a :: Type) (d :: Type). 24 | (Show a, Description d a) => 25 | (a -> PropertyT IO ()) -> 26 | d -> 27 | Property 28 | runTest cond d = property $ forAll (genDescribed d) >>= cond 29 | 30 | decorateTests :: 31 | forall (s :: Type) (d :: Type). 32 | (IsString s, Show d) => 33 | Map d Property -> 34 | [(s, Property)] 35 | decorateTests = map (first $ fromString . show) . Map.toList 36 | 37 | -- TODO caching calls to the solver in genSatisfying would probably be worth it 38 | selfTestForDescription :: 39 | forall (d :: Type) (a :: Type). 40 | (Eq d, Show d, Show a, Description d a) => 41 | d -> 42 | Property 43 | selfTestForDescription d = runTest (\a -> describe a === d) d 44 | 45 | {- | 46 | Test the lawfulness of a 'Description' instance. 47 | 48 | The result type is @IsString s => [(s, Property)]@ so it can be plugged directly 49 | into the Hedgehog 'Hedgehog.Group' constructor. 50 | -} 51 | selfTest :: 52 | forall (d :: Type) (a :: Type) (s :: Type). 53 | (Ord d, Show d, Show a, Description d a, IsString s) => 54 | Proxy d -> 55 | [(s, Property)] 56 | selfTest _ = selfTestWhere @d (const True) 57 | 58 | -- | Like 'selfTest', but you can filter which descriptions are tested. 59 | selfTestWhere :: 60 | forall (d :: Type) (a :: Type) (s :: Type). 61 | (Ord d, Show d, Show a, Description d a, IsString s) => 62 | (d -> Bool) -> 63 | [(s, Property)] 64 | selfTestWhere f = 65 | decorateTests 66 | . Map.fromSet selfTestForDescription 67 | . Set.filter f 68 | . Set.map variablesToDescription 69 | $ scenarios 70 | -------------------------------------------------------------------------------- /src/Apropos/Runner.hs: -------------------------------------------------------------------------------- 1 | module Apropos.Runner ( 2 | runTests, 3 | runTestsWhere, 4 | Outcome (Pass, Fail), 5 | passIf, 6 | OptOutcome (Run, Ignore), 7 | ) where 8 | 9 | import Apropos.Description (Description, scenarios, variablesToDescription) 10 | import Apropos.Generator (decorateTests, runTest) 11 | import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) 12 | import Data.Bool (bool) 13 | import Data.Either (isRight) 14 | import Data.Kind (Type) 15 | import Data.Map qualified as Map 16 | import Data.Set qualified as Set 17 | import Data.String (IsString) 18 | import Hedgehog (Property, PropertyT, (===)) 19 | import Hedgehog.Internal.Property ( 20 | PropertyT (PropertyT), 21 | TestT (TestT, unTest), 22 | unPropertyT, 23 | ) 24 | 25 | -- | Whether a test should pass or fail 26 | data Outcome = Pass | Fail 27 | deriving stock (Eq, Show) 28 | 29 | -- | Construct an 'Outcome' from a 'Bool' predicate 30 | passIf :: Bool -> Outcome 31 | passIf = bool Pass Fail 32 | 33 | -- | Whether a test should be ignored 34 | data OptOutcome 35 | = Run Outcome 36 | | Ignore 37 | 38 | optOutcomeToMaybe :: OptOutcome -> Maybe Outcome 39 | optOutcomeToMaybe Ignore = Nothing 40 | optOutcomeToMaybe (Run o) = Just o 41 | 42 | runAproposTest :: 43 | forall (d :: Type) (a :: Type). 44 | (Description d a, Show a) => 45 | Outcome -> 46 | (a -> PropertyT IO ()) -> 47 | d -> 48 | Property 49 | runAproposTest expect test = 50 | runTest 51 | ( \a -> do 52 | b <- passes (test a) 53 | expect === b 54 | ) 55 | where 56 | passes :: PropertyT IO () -> PropertyT IO Outcome 57 | passes = 58 | PropertyT 59 | . TestT 60 | . ExceptT 61 | . fmap (Right . passIf . isRight) 62 | . runExceptT 63 | . unTest 64 | . unPropertyT 65 | 66 | {- | 67 | 68 | Run Apropos tests. 69 | 70 | Apropos is able to test both positive and negative cases. By returning 'Fail' 71 | from the predicate, you can expect the test to fail for a given description. 72 | 73 | To ignore descriptions entirely, use 'runTestsWhere'. 74 | -} 75 | runTests :: 76 | forall (d :: Type) (a :: Type) (s :: Type). 77 | (Show d, Show a, Ord d, Description d a, IsString s) => 78 | -- | Should the test pass or fail? 79 | (d -> Outcome) -> 80 | -- | The test to run 81 | (a -> PropertyT IO ()) -> 82 | [(s, Property)] 83 | runTests f = runTestsWhere (Run . f) 84 | 85 | {- | 86 | 87 | Run Apropos tests on a subset of descriptions. 88 | -} 89 | runTestsWhere :: 90 | forall (d :: Type) (a :: Type) (s :: Type). 91 | (Show d, Show a, Ord d, Description d a, IsString s) => 92 | -- | Should the test pass, fail, or be ignored? 93 | (d -> OptOutcome) -> 94 | -- | The test to run 95 | (a -> PropertyT IO ()) -> 96 | [(s, Property)] 97 | runTestsWhere expect test = 98 | decorateTests 99 | . Map.mapMaybeWithKey 100 | ( \d () -> 101 | (\b -> runAproposTest b test d) <$> optOutcomeToMaybe (expect d) 102 | ) 103 | . Map.fromSet (const ()) 104 | . Set.map variablesToDescription 105 | $ scenarios @d 106 | --------------------------------------------------------------------------------