├── .github └── workflows │ └── ci.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── examples ├── generic-random-examples.cabal ├── generic.hs ├── text.hs └── tour.hs ├── generic-random.cabal ├── src └── Generic │ ├── Random.hs │ └── Random │ ├── DerivingVia.hs │ ├── Internal │ ├── BaseCase.hs │ └── Generic.hs │ └── Tutorial.hs ├── stack.yaml └── test ├── Inspect.hs ├── Inspect └── DerivingVia.hs ├── Spec.hs ├── Unit.hs └── coherence.hs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the master branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: [master] 8 | 9 | jobs: 10 | cabal: 11 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | matrix: 15 | os: [ubuntu-latest, macOS-latest, windows-latest] 16 | cabal: ["3.2"] 17 | ghc: 18 | - "8.6" 19 | - "8.8" 20 | - "8.10" 21 | - "9.0" 22 | - "9.2" 23 | - "9.4" 24 | - "latest" 25 | exclude: 26 | - os: macOS-latest 27 | ghc: 9.0 28 | - os: macOS-latest 29 | ghc: 8.10 30 | - os: macOS-latest 31 | ghc: 8.8 32 | - os: macOS-latest 33 | ghc: 8.6 34 | - os: macOS-latest 35 | ghc: 8.4 36 | - os: macOS-latest 37 | ghc: 8.2 38 | - os: macOS-latest 39 | ghc: 8.0 40 | - os: windows-latest 41 | ghc: 9.0 42 | - os: windows-latest 43 | ghc: 8.10 44 | - os: windows-latest 45 | ghc: 8.8 46 | - os: windows-latest 47 | ghc: 8.6 48 | - os: windows-latest 49 | ghc: 8.4 50 | - os: windows-latest 51 | ghc: 8.2 52 | - os: windows-latest 53 | ghc: 8.0 54 | 55 | steps: 56 | - uses: actions/checkout@v3 57 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 58 | 59 | - uses: haskell/actions/setup@v2 60 | id: setup-haskell-cabal 61 | name: Setup Haskell 62 | with: 63 | ghc-version: ${{ matrix.ghc }} 64 | cabal-version: ${{ matrix.cabal }} 65 | 66 | - name: Configure 67 | run: | 68 | cabal configure --enable-tests --enable-benchmarks --test-show-details=direct 69 | 70 | - name: Freeze 71 | run: | 72 | cabal freeze 73 | 74 | - uses: actions/cache@v2 75 | name: Cache ~/.cabal/store 76 | with: 77 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 78 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 79 | 80 | - name: Install dependencies 81 | run: | 82 | cabal build all --only-dependencies 83 | 84 | - name: Build 85 | run: | 86 | cabal build all --enable-tests --enable-benchmarks --write-ghc-environment-files=always 87 | 88 | - name: Test 89 | run: | 90 | cabal test all 91 | 92 | - name: Test inspect 93 | if: matrix.ghc == '8.10' 94 | run: | 95 | rm cabal.project.freeze 96 | cabal test .:inspect --flags="enable-inspect" 97 | 98 | stack: 99 | name: stack / ghc ${{ matrix.ghc }} 100 | runs-on: ubuntu-latest 101 | strategy: 102 | matrix: 103 | stack: ["latest"] 104 | ghc: ["9.2"] 105 | 106 | steps: 107 | - uses: actions/checkout@v2 108 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master' 109 | 110 | - uses: haskell/actions/setup@v1 111 | name: Setup Haskell Stack 112 | with: 113 | ghc-version: ${{ matrix.ghc }} 114 | stack-version: ${{ matrix.stack }} 115 | 116 | - uses: actions/cache@v2 117 | name: Cache ~/.stack 118 | with: 119 | path: ~/.stack 120 | key: ${{ runner.os }}-${{ matrix.ghc }}-stack 121 | 122 | - name: Install dependencies 123 | run: | 124 | stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies 125 | 126 | - name: Build 127 | run: | 128 | stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks 129 | 130 | - name: Test 131 | run: | 132 | stack test --system-ghc 133 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | Latest version: https://github.com/Lysxia/generic-random/blob/master/changelog.md 4 | 5 | # 1.5.0.1 6 | 7 | - Support GHC 9.2 8 | 9 | # 1.5.0.0 10 | 11 | - Add newtypes for `DerivingVia` (thanks, blackheaven) 12 | - Drop compatibility with GHC 8.0 and 8.2 13 | 14 | # 1.4.0.0 15 | 16 | - Add option to use only coherent instances 17 | - Export `SetSized` and `SetUnsized` 18 | - Drop compatibility with GHC 7 19 | 20 | # 1.3.0.1 21 | 22 | - Fix small typos in documentation. 23 | 24 | # 1.3.0.0 25 | 26 | - Add `ConstrGen` (custom generators for fields specified by constructor name 27 | and index). 28 | - Stop requiring custom generators lists to be terminated by `:+ ()`, or to be 29 | lists at all. 30 | - Breaking minor change: when a record field has a different type than 31 | a `FieldGen` custom generator for the same field name, this is now a 32 | compilation error. This was simply ignored before. 33 | - Miscellaneous documentation improvements in `Generic.Random` module. 34 | 35 | # 1.2.0.0 36 | 37 | - Fix a bug where generators did not decrease the size parameter with 38 | single-field constructors 39 | 40 | - The sized generators now use a custom generator for lists. 41 | Use `genericArbitraryRecG ()` to disable that. 42 | See tutorial for more information. 43 | 44 | - Lists of custom generators are now constructed using `(:+)` instead of 45 | `GenList` 46 | - Rename `Field` to `FieldGen` 47 | - Add `Gen1`, `Gen1_` (custom generators for unary type constructors) 48 | - Add `listOf'`, `listOf1'`, `vectorOf'` 49 | - Remove deprecated module `Generic.Random.Generic` 50 | 51 | # 1.1.0.2 52 | 53 | - Improved performance 54 | 55 | # 1.1.0.1 56 | 57 | - Fix build for GHC<8 58 | 59 | # 1.1.0.0 60 | 61 | - Add option to specify custom generators for certain fields, 62 | overriding Arbitrary instances 63 | + Add `genericArbitraryG`, `genericArbitraryUG`, `genericArbitrarySingleG`, 64 | `genericArbitraryRecG` 65 | - Add `GArbitrary` and `GUniformWeight` synonyms 66 | - Deprecate `Generic.Random.Generic` 67 | - Remove `weights` from the external API 68 | 69 | # 1.0.0.0 70 | 71 | - Make the main module `Generic.Random` 72 | - Rework generic base case generation 73 | + You can explicitly provide a trivial generator (e.g., returning a 74 | nullary constructor) using `withBaseCase` 75 | + Generically derive `BaseCaseSearch` and let `BaseCase` find small 76 | values, no depth parameter must be specified anymore 77 | - Add `genericArbitrarySingle`, `genericArbitraryRec`, `genericArbitraryU'` 78 | - Deprecate `weights` 79 | - Fixed bug with `genericArbitrary'` not dividing the size parameter 80 | 81 | # 0.5.0.0 82 | 83 | - Turn off dependency on boltzmann-samplers by default 84 | - Add `genericArbitraryU`, `genericArbitraryU0` and `genericArbitraryU1` 85 | - Compatible with GHC 7.8.4 and GHC 7.10.3 86 | 87 | # 0.4.1.0 88 | 89 | - Move Boltzmann sampler modules to another package: boltzmann-samplers 90 | 91 | # 0.4.0.0 92 | 93 | - Check well-formedness of constructor distributions at compile time. 94 | - No longer support GHC 7.10.3 (the above feature relies on Generic 95 | information which does not exist before GHC 8) 96 | 97 | # 0.3.0.0 98 | 99 | - Support GHC 7.10.3 100 | - Replace `TypeApplications` with ad-hoc data types in 101 | `genericArbitraryFrequency'`/`genericArbitrary'` 102 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Li-yao Xia 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Generic random generators [![Hackage](https://img.shields.io/hackage/v/generic-random.svg)](https://hackage.haskell.org/package/generic-random) [![Build Status](https://github.com/Lysxia/generic-random/actions/workflows/ci.yml/badge.svg)](https://github.com/Lysxia/generic-random/actions/workflows/ci.yml) 2 | ========================= 3 | 4 | Generic random generators 5 | to implement `Arbitrary` instances for [QuickCheck](https://hackage.haskell.org/package/QuickCheck) 6 | 7 | Automating the `arbitrary` boilerplate also ensures that when a type changes to 8 | have more or fewer constructors, then the generator either fixes itself to 9 | generate that new case (when using the `uniform` distribution) or causes a 10 | compilation error so you remember to fix it (when using an explicit 11 | distribution). 12 | 13 | This package also offers a simple (optional) strategy to ensure termination for 14 | recursive types: 15 | make `Test.QuickCheck.Gen`'s size parameter decrease at every recursive call; 16 | when it reaches zero, sample directly from a trivially terminating generator 17 | given explicitly (`genericArbitraryRec` and `withBaseCase`) or implicitly 18 | (`genericArbitrary'`). 19 | 20 | Example 21 | ------- 22 | 23 | ```haskell 24 | {-# LANGUAGE DeriveGeneric #-} 25 | 26 | import GHC.Generics (Generic) 27 | import Test.QuickCheck 28 | import Generic.Random 29 | 30 | data Tree a = Leaf | Node (Tree a) a (Tree a) 31 | deriving (Show, Generic) 32 | 33 | instance Arbitrary a => Arbitrary (Tree a) where 34 | arbitrary = genericArbitraryRec uniform `withBaseCase` return Leaf 35 | 36 | -- Equivalent to 37 | -- > arbitrary = 38 | -- > sized $ \n -> 39 | -- > if n == 0 then 40 | -- > return Leaf 41 | -- > else 42 | -- > oneof 43 | -- > [ return Leaf 44 | -- > , resize (n `div` 3) $ 45 | -- > Node <$> arbitrary <*> arbitrary <*> arbitrary 46 | -- > ] 47 | 48 | main :: IO () 49 | main = sample (arbitrary :: Gen (Tree ())) 50 | ``` 51 | 52 | Related 53 | ------- 54 | 55 | - The following two packages also derive random generators, but only with a uniform 56 | distribution of constructors: 57 | 58 | + [quickcheck-arbitrary-template](https://hackage.haskell.org/package/quickcheck-arbitrary-template) (TH) 59 | + [generic-arbitrary](https://hackage.haskell.org/package/generic-arbitrary-0.1.0) (GHC Generics) 60 | 61 | - [testing-feat](http://hackage.haskell.org/package/testing-feat): 62 | derive enumerations for algebraic data types, which can be turned into random generators (TH). 63 | 64 | - [boltzmann-samplers](https://hackage.haskell.org/package/boltzmann-samplers): 65 | derive Boltzmann samplers (SYB). 66 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/generic-random-examples.cabal: -------------------------------------------------------------------------------- 1 | name: generic-random-examples 2 | version: 0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | executable generic-example 7 | main-is: generic.hs 8 | ghc-options: -Wall 9 | if impl(ghc < 7.10) 10 | ghc-options: -fcontext-stack=30 11 | build-depends: 12 | base, 13 | QuickCheck, 14 | generic-random 15 | default-language: Haskell2010 16 | 17 | executable text-example 18 | main-is: text.hs 19 | ghc-options: -Wall -Wno-orphans -Wno-unused-top-binds 20 | build-depends: 21 | base, 22 | QuickCheck, 23 | text, 24 | generic-random 25 | default-language: Haskell2010 26 | if !impl(ghc >= 8.0) 27 | buildable: False 28 | 29 | executable tour-example 30 | main-is: tour.hs 31 | ghc-options: -Wall 32 | if impl(ghc >= 8.0) 33 | ghc-options: -Wno-orphans -Wno-unused-imports 34 | if impl(ghc < 7.10) 35 | ghc-options: -fcontext-stack=30 36 | build-depends: 37 | base, 38 | QuickCheck, 39 | text, 40 | generic-random 41 | default-language: Haskell2010 42 | 43 | executable tour-bench 44 | main-is: tour.hs 45 | ghc-options: -O2 -dsuppress-all -dno-suppress-module-prefixes 46 | if impl(ghc >= 8.0) 47 | ghc-options: -Wno-unused-imports 48 | cpp-options: -DBENCHMODE 49 | build-depends: 50 | base, 51 | QuickCheck, 52 | text, 53 | generic-random 54 | default-language: Haskell2010 55 | -------------------------------------------------------------------------------- /examples/generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | 9 | import GHC.Generics (Generic) 10 | import Test.QuickCheck 11 | import Generic.Random 12 | 13 | data Tree a = Leaf | Node (Tree a) a (Tree a) 14 | deriving (Show, Generic) 15 | 16 | instance Arbitrary a => Arbitrary (Tree a) where 17 | arbitrary = genericArbitrary' uniform 18 | 19 | data Bush a = Tip a | Fork (Bush a) (Bush a) 20 | deriving (Show, Generic) 21 | 22 | instance (Arbitrary a, BaseCase (Bush a)) => Arbitrary (Bush a) where 23 | arbitrary = genericArbitrary' (1 % (2 % ())) 24 | 25 | main :: IO () 26 | main = do 27 | sample (arbitrary :: Gen (Tree ())) 28 | putStrLn "" 29 | sample (arbitrary :: Gen (Bush ())) 30 | -------------------------------------------------------------------------------- /examples/text.hs: -------------------------------------------------------------------------------- 1 | -- An example of generic Arbitrary instances with explicit generators 2 | -- for some types of fields for which there is no 'Arbitrary' instance 3 | -- or the existing one is unsatisfactory. 4 | -- 5 | -- For example, Postgres can't handle strings containing NUL characters 6 | -- see https://github.com/lpsmith/postgresql-simple/issues/223 7 | -- so applications may want to generate data without them. 8 | 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE DeriveGeneric #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | 13 | import Data.Char (isAlphaNum) 14 | import Data.Text as T (Text, pack, unpack) 15 | import GHC.Generics (Generic) 16 | import Test.QuickCheck 17 | 18 | import Generic.Random 19 | 20 | instance Arbitrary Text where 21 | arbitrary = pack <$> arbitrary 22 | shrink = fmap pack . shrink . unpack 23 | 24 | data R = R -- Two constraints: 25 | { name :: Text -- names and 26 | , address :: Text -- addresses don't contain '\NUL' 27 | , id_ :: Text -- IDs are alphanumeric 28 | } deriving (Show, Generic) 29 | 30 | instance Arbitrary R where 31 | arbitrary = genericArbitrarySingleG gens 32 | where 33 | gens = 34 | (FieldGen (pack . filter isAlphaNum <$> scale (* 5) arbitrary) 35 | :: FieldGen "id_" Text) :+ 36 | (pack . filter (/= '\NUL') <$> arbitrary) 37 | 38 | shrink = genericShrink 39 | 40 | newtype Bugged a = Bugged a deriving Show 41 | 42 | instance Arbitrary (Bugged R) where 43 | arbitrary = Bugged <$> genericArbitrarySingle 44 | shrink (Bugged r) = Bugged <$> shrink r 45 | 46 | main :: IO () 47 | main = do 48 | sample (arbitrary :: Gen R) 49 | let prop_nameNullFree r = all (/= '\NUL') (unpack (name r)) 50 | prop_idAlpha r = all isAlphaNum (unpack (id_ r)) 51 | qc prop = quickCheckWith stdArgs{maxSuccess = 1000} prop 52 | qc prop_nameNullFree 53 | qc prop_idAlpha 54 | qc $ expectFailure $ \(Bugged r) -> prop_nameNullFree r 55 | qc $ expectFailure $ \(Bugged r) -> prop_idAlpha r 56 | -------------------------------------------------------------------------------- /examples/tour.hs: -------------------------------------------------------------------------------- 1 | -- Just another toy example 2 | 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE InstanceSigs #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | import Control.Monad (replicateM) 12 | import GHC.Generics 13 | import Test.QuickCheck (Arbitrary(..), Gen, quickCheck, sample, generate) 14 | 15 | import Generic.Random (genericArbitraryG, (:+)(..), (%)) 16 | 17 | data MyType 18 | = OneThing Int 19 | | TwoThings Double String 20 | | ThreeThings (Maybe Integer) [()] (Bool -> Word) 21 | deriving (Show, Generic) 22 | 23 | custom :: Gen (Maybe Integer) :+ () 24 | custom = (Just <$> arbitrary) :+ () 25 | 26 | instance Arbitrary MyType where 27 | arbitrary :: Gen MyType 28 | arbitrary = genericArbitraryG custom (1 % 4 % 4 % ()) 29 | -- arbitrary = frequency 30 | -- [ (1, OneThing <$> arbitrary) 31 | -- , (4, TwoThings <$> arbitrary <*> arbitrary) 32 | -- , (4, ThreeThings <$> (Just <$> arbitrary) <*> arbitrary <*> arbitrary) 33 | -- ] 34 | 35 | main :: IO () 36 | #ifndef BENCHMODE 37 | main = do 38 | -- Print some examples 39 | sample (arbitrary :: Gen MyType) 40 | 41 | -- Check the property that ThreeThings contains three things. 42 | quickCheck $ \case 43 | ThreeThings Nothing _ _ -> False 44 | _ -> True 45 | #else 46 | -- Quick and dirty benchmark 47 | main = do 48 | xs <- generate (replicateM 1000000 (arbitrary :: Gen MyType)) 49 | go xs 50 | where 51 | go [] = print () 52 | go (x : xs) = x `seq` go xs 53 | #endif 54 | 55 | -- Ew. Sorry. 56 | instance Show a => Show (Bool -> a) where 57 | show f = " " ++ show (f True) ++ ",False -> " ++ show (f False) ++ ">" 58 | -------------------------------------------------------------------------------- /generic-random.cabal: -------------------------------------------------------------------------------- 1 | name: generic-random 2 | version: 1.5.0.1 3 | synopsis: Generic random generators for QuickCheck 4 | description: 5 | Derive instances of @Arbitrary@ for QuickCheck, 6 | with various options to customize implementations. 7 | . 8 | For more information 9 | . 10 | - See the README 11 | . 12 | - "Generic.Random.Tutorial" 13 | . 14 | - http://blog.poisson.chat/posts/2018-01-05-generic-random-tour.html 15 | 16 | homepage: http://github.com/lysxia/generic-random 17 | license: MIT 18 | license-file: LICENSE 19 | stability: Stable 20 | author: Li-yao Xia 21 | maintainer: lysxia@gmail.com 22 | category: Generics, Testing 23 | build-type: Simple 24 | extra-source-files: README.md CHANGELOG.md 25 | cabal-version: >=1.10 26 | tested-with: GHC == 8.6.1, GHC == 8.8.4, GHC == 8.10.5, GHC == 9.0.1, GHC == 9.2.7, GHC == 9.4.4, GHC == 9.6.1 27 | 28 | library 29 | hs-source-dirs: src 30 | exposed-modules: 31 | Generic.Random 32 | Generic.Random.DerivingVia 33 | Generic.Random.Internal.BaseCase 34 | Generic.Random.Internal.Generic 35 | Generic.Random.Tutorial 36 | build-depends: 37 | base >= 4.12 && < 5, 38 | QuickCheck >= 2.14 39 | -- exports RecursivelyShrink 40 | default-language: Haskell2010 41 | ghc-options: -Wall -fno-warn-name-shadowing 42 | 43 | source-repository head 44 | type: git 45 | location: https://github.com/lysxia/generic-random 46 | 47 | test-suite unit 48 | hs-source-dirs: test 49 | main-is: Unit.hs 50 | build-depends: 51 | base, 52 | deepseq, 53 | QuickCheck, 54 | generic-random 55 | type: exitcode-stdio-1.0 56 | default-language: Haskell2010 57 | 58 | test-suite coherence 59 | hs-source-dirs: test 60 | main-is: coherence.hs 61 | build-depends: 62 | base, 63 | deepseq, 64 | QuickCheck, 65 | generic-random 66 | type: exitcode-stdio-1.0 67 | default-language: Haskell2010 68 | 69 | test-suite inspect 70 | hs-source-dirs: test 71 | main-is: Inspect.hs 72 | build-depends: 73 | base, 74 | QuickCheck, 75 | inspection-testing, 76 | generic-random 77 | type: exitcode-stdio-1.0 78 | default-language: Haskell2010 79 | if !flag(enable-inspect) 80 | buildable: False 81 | else 82 | build-depends: random < 1.2 83 | -- TODO: this test fails with newer versions of random 84 | 85 | test-suite inspect-derivingvia 86 | hs-source-dirs: test 87 | main-is: Inspect/DerivingVia.hs 88 | build-depends: 89 | base, 90 | QuickCheck, 91 | inspection-testing, 92 | generic-random 93 | type: exitcode-stdio-1.0 94 | default-language: Haskell2010 95 | if !flag(enable-inspect) 96 | buildable: False 97 | else 98 | build-depends: random < 1.2 99 | -- TODO: this test fails with newer versions of random 100 | 101 | flag enable-inspect 102 | description: Enable inspection tests 103 | default: False 104 | manual: True 105 | -------------------------------------------------------------------------------- /src/Generic/Random.hs: -------------------------------------------------------------------------------- 1 | -- | "GHC.Generics"-based 'Test.QuickCheck.arbitrary' generators. 2 | -- 3 | -- = Basic usage 4 | -- 5 | -- @ 6 | -- {-\# LANGUAGE DeriveGeneric \#-} 7 | -- 8 | -- data Foo = A | B | C -- some generic data type 9 | -- deriving 'GHC.Generics.Generic' 10 | -- @ 11 | -- 12 | -- Derive instances of 'Test.QuickCheck.Arbitrary'. 13 | -- 14 | -- @ 15 | -- instance Arbitrary Foo where 16 | -- arbitrary = 'genericArbitrary' 'uniform' -- Give a distribution of constructors. 17 | -- shrink = 'Test.QuickCheck.genericShrink' -- Generic shrinking is provided by the QuickCheck library. 18 | -- @ 19 | -- 20 | -- Or derive standalone generators (the fields must still be instances of 21 | -- 'Test.QuickCheck.Arbitrary', or use custom generators). 22 | -- 23 | -- @ 24 | -- genFoo :: Gen Foo 25 | -- genFoo = 'genericArbitrary' 'uniform' 26 | -- @ 27 | -- 28 | -- === Using @DerivingVia@ 29 | -- 30 | -- @ 31 | -- {-\# LANGUAGE DerivingVia, TypeOperators \#-} 32 | -- 33 | -- data Foo = A | B | C 34 | -- deriving 'GHC.Generics.Generic' 35 | -- deriving Arbitrary via ('GenericArbitraryU' `'AndShrinking'` Foo) 36 | -- @ 37 | -- 38 | -- For more information: 39 | -- 40 | -- - "Generic.Random.Tutorial" 41 | -- - http://blog.poisson.chat/posts/2018-01-05-generic-random-tour.html 42 | 43 | {-# LANGUAGE ExplicitNamespaces #-} 44 | 45 | module Generic.Random 46 | ( 47 | -- * Arbitrary implementations 48 | 49 | -- | The suffixes for the variants have the following meanings: 50 | -- 51 | -- - @U@: pick constructors with uniform distribution (equivalent to 52 | -- passing 'uniform' to the non-@U@ variant). 53 | -- - @Single@: restricted to types with a single constructor. 54 | -- - @G@: with custom generators. 55 | -- - @Rec@: decrease the size at every recursive call (ensuring termination 56 | -- for (most) recursive types). 57 | -- - @'@: automatic discovery of "base cases" when size reaches 0. 58 | genericArbitrary 59 | , genericArbitraryU 60 | , genericArbitrarySingle 61 | , genericArbitraryRec 62 | , genericArbitrary' 63 | , genericArbitraryU' 64 | 65 | -- ** With custom generators 66 | 67 | -- | 68 | -- === Note about incoherence 69 | -- 70 | -- The custom generator feature relies on incoherent instances, which can 71 | -- lead to surprising behaviors for parameterized types. 72 | -- 73 | -- ==== __Example__ 74 | -- 75 | -- For example, here is a pair type and a custom generator of @Int@ (always 76 | -- generating 0). 77 | -- 78 | -- @ 79 | -- data Pair a b = Pair a b 80 | -- deriving (Generic, Show) 81 | -- 82 | -- customGen :: Gen Int 83 | -- customGen = pure 0 84 | -- @ 85 | -- 86 | -- The following two ways of defining a generator of @Pair Int Int@ are 87 | -- __not__ equivalent. 88 | -- 89 | -- The first way is to use 'genericArbitrarySingleG' to define a 90 | -- @Gen (Pair a b)@ parameterized by types @a@ and @b@, and then 91 | -- specialize it to @Gen (Pair Int Int)@. 92 | -- 93 | -- In this case, the @customGen@ will be ignored. 94 | -- 95 | -- @ 96 | -- genPair :: (Arbitrary a, Arbitrary b) => Gen (Pair a b) 97 | -- genPair = 'genericArbitrarySingleG' customGen 98 | -- 99 | -- genPair' :: Gen (Pair Int Int) 100 | -- genPair' = genPair 101 | -- -- Will generate nonzero pairs 102 | -- @ 103 | -- 104 | -- The second way is to define @Gen (Pair Int Int)@ directly using 105 | -- 'genericArbitrarySingleG' (as if we inlined @genPair@ in @genPair'@ 106 | -- above. 107 | -- 108 | -- Then the @customGen@ will actually be used. 109 | -- 110 | -- @ 111 | -- genPair2 :: Gen (Pair Int Int) 112 | -- genPair2 = 'genericArbitrarySingleG' customGen 113 | -- -- Will only generate (Pair 0 0) 114 | -- @ 115 | -- 116 | -- In other words, the decision of whether to use a custom generator 117 | -- is done by comparing the type of the custom generator with the type of 118 | -- the field only in the context where 'genericArbitrarySingleG' is being 119 | -- used (or any other variant with a @G@ suffix). 120 | -- 121 | -- In the first case above, those fields have types @a@ and @b@, which are 122 | -- not equal to @Int@ (or rather, there is no available evidence that they 123 | -- are equal to @Int@, even if they could be instantiated as @Int@ later). 124 | -- In the second case, they both actually have type @Int@. 125 | 126 | , genericArbitraryG 127 | , genericArbitraryUG 128 | , genericArbitrarySingleG 129 | , genericArbitraryRecG 130 | 131 | -- * Specifying finite distributions 132 | , Weights 133 | , W 134 | , (%) 135 | , uniform 136 | 137 | -- * Custom generators 138 | 139 | -- | Custom generators can be specified in a list constructed with @(':+')@, 140 | -- and passed to functions such as 'genericArbitraryG' to override how certain 141 | -- fields are generated. 142 | -- 143 | -- Example: 144 | -- 145 | -- @ 146 | -- customGens :: Gen String ':+' Gen Int 147 | -- customGens = 148 | -- (filter (/= '\NUL') '<$>' arbitrary) ':+' 149 | -- (getNonNegative '<$>' arbitrary) 150 | -- @ 151 | -- 152 | -- There are also different types of generators, other than 'Test.QuickCheck.Gen', providing 153 | -- more ways to select the fields the generator than by simply comparing types: 154 | -- 155 | -- - @'Test.QuickCheck.Gen' a@: override fields of type @a@; 156 | -- - @'Gen1' f@: override fields of type @f x@ for some @x@, requiring a generator for @x@; 157 | -- - @'Gen1_' f@: override fields of type @f x@ for some @x@, __not__ requiring a generator for @x@; 158 | -- - @'FieldGen' s a@: override record fields named @s@, which must have type @a@; 159 | -- - @'ConstrGen' c i a@: override the field at index @i@ of constructor @c@, 160 | -- which must have type @a@ (0-indexed); 161 | -- 162 | -- Multiple generators may match a given field: the first, leftmost 163 | -- generator in the list will be chosen. 164 | , (:+) (..) 165 | , FieldGen (..) 166 | , fieldGen 167 | , ConstrGen (..) 168 | , constrGen 169 | , Gen1 (..) 170 | , Gen1_ (..) 171 | 172 | -- * Helpful combinators 173 | , listOf' 174 | , listOf1' 175 | , vectorOf' 176 | 177 | -- * Base cases for recursive types 178 | , withBaseCase 179 | , BaseCase (..) 180 | 181 | -- * Full options 182 | , Options () 183 | , genericArbitraryWith 184 | 185 | -- ** Setters 186 | , SetOptions 187 | , type (<+) 188 | , setOpts 189 | 190 | -- ** Size modifiers 191 | , Sizing (..) 192 | , SetSized 193 | , SetUnsized 194 | , setSized 195 | , setUnsized 196 | 197 | -- ** Custom generators 198 | , SetGens 199 | , setGenerators 200 | 201 | -- ** Coherence options 202 | , Coherence (..) 203 | , Incoherent (..) 204 | 205 | -- ** Common options 206 | , SizedOpts 207 | , sizedOpts 208 | , SizedOptsDef 209 | , sizedOptsDef 210 | , UnsizedOpts 211 | , unsizedOpts 212 | 213 | -- *** Advanced options 214 | -- | See 'Coherence' 215 | , CohUnsizedOpts 216 | , cohUnsizedOpts 217 | , CohSizedOpts 218 | , cohSizedOpts 219 | 220 | -- * Generic classes 221 | , GArbitrary 222 | , GUniformWeight 223 | 224 | -- * Newtypes for DerivingVia 225 | 226 | -- | These newtypes correspond to the variants of 'genericArbitrary' above. 227 | 228 | , GenericArbitrary (..) 229 | , GenericArbitraryU (..) 230 | , GenericArbitrarySingle (..) 231 | , GenericArbitraryRec (..) 232 | , GenericArbitraryG (..) 233 | , GenericArbitraryUG (..) 234 | , GenericArbitrarySingleG (..) 235 | , GenericArbitraryRecG (..) 236 | , GenericArbitraryWith (..) 237 | , AndShrinking (..) 238 | 239 | -- ** Helpers typeclasses 240 | , TypeLevelGenList (..) 241 | , TypeLevelOpts (..) 242 | ) where 243 | 244 | import Generic.Random.Internal.BaseCase 245 | import Generic.Random.Internal.Generic 246 | import Generic.Random.DerivingVia 247 | -------------------------------------------------------------------------------- /src/Generic/Random/DerivingVia.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | {-# OPTIONS_HADDOCK not-home #-} 16 | 17 | module Generic.Random.DerivingVia 18 | ( GenericArbitrary (..), 19 | GenericArbitraryU (..), 20 | GenericArbitrarySingle (..), 21 | GenericArbitraryRec (..), 22 | GenericArbitraryG (..), 23 | GenericArbitraryUG (..), 24 | GenericArbitrarySingleG (..), 25 | GenericArbitraryRecG (..), 26 | GenericArbitraryWith (..), 27 | AndShrinking (..), 28 | TypeLevelGenList (..), 29 | TypeLevelOpts (..), 30 | ) 31 | where 32 | 33 | import Data.Coerce (Coercible, coerce) 34 | import Data.Kind (Type) 35 | import Data.Proxy (Proxy (..)) 36 | import GHC.Generics (Generic(..)) 37 | import GHC.TypeLits (KnownNat, natVal) 38 | import Generic.Random.Internal.Generic 39 | import Test.QuickCheck (Arbitrary (..), Gen, genericShrink) 40 | import Test.QuickCheck.Arbitrary (RecursivelyShrink, GSubterms) 41 | 42 | -- * Newtypes for DerivingVia 43 | 44 | -- | Pick a constructor with a given distribution, and fill its fields 45 | -- with recursive calls to 'Test.QuickCheck.arbitrary'. 46 | -- 47 | -- === Example 48 | -- 49 | -- > data X = ... 50 | -- > deriving Arbitrary via (GenericArbitrary '[2, 3, 5] X) 51 | -- 52 | -- Picks the first constructor with probability @2/10@, 53 | -- the second with probability @3/10@, the third with probability @5/10@. 54 | -- 55 | -- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'. 56 | -- 57 | -- Uses 'genericArbitrary'. 58 | -- 59 | -- @since 1.5.0.0 60 | newtype GenericArbitrary weights a = GenericArbitrary {unGenericArbitrary :: a} deriving (Eq, Show) 61 | 62 | instance 63 | ( GArbitrary UnsizedOpts a, 64 | TypeLevelWeights' weights a 65 | ) => 66 | Arbitrary (GenericArbitrary weights a) 67 | where 68 | arbitrary = GenericArbitrary <$> genericArbitrary (typeLevelWeights @weights) 69 | 70 | -- | Pick every constructor with equal probability. 71 | -- 72 | -- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'. 73 | -- 74 | -- Uses 'genericArbitraryU'. 75 | -- 76 | -- @since 1.5.0.0 77 | newtype GenericArbitraryU a = GenericArbitraryU {unGenericArbitraryU :: a} deriving (Eq, Show) 78 | 79 | instance 80 | ( GArbitrary UnsizedOpts a, 81 | GUniformWeight a 82 | ) => 83 | Arbitrary (GenericArbitraryU a) 84 | where 85 | arbitrary = GenericArbitraryU <$> genericArbitraryU 86 | 87 | -- | @arbitrary@ for types with one constructor. 88 | -- Equivalent to 'GenericArbitraryU', with a stricter type. 89 | -- 90 | -- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'. 91 | -- 92 | -- Uses 'genericArbitrarySingle'. 93 | -- 94 | -- @since 1.5.0.0 95 | newtype GenericArbitrarySingle a = GenericArbitrarySingle {unGenericArbitrarySingle :: a} deriving (Eq, Show) 96 | 97 | instance 98 | ( GArbitrary UnsizedOpts a, 99 | Weights_ (Rep a) ~ L c0 100 | ) => 101 | Arbitrary (GenericArbitrarySingle a) 102 | where 103 | arbitrary = GenericArbitrarySingle <$> genericArbitrarySingle 104 | 105 | -- | Decrease size at every recursive call, but don't do anything different 106 | -- at size 0. 107 | -- 108 | -- > data X = ... 109 | -- > deriving Arbitrary via (GenericArbitraryRec '[2, 3, 5] X) 110 | -- 111 | -- N.B.: This replaces the generator for fields of type @[t]@ with 112 | -- @'listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for 113 | -- lists). 114 | -- 115 | -- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'. 116 | -- 117 | -- Uses 'genericArbitraryRec'. 118 | -- 119 | -- @since 1.5.0.0 120 | newtype GenericArbitraryRec weights a = GenericArbitraryRec {unGenericArbitraryRec :: a} deriving (Eq, Show) 121 | 122 | instance 123 | ( GArbitrary SizedOptsDef a, 124 | TypeLevelWeights' weights a 125 | ) => 126 | Arbitrary (GenericArbitraryRec weights a) 127 | where 128 | arbitrary = GenericArbitraryRec <$> genericArbitraryRec (typeLevelWeights @weights) 129 | 130 | -- | 'GenericArbitrary' with explicit generators. 131 | -- 132 | -- === Example 133 | -- 134 | -- > data X = ... 135 | -- > deriving Arbitrary via (GenericArbitraryG CustomGens '[2, 3, 5] X) 136 | -- 137 | -- where, for example, custom generators to override 'String' and 'Int' fields 138 | -- might look as follows: 139 | -- 140 | -- @ 141 | -- type CustomGens = CustomString ':+' CustomInt 142 | -- @ 143 | -- 144 | -- === Note on multiple matches 145 | -- 146 | -- Multiple generators may match a given field: the first will be chosen. 147 | -- 148 | -- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'. 149 | -- 150 | -- Uses 'genericArbitraryG'. 151 | -- 152 | -- @since 1.5.0.0 153 | newtype GenericArbitraryG genList weights a = GenericArbitraryG {unGenericArbitraryG :: a} deriving (Eq, Show) 154 | 155 | instance 156 | ( GArbitrary (SetGens genList UnsizedOpts) a, 157 | GUniformWeight a, 158 | TypeLevelWeights' weights a, 159 | TypeLevelGenList genList', 160 | genList ~ TypeLevelGenList' genList' 161 | ) => 162 | Arbitrary (GenericArbitraryG genList' weights a) 163 | where 164 | arbitrary = GenericArbitraryG <$> genericArbitraryG (toGenList $ Proxy @genList') (typeLevelWeights @weights) 165 | 166 | -- | 'GenericArbitraryU' with explicit generators. 167 | -- See also 'GenericArbitraryG'. 168 | -- 169 | -- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'. 170 | -- 171 | -- Uses 'genericArbitraryUG'. 172 | -- 173 | -- @since 1.5.0.0 174 | newtype GenericArbitraryUG genList a = GenericArbitraryUG {unGenericArbitraryUG :: a} deriving (Eq, Show) 175 | 176 | instance 177 | ( GArbitrary (SetGens genList UnsizedOpts) a, 178 | GUniformWeight a, 179 | TypeLevelGenList genList', 180 | genList ~ TypeLevelGenList' genList' 181 | ) => 182 | Arbitrary (GenericArbitraryUG genList' a) 183 | where 184 | arbitrary = GenericArbitraryUG <$> genericArbitraryUG (toGenList $ Proxy @genList') 185 | 186 | -- | 'genericArbitrarySingle' with explicit generators. 187 | -- See also 'GenericArbitraryG'. 188 | -- 189 | -- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'. 190 | -- 191 | -- Uses 'genericArbitrarySingleG'. 192 | -- 193 | -- @since 1.5.0.0 194 | newtype GenericArbitrarySingleG genList a = GenericArbitrarySingleG {unGenericArbitrarySingleG :: a} deriving (Eq, Show) 195 | 196 | instance 197 | ( GArbitrary (SetGens genList UnsizedOpts) a, 198 | Weights_ (Rep a) ~ L c0, 199 | TypeLevelGenList genList', 200 | genList ~ TypeLevelGenList' genList' 201 | ) => 202 | Arbitrary (GenericArbitrarySingleG genList' a) 203 | where 204 | arbitrary = GenericArbitrarySingleG <$> genericArbitrarySingleG (toGenList $ Proxy @genList') 205 | 206 | -- | 'genericArbitraryRec' with explicit generators. 207 | -- See also 'genericArbitraryG'. 208 | -- 209 | -- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'. 210 | -- 211 | -- Uses 'genericArbitraryRecG'. 212 | -- 213 | -- @since 1.5.0.0 214 | newtype GenericArbitraryRecG genList weights a = GenericArbitraryRecG {unGenericArbitraryRecG :: a} deriving (Eq, Show) 215 | 216 | instance 217 | ( GArbitrary (SetGens genList SizedOpts) a, 218 | TypeLevelWeights' weights a, 219 | TypeLevelGenList genList', 220 | genList ~ TypeLevelGenList' genList' 221 | ) => 222 | Arbitrary (GenericArbitraryRecG genList' weights a) 223 | where 224 | arbitrary = GenericArbitraryRecG <$> genericArbitraryRecG (toGenList $ Proxy @genList') (typeLevelWeights @weights) 225 | 226 | -- | General generic generator with custom options. 227 | -- 228 | -- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'. 229 | -- 230 | -- Uses 'genericArbitraryWith'. 231 | -- 232 | -- @since 1.5.0.0 233 | newtype GenericArbitraryWith opts weights a = GenericArbitraryWith {unGenericArbitraryWith :: a} deriving (Eq, Show) 234 | 235 | instance 236 | ( GArbitrary opts a, 237 | TypeLevelWeights' weights a, 238 | TypeLevelOpts opts', 239 | opts ~ TypeLevelOpts' opts' 240 | ) => 241 | Arbitrary (GenericArbitraryWith opts' weights a) 242 | where 243 | arbitrary = GenericArbitraryWith <$> genericArbitraryWith (toOpts $ Proxy @opts') (typeLevelWeights @weights) 244 | 245 | -- | Add generic shrinking to a newtype wrapper for 'Arbitrary', using 'genericShrink'. 246 | -- 247 | -- @ 248 | -- data X = ... 249 | -- deriving Arbitrary via ('GenericArbitrary' '[1,2,3] `'AndShrinking'` X) 250 | -- @ 251 | -- 252 | -- Equivalent to: 253 | -- 254 | -- @ 255 | -- instance Arbitrary X where 256 | -- arbitrary = 'genericArbitrary' (1 % 2 % 3 % ()) 257 | -- shrink = 'Test.QuickCheck.genericShrink' 258 | -- @ 259 | -- 260 | -- @since 1.5.0.0 261 | newtype AndShrinking f a = AndShrinking a deriving (Eq, Show) 262 | 263 | instance 264 | ( Arbitrary (f a), Coercible (f a) a, Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a 265 | ) => Arbitrary (AndShrinking f a) where 266 | arbitrary = coerce (arbitrary :: Gen (f a)) 267 | shrink = coerce (genericShrink :: a -> [a]) 268 | 269 | -- * Internal 270 | 271 | -- | 272 | -- @since 1.5.0.0 273 | type TypeLevelWeights' weights a = TypeLevelWeights weights (Weights_ (Rep a)) 274 | 275 | typeLevelWeights :: 276 | forall weights a. 277 | TypeLevelWeights weights (Weights_ (Rep a)) => 278 | Weights a 279 | typeLevelWeights = 280 | let (w, n) = typeLevelWeightsBuilder @weights 281 | in Weights w n 282 | 283 | -- | 284 | -- @since 1.5.0.0 285 | class TypeLevelWeights weights a where 286 | typeLevelWeightsBuilder :: (a, Int) 287 | 288 | instance 289 | ( KnownNat weight, 290 | TypeLevelWeights weights a 291 | ) => 292 | TypeLevelWeights (weight ': weights) (L x :| a) 293 | where 294 | typeLevelWeightsBuilder = 295 | let (a, m) = (L, fromIntegral $ natVal $ Proxy @weight) 296 | (b, n) = typeLevelWeightsBuilder @weights @a 297 | in (N a m b, m + n) 298 | 299 | instance 300 | ( KnownNat weight 301 | ) => 302 | TypeLevelWeights (weight ': '[]) (L x) 303 | where 304 | typeLevelWeightsBuilder = (L, fromIntegral $ natVal $ Proxy @weight) 305 | 306 | instance 307 | TypeLevelWeights (w ': ws) (t :| (u :| v)) => 308 | TypeLevelWeights (w ': ws) ((t :| u) :| v) 309 | where 310 | typeLevelWeightsBuilder = 311 | let (N t nt (N u nu v), m) = typeLevelWeightsBuilder @(w ': ws) @(t :| (u :| v)) 312 | in (N (N t nt u) (nt + nu) v, m) 313 | 314 | instance TypeLevelWeights '[] () where 315 | typeLevelWeightsBuilder = ((), 1) 316 | 317 | -- | 318 | -- @since 1.5.0.0 319 | class TypeLevelGenList a where 320 | type TypeLevelGenList' a :: Type 321 | toGenList :: Proxy a -> TypeLevelGenList' a 322 | 323 | instance Arbitrary a => TypeLevelGenList (Gen a) where 324 | type TypeLevelGenList' (Gen a) = Gen a 325 | toGenList _ = arbitrary 326 | 327 | instance (TypeLevelGenList a, TypeLevelGenList b) => TypeLevelGenList (a :+ b) where 328 | type TypeLevelGenList' (a :+ b) = TypeLevelGenList' a :+ TypeLevelGenList' b 329 | toGenList _ = toGenList (Proxy @a) :+ toGenList (Proxy @b) 330 | 331 | -- | 332 | -- @since 1.5.0.0 333 | class TypeLevelOpts a where 334 | type TypeLevelOpts' a :: Type 335 | toOpts :: Proxy a -> TypeLevelOpts' a 336 | -------------------------------------------------------------------------------- /src/Generic/Random/Internal/BaseCase.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE DefaultSignatures #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE PolyKinds #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | -- | Base case discovery. 17 | -- 18 | -- === Warning 19 | -- 20 | -- This is an internal module: it is not subject to any versioning policy, 21 | -- breaking changes can happen at any time. 22 | -- 23 | -- If something here seems useful, please report it or create a pull request to 24 | -- export it from an external module. 25 | 26 | module Generic.Random.Internal.BaseCase where 27 | 28 | import Control.Applicative 29 | import Data.Proxy 30 | import Data.Kind (Type) 31 | import GHC.Generics 32 | import GHC.TypeLits 33 | import Test.QuickCheck 34 | 35 | import Generic.Random.Internal.Generic 36 | 37 | -- | Decrease size to ensure termination for 38 | -- recursive types, looking for base cases once the size reaches 0. 39 | -- 40 | -- > genericArbitrary' (17 % 19 % 23 % ()) :: Gen a 41 | -- 42 | -- N.B.: This replaces the generator for fields of type @[t]@ with 43 | -- @'Test.QuickCheck.listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for 44 | -- lists). 45 | genericArbitrary' 46 | :: (GArbitrary SizedOptsDef a, BaseCase a) 47 | => Weights a -- ^ List of weights for every constructor 48 | -> Gen a 49 | genericArbitrary' w = genericArbitraryRec w `withBaseCase` baseCase 50 | 51 | -- | Equivalent to @'genericArbitrary'' 'uniform'@. 52 | -- 53 | -- > genericArbitraryU' :: Gen a 54 | -- 55 | -- N.B.: This replaces the generator for fields of type @[t]@ with 56 | -- @'Test.QuickCheck.listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for 57 | -- lists). 58 | genericArbitraryU' 59 | :: (GArbitrary SizedOptsDef a, BaseCase a, GUniformWeight a) 60 | => Gen a 61 | genericArbitraryU' = genericArbitrary' uniform 62 | 63 | -- | Run the first generator if the size is positive. 64 | -- Run the second if the size is zero. 65 | -- 66 | -- > defaultGen `withBaseCase` baseCaseGen 67 | withBaseCase :: Gen a -> Gen a -> Gen a 68 | withBaseCase def bc = sized $ \sz -> 69 | if sz > 0 then def else bc 70 | 71 | 72 | -- | Find a base case of type @a@ with maximum depth @z@, 73 | -- recursively using 'BaseCaseSearch' instances to search deeper levels. 74 | -- 75 | -- @y@ is the depth of a base case, if found. 76 | -- 77 | -- @e@ is the original type the search started with, that @a@ appears in. 78 | -- It is used for error reporting. 79 | class BaseCaseSearch (a :: Type) (z :: Nat) (y :: Maybe Nat) (e :: Type) where 80 | baseCaseSearch :: prox y -> proxy '(z, e) -> IfM y Gen Proxy a 81 | 82 | 83 | instance {-# OVERLAPPABLE #-} GBaseCaseSearch a z y e => BaseCaseSearch a z y e where 84 | baseCaseSearch = gBaseCaseSearch 85 | 86 | 87 | instance (y ~ 'Just 0) => BaseCaseSearch Char z y e where 88 | baseCaseSearch _ _ = arbitrary 89 | 90 | instance (y ~ 'Just 0) => BaseCaseSearch Int z y e where 91 | baseCaseSearch _ _ = arbitrary 92 | 93 | instance (y ~ 'Just 0) => BaseCaseSearch Integer z y e where 94 | baseCaseSearch _ _ = arbitrary 95 | 96 | instance (y ~ 'Just 0) => BaseCaseSearch Float z y e where 97 | baseCaseSearch _ _ = arbitrary 98 | 99 | instance (y ~ 'Just 0) => BaseCaseSearch Double z y e where 100 | baseCaseSearch _ _ = arbitrary 101 | 102 | instance (y ~ 'Just 0) => BaseCaseSearch Word z y e where 103 | baseCaseSearch _ _ = arbitrary 104 | 105 | instance (y ~ 'Just 0) => BaseCaseSearch () z y e where 106 | baseCaseSearch _ _ = arbitrary 107 | 108 | instance (y ~ 'Just 0) => BaseCaseSearch Bool z y e where 109 | baseCaseSearch _ _ = arbitrary 110 | 111 | instance (y ~ 'Just 0) => BaseCaseSearch [a] z y e where 112 | baseCaseSearch _ _ = return [] 113 | 114 | instance (y ~ 'Just 0) => BaseCaseSearch Ordering z y e where 115 | baseCaseSearch _ _ = arbitrary 116 | 117 | -- Either and (,) use Generics 118 | 119 | 120 | class BaseCaseSearching_ a z y where 121 | baseCaseSearching_ :: proxy y -> proxy2 '(z, a) -> IfM y Gen Proxy a -> Gen a 122 | 123 | instance BaseCaseSearching_ a z ('Just m) where 124 | baseCaseSearching_ _ _ = id 125 | 126 | instance BaseCaseSearching a (z + 1) => BaseCaseSearching_ a z 'Nothing where 127 | baseCaseSearching_ _ _ _ = baseCaseSearching (Proxy :: Proxy '(z + 1, a)) 128 | 129 | -- | Progressively increase the depth bound for 'BaseCaseSearch'. 130 | class BaseCaseSearching a z where 131 | baseCaseSearching :: proxy '(z, a) -> Gen a 132 | 133 | instance (BaseCaseSearch a z y a, BaseCaseSearching_ a z y) => BaseCaseSearching a z where 134 | baseCaseSearching z = baseCaseSearching_ y z (baseCaseSearch y z) 135 | where 136 | y = Proxy :: Proxy y 137 | 138 | -- | Custom instances can override the default behavior. 139 | class BaseCase a where 140 | -- | Generator of base cases. 141 | baseCase :: Gen a 142 | 143 | -- | Overlappable 144 | instance {-# OVERLAPPABLE #-} BaseCaseSearching a 0 => BaseCase a where 145 | baseCase = baseCaseSearching (Proxy :: Proxy '(0, a)) 146 | 147 | 148 | type family IfM (b :: Maybe t) (c :: k) (d :: k) :: k 149 | type instance IfM ('Just t) c d = c 150 | type instance IfM 'Nothing c d = d 151 | 152 | type (==) m n = IsEQ (CmpNat m n) 153 | 154 | type family IsEQ (e :: Ordering) :: Bool 155 | type instance IsEQ 'EQ = 'True 156 | type instance IsEQ 'GT = 'False 157 | type instance IsEQ 'LT = 'False 158 | 159 | type family (||?) (b :: Maybe Nat) (c :: Maybe Nat) :: Maybe Nat 160 | type instance 'Just m ||? 'Just n = 'Just (Min m n) 161 | type instance m ||? 'Nothing = m 162 | type instance 'Nothing ||? n = n 163 | 164 | type family (&&?) (b :: Maybe Nat) (c :: Maybe Nat) :: Maybe Nat 165 | type instance 'Just m &&? 'Just n = 'Just (Max m n) 166 | type instance m &&? 'Nothing = 'Nothing 167 | type instance 'Nothing &&? n = 'Nothing 168 | 169 | type Max m n = MaxOf (CmpNat m n) m n 170 | 171 | type family MaxOf (e :: Ordering) (m :: k) (n :: k) :: k 172 | type instance MaxOf 'GT m n = m 173 | type instance MaxOf 'EQ m n = m 174 | type instance MaxOf 'LT m n = n 175 | 176 | type Min m n = MinOf (CmpNat m n) m n 177 | 178 | type family MinOf (e :: Ordering) (m :: k) (n :: k) :: k 179 | type instance MinOf 'GT m n = n 180 | type instance MinOf 'EQ m n = n 181 | type instance MinOf 'LT m n = m 182 | 183 | class Alternative (IfM y Weighted Proxy) 184 | => GBCS (f :: k -> Type) (z :: Nat) (y :: Maybe Nat) (e :: Type) where 185 | gbcs :: prox y -> proxy '(z, e) -> IfM y Weighted Proxy (f p) 186 | 187 | instance GBCS f z y e => GBCS (M1 i c f) z y e where 188 | gbcs y z = fmap M1 (gbcs y z) 189 | 190 | instance 191 | ( Alternative (IfM y Weighted Proxy) -- logically redundant, but GHC isn't clever 192 | -- enough to deduce; see #32 193 | , GBCSSum f g z e yf yg 194 | , GBCS f z yf e 195 | , GBCS g z yg e 196 | , y ~ (yf ||? yg) 197 | ) => GBCS (f :+: g) z y e where 198 | gbcs _ z = gbcsSum (Proxy :: Proxy '(yf, yg)) z 199 | (gbcs (Proxy :: Proxy yf) z) 200 | (gbcs (Proxy :: Proxy yg) z) 201 | 202 | class Alternative (IfM (yf ||? yg) Weighted Proxy) => GBCSSum f g z e yf yg where 203 | gbcsSum 204 | :: prox '(yf, yg) 205 | -> proxy '(z, e) 206 | -> IfM yf Weighted Proxy (f p) 207 | -> IfM yg Weighted Proxy (g p) 208 | -> IfM (yf ||? yg) Weighted Proxy ((f :+: g) p) 209 | 210 | instance GBCSSum f g z e 'Nothing 'Nothing where 211 | gbcsSum _ _ _ _ = Proxy 212 | 213 | instance GBCSSum f g z e ('Just m) 'Nothing where 214 | gbcsSum _ _ f _ = fmap L1 f 215 | 216 | instance GBCSSum f g z e 'Nothing ('Just n) where 217 | gbcsSum _ _ _ g = fmap R1 g 218 | 219 | instance GBCSSumCompare f g z e (CmpNat m n) 220 | => GBCSSum f g z e ('Just m) ('Just n) where 221 | gbcsSum _ = gbcsSumCompare (Proxy :: Proxy (CmpNat m n)) 222 | 223 | class GBCSSumCompare f g z e o where 224 | gbcsSumCompare 225 | :: proxy0 o 226 | -> proxy '(z, e) 227 | -> Weighted (f p) 228 | -> Weighted (g p) 229 | -> Weighted ((f :+: g) p) 230 | 231 | instance GBCSSumCompare f g z e 'EQ where 232 | gbcsSumCompare _ _ f g = fmap L1 f <|> fmap R1 g 233 | 234 | instance GBCSSumCompare f g z e 'LT where 235 | gbcsSumCompare _ _ f _ = fmap L1 f 236 | 237 | instance GBCSSumCompare f g z e 'GT where 238 | gbcsSumCompare _ _ _ g = fmap R1 g 239 | 240 | instance 241 | ( Alternative (IfM y Weighted Proxy) -- logically redundant, but GHC isn't clever 242 | -- enough to deduce; see #32 243 | , GBCSProduct f g z e yf yg 244 | , GBCS f z yf e 245 | , GBCS g z yg e 246 | , y ~ (yf &&? yg) 247 | ) => GBCS (f :*: g) z y e where 248 | gbcs _ z = gbcsProduct (Proxy :: Proxy '(yf, yg)) z 249 | (gbcs (Proxy :: Proxy yf) z) 250 | (gbcs (Proxy :: Proxy yg) z) 251 | 252 | class Alternative (IfM (yf &&? yg) Weighted Proxy) => GBCSProduct f g z e yf yg where 253 | gbcsProduct 254 | :: prox '(yf, yg) 255 | -> proxy '(z, e) 256 | -> IfM yf Weighted Proxy (f p) 257 | -> IfM yg Weighted Proxy (g p) 258 | -> IfM (yf &&? yg) Weighted Proxy ((f :*: g) p) 259 | 260 | instance {-# OVERLAPPABLE #-} ((yf &&? yg) ~ 'Nothing) => GBCSProduct f g z e yf yg where 261 | gbcsProduct _ _ _ _ = Proxy 262 | 263 | instance GBCSProduct f g z e ('Just m) ('Just n) where 264 | gbcsProduct _ _ f g = liftA2 (:*:) f g 265 | 266 | class IsMaybe b where 267 | ifMmap :: proxy b -> (c a -> c' a') -> (d a -> d' a') -> IfM b c d a -> IfM b c' d' a' 268 | ifM :: proxy b -> c a -> d a -> IfM b c d a 269 | 270 | instance IsMaybe ('Just t) where 271 | ifMmap _ f _ a = f a 272 | ifM _ f _ = f 273 | 274 | instance IsMaybe 'Nothing where 275 | ifMmap _ _ g a = g a 276 | ifM _ _ g = g 277 | 278 | instance {-# OVERLAPPABLE #-} 279 | ( BaseCaseSearch c (z - 1) y e 280 | , (z == 0) ~ 'False 281 | , Alternative (IfM y Weighted Proxy) 282 | , IsMaybe y 283 | ) => GBCS (K1 i c) z y e where 284 | gbcs y _ = 285 | fmap K1 286 | (ifMmap y 287 | liftGen 288 | (id :: Proxy c -> Proxy c) 289 | (baseCaseSearch y (Proxy :: Proxy '(z - 1, e)))) 290 | 291 | instance (y ~ 'Nothing) => GBCS (K1 i c) 0 y e where 292 | gbcs _ _ = empty 293 | 294 | instance (y ~ 'Just 0) => GBCS U1 z y e where 295 | gbcs _ _ = pure U1 296 | 297 | instance {-# INCOHERENT #-} 298 | ( TypeError 299 | ( 'Text "Unrecognized Rep: " 300 | ':<>: 'ShowType f 301 | ':$$: 'Text "Possible causes:" 302 | ':$$: 'Text " Missing (" 303 | ':<>: 'ShowType (BaseCase e) 304 | ':<>: 'Text ") constraint" 305 | ':$$: 'Text " Missing Generic instance" 306 | ) 307 | , Alternative (IfM y Weighted Proxy) 308 | ) => GBCS f z y e where 309 | gbcs = error "Type error" 310 | 311 | class GBaseCaseSearch a z y e where 312 | gBaseCaseSearch :: prox y -> proxy '(z, e) -> IfM y Gen Proxy a 313 | 314 | instance (Generic a, GBCS (Rep a) z y e, IsMaybe y) 315 | => GBaseCaseSearch a z y e where 316 | gBaseCaseSearch y z = ifMmap y 317 | (\(Weighted gn) -> case gn of 318 | Just (g, n) -> choose (0, n-1) >>= fmap to . g 319 | Nothing -> error "How could this happen?") 320 | (\Proxy -> Proxy) 321 | (gbcs y z) 322 | -------------------------------------------------------------------------------- /src/Generic/Random/Internal/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | {-# LANGUAGE AllowAmbiguousTypes #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE DataKinds #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE GADTs #-} 10 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE PolyKinds #-} 13 | {-# LANGUAGE RankNTypes #-} 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE TypeFamilies #-} 16 | {-# LANGUAGE TypeOperators #-} 17 | {-# LANGUAGE UndecidableInstances #-} 18 | 19 | -- | Core implementation. 20 | -- 21 | -- === Warning 22 | -- 23 | -- This is an internal module: it is not subject to any versioning policy, 24 | -- breaking changes can happen at any time. 25 | -- 26 | -- If something here seems useful, please report it or create a pull request to 27 | -- export it from an external module. 28 | 29 | module Generic.Random.Internal.Generic where 30 | 31 | import Control.Applicative (Alternative(..), liftA2) 32 | import Data.Coerce (Coercible, coerce) 33 | import Data.Kind (Type) 34 | 35 | import Data.Proxy (Proxy(..)) 36 | import Data.Type.Bool (type (&&)) 37 | import Data.Type.Equality (type (==)) 38 | 39 | import GHC.Generics hiding (S, prec) 40 | import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), natVal) 41 | import Test.QuickCheck (Arbitrary(..), Gen, choose, scale, sized, vectorOf) 42 | 43 | -- * Random generators 44 | 45 | -- | Pick a constructor with a given distribution, and fill its fields 46 | -- with recursive calls to 'arbitrary'. 47 | -- 48 | -- === Example 49 | -- 50 | -- > genericArbitrary (2 % 3 % 5 % ()) :: Gen a 51 | -- 52 | -- Picks the first constructor with probability @2/10@, 53 | -- the second with probability @3/10@, the third with probability @5/10@. 54 | genericArbitrary 55 | :: (GArbitrary UnsizedOpts a) 56 | => Weights a -- ^ List of weights for every constructor 57 | -> Gen a 58 | genericArbitrary = genericArbitraryWith unsizedOpts 59 | 60 | -- | Pick every constructor with equal probability. 61 | -- Equivalent to @'genericArbitrary' 'uniform'@. 62 | -- 63 | -- > genericArbitraryU :: Gen a 64 | genericArbitraryU 65 | :: (GArbitrary UnsizedOpts a, GUniformWeight a) 66 | => Gen a 67 | genericArbitraryU = genericArbitrary uniform 68 | 69 | -- | 'arbitrary' for types with one constructor. 70 | -- Equivalent to 'genericArbitraryU', with a stricter type. 71 | -- 72 | -- > genericArbitrarySingle :: Gen a 73 | genericArbitrarySingle 74 | :: (GArbitrary UnsizedOpts a, Weights_ (Rep a) ~ L c0) 75 | => Gen a 76 | genericArbitrarySingle = genericArbitraryU 77 | 78 | -- | Decrease size at every recursive call, but don't do anything different 79 | -- at size 0. 80 | -- 81 | -- > genericArbitraryRec (7 % 11 % 13 % ()) :: Gen a 82 | -- 83 | -- N.B.: This replaces the generator for fields of type @[t]@ with 84 | -- @'listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for 85 | -- lists). 86 | genericArbitraryRec 87 | :: (GArbitrary SizedOptsDef a) 88 | => Weights a -- ^ List of weights for every constructor 89 | -> Gen a 90 | genericArbitraryRec = genericArbitraryWith sizedOptsDef 91 | 92 | -- | 'genericArbitrary' with explicit generators. 93 | -- 94 | -- === Example 95 | -- 96 | -- > genericArbitraryG customGens (17 % 19 % ()) 97 | -- 98 | -- where, the generators for 'String' and 'Int' fields are overridden as 99 | -- follows, for example: 100 | -- 101 | -- @ 102 | -- customGens :: Gen String ':+' Gen Int 103 | -- customGens = 104 | -- (filter (/= '\NUL') '<$>' arbitrary) ':+' 105 | -- (getNonNegative '<$>' arbitrary) 106 | -- @ 107 | -- 108 | -- === Note on multiple matches 109 | -- 110 | -- Multiple generators may match a given field: the first will be chosen. 111 | genericArbitraryG 112 | :: (GArbitrary (SetGens genList UnsizedOpts) a) 113 | => genList 114 | -> Weights a 115 | -> Gen a 116 | genericArbitraryG gs = genericArbitraryWith opts 117 | where 118 | opts = setGenerators gs unsizedOpts 119 | 120 | -- | 'genericArbitraryU' with explicit generators. 121 | -- See also 'genericArbitraryG'. 122 | genericArbitraryUG 123 | :: (GArbitrary (SetGens genList UnsizedOpts) a, GUniformWeight a) 124 | => genList 125 | -> Gen a 126 | genericArbitraryUG gs = genericArbitraryG gs uniform 127 | 128 | -- | 'genericArbitrarySingle' with explicit generators. 129 | -- See also 'genericArbitraryG'. 130 | genericArbitrarySingleG 131 | :: (GArbitrary (SetGens genList UnsizedOpts) a, Weights_ (Rep a) ~ L c0) 132 | => genList 133 | -> Gen a 134 | genericArbitrarySingleG = genericArbitraryUG 135 | 136 | -- | 'genericArbitraryRec' with explicit generators. 137 | -- See also 'genericArbitraryG'. 138 | genericArbitraryRecG 139 | :: (GArbitrary (SetGens genList SizedOpts) a) 140 | => genList 141 | -> Weights a -- ^ List of weights for every constructor 142 | -> Gen a 143 | genericArbitraryRecG gs = genericArbitraryWith opts 144 | where 145 | opts = setGenerators gs sizedOpts 146 | 147 | -- | General generic generator with custom options. 148 | genericArbitraryWith 149 | :: (GArbitrary opts a) 150 | => opts -> Weights a -> Gen a 151 | genericArbitraryWith opts (Weights w n) = 152 | fmap to (ga opts w n) 153 | 154 | -- * Internal 155 | 156 | type family Weights_ (f :: Type -> Type) :: Type where 157 | Weights_ (f :+: g) = Weights_ f :| Weights_ g 158 | Weights_ (M1 D _c f) = Weights_ f 159 | Weights_ (M1 C ('MetaCons c _i _j) _f) = L c 160 | 161 | data a :| b = N a Int b 162 | data L (c :: Symbol) = L 163 | 164 | -- | Trees of weights assigned to constructors of type @a@, 165 | -- rescaled to obtain a probability distribution. 166 | -- 167 | -- Two ways of constructing them. 168 | -- 169 | -- @ 170 | -- (x1 '%' x2 '%' ... '%' xn '%' ()) :: 'Weights' a 171 | -- 'uniform' :: 'Weights' a 172 | -- @ 173 | -- 174 | -- Using @('%')@, there must be exactly as many weights as 175 | -- there are constructors. 176 | -- 177 | -- 'uniform' is equivalent to @(1 '%' ... '%' 1 '%' ())@ 178 | -- (automatically fills out the right number of 1s). 179 | data Weights a = Weights (Weights_ (Rep a)) Int 180 | 181 | -- | Type of a single weight, tagged with the name of the associated 182 | -- constructor for additional compile-time checking. 183 | -- 184 | -- @ 185 | -- ((9 :: 'W' \"Leaf\") '%' (8 :: 'W' \"Node\") '%' ()) 186 | -- @ 187 | newtype W (c :: Symbol) = W Int deriving Num 188 | 189 | -- | A smart constructor to specify a custom distribution. 190 | -- It can be omitted for the '%' operator is overloaded to 191 | -- insert it. 192 | weights :: (Weights_ (Rep a), Int, ()) -> Weights a 193 | weights (w, n, ()) = Weights w n 194 | 195 | -- | Uniform distribution. 196 | uniform :: UniformWeight_ (Rep a) => Weights a 197 | uniform = 198 | let (w, n) = uniformWeight 199 | in Weights w n 200 | 201 | type family First a :: Symbol where 202 | First (a :| _b) = First a 203 | First (L c) = c 204 | 205 | type family First' w where 206 | First' (Weights a) = First (Weights_ (Rep a)) 207 | First' (a, Int, r) = First a 208 | 209 | type family Prec' w where 210 | Prec' (Weights a) = Prec (Weights_ (Rep a)) () 211 | Prec' (a, Int, r) = Prec a r 212 | 213 | class WeightBuilder' w where 214 | 215 | -- | A binary constructor for building up trees of weights. 216 | (%) :: (c ~ First' w) => W c -> Prec' w -> w 217 | 218 | instance WeightBuilder (Weights_ (Rep a)) => WeightBuilder' (Weights a) where 219 | w % prec = weights (w %. prec) 220 | 221 | instance WeightBuilder a => WeightBuilder' (a, Int, r) where 222 | (%) = (%.) 223 | 224 | class WeightBuilder a where 225 | type Prec a r 226 | 227 | (%.) :: (c ~ First a) => W c -> Prec a r -> (a, Int, r) 228 | 229 | infixr 1 % 230 | 231 | instance WeightBuilder a => WeightBuilder (a :| b) where 232 | type Prec (a :| b) r = Prec a (b, Int, r) 233 | m %. prec = 234 | let (a, n, (b, p, r)) = m % prec 235 | in (N a n b, n + p, r) 236 | 237 | instance WeightBuilder (L c) where 238 | type Prec (L c) r = r 239 | W m %. prec = (L, m, prec) 240 | 241 | instance WeightBuilder () where 242 | type Prec () r = r 243 | W m %. prec = ((), m, prec) 244 | 245 | class UniformWeight a where 246 | uniformWeight :: (a, Int) 247 | 248 | instance (UniformWeight a, UniformWeight b) => UniformWeight (a :| b) where 249 | uniformWeight = 250 | let 251 | (a, m) = uniformWeight 252 | (b, n) = uniformWeight 253 | in 254 | (N a m b, m + n) 255 | 256 | instance UniformWeight (L c) where 257 | uniformWeight = (L, 1) 258 | 259 | instance UniformWeight () where 260 | uniformWeight = ((), 1) 261 | 262 | class UniformWeight (Weights_ f) => UniformWeight_ f 263 | instance UniformWeight (Weights_ f) => UniformWeight_ f 264 | 265 | -- | Derived uniform distribution of constructors for @a@. 266 | class UniformWeight_ (Rep a) => GUniformWeight a 267 | instance UniformWeight_ (Rep a) => GUniformWeight a 268 | 269 | 270 | -- | Type-level options for 'GArbitrary'. 271 | -- 272 | -- Note: it is recommended to avoid referring to the 'Options' type 273 | -- explicitly in code, as the set of options may change in the future. 274 | -- Instead, use the provided synonyms ('UnsizedOpts', 'SizedOpts', 'SizedOptsDef') 275 | -- and the setter 'SetOptions' (abbreviated as @('<+')@). 276 | newtype Options (c :: Coherence) (s :: Sizing) (genList :: Type) = Options 277 | { _generators :: genList 278 | } 279 | 280 | -- | Setter for 'Options'. 281 | -- 282 | -- This subsumes the other setters: 'SetSized', 'SetUnsized', 'SetGens'. 283 | -- 284 | -- @since 1.4.0.0 285 | type family SetOptions (x :: k) (o :: Type) :: Type 286 | type instance SetOptions (s :: Sizing) (Options c _s g) = Options c s g 287 | type instance SetOptions (c :: Coherence) (Options _c s g) = Options c s g 288 | type instance SetOptions (g :: Type) (Options c s _g) = Options c s g 289 | 290 | -- | Infix flipped synonym for 'Options'. 291 | -- 292 | -- @since 1.4.0.0 293 | type (<+) o x = SetOptions x o 294 | infixl 1 <+ 295 | 296 | 297 | type UnsizedOpts = Options 'INCOHERENT 'Unsized () 298 | type SizedOpts = Options 'INCOHERENT 'Sized () 299 | type SizedOptsDef = Options 'INCOHERENT 'Sized (Gen1 [] :+ ()) 300 | 301 | -- | Like 'UnsizedOpts', but using coherent instances by default. 302 | -- 303 | -- @since 1.4.0.0 304 | type CohUnsizedOpts = Options 'COHERENT 'Unsized () 305 | 306 | -- | Like 'SizedOpts', but using coherent instances by default. 307 | -- 308 | -- @since 1.4.0.0 309 | type CohSizedOpts = Options 'COHERENT 'Sized () 310 | 311 | -- | Coerce an 'Options' value between types with the same representation. 312 | -- 313 | -- @since 1.4.0.0 314 | setOpts :: forall x o. (Coercible o (SetOptions x o)) => o -> SetOptions x o 315 | setOpts = coerce 316 | 317 | -- | Default options for unsized generators. 318 | unsizedOpts :: UnsizedOpts 319 | unsizedOpts = Options () 320 | 321 | -- | Default options for sized generators. 322 | sizedOpts :: SizedOpts 323 | sizedOpts = Options () 324 | 325 | -- | Default options overriding the list generator using 'listOf''. 326 | sizedOptsDef :: SizedOptsDef 327 | sizedOptsDef = Options (Gen1 listOf' :+ ()) 328 | 329 | -- | Like 'unsizedOpts', but using coherent instances by default. 330 | cohUnsizedOpts :: CohUnsizedOpts 331 | cohUnsizedOpts = Options () 332 | 333 | -- | Like 'sizedOpts' but using coherent instances by default. 334 | cohSizedOpts :: CohSizedOpts 335 | cohSizedOpts = Options () 336 | 337 | 338 | -- | Whether to decrease the size parameter before generating fields. 339 | -- 340 | -- The 'Sized' option makes the size parameter decrease in the following way: 341 | -- - Constructors with one field decrease the size parameter by 1 to generate 342 | -- that field. 343 | -- - Constructors with more than one field split the size parameter among all 344 | -- fields; the size parameter is rounded down to then be divided equally. 345 | data Sizing 346 | = Sized -- ^ Decrease the size parameter when running generators for fields 347 | | Unsized -- ^ Don't touch the size parameter 348 | 349 | type family SizingOf opts :: Sizing 350 | type instance SizingOf (Options _c s _g) = s 351 | 352 | type family SetSized (o :: Type) :: Type 353 | type instance SetSized (Options c s g) = Options c 'Sized g 354 | 355 | type family SetUnsized (o :: Type) :: Type 356 | type instance SetUnsized (Options c s g) = Options c 'Unsized g 357 | 358 | setSized :: Options c s g -> Options c 'Sized g 359 | setSized = coerce 360 | 361 | setUnsized :: Options c s g -> Options c 'Unsized g 362 | setUnsized = coerce 363 | 364 | 365 | -- | For custom generators to work with parameterized types, incoherent 366 | -- instances must be used internally. 367 | -- In practice, the resulting behavior is what users want 100% of the time, 368 | -- so you should forget this option even exists. 369 | -- 370 | -- === __Details__ 371 | -- 372 | -- tl;dr: 373 | -- 374 | -- - The default setting is 'INCOHERENT'. 375 | -- - You can use 'COHERENT' (via 'CohUnsizedOpts' or 'CohSizedOpts') to make 376 | -- sure that no incoherent instances ever occur in your instance search. 377 | -- - In 'COHERENT' mode, you can still selectively enable 'Incoherent' for 378 | -- individual generators. Doing this carefully might ensure a unique solution 379 | -- for instance resolution, even if incoherent. 380 | -- 381 | -- The default configuration of generic-random does a decent job if 382 | -- we trust GHC implements precisely the instance resolution algorithm as 383 | -- described in the GHC manual: 384 | -- 385 | -- - https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#overlapping-instances 386 | -- 387 | -- While that assumption holds in practice, it is overly context-dependent 388 | -- (to know the context leading to a particular choice, we must replay the 389 | -- whole resolution algorithm). 390 | -- In particular, this algorithm may find one solution, but it is not 391 | -- guaranteed to be unique: the behavior of the program is dependent on 392 | -- implementation details. 393 | -- 394 | -- A notable property to consider of an implicit type system (such as type 395 | -- classes) is coherence: the behavior of the program is stable under 396 | -- specialization. 397 | -- 398 | -- This sounds nice on paper, but actually leads to surprising behavior for 399 | -- generic implementations with parameterized types, such as generic-random. 400 | -- 401 | -- To address that, the coherence property can be relaxd by users, by 402 | -- explicitly allowing some custom generators to be chosen incoherently. With 403 | -- appropriate precautions, it is possible to ensure a weaker property which 404 | -- nevertheless helps keep type inference predictable: when a solution is 405 | -- found, it is unique. 406 | -- (This is assuredly weaker, i.e., is not stable under specialization.) 407 | -- 408 | -- @since 1.4.0.0 409 | data Coherence 410 | = INCOHERENT -- ^ Match custom generators incoherently. 411 | | COHERENT 412 | -- ^ Match custom generators coherently by default 413 | -- (can be locally bypassed with 'Incoherent'). 414 | 415 | type family CoherenceOf (o :: Type) :: Coherence 416 | type instance CoherenceOf (Options c _s _g) = c 417 | 418 | -- | Match this generator incoherently when the 'COHERENT' option is set. 419 | newtype Incoherent g = Incoherent g 420 | 421 | 422 | -- | Heterogeneous list of generators. 423 | data a :+ b = a :+ b 424 | 425 | infixr 1 :+ 426 | 427 | 428 | type family GeneratorsOf opts :: Type 429 | type instance GeneratorsOf (Options _c _s g) = g 430 | 431 | class HasGenerators opts where 432 | generators :: opts -> GeneratorsOf opts 433 | 434 | instance HasGenerators (Options c s g) where 435 | generators = _generators 436 | 437 | -- | Define the set of custom generators. 438 | -- 439 | -- Note: for recursive types which can recursively appear inside lists or other 440 | -- containers, you may want to include a custom generator to decrease the size 441 | -- when generating such containers. 442 | -- 443 | -- See also the Note about lists in "Generic.Random.Tutorial#notelists". 444 | setGenerators :: genList -> Options c s g0 -> Options c s genList 445 | setGenerators gens (Options _) = Options gens 446 | 447 | type family SetGens (g :: Type) opts 448 | type instance SetGens g (Options c s _g) = Options c s g 449 | 450 | 451 | -- | Custom generator for record fields named @s@. 452 | -- 453 | -- If there is a field named @s@ with a different type, 454 | -- this will result in a type error. 455 | newtype FieldGen (s :: Symbol) a = FieldGen { unFieldGen :: Gen a } 456 | 457 | -- | 'FieldGen' constructor with the field name given via a proxy. 458 | fieldGen :: proxy s -> Gen a -> FieldGen s a 459 | fieldGen _ = FieldGen 460 | 461 | -- | Custom generator for the @i@-th field of the constructor named @c@. 462 | -- Fields are 0-indexed. 463 | newtype ConstrGen (c :: Symbol) (i :: Nat) a = ConstrGen { unConstrGen :: Gen a } 464 | 465 | -- | 'ConstrGen' constructor with the constructor name given via a proxy. 466 | constrGen :: proxy '(c, i) -> Gen a -> ConstrGen c i a 467 | constrGen _ = ConstrGen 468 | 469 | -- | Custom generators for \"containers\" of kind @Type -> Type@, parameterized 470 | -- by the generator for \"contained elements\". 471 | -- 472 | -- A custom generator @'Gen1' f@ will be used for any field whose type has the 473 | -- form @f x@, requiring a generator of @x@. The generator for @x@ will be 474 | -- constructed using the list of custom generators if possible, otherwise 475 | -- an instance @Arbitrary x@ will be required. 476 | newtype Gen1 f = Gen1 { unGen1 :: forall a. Gen a -> Gen (f a) } 477 | 478 | -- | Custom generators for unary type constructors that are not \"containers\", 479 | -- i.e., which don't require a generator of @a@ to generate an @f a@. 480 | -- 481 | -- A custom generator @'Gen1_' f@ will be used for any field whose type has the 482 | -- form @f x@. 483 | newtype Gen1_ f = Gen1_ { unGen1_ :: forall a. Gen (f a) } 484 | 485 | 486 | -- | An alternative to 'vectorOf' that divides the size parameter by the 487 | -- length of the list. 488 | vectorOf' :: Int -> Gen a -> Gen [a] 489 | vectorOf' 0 = \_ -> pure [] 490 | vectorOf' i = scale (`div` i) . vectorOf i 491 | 492 | -- | An alternative to 'Test.QuickCheck.listOf' that divides the size parameter 493 | -- by the length of the list. 494 | -- The length follows a geometric distribution of parameter 495 | -- @1/(sqrt size + 1)@. 496 | listOf' :: Gen a -> Gen [a] 497 | listOf' g = sized $ \n -> do 498 | i <- geom n 499 | vectorOf' i g 500 | 501 | -- | An alternative to 'Test.QuickCheck.listOf1' (nonempty lists) that divides 502 | -- the size parameter by the length of the list. 503 | -- The length (minus one) follows a geometric distribution of parameter 504 | -- @1/(sqrt size + 1)@. 505 | listOf1' :: Gen a -> Gen [a] 506 | listOf1' g = liftA2 (:) g (listOf' g) 507 | 508 | -- | Geometric distribution of parameter @1/(sqrt n + 1)@ (@n >= 0@). 509 | geom :: Int -> Gen Int 510 | geom 0 = pure 0 511 | geom n = go 0 where 512 | n' = fromIntegral n 513 | p = 1 / (sqrt n' + 1) :: Double 514 | go r = do 515 | x <- choose (0, 1) 516 | if x < p then 517 | pure r 518 | else 519 | go $! (r + 1) 520 | 521 | --- 522 | 523 | -- | Generic Arbitrary 524 | class GA opts f where 525 | ga :: opts -> Weights_ f -> Int -> Gen (f p) 526 | 527 | -- | Generic Arbitrary 528 | class (Generic a, GA opts (Rep a)) => GArbitrary opts a 529 | instance (Generic a, GA opts (Rep a)) => GArbitrary opts a 530 | 531 | instance GA opts f => GA opts (M1 D c f) where 532 | ga z w n = fmap M1 (ga z w n) 533 | {-# INLINE ga #-} 534 | 535 | instance (GASum opts f, GASum opts g) => GA opts (f :+: g) where 536 | ga = gaSum' 537 | {-# INLINE ga #-} 538 | 539 | instance GAProduct (SizingOf opts) (Name c) opts f => GA opts (M1 C c f) where 540 | ga z _ _ = fmap M1 (gaProduct (Proxy :: Proxy '(SizingOf opts, Name c)) z) 541 | {-# INLINE ga #-} 542 | 543 | gaSum' :: GASum opts f => opts -> Weights_ f -> Int -> Gen (f p) 544 | gaSum' z w n = do 545 | i <- choose (0, n-1) 546 | gaSum z i w 547 | {-# INLINE gaSum' #-} 548 | 549 | class GASum opts f where 550 | gaSum :: opts -> Int -> Weights_ f -> Gen (f p) 551 | 552 | instance (GASum opts f, GASum opts g) => GASum opts (f :+: g) where 553 | gaSum z i (N a n b) 554 | | i < n = fmap L1 (gaSum z i a) 555 | | otherwise = fmap R1 (gaSum z (i - n) b) 556 | {-# INLINE gaSum #-} 557 | 558 | instance GAProduct (SizingOf opts) (Name c) opts f => GASum opts (M1 C c f) where 559 | gaSum z _ _ = fmap M1 (gaProduct (Proxy :: Proxy '(SizingOf opts, Name c)) z) 560 | {-# INLINE gaSum #-} 561 | 562 | 563 | class GAProduct (s :: Sizing) (c :: Maybe Symbol) opts f where 564 | gaProduct :: proxys '(s, c) -> opts -> Gen (f p) 565 | 566 | instance GAProduct' c 0 opts f => GAProduct 'Unsized c opts f where 567 | gaProduct _ = gaProduct' (Proxy :: Proxy '(c, 0)) 568 | {-# INLINE gaProduct #-} 569 | 570 | -- Single-field constructors: decrease size by 1. 571 | instance {-# OVERLAPPING #-} GAProduct' c 0 opts (S1 d f) 572 | => GAProduct 'Sized c opts (S1 d f) where 573 | gaProduct _ = scale (\n -> max 0 (n-1)) . gaProduct' (Proxy :: Proxy '(c, 0)) 574 | 575 | instance (GAProduct' c 0 opts f, KnownNat (Arity f)) => GAProduct 'Sized c opts f where 576 | gaProduct _ = scale (`div` arity) . gaProduct' (Proxy :: Proxy '(c, 0)) 577 | where 578 | arity = fromInteger (natVal (Proxy :: Proxy (Arity f))) 579 | {-# INLINE gaProduct #-} 580 | 581 | instance {-# OVERLAPPING #-} GAProduct 'Sized c opts U1 where 582 | gaProduct _ _ = pure U1 583 | {-# INLINE gaProduct #-} 584 | 585 | 586 | class GAProduct' (c :: Maybe Symbol) (i :: Nat) opts f where 587 | gaProduct' :: proxy '(c, i) -> opts -> Gen (f p) 588 | 589 | instance GAProduct' c i opts U1 where 590 | gaProduct' _ _ = pure U1 591 | {-# INLINE gaProduct' #-} 592 | 593 | instance 594 | ( HasGenerators opts 595 | , FindGen 'Shift ('S gs coh '(c, i, Name d)) () gs a 596 | , gs ~ GeneratorsOf opts 597 | , coh ~ CoherenceOf opts ) 598 | => GAProduct' c i opts (S1 d (K1 _k a)) where 599 | gaProduct' _ opts = fmap (M1 . K1) (findGen (is, s, gs) () gs) 600 | where 601 | is = Proxy :: Proxy 'Shift 602 | s = Proxy :: Proxy ('S gs coh '(c, i, Name d)) 603 | gs = generators opts 604 | {-# INLINE gaProduct' #-} 605 | 606 | instance (GAProduct' c i opts f, GAProduct' c (i + Arity f) opts g) => GAProduct' c i opts (f :*: g) where 607 | -- TODO: Why does this inline better than eta-reducing? (GHC-8.2) 608 | gaProduct' px = (liftA2 . liftA2) (:*:) 609 | (gaProduct' px) 610 | (gaProduct' (Proxy :: Proxy '(c, i + Arity f))) 611 | {-# INLINE gaProduct' #-} 612 | 613 | 614 | type family Arity f :: Nat where 615 | Arity (f :*: g) = Arity f + Arity g 616 | Arity (M1 _i _c _f) = 1 617 | 618 | -- | Given a list of custom generators @g :+ gs@, find one that applies, 619 | -- or use @Arbitrary a@ by default. 620 | -- 621 | -- @g@ and @gs@ follow this little state machine: 622 | -- 623 | -- > g, gs | result 624 | -- > ---------------------+----------------------------- 625 | -- > (), () | END 626 | -- > (), g :+ gs | g, gs 627 | -- > (), g | g, () when g is not (_ :+ _) 628 | -- > g :+ h, gs | g, h :+ gs 629 | -- > Gen a, gs | END if g matches, else ((), gs) 630 | -- > FieldGen a, gs | idem 631 | -- > ConstrGen a, gs | idem 632 | -- > Gen1 a, gs | idem 633 | -- > Gen1_ a, gs | idem 634 | class FindGen (i :: AInstr) (s :: AStore) (g :: Type) (gs :: Type) (a :: Type) where 635 | findGen :: (Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a 636 | 637 | data AInstr = Shift | Match Coherence | MatchCoh Bool 638 | data AStore = S Type Coherence ASel 639 | 640 | type ASel = (Maybe Symbol, Nat, Maybe Symbol) 641 | 642 | iShift :: Proxy 'Shift 643 | iShift = Proxy 644 | 645 | type family FullGenListOf (s :: AStore) :: Type where 646 | FullGenListOf ('S fg _coh _sel) = fg 647 | 648 | type family ACoherenceOf (s :: AStore) :: Coherence where 649 | ACoherenceOf ('S _fg coh _sel) = coh 650 | 651 | type family ASelOf (s :: AStore) :: ASel where 652 | ASelOf ('S _fg _coh sel) = sel 653 | 654 | -- | All candidates have been exhausted 655 | instance Arbitrary a => FindGen 'Shift s () () a where 656 | findGen _ _ _ = arbitrary 657 | {-# INLINEABLE findGen #-} 658 | 659 | -- | Examine the next candidate 660 | instance FindGen 'Shift s b g a => FindGen 'Shift s () (b :+ g) a where 661 | findGen p () (b :+ gens) = findGen p b gens 662 | {-# INLINEABLE findGen #-} 663 | 664 | -- | Examine the last candidate (@g@ is not of the form @_ :+ _@) 665 | instance {-# OVERLAPS #-} FindGen 'Shift s g () a => FindGen 'Shift s () g a where 666 | findGen p () g = findGen p g () 667 | 668 | -- | This can happen if the generators form a tree rather than a list, for whatever reason. 669 | instance FindGen 'Shift s g (h :+ gs) a => FindGen 'Shift s (g :+ h) gs a where 670 | findGen p (g :+ h) gs = findGen p g (h :+ gs) 671 | 672 | instance FindGen ('Match 'INCOHERENT) s g gs a => FindGen 'Shift s (Incoherent g) gs a where 673 | findGen (_, s, fg) (Incoherent g) = findGen (im, s, fg) g where 674 | im = Proxy :: Proxy ('Match 'INCOHERENT) 675 | 676 | -- | If none of the above matches, then @g@ should be a simple generator, 677 | -- and we test whether it matches the type @a@. 678 | instance {-# OVERLAPPABLE #-} FindGen ('Match (ACoherenceOf s)) s g gs a 679 | => FindGen 'Shift s g gs a where 680 | findGen (_, s, fg) = findGen (im, s, fg) where 681 | im = Proxy :: Proxy ('Match (ACoherenceOf s)) 682 | 683 | -- INCOHERENT 684 | 685 | -- | None of the INCOHERENT instances match, discard the candidate @g@ and look 686 | -- at the rest of the list @gs@. 687 | instance FindGen 'Shift s () gs a 688 | => FindGen ('Match 'INCOHERENT) s _g gs a where 689 | findGen (_, s, fg) _ = findGen (iShift, s, fg) () where 690 | 691 | -- | Matching custom generator for @a@. 692 | instance {-# INCOHERENT #-} FindGen ('Match 'INCOHERENT) s (Gen a) gs a where 693 | findGen _ gen _ = gen 694 | {-# INLINEABLE findGen #-} 695 | 696 | -- | Matching custom generator for non-container @f@. 697 | instance {-# INCOHERENT #-} FindGen ('Match 'INCOHERENT) s (Gen1_ f) gs (f a) where 698 | findGen _ (Gen1_ gen) _ = gen 699 | 700 | -- | Matching custom generator for container @f@. Start the search for containee @a@, 701 | -- discarding field information. 702 | instance {-# INCOHERENT #-} FindGen 'Shift ('S fg coh DummySel) () fg a 703 | => FindGen ('Match 'INCOHERENT) ('S fg coh _sel) (Gen1 f) gs (f a) where 704 | findGen (_, _, fg) (Gen1 gen) _ = gen (findGen (iShift, s, fg) () fg) where 705 | s = Proxy :: Proxy ('S fg coh DummySel) 706 | 707 | type DummySel = '( 'Nothing, 0, 'Nothing) 708 | 709 | -- | Matching custom generator for field @s@. 710 | instance {-# INCOHERENT #-} (a ~ a') 711 | => FindGen ('Match 'INCOHERENT) ('S _fg _coh '(con, i, 'Just s)) (FieldGen s a) gs a' where 712 | findGen _ (FieldGen gen) _ = gen 713 | {-# INLINEABLE findGen #-} 714 | 715 | -- | Matching custom generator for @i@-th field of constructor @c@. 716 | instance {-# INCOHERENT #-} (a ~ a') 717 | => FindGen ('Match 'INCOHERENT) ('S _fg _coh '( 'Just c, i, s)) (ConstrGen c i a) gs a' where 718 | findGen _ (ConstrGen gen) _ = gen 719 | {-# INLINEABLE findGen #-} 720 | 721 | -- | Get the name contained in a 'Meta' tag. 722 | type family Name (d :: Meta) :: Maybe Symbol 723 | type instance Name ('MetaSel mn su ss ds) = mn 724 | type instance Name ('MetaCons n _f _s) = 'Just n 725 | 726 | -- COHERENT 727 | 728 | -- Use a type famaily to do the matching coherently. 729 | instance FindGen ('MatchCoh (Matches (ASelOf s) g a)) s g gs a 730 | => FindGen ('Match 'COHERENT) s g gs a where 731 | findGen (_, s, fg) = findGen (im, s, fg) where 732 | im = Proxy :: Proxy ('MatchCoh (Matches (ASelOf s) g a)) 733 | 734 | type family Matches (s :: ASel) (g :: Type) (a :: Type) :: Bool where 735 | Matches _sel (Gen b) a = b == a 736 | Matches _sel (Gen1_ f) (f a) = 'True 737 | Matches _sel (Gen1_ f) a = 'False 738 | Matches _sel (Gen1 f) (f a) = 'True 739 | Matches _sel (Gen1 f) a = 'False 740 | Matches '(_c, i, s) (FieldGen s1 b) a = s == 'Just s1 && b == a 741 | Matches '( c, i, _s) (ConstrGen c1 j b) a = c == 'Just c1 && i == j && b == a 742 | 743 | -- If there is no match, skip and shift. 744 | instance FindGen 'Shift s () gs a => FindGen ('MatchCoh 'False) s _g gs a where 745 | findGen (_, s, fg) _ = findGen (iShift, s, fg) () where 746 | 747 | -- If there is a match, the search terminates 748 | 749 | instance (a ~ a') => FindGen ('MatchCoh 'True) s (Gen a) gs a' where 750 | findGen _ g _ = g 751 | 752 | instance (f x ~ a') => FindGen ('MatchCoh 'True) s (Gen1_ f) gs a' where 753 | findGen _ (Gen1_ g) _ = g 754 | 755 | instance (f x ~ a', FindGen 'Shift ('S fg coh DummySel) () fg x) 756 | => FindGen ('MatchCoh 'True) ('S fg coh _sel) (Gen1 f) gs a' where 757 | findGen (_, _, fg) (Gen1 gen) _ = gen (findGen (iShift, s, fg) () fg) where 758 | s = Proxy :: Proxy ('S fg coh DummySel) 759 | 760 | -- | Matching custom generator for field @s@. 761 | instance (a ~ a') 762 | => FindGen ('MatchCoh 'True) s (FieldGen sn a) gs a' where 763 | findGen _ (FieldGen gen) _ = gen 764 | 765 | -- | Matching custom generator for @i@-th field of constructor @c@. 766 | instance (a ~ a') 767 | => FindGen ('MatchCoh 'True) s (ConstrGen c i a) gs a' where 768 | findGen _ (ConstrGen gen) _ = gen 769 | 770 | -- 771 | 772 | newtype Weighted a = Weighted (Maybe (Int -> Gen a, Int)) 773 | deriving Functor 774 | 775 | instance Applicative Weighted where 776 | pure a = Weighted (Just ((pure . pure) a, 1)) 777 | Weighted f <*> Weighted a = Weighted $ liftA2 g f a 778 | where 779 | g (f1, m) (a1, n) = 780 | ( \i -> 781 | let (j, k) = i `divMod` m 782 | in f1 j <*> a1 k 783 | , m * n ) 784 | 785 | instance Alternative Weighted where 786 | empty = Weighted Nothing 787 | a <|> Weighted Nothing = a 788 | Weighted Nothing <|> b = b 789 | Weighted (Just (a, m)) <|> Weighted (Just (b, n)) = Weighted . Just $ 790 | ( \i -> 791 | if i < m then 792 | a i 793 | else 794 | b (i - m) 795 | , m + n ) 796 | 797 | liftGen :: Gen a -> Weighted a 798 | liftGen g = Weighted (Just (\_ -> g, 1)) 799 | 800 | -------------------------------------------------------------------------------- /src/Generic/Random/Tutorial.hs: -------------------------------------------------------------------------------- 1 | -- | Generic implementations of 2 | -- [QuickCheck](https://hackage.haskell.org/package/QuickCheck)'s 3 | -- @arbitrary@. 4 | -- 5 | -- = Example 6 | -- 7 | -- Define your type. 8 | -- 9 | -- @ 10 | -- data Tree a = Leaf a | Node (Tree a) (Tree a) 11 | -- deriving 'GHC.Generics.Generic' 12 | -- @ 13 | -- 14 | -- Pick an 'Test.QuickCheck.arbitrary' implementation, specifying the required distribution of 15 | -- data constructors. 16 | -- 17 | -- @ 18 | -- instance Arbitrary a => Arbitrary (Tree a) where 19 | -- arbitrary = 'genericArbitrary' (9 '%' 8 '%' ()) 20 | -- @ 21 | -- 22 | -- That random generator @arbitrary :: 'Test.QuickCheck.Gen' (Tree a)@ picks a 23 | -- @Leaf@ with probability 9\/17, or a 24 | -- @Node@ with probability 8\/17, and recursively fills their fields with 25 | -- @arbitrary@. 26 | -- 27 | -- For @Tree@, the generic implementation 'genericArbitrary' is equivalent to 28 | -- the following: 29 | -- 30 | -- @ 31 | -- 'genericArbitrary' :: Arbitrary a => 'Weights' (Tree a) -> Gen (Tree a) 32 | -- 'genericArbitrary' (x '%' y '%' ()) = 33 | -- frequency 34 | -- [ (x, Leaf '<$>' arbitrary) 35 | -- , (y, Node '<$>' arbitrary '<*>' arbitrary) 36 | -- ] 37 | -- @ 38 | -- 39 | -- = Distribution of constructors 40 | -- 41 | -- The distribution of constructors can be specified as 42 | -- a special list of /weights/ in the same order as the data type definition. 43 | -- This assigns to each constructor a probability @p_C@ proportional to its weight @weight_C@; 44 | -- in other words, @p_C = weight_C / sumOfWeights@. 45 | -- 46 | -- The list of weights is built up with the @('%')@ operator as a cons, and using 47 | -- the unit @()@ as the empty list, in the order corresponding to the data type 48 | -- definition. 49 | -- 50 | -- == Uniform distribution 51 | -- 52 | -- You can specify the uniform distribution (all weights equal to 1) with 'uniform'. 53 | -- ('genericArbitraryU' is available as a shorthand for 54 | -- @'genericArbitrary' 'uniform'@.) 55 | -- 56 | -- Note that for many recursive types, a uniform distribution tends to produce 57 | -- big or even infinite values. 58 | -- 59 | -- == Typed weights 60 | -- 61 | -- The weights actually have type @'W' \"ConstructorName\"@ (just a newtype 62 | -- around 'Int'), so that you can annotate a weight with its corresponding 63 | -- constructor. The constructors must appear in the same order as in the 64 | -- original type definition. 65 | -- 66 | -- This will type-check: 67 | -- 68 | -- @ 69 | -- ((x :: 'W' \"Leaf\") '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) 70 | -- ( x '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) 71 | -- @ 72 | -- 73 | -- This will not: 74 | -- 75 | -- @ 76 | -- ((x :: 'W' \"Node\") '%' y '%' ()) :: 'Weights' (Tree a) 77 | -- -- Requires an order of constructors different from the definition of the @Tree@ type. 78 | -- 79 | -- ( x '%' y '%' z '%' ()) :: 'Weights' (Tree a) 80 | -- -- Doesn't have the right number of weights. 81 | -- @ 82 | -- 83 | -- = Ensuring termination 84 | -- 85 | -- As mentioned earlier, one must be careful with recursive types 86 | -- to avoid producing extremely large values. 87 | -- The alternative generator 'genericArbitraryRec' decreases the size 88 | -- parameter at every call to keep values at reasonable sizes. 89 | -- It is to be used together with 'withBaseCase'. 90 | -- 91 | -- For example, we may provide a base case consisting of only @Leaf@: 92 | -- 93 | -- @ 94 | -- instance Arbitrary a => Arbitrary (Tree a) where 95 | -- arbitrary = 'genericArbitraryRec' (1 '%' 2 '%' ()) 96 | -- ``withBaseCase`` (Leaf '<$>' arbitrary) 97 | -- @ 98 | -- 99 | -- That is equivalent to the following definition. Note the 100 | -- 'Test.QuickCheck.resize' modifier. 101 | -- 102 | -- @ 103 | -- arbitrary :: Arbitrary a => Gen (Tree a) 104 | -- arbitrary = sized $ \\n -> 105 | -- -- "if" condition from withBaseCase 106 | -- if n == 0 then 107 | -- Leaf \<$\> arbitrary 108 | -- else 109 | -- -- genericArbitraryRec 110 | -- frequency 111 | -- [ (1, resize (max 0 (n - 1)) (Leaf '<$>' arbitrary)) 112 | -- , (2, resize (n \`div\` 2) (Node '<$>' arbitrary '<*>' arbitrary)) 113 | -- ] 114 | -- @ 115 | -- 116 | -- The resizing strategy is as follows: 117 | -- the size parameter of 'Test.QuickCheck.Gen' is divided among the fields of 118 | -- the chosen constructor, or decreases by one if the constructor is unary. 119 | -- @'withBaseCase' defG baseG@ is equal to @defG@ as long as the size parameter 120 | -- is nonzero, and it becomes @baseG@ once the size reaches zero. 121 | -- This combination generally ensures that the number of constructors remains 122 | -- bounded by the initial size parameter passed to 'Test.QuickCheck.Gen'. 123 | -- 124 | -- == Automatic base case discovery 125 | -- 126 | -- In some situations, generic-random can also construct base cases automatically. 127 | -- This works best with fully concrete types (no type parameters). 128 | -- 129 | -- @ 130 | -- {-\# LANGUAGE FlexibleInstances #-} 131 | -- 132 | -- instance Arbitrary (Tree ()) where 133 | -- arbitrary = 'genericArbitrary'' (1 '%' 2 '%' ()) 134 | -- @ 135 | -- 136 | -- The above instance will infer the value @Leaf ()@ as a base case. 137 | -- 138 | -- To discover values of type @Tree a@, we must inspect the type argument @a@, 139 | -- thus we incur some extra constraints if we want polymorphism. 140 | -- It is preferrable to apply the type class 'BaseCase' to the instance head 141 | -- (@Tree a@) as follows, as it doesn't reduce to something worth seeing. 142 | -- 143 | -- @ 144 | -- {-\# LANGUAGE FlexibleContexts, UndecidableInstances \#-} 145 | -- 146 | -- instance (Arbitrary a, 'BaseCase' (Tree a)) 147 | -- => Arbitrary (Tree a) where 148 | -- arbitrary = 'genericArbitrary'' (1 '%' 2 '%' ()) 149 | -- @ 150 | -- 151 | -- The 'BaseCase' type class finds values of minimal depth, 152 | -- where the depth of a constructor is defined as @1 + max(0, depths of fields)@, 153 | -- e.g., @Leaf ()@ has depth 2. 154 | -- 155 | -- == Note about lists #notelists# 156 | -- 157 | -- The @Arbitrary@ instance for lists can be problematic for this way 158 | -- of implementing recursive sized generators, because they make a lot of 159 | -- recursive calls to 'Test.QuickCheck.arbitrary' without decreasing the size parameter. 160 | -- Hence, as a default, 'genericArbitraryRec' also detects fields which are 161 | -- lists to replace 'Test.QuickCheck.arbitrary' with a different generator that divides 162 | -- the size parameter by the length of the list before generating each 163 | -- element. This uses the customizable mechanism shown in the next section. 164 | -- 165 | -- If you really want to use 'Test.QuickCheck.arbitrary' for lists in the derived instances, 166 | -- substitute @'genericArbitraryRec'@ with @'genericArbitraryRecG' ()@. 167 | -- 168 | -- @ 169 | -- arbitrary = 'genericArbitraryRecG' () 170 | -- ``withBaseCase`` baseGen 171 | -- @ 172 | -- 173 | -- Some combinators are available for further tweaking: 'listOf'', 'listOf1'', 174 | -- 'vectorOf''. 175 | -- 176 | -- = Custom generators for some fields #custom# 177 | -- 178 | -- == Example 1 ('Test.QuickCheck.Gen', 'FieldGen') 179 | -- 180 | -- Sometimes, a few fields may need custom generators instead of 'Test.QuickCheck.arbitrary'. 181 | -- For example, imagine here that: 182 | -- 183 | -- - @String@ is meant to represent alphanumerical strings only, 184 | -- - IDs are meant to be nonnegative, 185 | -- - balances can have any sign. 186 | -- 187 | -- @ 188 | -- data User = User { 189 | -- userName :: String, 190 | -- userId :: Int, 191 | -- userBalance :: Int 192 | -- } deriving 'GHC.Generics.Generic' 193 | -- @ 194 | -- 195 | -- A naive approach has the following problems: 196 | -- 197 | -- - @'Test.QuickCheck.Arbitrary' String@ may generate any unicode character, 198 | -- alphanumeric or not; 199 | -- - @'Test.QuickCheck.Arbitrary' Int@ may generate negative values; 200 | -- - using @newtype@ wrappers or passing generators explicitly to properties 201 | -- may be impractical (the maintenance overhead can be high because the types 202 | -- are big or change often). 203 | -- 204 | -- Using generic-random, we can declare a (heterogeneous) list of generators to 205 | -- be used instead of 'Test.QuickCheck.arbitrary' when generating certain fields. 206 | -- 207 | -- @ 208 | -- customGens :: 'FieldGen' "userId" Int ':+' 'Test.QuickCheck.Gen' String 209 | -- customGens = 210 | -- 'FieldGen' ('Test.QuickCheck.getNonNegative' '<$>' arbitrary) ':+' 211 | -- 'Test.QuickCheck.listOf' ('Test.QuickCheck.elements' (filter isAlphaNum [minBound .. maxBound])) 212 | -- @ 213 | -- 214 | -- Now we use the 'genericArbitraryG' combinator and other @G@-suffixed 215 | -- variants that accept those explicit generators. 216 | -- 217 | -- With the above @customGens@, a generic 'Arbitrary' instance will have the following properties: 218 | -- 219 | -- - All @String@ fields will use the provided generator of 220 | -- alphanumeric strings; 221 | -- - the field @"userId"@ of type @Int@ will use the generator 222 | -- of nonnegative integers; 223 | -- - @userBalance@ defaults to 'Test.QuickCheck.arbitrary'. 224 | -- 225 | -- Random @User@ values will thus satisfy the above requirements. 226 | -- In particular, @'FieldGen' \"userId\" Int@ avoids overriding the 227 | -- @userBalance@ field so that negative values are still generated. 228 | -- 229 | -- @ 230 | -- instance Arbitrary User where 231 | -- arbitrary = 'genericArbitrarySingleG' customGens 232 | -- @ 233 | -- 234 | -- == Example 2 ('ConstrGen') 235 | -- 236 | -- Here's the @Tree@ type from the beginning again. 237 | -- 238 | -- @ 239 | -- data Tree a = Leaf a | Node (Tree a) (Tree a) 240 | -- deriving 'GHC.Generics.Generic' 241 | -- @ 242 | -- 243 | -- We will generate "right-leaning linear trees", which look like this: 244 | -- 245 | -- > Node (Leaf 1) 246 | -- > (Node (Leaf 2) 247 | -- > (Node (Leaf 3) 248 | -- > (Node (Leaf 4) 249 | -- > (Leaf 5)))) 250 | -- 251 | -- To do so, we force every left child of a @Node@ to be a @Leaf@: 252 | -- 253 | -- @ 254 | -- {-\# LANGUAGE ScopedTypeVariables \#-} 255 | -- 256 | -- instance Arbitrary a => Arbitrary (Tree a) where 257 | -- arbitrary = 'genericArbitraryUG' customGens 258 | -- where 259 | -- -- Generator for the left field (i.e., at index 0) of constructor Node, 260 | -- -- which must have type (Tree a). 261 | -- customGens :: 'ConstrGen' \"Node\" 0 (Tree a) 262 | -- customGens = 'ConstrGen' (Leaf '<$>' arbitrary) 263 | -- @ 264 | -- 265 | -- That instance is equivalent to the following: 266 | -- 267 | -- @ 268 | -- instance Arbitrary a => Arbitrary (Tree a) where 269 | -- arbitrary = oneof 270 | -- [ Leaf '<$>' arbitrary 271 | -- , Node '<$>' (Leaf '<$>' arbitrary) '<*>' arbitrary 272 | -- -- ^ recursive call 273 | -- ] 274 | -- @ 275 | -- 276 | -- == Custom generators reference 277 | -- 278 | -- The custom generator modifiers that can occur in the list are: 279 | -- 280 | -- - 'Test.QuickCheck.Gen': a generator for a specific type; 281 | -- - 'FieldGen': a generator for a record field; 282 | -- - 'ConstrGen': a generator for a field of a given constructor; 283 | -- - 'Gen1': a generator for \"containers\", parameterized by a generator 284 | -- for individual elements; 285 | -- - 'Gen1_': a generator for unary type constructors that are not 286 | -- containers. 287 | -- 288 | -- Suggestions to add more modifiers or otherwise improve this tutorial are welcome! 289 | -- 290 | 291 | {-# OPTIONS_GHC -Wno-unused-imports #-} 292 | 293 | module Generic.Random.Tutorial () where 294 | 295 | import Generic.Random 296 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.1 2 | packages: 3 | - '.' 4 | - 'examples/' 5 | extra-deps: [] 6 | -------------------------------------------------------------------------------- /test/Inspect.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -dsuppress-all #-} 2 | {-# LANGUAGE 3 | DeriveGeneric, 4 | TemplateHaskell 5 | #-} 6 | 7 | 8 | import GHC.Generics (Generic) 9 | import Test.QuickCheck (Arbitrary(arbitrary), Gen, choose) 10 | 11 | import Test.Inspection (inspect, (===)) 12 | 13 | import Generic.Random 14 | 15 | arbMaybe :: Arbitrary a => Gen (Maybe a) 16 | arbMaybe = genericArbitraryU 17 | 18 | arbMaybe' :: Arbitrary a => Gen (Maybe a) 19 | arbMaybe' = do 20 | i <- choose (0, 1 :: Int) 21 | if i < 1 then 22 | pure Nothing 23 | else 24 | Just <$> arbitrary 25 | 26 | data T = A | B | C Int [Bool] 27 | deriving Generic 28 | 29 | arbT :: Gen T 30 | arbT = genericArbitrary (1 % 2 % 3 % ()) 31 | 32 | arbT' :: Gen T 33 | arbT' = do 34 | i <- choose (0, 5 :: Int) 35 | if i < 1 then 36 | pure A 37 | else 38 | if i - 1 < 2 then 39 | pure B 40 | else 41 | C <$> arbitrary <*> arbitrary 42 | 43 | main :: IO () 44 | main = pure () 45 | 46 | inspect $ 'arbMaybe === 'arbMaybe' 47 | inspect $ 'arbT === 'arbT' 48 | -------------------------------------------------------------------------------- /test/Inspect/DerivingVia.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds, 3 | DeriveGeneric, 4 | DerivingVia, 5 | TypeOperators, 6 | TemplateHaskell 7 | #-} 8 | 9 | import GHC.Generics (Generic) 10 | import Test.QuickCheck (Arbitrary(arbitrary), Gen) 11 | 12 | import Test.Inspection (inspect, (==-)) 13 | 14 | import Generic.Random 15 | 16 | data T = A | B | C Int [Bool] 17 | deriving Generic 18 | deriving Arbitrary via (GenericArbitrary '[1,2,3] T) 19 | 20 | arbT :: Gen T 21 | arbT = genericArbitrary (1 % 2 % 3 % ()) 22 | 23 | arbT' :: Gen T 24 | arbT' = arbitrary 25 | 26 | data T1 = A1 | B1 | C1 Int [Bool] 27 | deriving Generic 28 | deriving Arbitrary via (GenericArbitrary '[1,2,3] `AndShrinking` T1) 29 | 30 | main :: IO () 31 | main = pure () 32 | 33 | inspect $ 'arbT ==- 'arbT' 34 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | import Control.Applicative 2 | import Data.Generics.Random.Boltzmann.GeneratingFunctions 3 | import Numeric.LinearAlgebra 4 | import Test.HUnit 5 | 6 | main = runTestTT $ TestList 7 | [ test_solve 8 | ] 9 | 10 | test_solve = "F(x) = 1 + x F(x)^2" ~: do 11 | print xs 12 | print (evalDeltas <$> xs <*> pure es) 13 | where 14 | x : fx : f'x : _ = fmap X [0 ..] 15 | expectedSize x n = (n * fx, x * f'x) 16 | es = 17 | [ expectedSize x 10000 18 | , (fx, 1 + x * fx * fx) 19 | , (f'x, fx * fx + 2 * x * f'x * fx) 20 | ] 21 | xs = solveEquations defSolveArgs es (vector [0, 1, 1]) 22 | -------------------------------------------------------------------------------- /test/Unit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | DataKinds, 3 | DeriveGeneric, 4 | FlexibleContexts, 5 | FlexibleInstances, 6 | LambdaCase, 7 | TypeFamilies, 8 | UndecidableInstances #-} 9 | 10 | import Control.Monad (replicateM) 11 | import Control.DeepSeq (NFData, force) 12 | import GHC.Generics (Generic) 13 | import System.Timeout (timeout) 14 | 15 | import Test.QuickCheck 16 | 17 | import Generic.Random 18 | 19 | -- Binary trees 20 | data B = BL | BN B B 21 | deriving (Eq, Ord, Show, Generic) 22 | 23 | size :: B -> Int 24 | size (BN l r) = 1 + size l + size r 25 | size BL = 0 26 | 27 | instance Arbitrary B where 28 | arbitrary = genericArbitrary ((9 :: W "BL") % (3 :: W "BN") % ()) 29 | 30 | instance NFData B 31 | 32 | 33 | -- Messing with base cases 34 | newtype T a = W a deriving (Generic, Show) 35 | 36 | instance (Arbitrary a, BaseCase (T a)) => Arbitrary (T a) where 37 | arbitrary = genericArbitrary' uniform 38 | 39 | instance NFData a => NFData (T a) 40 | 41 | 42 | -- Rose tree for testing the custom list generator that's inserted by default. 43 | data NTree = Leaf | Node [NTree] deriving (Generic, Show) 44 | 45 | instance Arbitrary NTree where 46 | arbitrary = genericArbitraryU' 47 | 48 | instance NFData NTree 49 | 50 | eval :: NFData a => String -> Gen a -> IO () 51 | eval name g = do 52 | x <- timeout (10 ^ (6 :: Int)) $ do 53 | xs <- generate (replicateM 100 g) 54 | return $! force xs 55 | case x of 56 | Just _ -> return () 57 | Nothing -> fail $ name ++ ": did not finish on time" 58 | 59 | -- Tests for ConstrGen 60 | 61 | data Tree2 = Leaf2 Int | Node2 Tree2 Tree2 deriving (Generic, Show) 62 | 63 | instance Arbitrary Tree2 where 64 | arbitrary = genericArbitraryUG (ConstrGen (Leaf2 <$> arbitrary) :: ConstrGen "Node2" 1 Tree2) 65 | 66 | isLeftBiased :: Tree2 -> Bool 67 | isLeftBiased (Leaf2 _) = True 68 | isLeftBiased (Node2 t (Leaf2 _)) = isLeftBiased t 69 | isLeftBiased _ = False 70 | 71 | main :: IO () 72 | main = do 73 | eval "B" (arbitrary :: Gen B) 74 | eval "T" (arbitrary :: Gen (T (T Int))) 75 | eval "NTree" (arbitrary :: Gen NTree) 76 | quickCheck . whenFail (putStrLn "Tree2") $ isLeftBiased 77 | -------------------------------------------------------------------------------- /test/coherence.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-} 2 | {-# LANGUAGE 3 | BangPatterns, 4 | DataKinds, 5 | DeriveGeneric, 6 | ScopedTypeVariables, 7 | TypeOperators, 8 | RebindableSyntax, 9 | TypeApplications #-} 10 | 11 | import Control.Monad (replicateM) 12 | import Control.Exception 13 | import System.Exit (exitFailure) 14 | import Data.Foldable (find, traverse_) 15 | import Data.Maybe (catMaybes) 16 | 17 | import GHC.Generics ( Generic ) 18 | import Test.QuickCheck (Arbitrary (..), Gen, sample, generate) 19 | import Prelude 20 | 21 | import Generic.Random 22 | 23 | -- @T0@, @T1@: Override the @Int@ generator in the presence of a type parameter @a@. 24 | 25 | -- Counterexample that's not supposed to type check. 26 | -- Use BangPatterns so we can force it with just seq. 27 | data T0 a = N0 !a !Int 28 | deriving (Generic, Show) 29 | 30 | instance Arbitrary a => Arbitrary (T0 a) where 31 | arbitrary = genericArbitraryWith 32 | (setGenerators customGens cohSizedOpts) 33 | uniform 34 | where 35 | customGens :: Gen Int 36 | customGens = pure 33 37 | 38 | 39 | -- This one works. 40 | data T1 a = N1 a Int 41 | deriving (Generic, Show) 42 | 43 | instance Arbitrary a => Arbitrary (T1 a) where 44 | arbitrary = genericArbitraryWith 45 | (setGenerators customGens cohSizedOpts) 46 | uniform 47 | where 48 | customGens :: Incoherent (Gen a) :+ Gen Int 49 | customGens = Incoherent arbitrary :+ pure 33 50 | 51 | check1 :: T1 a -> Bool 52 | check1 (N1 _ n) = n == 33 53 | 54 | 55 | -- A bigger example to cover the remaining generator types. 56 | data T2 a = N2 57 | { f2a :: a 58 | , f2b :: Int 59 | , f2c :: [Int] 60 | , f2d :: Maybe Int 61 | , f2e :: Int 62 | , f2g :: Int 63 | , f2h :: [a] 64 | } deriving (Show, Generic) 65 | 66 | instance Arbitrary a => Arbitrary (T2 a) where 67 | arbitrary = genericArbitraryWith 68 | (setGenerators customGens cohSizedOpts) 69 | uniform 70 | where 71 | -- Hack to allow annotating each generator in the list while avoiding parentheses 72 | (>>) = (:+) 73 | customGens = do 74 | Incoherent arbitrary :: Incoherent (Gen a) 75 | Incoherent (FieldGen ((: []) <$> arbitrary)) 76 | :: Incoherent (FieldGen "f2h" [a]) 77 | Gen1_ (pure Nothing) :: Gen1_ Maybe 78 | Gen1 (fmap (\x -> [x, x])) :: Gen1 [] 79 | ConstrGen (pure 88) :: ConstrGen "N2" 4 Int 80 | FieldGen (pure 77) :: FieldGen "f2g" Int 81 | pure 33 :: Gen Int 82 | 83 | check2 :: T2 a -> Bool 84 | check2 t = 85 | f2b t == 33 86 | && length (f2c t) == 2 87 | && f2d t == Nothing 88 | && f2e t == 88 89 | && f2g t == 77 90 | && length (f2h t) == 1 91 | 92 | 93 | type Error = String 94 | 95 | expectTypeError :: IO a -> IO (Maybe Error) 96 | expectTypeError gen = do 97 | r <- try (gen >>= evaluate) 98 | case r of 99 | Left (e :: TypeError) -> pure Nothing -- success 100 | Right _ -> (pure . Just) "Unexpected evaluation (expected a type error)" 101 | 102 | 103 | sample_ :: Show a => (a -> Bool) -> Gen a -> IO (Maybe Error) 104 | sample_ check g = do 105 | xs <- generate (replicateM 100 g) 106 | case find (not . check) xs of 107 | Nothing -> pure Nothing 108 | Just x -> (pure . Just) ("Invalid value: " ++ show x) 109 | 110 | 111 | collectErrors :: [IO (Maybe Error)] -> IO () 112 | collectErrors xs = do 113 | es <- sequence xs 114 | case catMaybes es of 115 | [] -> pure () 116 | es@(_ : _) -> do 117 | putStrLn "Test failed. Errors:" 118 | traverse_ putStrLn es 119 | exitFailure 120 | 121 | main :: IO () 122 | main = collectErrors 123 | [ expectTypeError (generate (arbitrary :: Gen (T0 ()))) 124 | , sample_ check1 (arbitrary :: Gen (T1 ())) 125 | , sample_ check2 (arbitrary :: Gen (T2 ())) 126 | ] 127 | --------------------------------------------------------------------------------