generic-random 0.4.1.0 → 1.5.0.1
raw patch · 15 files changed
Files
- CHANGELOG.md +88/−2
- README.md +53/−25
- generic-random.cabal +82/−20
- src/Generic/Random.hs +246/−0
- src/Generic/Random/Boltzmann.hs +0/−7
- src/Generic/Random/Data.hs +0/−6
- src/Generic/Random/DerivingVia.hs +334/−0
- src/Generic/Random/Generic.hs +0/−214
- src/Generic/Random/Internal/BaseCase.hs +321/−0
- src/Generic/Random/Internal/Generic.hs +641/−151
- src/Generic/Random/Tutorial.hs +287/−0
- test/Inspect.hs +47/−0
- test/Inspect/DerivingVia.hs +33/−0
- test/Unit.hs +76/−0
- test/coherence.hs +126/−0
CHANGELOG.md view
@@ -1,3 +1,89 @@+# Changelog++Latest version: https://github.com/Lysxia/generic-random/blob/master/changelog.md++# 1.5.1.0++- Support GHC 9.2++# 1.5.0.0++- Add newtypes for `DerivingVia` (thanks, blackheaven)+- Drop compatibility with GHC 8.0 and 8.2++# 1.4.0.0++- Add option to use only coherent instances+- Export `SetSized` and `SetUnsized`+- Drop compatibility with GHC 7++# 1.3.0.1++- Fix small typos in documentation.++# 1.3.0.0++- Add `ConstrGen` (custom generators for fields specified by constructor name+ and index).+- Stop requiring custom generators lists to be terminated by `:+ ()`, or to be+ lists at all.+- Breaking minor change: when a record field has a different type than+ a `FieldGen` custom generator for the same field name, this is now a+ compilation error. This was simply ignored before.+- Miscellaneous documentation improvements in `Generic.Random` module.++# 1.2.0.0++- Fix a bug where generators did not decrease the size parameter with+ single-field constructors++- The sized generators now use a custom generator for lists.+ Use `genericArbitraryRecG ()` to disable that.+ See tutorial for more information.++- Lists of custom generators are now constructed using `(:+)` instead of+ `GenList`+- Rename `Field` to `FieldGen`+- Add `Gen1`, `Gen1_` (custom generators for unary type constructors)+- Add `listOf'`, `listOf1'`, `vectorOf'`+- Remove deprecated module `Generic.Random.Generic`++# 1.1.0.2++- Improved performance++# 1.1.0.1++- Fix build for GHC<8++# 1.1.0.0++- Add option to specify custom generators for certain fields,+ overriding Arbitrary instances+ + Add `genericArbitraryG`, `genericArbitraryUG`, `genericArbitrarySingleG`,+ `genericArbitraryRecG`+- Add `GArbitrary` and `GUniformWeight` synonyms+- Deprecate `Generic.Random.Generic`+- Remove `weights` from the external API++# 1.0.0.0++- Make the main module `Generic.Random`+- Rework generic base case generation+ + You can explicitly provide a trivial generator (e.g., returning a+ nullary constructor) using `withBaseCase`+ + Generically derive `BaseCaseSearch` and let `BaseCase` find small+ values, no depth parameter must be specified anymore+- Add `genericArbitrarySingle`, `genericArbitraryRec`, `genericArbitraryU'`+- Deprecate `weights`+- Fixed bug with `genericArbitrary'` not dividing the size parameter++# 0.5.0.0++- Turn off dependency on boltzmann-samplers by default+- Add `genericArbitraryU`, `genericArbitraryU0` and `genericArbitraryU1`+- Compatible with GHC 7.8.4 and GHC 7.10.3+ # 0.4.1.0 - Move Boltzmann sampler modules to another package: boltzmann-samplers@@ -11,5 +97,5 @@ # 0.3.0.0 - Support GHC 7.10.3-- Replace TypeApplications with ad-hoc data types in- genericArbitraryFrequency'/genericArbitrary'+- Replace `TypeApplications` with ad-hoc data types in+ `genericArbitraryFrequency'`/`genericArbitrary'`
README.md view
@@ -1,37 +1,65 @@ Generic random generators [](https://hackage.haskell.org/package/generic-random) [](https://travis-ci.org/Lysxia/generic-random) ========================= -Say goodbye to `Constructor <$> arbitrary <*> arbitrary <*> arbitrary`-boilerplate.+Generic random generators+to implement `Arbitrary` instances for [QuickCheck](https://hackage.haskell.org/package/QuickCheck) +Automating the `arbitrary` boilerplate also ensures that when a type changes to+have more or fewer constructors, then the generator either fixes itself to+generate that new case (when using the `uniform` distribution) or causes a+compilation error so you remember to fix it (when using an explicit+distribution).++This package also offers a simple (optional) strategy to ensure termination for+recursive types:+make `Test.QuickCheck.Gen`'s size parameter decrease at every recursive call;+when it reaches zero, sample directly from a trivially terminating generator+given explicitly (`genericArbitraryRec` and `withBaseCase`) or implicitly+(`genericArbitrary'`).++Example+-------+ ```haskell- {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} - import GHC.Generics ( Generic )- import Test.QuickCheck- import Generic.Random.Generic+import GHC.Generics (Generic)+import Test.QuickCheck+import Generic.Random - data Tree a = Leaf | Node (Tree a) a (Tree a)- deriving (Show, Generic)+data Tree a = Leaf | Node (Tree a) a (Tree a)+ deriving (Show, Generic) - instance Arbitrary a => Arbitrary (Tree a) where- arbitrary = genericArbitrary' Z uniform+instance Arbitrary a => Arbitrary (Tree a) where+ arbitrary = genericArbitraryRec uniform `withBaseCase` return Leaf - -- Equivalent to- -- > arbitrary =- -- > sized $ \n ->- -- > if n == 0 then- -- > return Leaf- -- > else- -- > oneof- -- > [ return Leaf- -- > , Node <$> arbitrary <*> arbitrary <*> arbitrary- -- > ]+-- Equivalent to+-- > arbitrary =+-- > sized $ \n ->+-- > if n == 0 then+-- > return Leaf+-- > else+-- > oneof+-- > [ return Leaf+-- > , resize (n `div` 3) $+-- > Node <$> arbitrary <*> arbitrary <*> arbitrary+-- > ] - main = sample (arbitrary :: Gen (Tree ()))+main :: IO ()+main = sample (arbitrary :: Gen (Tree ())) ``` -- User-specified distribution of constructors, with a compile-time check that- weights have been specified for all constructors.-- A simple (optional) strategy to ensure termination: `Test.QuickCheck.Gen`'s- size parameter decreases at every recursive `genericArbitrary'` call; when it- reaches zero, sample directly from a finite set of finite values.+Related+-------++- The following two packages also derive random generators, but only with a uniform+ distribution of constructors:++ + [quickcheck-arbitrary-template](https://hackage.haskell.org/package/quickcheck-arbitrary-template) (TH)+ + [generic-arbitrary](https://hackage.haskell.org/package/generic-arbitrary-0.1.0) (GHC Generics)++- [testing-feat](http://hackage.haskell.org/package/testing-feat):+ derive enumerations for algebraic data types, which can be turned into random generators (TH).++- [boltzmann-samplers](https://hackage.haskell.org/package/boltzmann-samplers):+ derive Boltzmann samplers (SYB).
generic-random.cabal view
@@ -1,42 +1,104 @@ name: generic-random-version: 0.4.1.0-synopsis: Generic random generators-description: Please see the README.+version: 1.5.0.1+synopsis: Generic random generators for QuickCheck+description:+ Derive instances of @Arbitrary@ for QuickCheck,+ with various options to customize implementations.+ .+ For more information+ .+ - See the README+ .+ - "Generic.Random.Tutorial"+ .+ - http://blog.poisson.chat/posts/2018-01-05-generic-random-tour.html+ homepage: http://github.com/lysxia/generic-random license: MIT license-file: LICENSE-stability: Experimental+stability: Stable author: Li-yao Xia maintainer: lysxia@gmail.com category: Generics, Testing build-type: Simple extra-source-files: README.md CHANGELOG.md cabal-version: >=1.10-tested-with: GHC == 8.0.1--flag boltzmann- Description:- Dependency on boltzmann-samplers for backwards compatibility.- Manual: False- Default: True+tested-with: GHC == 8.4.1, GHC == 8.6.1, GHC == 8.8.4, GHC == 8.10.5, GHC == 9.0.1, GHC == 9.2.1 library hs-source-dirs: src exposed-modules:- Generic.Random.Generic+ Generic.Random+ Generic.Random.DerivingVia+ Generic.Random.Internal.BaseCase Generic.Random.Internal.Generic+ Generic.Random.Tutorial build-depends:- base >= 4.9 && < 4.10,- QuickCheck- if flag(boltzmann)- exposed-modules:- Generic.Random.Boltzmann- Generic.Random.Data- build-depends:- boltzmann-samplers <= 0.2+ base >= 4.11 && < 5,+ QuickCheck >= 2.14+ -- exports RecursivelyShrink default-language: Haskell2010 ghc-options: -Wall -fno-warn-name-shadowing source-repository head type: git location: https://github.com/lysxia/generic-random++test-suite unit+ hs-source-dirs: test+ main-is: Unit.hs+ build-depends:+ base,+ deepseq,+ QuickCheck,+ generic-random+ type: exitcode-stdio-1.0+ default-language: Haskell2010++test-suite coherence+ hs-source-dirs: test+ main-is: coherence.hs+ build-depends:+ base,+ deepseq,+ QuickCheck,+ generic-random+ type: exitcode-stdio-1.0+ default-language: Haskell2010++test-suite inspect+ hs-source-dirs: test+ main-is: Inspect.hs+ build-depends:+ base,+ QuickCheck,+ inspection-testing,+ generic-random+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ if !flag(enable-inspect)+ buildable: False+ else+ build-depends: random < 1.2+ -- TODO: this test fails with newer versions of random++test-suite inspect-derivingvia+ hs-source-dirs: test+ main-is: Inspect/DerivingVia.hs+ build-depends:+ base,+ QuickCheck,+ inspection-testing,+ generic-random+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ if !flag(enable-inspect)+ buildable: False+ else+ build-depends: random < 1.2+ -- TODO: this test fails with newer versions of random++flag enable-inspect+ description: Enable inspection tests+ default: False+ manual: True
+ src/Generic/Random.hs view
@@ -0,0 +1,246 @@+-- | "GHC.Generics"-based 'Test.QuickCheck.arbitrary' generators.+--+-- = Basic usage+--+-- @+-- {-\# LANGUAGE DeriveGeneric \#-}+--+-- data Foo = A | B | C -- some generic data type+-- deriving 'GHC.Generics.Generic'+-- @+--+-- Derive instances of 'Test.QuickCheck.Arbitrary'.+--+-- @+-- instance Arbitrary Foo where+-- arbitrary = 'genericArbitrary' 'uniform' -- Give a distribution of constructors.+-- shrink = 'Test.QuickCheck.genericShrink' -- Generic shrinking is provided by the QuickCheck library.+-- @+--+-- Or derive standalone generators (the fields must still be instances of+-- 'Test.QuickCheck.Arbitrary', or use custom generators).+--+-- @+-- genFoo :: Gen Foo+-- genFoo = 'genericArbitrary' 'uniform'+-- @+--+-- === Using @DerivingVia@+--+-- @+-- {-\# LANGUAGE DerivingVia, TypeOperators \#-}+--+-- data Foo = A | B | C+-- deriving 'GHC.Generics.Generic'+-- deriving Arbitrary via ('GenericArbitraryU' `'AndShrinking'` Foo)+-- @+--+-- For more information:+--+-- - "Generic.Random.Tutorial"+-- - http://blog.poisson.chat/posts/2018-01-05-generic-random-tour.html++{-# LANGUAGE ExplicitNamespaces #-}++module Generic.Random+ (+ -- * Arbitrary implementations++ -- | The suffixes for the variants have the following meanings:+ --+ -- - @U@: pick constructors with uniform distribution (equivalent to+ -- passing 'uniform' to the non-@U@ variant).+ -- - @Single@: restricted to types with a single constructor.+ -- - @G@: with custom generators.+ -- - @Rec@: decrease the size at every recursive call (ensuring termination+ -- for (most) recursive types).+ -- - @'@: automatic discovery of "base cases" when size reaches 0.+ genericArbitrary+ , genericArbitraryU+ , genericArbitrarySingle+ , genericArbitraryRec+ , genericArbitrary'+ , genericArbitraryU'++ -- ** With custom generators++ -- |+ -- === Note about incoherence+ --+ -- The custom generator feature relies on incoherent instances, which can+ -- lead to surprising behaviors for parameterized types.+ --+ -- ==== __Example__+ --+ -- For example, here is a pair type and a custom generator of @Int@ (always+ -- generating 0).+ --+ -- @+ -- data Pair a b = Pair a b+ -- deriving (Generic, Show)+ --+ -- customGen :: Gen Int+ -- customGen = pure 0+ -- @+ --+ -- The following two ways of defining a generator of @Pair Int Int@ are+ -- __not__ equivalent.+ --+ -- The first way is to use 'genericArbitrarySingleG' to define a+ -- @Gen (Pair a b)@ parameterized by types @a@ and @b@, and then+ -- specialize it to @Gen (Pair Int Int)@.+ --+ -- In this case, the @customGen@ will be ignored.+ --+ -- @+ -- genPair :: (Arbitrary a, Arbitrary b) => Gen (Pair a b)+ -- genPair = 'genericArbitrarySingleG' customGen+ --+ -- genPair' :: Gen (Pair Int Int)+ -- genPair' = genPair+ -- -- Will generate nonzero pairs+ -- @+ --+ -- The second way is to define @Gen (Pair Int Int)@ directly using+ -- 'genericArbitrarySingleG' (as if we inlined @genPair@ in @genPair'@+ -- above.+ --+ -- Then the @customGen@ will actually be used.+ --+ -- @+ -- genPair2 :: Gen (Pair Int Int)+ -- genPair2 = 'genericArbitrarySingleG' customGen+ -- -- Will only generate (Pair 0 0)+ -- @+ --+ -- In other words, the decision of whether to use a custom generator+ -- is done by comparing the type of the custom generator with the type of+ -- the field only in the context where 'genericArbitrarySingleG' is being+ -- used (or any other variant with a @G@ suffix).+ --+ -- In the first case above, those fields have types @a@ and @b@, which are+ -- not equal to @Int@ (or rather, there is no available evidence that they+ -- are equal to @Int@, even if they could be instantiated as @Int@ later).+ -- In the second case, they both actually have type @Int@.++ , genericArbitraryG+ , genericArbitraryUG+ , genericArbitrarySingleG+ , genericArbitraryRecG++ -- * Specifying finite distributions+ , Weights+ , W+ , (%)+ , uniform++ -- * Custom generators++ -- | Custom generators can be specified in a list constructed with @(':+')@,+ -- and passed to functions such as 'genericArbitraryG' to override how certain+ -- fields are generated.+ --+ -- Example:+ --+ -- @+ -- customGens :: Gen String ':+' Gen Int+ -- customGens =+ -- (filter (/= '\NUL') '<$>' arbitrary) ':+'+ -- (getNonNegative '<$>' arbitrary)+ -- @+ --+ -- There are also different types of generators, other than 'Test.QuickCheck.Gen', providing+ -- more ways to select the fields the generator than by simply comparing types:+ --+ -- - @'Test.QuickCheck.Gen' a@: override fields of type @a@;+ -- - @'Gen1' f@: override fields of type @f x@ for some @x@, requiring a generator for @x@;+ -- - @'Gen1_' f@: override fields of type @f x@ for some @x@, __not__ requiring a generator for @x@;+ -- - @'FieldGen' s a@: override record fields named @s@, which must have type @a@;+ -- - @'ConstrGen' c i a@: override the field at index @i@ of constructor @c@,+ -- which must have type @a@ (0-indexed);+ --+ -- Multiple generators may match a given field: the first, leftmost+ -- generator in the list will be chosen.+ , (:+) (..)+ , FieldGen (..)+ , fieldGen+ , ConstrGen (..)+ , constrGen+ , Gen1 (..)+ , Gen1_ (..)++ -- * Helpful combinators+ , listOf'+ , listOf1'+ , vectorOf'++ -- * Base cases for recursive types+ , withBaseCase+ , BaseCase (..)++ -- * Full options+ , Options ()+ , genericArbitraryWith++ -- ** Setters+ , SetOptions+ , type (<+)+ , setOpts++ -- ** Size modifiers+ , Sizing (..)+ , SetSized+ , SetUnsized+ , setSized+ , setUnsized++ -- ** Custom generators+ , SetGens+ , setGenerators++ -- ** Coherence options+ , Coherence (..)+ , Incoherent (..)++ -- ** Common options+ , SizedOpts+ , sizedOpts+ , SizedOptsDef+ , sizedOptsDef+ , UnsizedOpts+ , unsizedOpts++ -- *** Advanced options+ -- | See 'Coherence'+ , CohUnsizedOpts+ , cohUnsizedOpts+ , CohSizedOpts+ , cohSizedOpts++ -- * Generic classes+ , GArbitrary+ , GUniformWeight++ -- * Newtypes for DerivingVia++ -- | These newtypes correspond to the variants of 'genericArbitrary' above.++ , GenericArbitrary (..)+ , GenericArbitraryU (..)+ , GenericArbitrarySingle (..)+ , GenericArbitraryRec (..)+ , GenericArbitraryG (..)+ , GenericArbitraryUG (..)+ , GenericArbitrarySingleG (..)+ , GenericArbitraryRecG (..)+ , GenericArbitraryWith (..)+ , AndShrinking (..)++ -- ** Helpers typeclasses+ , TypeLevelGenList (..)+ , TypeLevelOpts (..)+ ) where++import Generic.Random.Internal.BaseCase+import Generic.Random.Internal.Generic+import Generic.Random.DerivingVia
− src/Generic/Random/Boltzmann.hs
@@ -1,7 +0,0 @@--module Generic.Random.Boltzmann- {-# DEPRECATED "Directly use \"Boltzmann.Species\" from @boltzmann-samplers@ instead." #-}- ( module Boltzmann.Species- ) where--import Boltzmann.Species
− src/Generic/Random/Data.hs
@@ -1,6 +0,0 @@-module Generic.Random.Data- {-# DEPRECATED "Directly use \"Boltzmann.Data\" from @boltzmann-samplers@ instead." #-}- ( module Boltzmann.Data- ) where--import Boltzmann.Data
+ src/Generic/Random/DerivingVia.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++module Generic.Random.DerivingVia+ ( GenericArbitrary (..),+ GenericArbitraryU (..),+ GenericArbitrarySingle (..),+ GenericArbitraryRec (..),+ GenericArbitraryG (..),+ GenericArbitraryUG (..),+ GenericArbitrarySingleG (..),+ GenericArbitraryRecG (..),+ GenericArbitraryWith (..),+ AndShrinking (..),+ TypeLevelGenList (..),+ TypeLevelOpts (..),+ )+where++import Data.Coerce (Coercible, coerce)+import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import GHC.Generics (Generic(..))+import GHC.TypeLits (KnownNat, natVal)+import Generic.Random.Internal.Generic+import Test.QuickCheck (Arbitrary (..), Gen, genericShrink)+import Test.QuickCheck.Arbitrary (RecursivelyShrink, GSubterms)++-- * Newtypes for DerivingVia++-- | Pick a constructor with a given distribution, and fill its fields+-- with recursive calls to 'Test.QuickCheck.arbitrary'.+--+-- === Example+--+-- > data X = ...+-- > deriving Arbitrary via (GenericArbitrary '[2, 3, 5] X)+--+-- Picks the first constructor with probability @2/10@,+-- the second with probability @3/10@, the third with probability @5/10@.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitrary'.+--+-- @since 1.5.0.0+newtype GenericArbitrary weights a = GenericArbitrary {unGenericArbitrary :: a} deriving (Eq, Show)++instance+ ( GArbitrary UnsizedOpts a,+ TypeLevelWeights' weights a+ ) =>+ Arbitrary (GenericArbitrary weights a)+ where+ arbitrary = GenericArbitrary <$> genericArbitrary (typeLevelWeights @weights)++-- | Pick every constructor with equal probability.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryU'.+--+-- @since 1.5.0.0+newtype GenericArbitraryU a = GenericArbitraryU {unGenericArbitraryU :: a} deriving (Eq, Show)++instance+ ( GArbitrary UnsizedOpts a,+ GUniformWeight a+ ) =>+ Arbitrary (GenericArbitraryU a)+ where+ arbitrary = GenericArbitraryU <$> genericArbitraryU++-- | @arbitrary@ for types with one constructor.+-- Equivalent to 'GenericArbitraryU', with a stricter type.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitrarySingle'.+--+-- @since 1.5.0.0+newtype GenericArbitrarySingle a = GenericArbitrarySingle {unGenericArbitrarySingle :: a} deriving (Eq, Show)++instance+ ( GArbitrary UnsizedOpts a,+ Weights_ (Rep a) ~ L c0+ ) =>+ Arbitrary (GenericArbitrarySingle a)+ where+ arbitrary = GenericArbitrarySingle <$> genericArbitrarySingle++-- | Decrease size at every recursive call, but don't do anything different+-- at size 0.+--+-- > data X = ...+-- > deriving Arbitrary via (GenericArbitraryRec '[2, 3, 5] X)+--+-- N.B.: This replaces the generator for fields of type @[t]@ with+-- @'listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for+-- lists).+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryRec'.+--+-- @since 1.5.0.0+newtype GenericArbitraryRec weights a = GenericArbitraryRec {unGenericArbitraryRec :: a} deriving (Eq, Show)++instance+ ( GArbitrary SizedOptsDef a,+ TypeLevelWeights' weights a+ ) =>+ Arbitrary (GenericArbitraryRec weights a)+ where+ arbitrary = GenericArbitraryRec <$> genericArbitraryRec (typeLevelWeights @weights)++-- | 'GenericArbitrary' with explicit generators.+--+-- === Example+--+-- > data X = ...+-- > deriving Arbitrary via (GenericArbitraryG CustomGens '[2, 3, 5] X)+--+-- where, for example, custom generators to override 'String' and 'Int' fields+-- might look as follows:+--+-- @+-- type CustomGens = CustomString ':+' CustomInt+-- @+--+-- === Note on multiple matches+--+-- Multiple generators may match a given field: the first will be chosen.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryG'.+--+-- @since 1.5.0.0+newtype GenericArbitraryG genList weights a = GenericArbitraryG {unGenericArbitraryG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList UnsizedOpts) a,+ GUniformWeight a,+ TypeLevelWeights' weights a,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitraryG genList' weights a)+ where+ arbitrary = GenericArbitraryG <$> genericArbitraryG (toGenList $ Proxy @genList') (typeLevelWeights @weights)++-- | 'GenericArbitraryU' with explicit generators.+-- See also 'GenericArbitraryG'.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryUG'.+--+-- @since 1.5.0.0+newtype GenericArbitraryUG genList a = GenericArbitraryUG {unGenericArbitraryUG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList UnsizedOpts) a,+ GUniformWeight a,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitraryUG genList' a)+ where+ arbitrary = GenericArbitraryUG <$> genericArbitraryUG (toGenList $ Proxy @genList')++-- | 'genericArbitrarySingle' with explicit generators.+-- See also 'GenericArbitraryG'.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitrarySingleG'.+--+-- @since 1.5.0.0+newtype GenericArbitrarySingleG genList a = GenericArbitrarySingleG {unGenericArbitrarySingleG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList UnsizedOpts) a,+ Weights_ (Rep a) ~ L c0,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitrarySingleG genList' a)+ where+ arbitrary = GenericArbitrarySingleG <$> genericArbitrarySingleG (toGenList $ Proxy @genList')++-- | 'genericArbitraryRec' with explicit generators.+-- See also 'genericArbitraryG'.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryRecG'.+--+-- @since 1.5.0.0+newtype GenericArbitraryRecG genList weights a = GenericArbitraryRecG {unGenericArbitraryRecG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList SizedOpts) a,+ TypeLevelWeights' weights a,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitraryRecG genList' weights a)+ where+ arbitrary = GenericArbitraryRecG <$> genericArbitraryRecG (toGenList $ Proxy @genList') (typeLevelWeights @weights)++-- | General generic generator with custom options.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryWith'.+--+-- @since 1.5.0.0+newtype GenericArbitraryWith opts weights a = GenericArbitraryWith {unGenericArbitraryWith :: a} deriving (Eq, Show)++instance+ ( GArbitrary opts a,+ TypeLevelWeights' weights a,+ TypeLevelOpts opts',+ opts ~ TypeLevelOpts' opts'+ ) =>+ Arbitrary (GenericArbitraryWith opts' weights a)+ where+ arbitrary = GenericArbitraryWith <$> genericArbitraryWith (toOpts $ Proxy @opts') (typeLevelWeights @weights)++-- | Add generic shrinking to a newtype wrapper for 'Arbitrary', using 'genericShrink'.+--+-- @+-- data X = ...+-- deriving Arbitrary via ('GenericArbitrary' '[1,2,3] `'AndShrinking'` X)+-- @+--+-- Equivalent to:+--+-- @+-- instance Arbitrary X where+-- arbitrary = 'genericArbitrary' (1 % 2 % 3 % ())+-- shrink = 'Test.QuickCheck.genericShrink'+-- @+--+-- @since 1.5.0.0+newtype AndShrinking f a = AndShrinking a deriving (Eq, Show)++instance+ ( Arbitrary (f a), Coercible (f a) a, Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a+ ) => Arbitrary (AndShrinking f a) where+ arbitrary = coerce (arbitrary :: Gen (f a))+ shrink = coerce (genericShrink :: a -> [a])++-- * Internal++-- |+-- @since 1.5.0.0+type TypeLevelWeights' weights a = TypeLevelWeights weights (Weights_ (Rep a))++typeLevelWeights ::+ forall weights a.+ TypeLevelWeights weights (Weights_ (Rep a)) =>+ Weights a+typeLevelWeights =+ let (w, n) = typeLevelWeightsBuilder @weights+ in Weights w n++-- |+-- @since 1.5.0.0+class TypeLevelWeights weights a where+ typeLevelWeightsBuilder :: (a, Int)++instance+ ( KnownNat weight,+ TypeLevelWeights weights a+ ) =>+ TypeLevelWeights (weight ': weights) (L x :| a)+ where+ typeLevelWeightsBuilder =+ let (a, m) = (L, fromIntegral $ natVal $ Proxy @weight)+ (b, n) = typeLevelWeightsBuilder @weights @a+ in (N a m b, m + n)++instance+ ( KnownNat weight+ ) =>+ TypeLevelWeights (weight ': '[]) (L x)+ where+ typeLevelWeightsBuilder = (L, fromIntegral $ natVal $ Proxy @weight)++instance+ TypeLevelWeights (w ': ws) (t :| (u :| v)) =>+ TypeLevelWeights (w ': ws) ((t :| u) :| v)+ where+ typeLevelWeightsBuilder =+ let (N t nt (N u nu v), m) = typeLevelWeightsBuilder @(w ': ws) @(t :| (u :| v))+ in (N (N t nt u) (nt + nu) v, m)++instance TypeLevelWeights '[] () where+ typeLevelWeightsBuilder = ((), 1)++-- |+-- @since 1.5.0.0+class TypeLevelGenList a where+ type TypeLevelGenList' a :: Type+ toGenList :: Proxy a -> TypeLevelGenList' a++instance Arbitrary a => TypeLevelGenList (Gen a) where+ type TypeLevelGenList' (Gen a) = Gen a+ toGenList _ = arbitrary++instance (TypeLevelGenList a, TypeLevelGenList b) => TypeLevelGenList (a :+ b) where+ type TypeLevelGenList' (a :+ b) = TypeLevelGenList' a :+ TypeLevelGenList' b+ toGenList _ = toGenList (Proxy @a) :+ toGenList (Proxy @b)++-- |+-- @since 1.5.0.0+class TypeLevelOpts a where+ type TypeLevelOpts' a :: Type+ toOpts :: Proxy a -> TypeLevelOpts' a
− src/Generic/Random/Generic.hs
@@ -1,214 +0,0 @@--- | Simple 'GHC.Generics'-based 'arbitrary' generators.------ Here is an example. Define your type.------ @--- data Tree a = Leaf a | Node (Tree a) (Tree a)--- deriving Generic--- @------ Pick an 'arbitrary' implementation.------ @--- instance Arbitrary a => Arbitrary (Tree a) where--- arbitrary = 'genericArbitrary' ('weights' (9 '%' 8 '%' ()))--- @------ @arbitrary :: 'Gen' (Tree a)@ picks a @Leaf@ with probability 9\/17, or a--- @Node@ with probability 8\/17, and recursively fills their fields with--- @arbitrary@.------ == Distribution of constructors------ The distribution of constructors can be specified using 'weights' applied to--- a special list of /weights/ in the same order as the data type definition.--- This assigns to each constructor a probability proportional to its weight;--- in other words, @p_C = weight_C / sumOfWeights@.------ The list of weights is built up with the @('%')@ operator as a cons, and using--- the unit @()@ as the empty list, in the order corresponding to the data type--- definition.------ For @Tree@, 'genericArbitrary' produces code equivalent to the following:------ @--- 'genericArbitrary' :: Arbitrary a => 'Weights' (Tree a) -> Gen (Tree a)--- 'genericArbitrary' ('weighted' (x '%' y '%' ())) =--- frequency--- [ (x, Leaf \<$\> arbitrary)--- , (y, Node \<$\> arbitrary \<*\> arbitrary)--- ]--- @------ The weights actually have type @'W' \"ConstructorName\"@ (just a newtype--- around 'Int'), so that you can annotate a weight with its corresponding--- constructor, and it will be checked that you got the order right.------ This will type-check.------ @--- 'weighted' ((x :: 'W' \"Leaf\") '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a)--- 'weighted' (x '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a)--- @------ This will not: the first requires an order of constructors different from--- the definition of the @Tree@ type; the second doesn't have the right number--- of weights.------ @--- 'weighted' ((x :: 'W' \"Node\") '%' y '%' ()) :: 'Weights' (Tree a)--- 'weighted' (x '%' y '%' z '%' ()) :: 'Weights' (Tree a)--- @------ === Uniform distribution------ You can specify the uniform distribution with 'uniform'.------ For @Tree@, @'genericArbitrary' 'uniform'@ produces code equivalent to the--- following:------ @--- 'genericArbitrary' 'uniform' :: Arbitrary a => Gen (Tree a)--- 'genericArbitrary' 'uniform' =--- oneof--- [ Leaf \<$\> arbitrary -- Uses Arbitrary a--- , Node \<$\> arbitrary \<*\> arbitrary -- Uses Arbitrary (Tree a)--- ]--- @------ Note that for many types, a uniform distribution tends to produce big--- values. For instance for @Tree a@, generated values are finite but the--- __average__ number of @Leaf@ and @Node@ constructors is __infinite__.------ == Ensuring termination------ As was just mentioned, one must be careful with recursive types--- to avoid producing extremely large values.------ The alternative 'genericArbitrary'' implements a simple strategy to keep--- values at reasonable sizes: the size parameter of 'Gen' is divided among the--- fields of the chosen constructor. When it reaches zero, the generator--- selects a finite term whenever it can find any of the given type. This--- generally ensures that the number of constructors remains close to the--- initial size parameter passed to 'Gen'.------ A natural number @n@ determines the maximum /depth/ of terms that can be--- used to end recursion.--- It is encoded using @'Z' :: 'Z'@ and @'S' :: n -> 'S' n@.------ @--- 'genericArbitrary'' n ('weights' (...))--- @------ With @n = 'Z'@, the generator looks for a simple nullary constructor. If none--- exist at the current type, as is the case for our @Tree@ type, it carries on--- as in 'genericArbitrary'.------ @--- 'genericArbitrary'' 'Z' :: Arbitrary a => 'Weights' (Tree a) -> Gen (Tree a)--- 'genericArbitrary'' 'Z' ('weights' (x '%' y '%' ())) =--- frequency--- [ (x, Leaf \<$\> arbitrary)--- , (y, scale (\`div\` 2) $ Node \<$\> arbitrary \<*\> arbitrary)--- -- 2 because Node is 2-ary.--- ]--- @------ Here is another example with nullary constructors:------ @--- data Tree' = Leaf1 | Leaf2 | Node3 Tree' Tree' Tree'--- deriving Generic------ instance Arbitrary Tree' where--- arbitrary = 'genericArbitrary'' 'Z' ('weights' (1 '%' 2 '%' 3 '%' ()))--- @------ Here, @'genericArbitrary'' 'Z'@ is equivalent to:------ @--- 'genericArbitrary'' 'Z' :: 'Weights' Tree' -> Gen Tree'--- 'genericArbitrary'' 'Z' ('weights' (x '%' y '%' z '%' ())) =--- sized $ \n ->--- if n == 0 then--- -- If the size parameter is zero, the non-nullary alternative is discarded.--- frequency $--- [ (x, return Leaf1)--- , (y, return Leaf2)--- ]--- else--- frequency $--- [ (x, return Leaf1)--- , (y, return Leaf2)--- , (z, resize (n \`div\` 3) node) -- 3 because Node3 is 3-ary--- ]--- where--- node = Node3 \<$\> arbitrary \<*\> arbitrary \<*\> arbitrary--- @------ To increase the chances of termination when no nullary constructor is directly--- available, such as in @Tree@, we can pass a larger depth @n@. The effectiveness--- of this parameter depends on the concrete type the generator is used for.------ For instance, if we want to generate a value of type @Tree ()@, there is a--- value of depth 1 (represented by @'S' 'Z'@) that we can use to end--- recursion: @Leaf ()@.------ @--- 'genericArbitrary'' ('S' 'Z') :: 'Weights' (Tree ()) -> Gen (Tree ())--- 'genericArbitrary'' ('S' 'Z') ('weights' (x '%' y '%' ())) =--- sized $ \n ->--- if n == 0 then--- return (Leaf ())--- else--- frequency--- [ (x, Leaf \<$\> arbitrary)--- , (y, scale (\`div\` 2) $ Node \<$\> arbitrary \<*\> arbitrary)--- ]--- @------ Because the argument of @Tree@ must be inspected in order to discover--- values of type @Tree ()@, we incur some extra constraints if we want--- polymorphism.------ @UndecidableInstances@ is also required.------ @--- instance (Arbitrary a, Generic a, 'ListBaseCases' 'Z' (Rep a))--- => Arbitrary (Tree a) where--- arbitrary = 'genericArbitrary'' ('S' 'Z') ('weights' (1 '%' 2 '%' ()))--- @------ A synonym is provided for brevity.------ @--- instance (Arbitrary a, 'BaseCases'' Z a) => Arbitrary (Tree a) where--- arbitrary = 'genericArbitrary'' ('S' 'Z') ('weights' (1 '%' 2 '%' ()))--- @---module Generic.Random.Generic- (- -- * Arbitrary implementations- genericArbitrary- , genericArbitrary'-- -- * Specifying finite distributions- , Weights- , W- , weights- , (%)- , uniform-- -- * Type-level natural numbers- -- $nat- , Z (..)- , S (..)-- -- * Generic classes for finite values- , BaseCases'- , BaseCases- , ListBaseCases- ) where--import Generic.Random.Internal.Generic
+ src/Generic/Random/Internal/BaseCase.hs view
@@ -0,0 +1,321 @@+{-# OPTIONS_HADDOCK not-home #-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Base case discovery.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.++module Generic.Random.Internal.BaseCase where++import Control.Applicative+import Data.Proxy+import Data.Kind (Type)+import GHC.Generics+import GHC.TypeLits+import Test.QuickCheck++import Generic.Random.Internal.Generic++-- | Decrease size to ensure termination for+-- recursive types, looking for base cases once the size reaches 0.+--+-- > genericArbitrary' (17 % 19 % 23 % ()) :: Gen a+--+-- N.B.: This replaces the generator for fields of type @[t]@ with+-- @'Test.QuickCheck.listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for+-- lists).+genericArbitrary'+ :: (GArbitrary SizedOptsDef a, BaseCase a)+ => Weights a -- ^ List of weights for every constructor+ -> Gen a+genericArbitrary' w = genericArbitraryRec w `withBaseCase` baseCase++-- | Equivalent to @'genericArbitrary'' 'uniform'@.+--+-- > genericArbitraryU' :: Gen a+--+-- N.B.: This replaces the generator for fields of type @[t]@ with+-- @'Test.QuickCheck.listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for+-- lists).+genericArbitraryU'+ :: (GArbitrary SizedOptsDef a, BaseCase a, GUniformWeight a)+ => Gen a+genericArbitraryU' = genericArbitrary' uniform++-- | Run the first generator if the size is positive.+-- Run the second if the size is zero.+--+-- > defaultGen `withBaseCase` baseCaseGen+withBaseCase :: Gen a -> Gen a -> Gen a+withBaseCase def bc = sized $ \sz ->+ if sz > 0 then def else bc+++-- | Find a base case of type @a@ with maximum depth @z@,+-- recursively using 'BaseCaseSearch' instances to search deeper levels.+--+-- @y@ is the depth of a base case, if found.+--+-- @e@ is the original type the search started with, that @a@ appears in.+-- It is used for error reporting.+class BaseCaseSearch (a :: Type) (z :: Nat) (y :: Maybe Nat) (e :: Type) where+ baseCaseSearch :: prox y -> proxy '(z, e) -> IfM y Gen Proxy a+++instance {-# OVERLAPPABLE #-} GBaseCaseSearch a z y e => BaseCaseSearch a z y e where+ baseCaseSearch = gBaseCaseSearch+++instance (y ~ 'Just 0) => BaseCaseSearch Char z y e where+ baseCaseSearch _ _ = arbitrary++instance (y ~ 'Just 0) => BaseCaseSearch Int z y e where+ baseCaseSearch _ _ = arbitrary++instance (y ~ 'Just 0) => BaseCaseSearch Integer z y e where+ baseCaseSearch _ _ = arbitrary++instance (y ~ 'Just 0) => BaseCaseSearch Float z y e where+ baseCaseSearch _ _ = arbitrary++instance (y ~ 'Just 0) => BaseCaseSearch Double z y e where+ baseCaseSearch _ _ = arbitrary++instance (y ~ 'Just 0) => BaseCaseSearch Word z y e where+ baseCaseSearch _ _ = arbitrary++instance (y ~ 'Just 0) => BaseCaseSearch () z y e where+ baseCaseSearch _ _ = arbitrary++instance (y ~ 'Just 0) => BaseCaseSearch Bool z y e where+ baseCaseSearch _ _ = arbitrary++instance (y ~ 'Just 0) => BaseCaseSearch [a] z y e where+ baseCaseSearch _ _ = return []++instance (y ~ 'Just 0) => BaseCaseSearch Ordering z y e where+ baseCaseSearch _ _ = arbitrary++-- Either and (,) use Generics+++class BaseCaseSearching_ a z y where+ baseCaseSearching_ :: proxy y -> proxy2 '(z, a) -> IfM y Gen Proxy a -> Gen a++instance BaseCaseSearching_ a z ('Just m) where+ baseCaseSearching_ _ _ = id++instance BaseCaseSearching a (z + 1) => BaseCaseSearching_ a z 'Nothing where+ baseCaseSearching_ _ _ _ = baseCaseSearching (Proxy :: Proxy '(z + 1, a))++-- | Progressively increase the depth bound for 'BaseCaseSearch'.+class BaseCaseSearching a z where+ baseCaseSearching :: proxy '(z, a) -> Gen a++instance (BaseCaseSearch a z y a, BaseCaseSearching_ a z y) => BaseCaseSearching a z where+ baseCaseSearching z = baseCaseSearching_ y z (baseCaseSearch y z)+ where+ y = Proxy :: Proxy y++-- | Custom instances can override the default behavior.+class BaseCase a where+ -- | Generator of base cases.+ baseCase :: Gen a++-- | Overlappable+instance {-# OVERLAPPABLE #-} BaseCaseSearching a 0 => BaseCase a where+ baseCase = baseCaseSearching (Proxy :: Proxy '(0, a))+++type family IfM (b :: Maybe t) (c :: k) (d :: k) :: k+type instance IfM ('Just t) c d = c+type instance IfM 'Nothing c d = d++type (==) m n = IsEQ (CmpNat m n)++type family IsEQ (e :: Ordering) :: Bool+type instance IsEQ 'EQ = 'True+type instance IsEQ 'GT = 'False+type instance IsEQ 'LT = 'False++type family (||?) (b :: Maybe Nat) (c :: Maybe Nat) :: Maybe Nat+type instance 'Just m ||? 'Just n = 'Just (Min m n)+type instance m ||? 'Nothing = m+type instance 'Nothing ||? n = n++type family (&&?) (b :: Maybe Nat) (c :: Maybe Nat) :: Maybe Nat+type instance 'Just m &&? 'Just n = 'Just (Max m n)+type instance m &&? 'Nothing = 'Nothing+type instance 'Nothing &&? n = 'Nothing++type Max m n = MaxOf (CmpNat m n) m n++type family MaxOf (e :: Ordering) (m :: k) (n :: k) :: k+type instance MaxOf 'GT m n = m+type instance MaxOf 'EQ m n = m+type instance MaxOf 'LT m n = n++type Min m n = MinOf (CmpNat m n) m n++type family MinOf (e :: Ordering) (m :: k) (n :: k) :: k+type instance MinOf 'GT m n = n+type instance MinOf 'EQ m n = n+type instance MinOf 'LT m n = m++class Alternative (IfM y Weighted Proxy)+ => GBCS (f :: k -> Type) (z :: Nat) (y :: Maybe Nat) (e :: Type) where+ gbcs :: prox y -> proxy '(z, e) -> IfM y Weighted Proxy (f p)++instance GBCS f z y e => GBCS (M1 i c f) z y e where+ gbcs y z = fmap M1 (gbcs y z)++instance+ ( Alternative (IfM y Weighted Proxy) -- logically redundant, but GHC isn't clever+ -- enough to deduce; see #32+ , GBCSSum f g z e yf yg+ , GBCS f z yf e+ , GBCS g z yg e+ , y ~ (yf ||? yg)+ ) => GBCS (f :+: g) z y e where+ gbcs _ z = gbcsSum (Proxy :: Proxy '(yf, yg)) z+ (gbcs (Proxy :: Proxy yf) z)+ (gbcs (Proxy :: Proxy yg) z)++class Alternative (IfM (yf ||? yg) Weighted Proxy) => GBCSSum f g z e yf yg where+ gbcsSum+ :: prox '(yf, yg)+ -> proxy '(z, e)+ -> IfM yf Weighted Proxy (f p)+ -> IfM yg Weighted Proxy (g p)+ -> IfM (yf ||? yg) Weighted Proxy ((f :+: g) p)++instance GBCSSum f g z e 'Nothing 'Nothing where+ gbcsSum _ _ _ _ = Proxy++instance GBCSSum f g z e ('Just m) 'Nothing where+ gbcsSum _ _ f _ = fmap L1 f++instance GBCSSum f g z e 'Nothing ('Just n) where+ gbcsSum _ _ _ g = fmap R1 g++instance GBCSSumCompare f g z e (CmpNat m n)+ => GBCSSum f g z e ('Just m) ('Just n) where+ gbcsSum _ = gbcsSumCompare (Proxy :: Proxy (CmpNat m n))++class GBCSSumCompare f g z e o where+ gbcsSumCompare+ :: proxy0 o+ -> proxy '(z, e)+ -> Weighted (f p)+ -> Weighted (g p)+ -> Weighted ((f :+: g) p)++instance GBCSSumCompare f g z e 'EQ where+ gbcsSumCompare _ _ f g = fmap L1 f <|> fmap R1 g++instance GBCSSumCompare f g z e 'LT where+ gbcsSumCompare _ _ f _ = fmap L1 f++instance GBCSSumCompare f g z e 'GT where+ gbcsSumCompare _ _ _ g = fmap R1 g++instance+ ( Alternative (IfM y Weighted Proxy) -- logically redundant, but GHC isn't clever+ -- enough to deduce; see #32+ , GBCSProduct f g z e yf yg+ , GBCS f z yf e+ , GBCS g z yg e+ , y ~ (yf &&? yg)+ ) => GBCS (f :*: g) z y e where+ gbcs _ z = gbcsProduct (Proxy :: Proxy '(yf, yg)) z+ (gbcs (Proxy :: Proxy yf) z)+ (gbcs (Proxy :: Proxy yg) z)++class Alternative (IfM (yf &&? yg) Weighted Proxy) => GBCSProduct f g z e yf yg where+ gbcsProduct+ :: prox '(yf, yg)+ -> proxy '(z, e)+ -> IfM yf Weighted Proxy (f p)+ -> IfM yg Weighted Proxy (g p)+ -> IfM (yf &&? yg) Weighted Proxy ((f :*: g) p)++instance {-# OVERLAPPABLE #-} ((yf &&? yg) ~ 'Nothing) => GBCSProduct f g z e yf yg where+ gbcsProduct _ _ _ _ = Proxy++instance GBCSProduct f g z e ('Just m) ('Just n) where+ gbcsProduct _ _ f g = liftA2 (:*:) f g++class IsMaybe b where+ ifMmap :: proxy b -> (c a -> c' a') -> (d a -> d' a') -> IfM b c d a -> IfM b c' d' a'+ ifM :: proxy b -> c a -> d a -> IfM b c d a++instance IsMaybe ('Just t) where+ ifMmap _ f _ a = f a+ ifM _ f _ = f++instance IsMaybe 'Nothing where+ ifMmap _ _ g a = g a+ ifM _ _ g = g++instance {-# OVERLAPPABLE #-}+ ( BaseCaseSearch c (z - 1) y e+ , (z == 0) ~ 'False+ , Alternative (IfM y Weighted Proxy)+ , IsMaybe y+ ) => GBCS (K1 i c) z y e where+ gbcs y _ =+ fmap K1+ (ifMmap y+ liftGen+ (id :: Proxy c -> Proxy c)+ (baseCaseSearch y (Proxy :: Proxy '(z - 1, e))))++instance (y ~ 'Nothing) => GBCS (K1 i c) 0 y e where+ gbcs _ _ = empty++instance (y ~ 'Just 0) => GBCS U1 z y e where+ gbcs _ _ = pure U1++instance {-# INCOHERENT #-}+ ( TypeError+ ( 'Text "Unrecognized Rep: "+ ':<>: 'ShowType f+ ':$$: 'Text "Possible causes:"+ ':$$: 'Text " Missing ("+ ':<>: 'ShowType (BaseCase e)+ ':<>: 'Text ") constraint"+ ':$$: 'Text " Missing Generic instance"+ )+ , Alternative (IfM y Weighted Proxy)+ ) => GBCS f z y e where+ gbcs = error "Type error"++class GBaseCaseSearch a z y e where+ gBaseCaseSearch :: prox y -> proxy '(z, e) -> IfM y Gen Proxy a++instance (Generic a, GBCS (Rep a) z y e, IsMaybe y)+ => GBaseCaseSearch a z y e where+ gBaseCaseSearch y z = ifMmap y+ (\(Weighted gn) -> case gn of+ Just (g, n) -> choose (0, n-1) >>= fmap to . g+ Nothing -> error "How could this happen?")+ (\Proxy -> Proxy)+ (gbcs y z)
src/Generic/Random/Internal/Generic.hs view
@@ -1,51 +1,159 @@-{-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_HADDOCK not-home #-}++{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- | Core implementation.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.+ module Generic.Random.Internal.Generic where -import Control.Applicative-import Data.Coerce-import GHC.Exts (Proxy#, proxy#)-import GHC.Generics hiding ( S )-import GHC.TypeLits-import Test.QuickCheck+import Control.Applicative (Alternative(..), liftA2)+import Data.Coerce (Coercible, coerce)+import Data.Kind (Type) +import Data.Proxy (Proxy(..))+import Data.Type.Bool (type (&&))+import Data.Type.Equality (type (==))++import GHC.Generics hiding (S, prec)+import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), natVal)+import Test.QuickCheck (Arbitrary(..), Gen, choose, scale, sized, vectorOf)+ -- * Random generators -- | Pick a constructor with a given distribution, and fill its fields--- recursively.+-- with recursive calls to 'arbitrary'.+--+-- === Example+--+-- > genericArbitrary (2 % 3 % 5 % ()) :: Gen a+--+-- Picks the first constructor with probability @2/10@,+-- the second with probability @3/10@, the third with probability @5/10@. genericArbitrary- :: forall a- . (Generic a, GA Unsized (Rep a))- => Weights a+ :: (GArbitrary UnsizedOpts a)+ => Weights a -- ^ List of weights for every constructor -> Gen a-genericArbitrary (Weights w n) = (unGen' . fmap to) (ga w n :: Gen' Unsized (Rep a p))+genericArbitrary = genericArbitraryWith unsizedOpts --- | Like 'genericArbitrary'', with bounded size to ensure termination for--- recursive types.-genericArbitrary'- :: forall n a- . (Generic a, GA (Sized n) (Rep a))- => n+-- | Pick every constructor with equal probability.+-- Equivalent to @'genericArbitrary' 'uniform'@.+--+-- > genericArbitraryU :: Gen a+genericArbitraryU+ :: (GArbitrary UnsizedOpts a, GUniformWeight a)+ => Gen a+genericArbitraryU = genericArbitrary uniform++-- | 'arbitrary' for types with one constructor.+-- Equivalent to 'genericArbitraryU', with a stricter type.+--+-- > genericArbitrarySingle :: Gen a+genericArbitrarySingle+ :: (GArbitrary UnsizedOpts a, Weights_ (Rep a) ~ L c0)+ => Gen a+genericArbitrarySingle = genericArbitraryU++-- | Decrease size at every recursive call, but don't do anything different+-- at size 0.+--+-- > genericArbitraryRec (7 % 11 % 13 % ()) :: Gen a+--+-- N.B.: This replaces the generator for fields of type @[t]@ with+-- @'listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for+-- lists).+genericArbitraryRec+ :: (GArbitrary SizedOptsDef a)+ => Weights a -- ^ List of weights for every constructor+ -> Gen a+genericArbitraryRec = genericArbitraryWith sizedOptsDef++-- | 'genericArbitrary' with explicit generators.+--+-- === Example+--+-- > genericArbitraryG customGens (17 % 19 % ())+--+-- where, the generators for 'String' and 'Int' fields are overridden as+-- follows, for example:+--+-- @+-- customGens :: Gen String ':+' Gen Int+-- customGens =+-- (filter (/= '\NUL') '<$>' arbitrary) ':+'+-- (getNonNegative '<$>' arbitrary)+-- @+--+-- === Note on multiple matches+--+-- Multiple generators may match a given field: the first will be chosen.+genericArbitraryG+ :: (GArbitrary (SetGens genList UnsizedOpts) a)+ => genList+ -> Weights a+ -> Gen a+genericArbitraryG gs = genericArbitraryWith opts+ where+ opts = setGenerators gs unsizedOpts++-- | 'genericArbitraryU' with explicit generators.+-- See also 'genericArbitraryG'.+genericArbitraryUG+ :: (GArbitrary (SetGens genList UnsizedOpts) a, GUniformWeight a)+ => genList+ -> Gen a+genericArbitraryUG gs = genericArbitraryG gs uniform++-- | 'genericArbitrarySingle' with explicit generators.+-- See also 'genericArbitraryG'.+genericArbitrarySingleG+ :: (GArbitrary (SetGens genList UnsizedOpts) a, Weights_ (Rep a) ~ L c0)+ => genList+ -> Gen a+genericArbitrarySingleG = genericArbitraryUG++-- | 'genericArbitraryRec' with explicit generators.+-- See also 'genericArbitraryG'.+genericArbitraryRecG+ :: (GArbitrary (SetGens genList SizedOpts) a)+ => genList -> Weights a -- ^ List of weights for every constructor -> Gen a-genericArbitrary' _ (Weights w n) =- (unGen' . fmap to) (ga w n :: Gen' (Sized n) (Rep a p))+genericArbitraryRecG gs = genericArbitraryWith opts+ where+ opts = setGenerators gs sizedOpts +-- | General generic generator with custom options.+genericArbitraryWith+ :: (GArbitrary opts a)+ => opts -> Weights a -> Gen a+genericArbitraryWith opts (Weights w n) =+ fmap to (ga opts w n) -- * Internal -type family Weights_ (f :: * -> *) :: * where+type family Weights_ (f :: Type -> Type) :: Type where Weights_ (f :+: g) = Weights_ f :| Weights_ g Weights_ (M1 D _c f) = Weights_ f Weights_ (M1 C ('MetaCons c _i _j) _f) = L c@@ -59,14 +167,14 @@ -- Two ways of constructing them. -- -- @--- 'weights' (x1 '%' x2 '%' ... '%' xn '%' ()) :: 'Weights' a+-- (x1 '%' x2 '%' ... '%' xn '%' ()) :: 'Weights' a -- 'uniform' :: 'Weights' a -- @ ----- Using @weights@, there must be exactly as many weights as+-- Using @('%')@, there must be exactly as many weights as -- there are constructors. ----- 'uniform' is equivalent to @'weights' (1 '%' ... '%' 1 '%' ())@+-- 'uniform' is equivalent to @(1 '%' ... '%' 1 '%' ())@ -- (automatically fills out the right number of 1s). data Weights a = Weights (Weights_ (Rep a)) Int @@ -74,16 +182,18 @@ -- constructor for additional compile-time checking. -- -- @--- 'weights' ((9 :: 'W' \"Leaf\") '%' (8 :: 'W' \"Node\") '%' ())+-- ((9 :: 'W' \"Leaf\") '%' (8 :: 'W' \"Node\") '%' ()) -- @ newtype W (c :: Symbol) = W Int deriving Num -- | A smart constructor to specify a custom distribution.+-- It can be omitted for the '%' operator is overloaded to+-- insert it. weights :: (Weights_ (Rep a), Int, ()) -> Weights a weights (w, n, ()) = Weights w n -- | Uniform distribution.-uniform :: UniformWeight (Weights_ (Rep a)) => Weights a+uniform :: UniformWeight_ (Rep a) => Weights a uniform = let (w, n) = uniformWeight in Weights w n@@ -92,24 +202,46 @@ First (a :| _b) = First a First (L c) = c +type family First' w where+ First' (Weights a) = First (Weights_ (Rep a))+ First' (a, Int, r) = First a++type family Prec' w where+ Prec' (Weights a) = Prec (Weights_ (Rep a)) ()+ Prec' (a, Int, r) = Prec a r++class WeightBuilder' w where++ -- | A binary constructor for building up trees of weights.+ (%) :: (c ~ First' w) => W c -> Prec' w -> w++instance WeightBuilder (Weights_ (Rep a)) => WeightBuilder' (Weights a) where+ w % prec = weights (w %. prec)++instance WeightBuilder a => WeightBuilder' (a, Int, r) where+ (%) = (%.)+ class WeightBuilder a where type Prec a r - -- | A binary constructor for building up trees of weights.- (%) :: W (First a) -> Prec a r -> (a, Int, r)+ (%.) :: (c ~ First a) => W c -> Prec a r -> (a, Int, r) infixr 1 % instance WeightBuilder a => WeightBuilder (a :| b) where type Prec (a :| b) r = Prec a (b, Int, r)- m % prec =+ m %. prec = let (a, n, (b, p, r)) = m % prec in (N a n b, n + p, r) instance WeightBuilder (L c) where type Prec (L c) r = r- W m % prec = (L, m, prec)+ W m %. prec = (L, m, prec) +instance WeightBuilder () where+ type Prec () r = r+ W m %. prec = ((), m, prec)+ class UniformWeight a where uniformWeight :: (a, Int) @@ -124,96 +256,510 @@ instance UniformWeight (L c) where uniformWeight = (L, 1) -newtype Gen' sized a = Gen' { unGen' :: Gen a }- deriving (Functor, Applicative, Monad)+instance UniformWeight () where+ uniformWeight = ((), 1) -data Sized n-data Unsized+class UniformWeight (Weights_ f) => UniformWeight_ f+instance UniformWeight (Weights_ f) => UniformWeight_ f -sized' :: (Int -> Gen' sized a) -> Gen' sized a-sized' g = Gen' . sized $ \sz -> unGen' (g sz)+-- | Derived uniform distribution of constructors for @a@.+class UniformWeight_ (Rep a) => GUniformWeight a+instance UniformWeight_ (Rep a) => GUniformWeight a --- | Generic Arbitrary-class GA sized f where- ga :: Weights_ f -> Int -> Gen' sized (f p) -instance GA sized f => GA sized (M1 D c f) where- ga w n = fmap M1 (ga w n)+-- | Type-level options for 'GArbitrary'.+--+-- Note: it is recommended to avoid referring to the 'Options' type+-- explicitly in code, as the set of options may change in the future.+-- Instead, use the provided synonyms ('UnsizedOpts', 'SizedOpts', 'SizedOptsDef')+-- and the setter 'SetOptions' (abbreviated as @('<+')@).+newtype Options (c :: Coherence) (s :: Sizing) (genList :: Type) = Options+ { _generators :: genList+ } -instance GAProduct f => GA Unsized (M1 C c f) where- ga _ _ = (Gen' . fmap M1) gaProduct+-- | Setter for 'Options'.+--+-- This subsumes the other setters: 'SetSized', 'SetUnsized', 'SetGens'.+--+-- @since 1.4.0.0+type family SetOptions (x :: k) (o :: Type) :: Type+type instance SetOptions (s :: Sizing) (Options c _s g) = Options c s g+type instance SetOptions (c :: Coherence) (Options _c s g) = Options c s g+type instance SetOptions (g :: Type) (Options c s _g) = Options c s g -instance (GAProduct f, KnownNat (Arity f)) => GA (Sized n) (M1 C c f) where- ga _ _ = Gen' (scale (`div` arity) gaProduct)- where- arity = fromInteger (natVal' (proxy# :: Proxy# (Arity f)))+-- | Infix flipped synonym for 'Options'.+--+-- @since 1.4.0.0+type (<+) o x = SetOptions x o+infixl 1 <+ -instance (GASum (Sized n) f, GASum (Sized n) g, BaseCases n f, BaseCases n g)- => GA (Sized n) (f :+: g) where- ga w n = sized' $ \sz ->- case unTagged (baseCases w n :: Tagged n (Weighted ((f :+: g) p))) of- Weighted (Just (bc, n)) | sz == 0 -> Gen' (choose (0, n - 1) >>= bc)- _ -> gaSum' w n -instance (GASum Unsized f, GASum Unsized g) => GA Unsized (f :+: g) where+type UnsizedOpts = Options 'INCOHERENT 'Unsized ()+type SizedOpts = Options 'INCOHERENT 'Sized ()+type SizedOptsDef = Options 'INCOHERENT 'Sized (Gen1 [] :+ ())++-- | Like 'UnsizedOpts', but using coherent instances by default.+--+-- @since 1.4.0.0+type CohUnsizedOpts = Options 'COHERENT 'Unsized ()++-- | Like 'SizedOpts', but using coherent instances by default.+--+-- @since 1.4.0.0+type CohSizedOpts = Options 'COHERENT 'Sized ()++-- | Coerce an 'Options' value between types with the same representation.+--+-- @since 1.4.0.0+setOpts :: forall x o. (Coercible o (SetOptions x o)) => o -> SetOptions x o+setOpts = coerce++-- | Default options for unsized generators.+unsizedOpts :: UnsizedOpts+unsizedOpts = Options ()++-- | Default options for sized generators.+sizedOpts :: SizedOpts+sizedOpts = Options ()++-- | Default options overriding the list generator using 'listOf''.+sizedOptsDef :: SizedOptsDef+sizedOptsDef = Options (Gen1 listOf' :+ ())++-- | Like 'unsizedOpts', but using coherent instances by default.+cohUnsizedOpts :: CohUnsizedOpts+cohUnsizedOpts = Options ()++-- | Like 'sizedOpts' but using coherent instances by default.+cohSizedOpts :: CohSizedOpts+cohSizedOpts = Options ()+++-- | Whether to decrease the size parameter before generating fields.+--+-- The 'Sized' option makes the size parameter decrease in the following way:+-- - Constructors with one field decrease the size parameter by 1 to generate+-- that field.+-- - Constructors with more than one field split the size parameter among all+-- fields; the size parameter is rounded down to then be divided equally.+data Sizing+ = Sized -- ^ Decrease the size parameter when running generators for fields+ | Unsized -- ^ Don't touch the size parameter++type family SizingOf opts :: Sizing+type instance SizingOf (Options _c s _g) = s++type family SetSized (o :: Type) :: Type+type instance SetSized (Options c s g) = Options c 'Sized g++type family SetUnsized (o :: Type) :: Type+type instance SetUnsized (Options c s g) = Options c 'Unsized g++setSized :: Options c s g -> Options c 'Sized g+setSized = coerce++setUnsized :: Options c s g -> Options c 'Unsized g+setUnsized = coerce+++-- | For custom generators to work with parameterized types, incoherent+-- instances must be used internally.+-- In practice, the resulting behavior is what users want 100% of the time,+-- so you should forget this option even exists.+--+-- === __Details__+--+-- The default configuration of generic-random does a decent job if+-- we trust GHC implements precisely the instance resolution algorithm as+-- described in the GHC manual:+--+-- - https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#overlapping-instances+--+-- While that assumption holds in practice, it is overly context-dependent+-- (to know the context leading to a particular choice, we must replay the+-- whole resolution algorithm).+-- In particular, this algorithm may find one solution, but it is not+-- guaranteed to be unique: the behavior of the program is dependent on+-- implementation details.+--+-- An notable property to consider of an implicit type system (such as type+-- classes) is coherence: the behavior of the program is stable under+-- specialization.+--+-- This sounds nice on paper, but actually leads to surprising behavior for+-- generic implementations with parameterized types, such as generic-random.+--+-- To address that, the coherence property can be relaxd by users, by+-- explicitly allowing some custom generators to be chosen incoherently. With+-- appropriate precautions, it is possible to ensure a weaker property which+-- nevertheless helps keep type inference predictable: when a solution is+-- found, it is unique.+-- (This is assuredly weaker, i.e., is not stable under specialization.)+--+-- @since 1.4.0.0+data Coherence+ = INCOHERENT -- ^ Match custom generators incoherently.+ | COHERENT+ -- ^ Match custom generators coherently by default+ -- (can be manually bypassed with 'Incoherent').++type family CoherenceOf (o :: Type) :: Coherence+type instance CoherenceOf (Options c _s _g) = c++-- | Match this generator incoherently when the 'COHERENT' option is set.+newtype Incoherent g = Incoherent g+++-- | Heterogeneous list of generators.+data a :+ b = a :+ b++infixr 1 :++++type family GeneratorsOf opts :: Type+type instance GeneratorsOf (Options _c _s g) = g++class HasGenerators opts where+ generators :: opts -> GeneratorsOf opts++instance HasGenerators (Options c s g) where+ generators = _generators++-- | Define the set of custom generators.+--+-- Note: for recursive types which can recursively appear inside lists or other+-- containers, you may want to include a custom generator to decrease the size+-- when generating such containers.+--+-- See also the Note about lists in "Generic.Random.Tutorial#notelists".+setGenerators :: genList -> Options c s g0 -> Options c s genList+setGenerators gens (Options _) = Options gens++type family SetGens (g :: Type) opts+type instance SetGens g (Options c s _g) = Options c s g+++-- | Custom generator for record fields named @s@.+--+-- If there is a field named @s@ with a different type,+-- this will result in a type error.+newtype FieldGen (s :: Symbol) a = FieldGen { unFieldGen :: Gen a }++-- | 'FieldGen' constructor with the field name given via a proxy.+fieldGen :: proxy s -> Gen a -> FieldGen s a+fieldGen _ = FieldGen++-- | Custom generator for the @i@-th field of the constructor named @c@.+-- Fields are 0-indexed.+newtype ConstrGen (c :: Symbol) (i :: Nat) a = ConstrGen { unConstrGen :: Gen a }++-- | 'ConstrGen' constructor with the constructor name given via a proxy.+constrGen :: proxy '(c, i) -> Gen a -> ConstrGen c i a+constrGen _ = ConstrGen++-- | Custom generators for \"containers\" of kind @Type -> Type@, parameterized+-- by the generator for \"contained elements\".+--+-- A custom generator @'Gen1' f@ will be used for any field whose type has the+-- form @f x@, requiring a generator of @x@. The generator for @x@ will be+-- constructed using the list of custom generators if possible, otherwise+-- an instance @Arbitrary x@ will be required.+newtype Gen1 f = Gen1 { unGen1 :: forall a. Gen a -> Gen (f a) }++-- | Custom generators for unary type constructors that are not \"containers\",+-- i.e., which don't require a generator of @a@ to generate an @f a@.+--+-- A custom generator @'Gen1_' f@ will be used for any field whose type has the+-- form @f x@.+newtype Gen1_ f = Gen1_ { unGen1_ :: forall a. Gen (f a) }+++-- | An alternative to 'vectorOf' that divides the size parameter by the+-- length of the list.+vectorOf' :: Int -> Gen a -> Gen [a]+vectorOf' 0 = \_ -> pure []+vectorOf' i = scale (`div` i) . vectorOf i++-- | An alternative to 'Test.QuickCheck.listOf' that divides the size parameter+-- by the length of the list.+-- The length follows a geometric distribution of parameter+-- @1/(sqrt size + 1)@.+listOf' :: Gen a -> Gen [a]+listOf' g = sized $ \n -> do+ i <- geom n+ vectorOf' i g++-- | An alternative to 'Test.QuickCheck.listOf1' (nonempty lists) that divides+-- the size parameter by the length of the list.+-- The length (minus one) follows a geometric distribution of parameter+-- @1/(sqrt size + 1)@.+listOf1' :: Gen a -> Gen [a]+listOf1' g = liftA2 (:) g (listOf' g)++-- | Geometric distribution of parameter @1/(sqrt n + 1)@ (@n >= 0@).+geom :: Int -> Gen Int+geom 0 = pure 0+geom n = go 0 where+ n' = fromIntegral n+ p = 1 / (sqrt n' + 1) :: Double+ go r = do+ x <- choose (0, 1)+ if x < p then+ pure r+ else+ go $! (r + 1)++---++-- | Generic Arbitrary+class GA opts f where+ ga :: opts -> Weights_ f -> Int -> Gen (f p)++-- | Generic Arbitrary+class (Generic a, GA opts (Rep a)) => GArbitrary opts a+instance (Generic a, GA opts (Rep a)) => GArbitrary opts a++instance GA opts f => GA opts (M1 D c f) where+ ga z w n = fmap M1 (ga z w n)+ {-# INLINE ga #-}++instance (GASum opts f, GASum opts g) => GA opts (f :+: g) where ga = gaSum'+ {-# INLINE ga #-} -gArbitrarySingle- :: forall sized f p c0- . (GA sized f, Weights_ f ~ L c0)- => Gen' sized (f p)-gArbitrarySingle = ga L 0+instance GAProduct (SizingOf opts) (Name c) opts f => GA opts (M1 C c f) where+ ga z _ _ = fmap M1 (gaProduct (Proxy :: Proxy '(SizingOf opts, Name c)) z)+ {-# INLINE ga #-} -gaSum' :: GASum sized f => Weights_ f -> Int -> Gen' sized (f p)-gaSum' w n = do- i <- Gen' $ choose (0, n-1)- gaSum i w+gaSum' :: GASum opts f => opts -> Weights_ f -> Int -> Gen (f p)+gaSum' z w n = do+ i <- choose (0, n-1)+ gaSum z i w+{-# INLINE gaSum' #-} -class GASum sized f where- gaSum :: Int -> Weights_ f -> Gen' sized (f p)+class GASum opts f where+ gaSum :: opts -> Int -> Weights_ f -> Gen (f p) -instance (GASum sized f, GASum sized g) => GASum sized (f :+: g) where- gaSum i (N a n b)- | i < n = fmap L1 (gaSum i a)- | otherwise = fmap R1 (gaSum (i - n) b)+instance (GASum opts f, GASum opts g) => GASum opts (f :+: g) where+ gaSum z i (N a n b)+ | i < n = fmap L1 (gaSum z i a)+ | otherwise = fmap R1 (gaSum z (i - n) b)+ {-# INLINE gaSum #-} -instance GAProduct f => GASum sized (M1 i c f) where- gaSum _ _ = Gen' gaProduct+instance GAProduct (SizingOf opts) (Name c) opts f => GASum opts (M1 C c f) where+ gaSum z _ _ = fmap M1 (gaProduct (Proxy :: Proxy '(SizingOf opts, Name c)) z)+ {-# INLINE gaSum #-} -class GAProduct f where- gaProduct :: Gen (f p)+class GAProduct (s :: Sizing) (c :: Maybe Symbol) opts f where+ gaProduct :: proxys '(s, c) -> opts -> Gen (f p) -instance GAProduct U1 where- gaProduct = pure U1+instance GAProduct' c 0 opts f => GAProduct 'Unsized c opts f where+ gaProduct _ = gaProduct' (Proxy :: Proxy '(c, 0))+ {-# INLINE gaProduct #-} -instance Arbitrary c => GAProduct (K1 i c) where- gaProduct = fmap K1 arbitrary+-- Single-field constructors: decrease size by 1.+instance {-# OVERLAPPING #-} GAProduct' c 0 opts (S1 d f)+ => GAProduct 'Sized c opts (S1 d f) where+ gaProduct _ = scale (\n -> max 0 (n-1)) . gaProduct' (Proxy :: Proxy '(c, 0)) -instance GAProduct f => GAProduct (M1 i c f) where- gaProduct = fmap M1 gaProduct+instance (GAProduct' c 0 opts f, KnownNat (Arity f)) => GAProduct 'Sized c opts f where+ gaProduct _ = scale (`div` arity) . gaProduct' (Proxy :: Proxy '(c, 0))+ where+ arity = fromInteger (natVal (Proxy :: Proxy (Arity f)))+ {-# INLINE gaProduct #-} -instance (GAProduct f, GAProduct g) => GAProduct (f :*: g) where- gaProduct = liftA2 (:*:) gaProduct gaProduct+instance {-# OVERLAPPING #-} GAProduct 'Sized c opts U1 where+ gaProduct _ _ = pure U1+ {-# INLINE gaProduct #-} ++class GAProduct' (c :: Maybe Symbol) (i :: Nat) opts f where+ gaProduct' :: proxy '(c, i) -> opts -> Gen (f p)++instance GAProduct' c i opts U1 where+ gaProduct' _ _ = pure U1+ {-# INLINE gaProduct' #-}++instance+ ( HasGenerators opts+ , FindGen 'Shift ('S gs coh '(c, i, Name d)) () gs a+ , gs ~ GeneratorsOf opts+ , coh ~ CoherenceOf opts )+ => GAProduct' c i opts (S1 d (K1 _k a)) where+ gaProduct' _ opts = fmap (M1 . K1) (findGen (is, s, gs) () gs)+ where+ is = Proxy :: Proxy 'Shift+ s = Proxy :: Proxy ('S gs coh '(c, i, Name d))+ gs = generators opts+ {-# INLINE gaProduct' #-}++instance (GAProduct' c i opts f, GAProduct' c (i + Arity f) opts g) => GAProduct' c i opts (f :*: g) where+ -- TODO: Why does this inline better than eta-reducing? (GHC-8.2)+ gaProduct' px = (liftA2 . liftA2) (:*:)+ (gaProduct' px)+ (gaProduct' (Proxy :: Proxy '(c, i + Arity f)))+ {-# INLINE gaProduct' #-}++ type family Arity f :: Nat where Arity (f :*: g) = Arity f + Arity g Arity (M1 _i _c _f) = 1 +-- | Given a list of custom generators @g :+ gs@, find one that applies,+-- or use @Arbitrary a@ by default.+--+-- @g@ and @gs@ follow this little state machine:+--+-- > g, gs | result+-- > ---------------------+-----------------------------+-- > (), () | END+-- > (), g :+ gs | g, gs+-- > (), g | g, () when g is not (_ :+ _)+-- > g :+ h, gs | g, h :+ gs+-- > Gen a, gs | END if g matches, else ((), gs)+-- > FieldGen a, gs | idem+-- > ConstrGen a, gs | idem+-- > Gen1 a, gs | idem+-- > Gen1_ a, gs | idem+class FindGen (i :: AInstr) (s :: AStore) (g :: Type) (gs :: Type) (a :: Type) where+ findGen :: (Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a -newtype Tagged a b = Tagged { unTagged :: b }- deriving Functor+data AInstr = Shift | Match Coherence | MatchCoh Bool+data AStore = S Type Coherence ASel --- $nat--- Use the 'Z' and 'S' data types to define the depths of values used--- by 'genericArbitrary'' to make generators terminate.+type ASel = (Maybe Symbol, Nat, Maybe Symbol) --- | Zero-data Z = Z+iShift :: Proxy 'Shift+iShift = Proxy --- | Successor-data S n = S n+type family FullGenListOf (s :: AStore) :: Type where+ FullGenListOf ('S fg _coh _sel) = fg +type family ACoherenceOf (s :: AStore) :: Coherence where+ ACoherenceOf ('S _fg coh _sel) = coh++type family ASelOf (s :: AStore) :: ASel where+ ASelOf ('S _fg _coh sel) = sel++-- | All candidates have been exhausted+instance Arbitrary a => FindGen 'Shift s () () a where+ findGen _ _ _ = arbitrary+ {-# INLINEABLE findGen #-}++-- | Examine the next candidate+instance FindGen 'Shift s b g a => FindGen 'Shift s () (b :+ g) a where+ findGen p () (b :+ gens) = findGen p b gens+ {-# INLINEABLE findGen #-}++-- | Examine the last candidate (@g@ is not of the form @_ :+ _@)+instance {-# OVERLAPS #-} FindGen 'Shift s g () a => FindGen 'Shift s () g a where+ findGen p () g = findGen p g ()++-- | This can happen if the generators form a tree rather than a list, for whatever reason.+instance FindGen 'Shift s g (h :+ gs) a => FindGen 'Shift s (g :+ h) gs a where+ findGen p (g :+ h) gs = findGen p g (h :+ gs)++instance FindGen ('Match 'INCOHERENT) s g gs a => FindGen 'Shift s (Incoherent g) gs a where+ findGen (_, s, fg) (Incoherent g) = findGen (im, s, fg) g where+ im = Proxy :: Proxy ('Match 'INCOHERENT)++-- | If none of the above matches, then @g@ should be a simple generator,+-- and we test whether it matches the type @a@.+instance {-# OVERLAPPABLE #-} FindGen ('Match (ACoherenceOf s)) s g gs a+ => FindGen 'Shift s g gs a where+ findGen (_, s, fg) = findGen (im, s, fg) where+ im = Proxy :: Proxy ('Match (ACoherenceOf s))++-- INCOHERENT++-- | None of the INCOHERENT instances match, discard the candidate @g@ and look+-- at the rest of the list @gs@.+instance FindGen 'Shift s () gs a+ => FindGen ('Match 'INCOHERENT) s _g gs a where+ findGen (_, s, fg) _ = findGen (iShift, s, fg) () where++-- | Matching custom generator for @a@.+instance {-# INCOHERENT #-} FindGen ('Match 'INCOHERENT) s (Gen a) gs a where+ findGen _ gen _ = gen+ {-# INLINEABLE findGen #-}++-- | Matching custom generator for non-container @f@.+instance {-# INCOHERENT #-} FindGen ('Match 'INCOHERENT) s (Gen1_ f) gs (f a) where+ findGen _ (Gen1_ gen) _ = gen++-- | Matching custom generator for container @f@. Start the search for containee @a@,+-- discarding field information.+instance {-# INCOHERENT #-} FindGen 'Shift ('S fg coh DummySel) () fg a+ => FindGen ('Match 'INCOHERENT) ('S fg coh _sel) (Gen1 f) gs (f a) where+ findGen (_, _, fg) (Gen1 gen) _ = gen (findGen (iShift, s, fg) () fg) where+ s = Proxy :: Proxy ('S fg coh DummySel)++type DummySel = '( 'Nothing, 0, 'Nothing)++-- | Matching custom generator for field @s@.+instance {-# INCOHERENT #-} (a ~ a')+ => FindGen ('Match 'INCOHERENT) ('S _fg _coh '(con, i, 'Just s)) (FieldGen s a) gs a' where+ findGen _ (FieldGen gen) _ = gen+ {-# INLINEABLE findGen #-}++-- | Matching custom generator for @i@-th field of constructor @c@.+instance {-# INCOHERENT #-} (a ~ a')+ => FindGen ('Match 'INCOHERENT) ('S _fg _coh '( 'Just c, i, s)) (ConstrGen c i a) gs a' where+ findGen _ (ConstrGen gen) _ = gen+ {-# INLINEABLE findGen #-}++-- | Get the name contained in a 'Meta' tag.+type family Name (d :: Meta) :: Maybe Symbol+type instance Name ('MetaSel mn su ss ds) = mn+type instance Name ('MetaCons n _f _s) = 'Just n++-- COHERENT++-- Use a type famaily to do the matching coherently.+instance FindGen ('MatchCoh (Matches (ASelOf s) g a)) s g gs a+ => FindGen ('Match 'COHERENT) s g gs a where+ findGen (_, s, fg) = findGen (im, s, fg) where+ im = Proxy :: Proxy ('MatchCoh (Matches (ASelOf s) g a))++type family Matches (s :: ASel) (g :: Type) (a :: Type) :: Bool where+ Matches _sel (Gen b) a = b == a+ Matches _sel (Gen1_ f) (f a) = 'True+ Matches _sel (Gen1_ f) a = 'False+ Matches _sel (Gen1 f) (f a) = 'True+ Matches _sel (Gen1 f) a = 'False+ Matches '(_c, i, s) (FieldGen s1 b) a = s == 'Just s1 && b == a+ Matches '( c, i, _s) (ConstrGen c1 j b) a = c == 'Just c1 && i == j && b == a++-- If there is no match, skip and shift.+instance FindGen 'Shift s () gs a => FindGen ('MatchCoh 'False) s _g gs a where+ findGen (_, s, fg) _ = findGen (iShift, s, fg) () where++-- If there is a match, the search terminates++instance (a ~ a') => FindGen ('MatchCoh 'True) s (Gen a) gs a' where+ findGen _ g _ = g++instance (f x ~ a') => FindGen ('MatchCoh 'True) s (Gen1_ f) gs a' where+ findGen _ (Gen1_ g) _ = g++instance (f x ~ a', FindGen 'Shift ('S fg coh DummySel) () fg x)+ => FindGen ('MatchCoh 'True) ('S fg coh _sel) (Gen1 f) gs a' where+ findGen (_, _, fg) (Gen1 gen) _ = gen (findGen (iShift, s, fg) () fg) where+ s = Proxy :: Proxy ('S fg coh DummySel)++-- | Matching custom generator for field @s@.+instance (a ~ a')+ => FindGen ('MatchCoh 'True) s (FieldGen sn a) gs a' where+ findGen _ (FieldGen gen) _ = gen++-- | Matching custom generator for @i@-th field of constructor @c@.+instance (a ~ a')+ => FindGen ('MatchCoh 'True) s (ConstrGen c i a) gs a' where+ findGen _ (ConstrGen gen) _ = gen++--+ newtype Weighted a = Weighted (Maybe (Int -> Gen a, Int)) deriving Functor @@ -221,10 +767,10 @@ pure a = Weighted (Just ((pure . pure) a, 1)) Weighted f <*> Weighted a = Weighted $ liftA2 g f a where- g (f, m) (a, n) =+ g (f1, m) (a1, n) = ( \i -> let (j, k) = i `divMod` m- in f j <*> a k+ in f1 j <*> a1 k , m * n ) instance Alternative Weighted where@@ -239,62 +785,6 @@ b (i - m) , m + n ) -class BaseCases n f where- baseCases :: Weights_ f -> Int -> Tagged n (Weighted (f p))--instance (BaseCases n f, BaseCases n g) => BaseCases n (f :+: g) where- baseCases (N a m b) n =- concat- ((fmap . fmap) L1 (baseCases a m))- ((fmap . fmap) R1 (baseCases b (n - m)))- where- concat :: Alternative u => Tagged n (u a) -> Tagged n (u a) -> Tagged n (u a)- concat (Tagged a) (Tagged b) = Tagged (a <|> b)--instance ListBaseCases n f => BaseCases n (M1 i c f) where- baseCases _ n = fmap reweigh listBaseCases- where- reweigh :: Weighted a -> Weighted a- reweigh (Weighted h) = Weighted (fmap (\(g, _) -> (g, n)) h)---- | A @ListBaseCases n ('Rep' a)@ constraint basically provides the list of--- values of type @a@ with depth at most @n@.-class ListBaseCases n f where- listBaseCases :: Alternative u => Tagged n (u (f p))---- | For convenience.-type BaseCases' n a = (Generic a, ListBaseCases n (Rep a))--instance ListBaseCases n U1 where- listBaseCases = Tagged (pure U1)--instance ListBaseCases n f => ListBaseCases n (M1 i c f) where- listBaseCases = (fmap . fmap) M1 listBaseCases--instance ListBaseCases Z (K1 i c) where- listBaseCases = Tagged empty--instance (Generic c, ListBaseCases n (Rep c)) => ListBaseCases (S n) (K1 i c) where- listBaseCases = (retag . (fmap . fmap) (K1 . to)) listBaseCases- where- retag :: Tagged n a -> Tagged (S n) a- retag = coerce--instance (ListBaseCases n f, ListBaseCases n g) => ListBaseCases n (f :+: g) where- listBaseCases =- concat- ((fmap . fmap) L1 listBaseCases)- ((fmap . fmap) R1 listBaseCases)- where- concat :: Alternative u => Tagged n (u a) -> Tagged n (u a) -> Tagged n (u a)- concat (Tagged a) (Tagged b) = Tagged (a <|> b)+liftGen :: Gen a -> Weighted a+liftGen g = Weighted (Just (\_ -> g, 1)) -instance (ListBaseCases n f, ListBaseCases n g) => ListBaseCases n (f :*: g) where- listBaseCases = liftedP listBaseCases listBaseCases- where- liftedP- :: Applicative u- => Tagged n (u (f p))- -> Tagged n (u (g p))- -> Tagged n (u ((f :*: g) p))- liftedP (Tagged f) (Tagged g) = Tagged (liftA2 (:*:) f g)
+ src/Generic/Random/Tutorial.hs view
@@ -0,0 +1,287 @@+-- | Generic implementations of+-- [QuickCheck](https://hackage.haskell.org/package/QuickCheck)'s+-- @arbitrary@.+--+-- = Example+--+-- Define your type.+--+-- @+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+-- deriving 'GHC.Generics.Generic'+-- @+--+-- Pick an 'Test.QuickCheck.arbitrary' implementation, specifying the required distribution of+-- data constructors.+--+-- @+-- instance Arbitrary a => Arbitrary (Tree a) where+-- arbitrary = 'genericArbitrary' (9 '%' 8 '%' ())+-- @+--+-- That random generator @arbitrary :: 'Test.QuickCheck.Gen' (Tree a)@ picks a+-- @Leaf@ with probability 9\/17, or a+-- @Node@ with probability 8\/17, and recursively fills their fields with+-- @arbitrary@.+--+-- For @Tree@, the generic implementation 'genericArbitrary' is equivalent to+-- the following:+--+-- @+-- 'genericArbitrary' :: Arbitrary a => 'Weights' (Tree a) -> Gen (Tree a)+-- 'genericArbitrary' (x '%' y '%' ()) =+-- frequency+-- [ (x, Leaf '<$>' arbitrary)+-- , (y, Node '<$>' arbitrary '<*>' arbitrary)+-- ]+-- @+--+-- = Distribution of constructors+--+-- The distribution of constructors can be specified as+-- a special list of /weights/ in the same order as the data type definition.+-- This assigns to each constructor a probability @p_C@ proportional to its weight @weight_C@;+-- in other words, @p_C = weight_C / sumOfWeights@.+--+-- The list of weights is built up with the @('%')@ operator as a cons, and using+-- the unit @()@ as the empty list, in the order corresponding to the data type+-- definition.+--+-- == Uniform distribution+--+-- You can specify the uniform distribution (all weights equal to 1) with 'uniform'.+-- ('genericArbitraryU' is available as a shorthand for+-- @'genericArbitrary' 'uniform'@.)+--+-- Note that for many recursive types, a uniform distribution tends to produce+-- big or even infinite values.+--+-- == Typed weights+--+-- The weights actually have type @'W' \"ConstructorName\"@ (just a newtype+-- around 'Int'), so that you can annotate a weight with its corresponding+-- constructor. The constructors must appear in the same order as in the+-- original type definition.+--+-- This will type-check:+--+-- @+-- ((x :: 'W' \"Leaf\") '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a)+-- ( x '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a)+-- @+--+-- This will not:+--+-- @+-- ((x :: 'W' \"Node\") '%' y '%' ()) :: 'Weights' (Tree a)+-- -- Requires an order of constructors different from the definition of the @Tree@ type.+--+-- ( x '%' y '%' z '%' ()) :: 'Weights' (Tree a)+-- -- Doesn't have the right number of weights.+-- @+--+-- = Ensuring termination+--+-- As mentioned earlier, one must be careful with recursive types+-- to avoid producing extremely large values.+-- The alternative generator 'genericArbitraryRec' decreases the size+-- parameter at every call to keep values at reasonable sizes.+-- It is to be used together with 'withBaseCase'.+--+-- For example, we may provide a base case consisting of only @Leaf@:+--+-- @+-- instance Arbitrary a => Arbitrary (Tree a) where+-- arbitrary = 'genericArbitraryRec' (1 '%' 2 '%' ())+-- ``withBaseCase`` (Leaf '<$>' arbitrary)+-- @+--+-- That is equivalent to the following definition. Note the+-- 'Test.QuickCheck.resize' modifier.+--+-- @+-- arbitrary :: Arbitrary a => Gen (Tree a)+-- arbitrary = sized $ \\n ->+-- -- "if" condition from withBaseCase+-- if n == 0 then+-- Leaf \<$\> arbitrary+-- else+-- -- genericArbitraryRec+-- frequency+-- [ (1, resize (max 0 (n - 1)) (Leaf '<$>' arbitrary))+-- , (2, resize (n \`div\` 2) (Node '<$>' arbitrary '<*>' arbitrary))+-- ]+-- @+--+-- The resizing strategy is as follows:+-- the size parameter of 'Test.QuickCheck.Gen' is divided among the fields of+-- the chosen constructor, or decreases by one if the constructor is unary.+-- @'withBaseCase' defG baseG@ is equal to @defG@ as long as the size parameter+-- is nonzero, and it becomes @baseG@ once the size reaches zero.+-- This combination generally ensures that the number of constructors remains+-- bounded by the initial size parameter passed to 'Test.QuickCheck.Gen'.+--+-- == Automatic base case discovery+--+-- In some situations, generic-random can also construct base cases automatically.+-- This works best with fully concrete types (no type parameters).+--+-- @+-- {-\# LANGUAGE FlexibleInstances #-}+--+-- instance Arbitrary (Tree ()) where+-- arbitrary = 'genericArbitrary'' (1 '%' 2 '%' ())+-- @+--+-- The above instance will infer the value @Leaf ()@ as a base case.+--+-- To discover values of type @Tree a@, we must inspect the type argument @a@,+-- thus we incur some extra constraints if we want polymorphism.+-- It is preferrable to apply the type class 'BaseCase' to the instance head+-- (@Tree a@) as follows, as it doesn't reduce to something worth seeing.+--+-- @+-- {-\# LANGUAGE FlexibleContexts, UndecidableInstances \#-}+--+-- instance (Arbitrary a, 'BaseCase' (Tree a))+-- => Arbitrary (Tree a) where+-- arbitrary = 'genericArbitrary'' (1 '%' 2 '%' ())+-- @+--+-- The 'BaseCase' type class finds values of minimal depth,+-- where the depth of a constructor is defined as @1 + max(0, depths of fields)@,+-- e.g., @Leaf ()@ has depth 2.+--+-- == Note about lists #notelists#+--+-- The @Arbitrary@ instance for lists can be problematic for this way+-- of implementing recursive sized generators, because they make a lot of+-- recursive calls to 'Test.QuickCheck.arbitrary' without decreasing the size parameter.+-- Hence, as a default, 'genericArbitraryRec' also detects fields which are+-- lists to replace 'Test.QuickCheck.arbitrary' with a different generator that divides+-- the size parameter by the length of the list before generating each+-- element. This uses the customizable mechanism shown in the next section.+--+-- If you really want to use 'Test.QuickCheck.arbitrary' for lists in the derived instances,+-- substitute @'genericArbitraryRec'@ with @'genericArbitraryRecG' ()@.+--+-- @+-- arbitrary = 'genericArbitraryRecG' ()+-- ``withBaseCase`` baseGen+-- @+--+-- Some combinators are available for further tweaking: 'listOf'', 'listOf1'',+-- 'vectorOf''.+--+-- = Custom generators for some fields+--+-- == Example 1 ('Test.QuickCheck.Gen', 'FieldGen')+--+-- Sometimes, a few fields may need custom generators instead of 'Test.QuickCheck.arbitrary'.+-- For example, imagine here that @String@ is meant to represent+-- alphanumerical strings only, and that IDs are meant to be nonnegative,+-- whereas balances can have any sign.+--+-- @+-- data User = User {+-- userName :: String,+-- userId :: Int,+-- userBalance :: Int+-- } deriving 'GHC.Generics.Generic'+-- @+--+-- A naive approach has the following problems:+--+-- - @'Test.QuickCheck.Arbitrary' String@ may generate any unicode character,+-- alphanumeric or not;+-- - @'Test.QuickCheck.Arbitrary' Int@ may generate negative values;+-- - using @newtype@ wrappers or passing generators explicitly to properties+-- may be impractical (the maintenance overhead can be high because the types+-- are big or change often).+--+-- Using generic-random, we can declare a (heterogeneous) list of generators to+-- be used instead of 'Test.QuickCheck.arbitrary' when generating certain fields.+--+-- @+-- customGens :: 'FieldGen' "userId" Int ':+' 'Test.QuickCheck.Gen' String+-- customGens =+-- 'FieldGen' ('Test.QuickCheck.getNonNegative' '<$>' arbitrary) ':+'+-- 'Test.QuickCheck.listOf' ('Test.QuickCheck.elements' (filter isAlphaNum [minBound .. maxBound]))+-- @+--+-- Now we use the 'genericArbitraryG' combinator and other @G@-suffixed+-- variants that accept those explicit generators.+--+-- - All @String@ fields will use the provided generator of+-- alphanumeric strings;+-- - the field @"userId"@ of type @Int@ will use the generator+-- of nonnegative integers;+-- - everything else defaults to 'Test.QuickCheck.arbitrary'.+--+-- @+-- instance Arbitrary User where+-- arbitrary = 'genericArbitrarySingleG' customGens+-- @+--+-- == Example 2 ('ConstrGen')+--+-- Here's the @Tree@ type from the beginning again.+--+-- @+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+-- deriving 'GHC.Generics.Generic'+-- @+--+-- We will generate "right-leaning linear trees", which look like this:+--+-- > Node (Leaf 1)+-- > (Node (Leaf 2)+-- > (Node (Leaf 3)+-- > (Node (Leaf 4)+-- > (Leaf 5))))+--+-- To do so, we force every left child of a @Node@ to be a @Leaf@:+--+-- @+-- {-\# LANGUAGE ScopedTypeVariables \#-}+--+-- instance Arbitrary a => Arbitrary (Tree a) where+-- arbitrary = 'genericArbitraryUG' customGens+-- where+-- -- Generator for the left field (i.e., at index 0) of constructor Node,+-- -- which must have type (Tree a).+-- customGens :: 'ConstrGen' \"Node\" 0 (Tree a)+-- customGens = 'ConstrGen' (Leaf '<$>' arbitrary)+-- @+--+-- That instance is equivalent to the following:+--+-- @+-- instance Arbitrary a => Arbitrary (Tree a) where+-- arbitrary = oneof+-- [ Leaf '<$>' arbitrary+-- , Node '<$>' (Leaf '<$>' arbitrary) '<*>' arbitrary+-- -- ^ recursive call+-- ]+-- @+--+-- == Custom generators reference+--+-- The custom generator modifiers that can occur in the list are:+--+-- - 'Test.QuickCheck.Gen': a generator for a specific type;+-- - 'FieldGen': a generator for a record field;+-- - 'ConstrGen': a generator for a field of a given constructor;+-- - 'Gen1': a generator for \"containers\", parameterized by a generator+-- for individual elements;+-- - 'Gen1_': a generator for unary type constructors that are not+-- containers.+--+-- Suggestions to add more modifiers or otherwise improve this tutorial are welcome!+-- <https://github.com/Lysxia/generic-random/issues The issue tracker is this way.>++{-# OPTIONS_GHC -Wno-unused-imports #-}++module Generic.Random.Tutorial () where++import Generic.Random
+ test/Inspect.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -dsuppress-all #-}+{-# LANGUAGE+ DeriveGeneric,+ TemplateHaskell+ #-}+++import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary(arbitrary), Gen, choose)++import Test.Inspection (inspect, (===))++import Generic.Random++arbMaybe :: Arbitrary a => Gen (Maybe a)+arbMaybe = genericArbitraryU++arbMaybe' :: Arbitrary a => Gen (Maybe a)+arbMaybe' = do+ i <- choose (0, 1 :: Int)+ if i < 1 then+ pure Nothing+ else+ Just <$> arbitrary++data T = A | B | C Int [Bool]+ deriving Generic++arbT :: Gen T+arbT = genericArbitrary (1 % 2 % 3 % ())++arbT' :: Gen T+arbT' = do+ i <- choose (0, 5 :: Int)+ if i < 1 then+ pure A+ else+ if i - 1 < 2 then+ pure B+ else+ C <$> arbitrary <*> arbitrary++main :: IO ()+main = pure ()++inspect $ 'arbMaybe === 'arbMaybe'+inspect $ 'arbT === 'arbT'
+ test/Inspect/DerivingVia.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE+ DataKinds,+ DeriveGeneric,+ DerivingVia,+ TypeOperators,+ TemplateHaskell+ #-}++import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary(arbitrary), Gen)++import Test.Inspection (inspect, (==-))++import Generic.Random++data T = A | B | C Int [Bool]+ deriving Generic+ deriving Arbitrary via (GenericArbitrary '[1,2,3] T)++arbT :: Gen T+arbT = genericArbitrary (1 % 2 % 3 % ())++arbT' :: Gen T+arbT' = arbitrary++data T1 = A1 | B1 | C1 Int [Bool]+ deriving Generic+ deriving Arbitrary via (GenericArbitrary '[1,2,3] `AndShrinking` T1)++main :: IO ()+main = pure ()++inspect $ 'arbT ==- 'arbT'
+ test/Unit.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE+ DataKinds,+ DeriveGeneric,+ FlexibleContexts,+ FlexibleInstances,+ LambdaCase,+ TypeFamilies,+ UndecidableInstances #-}++import Control.Monad (replicateM)+import Control.DeepSeq (NFData, force)+import GHC.Generics (Generic)+import System.Timeout (timeout)++import Test.QuickCheck++import Generic.Random++-- Binary trees+data B = BL | BN B B+ deriving (Eq, Ord, Show, Generic)++size :: B -> Int+size (BN l r) = 1 + size l + size r+size BL = 0++instance Arbitrary B where+ arbitrary = genericArbitrary ((9 :: W "BL") % (3 :: W "BN") % ())++instance NFData B+++-- Messing with base cases+newtype T a = W a deriving (Generic, Show)++instance (Arbitrary a, BaseCase (T a)) => Arbitrary (T a) where+ arbitrary = genericArbitrary' uniform++instance NFData a => NFData (T a)+++-- Rose tree for testing the custom list generator that's inserted by default.+data NTree = Leaf | Node [NTree] deriving (Generic, Show)++instance Arbitrary NTree where+ arbitrary = genericArbitraryU'++instance NFData NTree++eval :: NFData a => String -> Gen a -> IO ()+eval name g = do+ x <- timeout (10 ^ (6 :: Int)) $ do+ xs <- generate (replicateM 100 g)+ return $! force xs+ case x of+ Just _ -> return ()+ Nothing -> fail $ name ++ ": did not finish on time"++-- Tests for ConstrGen++data Tree2 = Leaf2 Int | Node2 Tree2 Tree2 deriving (Generic, Show)++instance Arbitrary Tree2 where+ arbitrary = genericArbitraryUG (ConstrGen (Leaf2 <$> arbitrary) :: ConstrGen "Node2" 1 Tree2)++isLeftBiased :: Tree2 -> Bool+isLeftBiased (Leaf2 _) = True+isLeftBiased (Node2 t (Leaf2 _)) = isLeftBiased t+isLeftBiased _ = False++main :: IO ()+main = do+ eval "B" (arbitrary :: Gen B)+ eval "T" (arbitrary :: Gen (T (T Int)))+ eval "NTree" (arbitrary :: Gen NTree)+ quickCheck . whenFail (putStrLn "Tree2") $ isLeftBiased
+ test/coherence.hs view
@@ -0,0 +1,126 @@+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}+{-# LANGUAGE+ BangPatterns,+ DataKinds,+ DeriveGeneric,+ ScopedTypeVariables,+ TypeOperators,+ RebindableSyntax,+ TypeApplications #-}++import Control.Monad (replicateM)+import Control.Exception+import System.Exit (exitFailure)+import Data.Foldable (find, traverse_)+import Data.Maybe (catMaybes)++import GHC.Generics ( Generic )+import Test.QuickCheck (Arbitrary (..), Gen, sample, generate)+import Prelude++import Generic.Random++-- @T0@, @T1@: Override the @Int@ generator in the presence of a type parameter @a@.++-- Counterexample that's not supposed to type check.+-- Use BangPatterns so we can force it with just seq.+data T0 a = N0 !a !Int+ deriving (Generic, Show)++instance Arbitrary a => Arbitrary (T0 a) where+ arbitrary = genericArbitraryWith+ (setGenerators customGens cohSizedOpts)+ uniform+ where+ customGens :: Gen Int+ customGens = pure 33+++-- This one works.+data T1 a = N1 a Int+ deriving (Generic, Show)++instance Arbitrary a => Arbitrary (T1 a) where+ arbitrary = genericArbitraryWith+ (setGenerators customGens cohSizedOpts)+ uniform+ where+ customGens :: Incoherent (Gen a) :+ Gen Int+ customGens = Incoherent arbitrary :+ pure 33++check1 :: T1 a -> Bool+check1 (N1 _ n) = n == 33+++-- A bigger example to cover the remaining generator types.+data T2 a = N2+ { f2a :: a+ , f2b :: Int+ , f2c :: [Int]+ , f2d :: Maybe Int+ , f2e :: Int+ , f2g :: Int+ , f2h :: [a]+ } deriving (Show, Generic)++instance Arbitrary a => Arbitrary (T2 a) where+ arbitrary = genericArbitraryWith+ (setGenerators customGens cohSizedOpts)+ uniform+ where+ -- Hack to allow annotating each generator in the list while avoiding parentheses+ (>>) = (:+)+ customGens = do+ Incoherent arbitrary :: Incoherent (Gen a)+ Incoherent (FieldGen ((: []) <$> arbitrary))+ :: Incoherent (FieldGen "f2h" [a])+ Gen1_ (pure Nothing) :: Gen1_ Maybe+ Gen1 (fmap (\x -> [x, x])) :: Gen1 []+ ConstrGen (pure 88) :: ConstrGen "N2" 4 Int+ FieldGen (pure 77) :: FieldGen "f2g" Int+ pure 33 :: Gen Int++check2 :: T2 a -> Bool+check2 t =+ f2b t == 33+ && length (f2c t) == 2+ && f2d t == Nothing+ && f2e t == 88+ && f2g t == 77+ && length (f2h t) == 1+++type Error = String++expectTypeError :: IO a -> IO (Maybe Error)+expectTypeError gen = do+ r <- try (gen >>= evaluate)+ case r of+ Left (e :: TypeError) -> pure Nothing -- success+ Right _ -> (pure . Just) "Unexpected evaluation (expected a type error)"+++sample_ :: Show a => (a -> Bool) -> Gen a -> IO (Maybe Error)+sample_ check g = do+ xs <- generate (replicateM 100 g)+ case find (not . check) xs of+ Nothing -> pure Nothing+ Just x -> (pure . Just) ("Invalid value: " ++ show x)+++collectErrors :: [IO (Maybe Error)] -> IO ()+collectErrors xs = do+ es <- sequence xs+ case catMaybes es of+ [] -> pure ()+ es@(_ : _) -> do+ putStrLn "Test failed. Errors:"+ traverse_ putStrLn es+ exitFailure++main :: IO ()+main = collectErrors+ [ expectTypeError (generate (arbitrary :: Gen (T0 ())))+ , sample_ check1 (arbitrary :: Gen (T1 ()))+ , sample_ check2 (arbitrary :: Gen (T2 ()))+ ]