generic-random-1.5.0.1/0000755000000000000000000000000007346545000012737 5ustar0000000000000000generic-random-1.5.0.1/CHANGELOG.md0000755000000000000000000000555307346545000014563 0ustar0000000000000000# 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 # 0.4.0.0 - Check well-formedness of constructor distributions at compile time. - No longer support GHC 7.10.3 (the above feature relies on Generic information which does not exist before GHC 8) # 0.3.0.0 - Support GHC 7.10.3 - Replace `TypeApplications` with ad-hoc data types in `genericArbitraryFrequency'`/`genericArbitrary'` generic-random-1.5.0.1/LICENSE0000644000000000000000000000206607346545000013750 0ustar0000000000000000The MIT License (MIT) Copyright (c) 2016 Li-yao Xia Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. generic-random-1.5.0.1/README.md0000755000000000000000000000450007346545000014220 0ustar0000000000000000Generic random generators [![Hackage](https://img.shields.io/hackage/v/generic-random.svg)](https://hackage.haskell.org/package/generic-random) [![Build Status](https://travis-ci.org/Lysxia/generic-random.svg)](https://travis-ci.org/Lysxia/generic-random) ========================= 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 #-} import GHC.Generics (Generic) import Test.QuickCheck import Generic.Random data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Show, Generic) 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 -- > , resize (n `div` 3) $ -- > Node <$> arbitrary <*> arbitrary <*> arbitrary -- > ] main :: IO () main = sample (arbitrary :: Gen (Tree ())) ``` 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-1.5.0.1/Setup.hs0000644000000000000000000000005607346545000014374 0ustar0000000000000000import Distribution.Simple main = defaultMain generic-random-1.5.0.1/generic-random.cabal0000644000000000000000000000507207346545000016621 0ustar0000000000000000name: generic-random 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: 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.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.Random.DerivingVia Generic.Random.Internal.BaseCase Generic.Random.Internal.Generic Generic.Random.Tutorial build-depends: 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 generic-random-1.5.0.1/src/Generic/0000755000000000000000000000000007346545000015102 5ustar0000000000000000generic-random-1.5.0.1/src/Generic/Random.hs0000644000000000000000000001527407346545000016667 0ustar0000000000000000-- | "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 generic-random-1.5.0.1/src/Generic/Random/0000755000000000000000000000000007346545000016322 5ustar0000000000000000generic-random-1.5.0.1/src/Generic/Random/DerivingVia.hs0000644000000000000000000002337707346545000021101 0ustar0000000000000000{-# 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 generic-random-1.5.0.1/src/Generic/Random/Internal/0000755000000000000000000000000007346545000020076 5ustar0000000000000000generic-random-1.5.0.1/src/Generic/Random/Internal/BaseCase.hs0000644000000000000000000002326307346545000022106 0ustar0000000000000000{-# 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) generic-random-1.5.0.1/src/Generic/Random/Internal/Generic.hs0000644000000000000000000006250107346545000022012 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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 (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 -- 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 :: (GArbitrary UnsizedOpts a) => Weights a -- ^ List of weights for every constructor -> Gen a genericArbitrary = genericArbitraryWith unsizedOpts -- | 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 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 :: 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 data a :| b = N a Int b data L (c :: Symbol) = L -- | Trees of weights assigned to constructors of type @a@, -- rescaled to obtain a probability distribution. -- -- Two ways of constructing them. -- -- @ -- (x1 '%' x2 '%' ... '%' xn '%' ()) :: 'Weights' a -- 'uniform' :: 'Weights' a -- @ -- -- Using @('%')@, there must be exactly as many weights as -- there are constructors. -- -- 'uniform' is equivalent to @(1 '%' ... '%' 1 '%' ())@ -- (automatically fills out the right number of 1s). data Weights a = Weights (Weights_ (Rep a)) Int -- | Type of a single weight, tagged with the name of the associated -- constructor for additional compile-time checking. -- -- @ -- ((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_ (Rep a) => Weights a uniform = let (w, n) = uniformWeight in Weights w n type family First a :: Symbol where 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 (%.) :: (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 = 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) instance WeightBuilder () where type Prec () r = r W m %. prec = ((), m, prec) class UniformWeight a where uniformWeight :: (a, Int) instance (UniformWeight a, UniformWeight b) => UniformWeight (a :| b) where uniformWeight = let (a, m) = uniformWeight (b, n) = uniformWeight in (N a m b, m + n) instance UniformWeight (L c) where uniformWeight = (L, 1) instance UniformWeight () where uniformWeight = ((), 1) class UniformWeight (Weights_ f) => UniformWeight_ f instance UniformWeight (Weights_ f) => UniformWeight_ f -- | Derived uniform distribution of constructors for @a@. class UniformWeight_ (Rep a) => GUniformWeight a instance UniformWeight_ (Rep a) => GUniformWeight a -- | 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 } -- | 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 -- | Infix flipped synonym for 'Options'. -- -- @since 1.4.0.0 type (<+) o x = SetOptions x o infixl 1 <+ 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 #-} 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 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 opts f where gaSum :: opts -> Int -> Weights_ f -> Gen (f p) 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 (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 (s :: Sizing) (c :: Maybe Symbol) opts f where gaProduct :: proxys '(s, c) -> opts -> Gen (f p) instance GAProduct' c 0 opts f => GAProduct 'Unsized c opts f where gaProduct _ = gaProduct' (Proxy :: Proxy '(c, 0)) {-# INLINE gaProduct #-} -- 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' 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 {-# 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 data AInstr = Shift | Match Coherence | MatchCoh Bool data AStore = S Type Coherence ASel type ASel = (Maybe Symbol, Nat, Maybe Symbol) iShift :: Proxy 'Shift iShift = Proxy 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 instance Applicative Weighted where pure a = Weighted (Just ((pure . pure) a, 1)) Weighted f <*> Weighted a = Weighted $ liftA2 g f a where g (f1, m) (a1, n) = ( \i -> let (j, k) = i `divMod` m in f1 j <*> a1 k , m * n ) instance Alternative Weighted where empty = Weighted Nothing a <|> Weighted Nothing = a Weighted Nothing <|> b = b Weighted (Just (a, m)) <|> Weighted (Just (b, n)) = Weighted . Just $ ( \i -> if i < m then a i else b (i - m) , m + n ) liftGen :: Gen a -> Weighted a liftGen g = Weighted (Just (\_ -> g, 1)) generic-random-1.5.0.1/src/Generic/Random/Tutorial.hs0000644000000000000000000002342407346545000020466 0ustar0000000000000000-- | 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! -- {-# OPTIONS_GHC -Wno-unused-imports #-} module Generic.Random.Tutorial () where import Generic.Random generic-random-1.5.0.1/test/0000755000000000000000000000000007346545000013716 5ustar0000000000000000generic-random-1.5.0.1/test/Inspect.hs0000644000000000000000000000150407346545000015657 0ustar0000000000000000{-# 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' generic-random-1.5.0.1/test/Inspect/0000755000000000000000000000000007346545000015323 5ustar0000000000000000generic-random-1.5.0.1/test/Inspect/DerivingVia.hs0000644000000000000000000000117107346545000020066 0ustar0000000000000000{-# 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' generic-random-1.5.0.1/test/Unit.hs0000644000000000000000000000345707346545000015202 0ustar0000000000000000{-# 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 generic-random-1.5.0.1/test/coherence.hs0000644000000000000000000000640207346545000016207 0ustar0000000000000000{-# 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 ())) ]