packages feed

generic-random 1.2.0.0 → 1.5.0.1

raw patch · 12 files changed

Files

CHANGELOG.md view
@@ -1,5 +1,37 @@-https://github.com/Lysxia/generic-random/blob/master/changelog.md+# 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@@ -7,6 +39,7 @@  - 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`
README.md view
@@ -1,14 +1,17 @@ Generic 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) ========================= -Derive simple random generators for [QuickCheck](https://hackage.haskell.org/package/QuickCheck) using generics.+Generic random generators+to implement `Arbitrary` instances for [QuickCheck](https://hackage.haskell.org/package/QuickCheck) -Automating the `Arbitrary` boilerplate also ensures that if a type changes to-have more constructors, then the generator fixes itself to generate that new-case (with `uniform` distribution) or causes a compilation error (with an-explicit distribution).+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). -A simple (optional) strategy to ensure termination for recursive types:+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@@ -42,5 +45,21 @@ -- >             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.cabal view
@@ -1,37 +1,42 @@ name:                generic-random-version:             1.2.0.0-synopsis:            Generic random generators+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-    .-    - https://byorgey.wordpress.com/2016/09/20/the-generic-random-library-part-1-simple-generic-arbitrary-instances/  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 == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.1, GHC == 8.4.1+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.7 && < 4.12,-    QuickCheck+    base >= 4.11 && < 5,+    QuickCheck >= 2.14+    -- exports RecursivelyShrink   default-language:    Haskell2010   ghc-options: -Wall -fno-warn-name-shadowing @@ -40,12 +45,60 @@   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+  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
@@ -1,67 +1,246 @@--- | Simple "GHC.Generics"-based 'arbitrary' generators.+-- | "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--- - https://byorgey.wordpress.com/2016/09/20/the-generic-random-library-part-1-simple-generic-arbitrary-instances/ -{-# LANGUAGE CPP #-}+{-# 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-  , genericArbitraryWith -    -- * Base cases for recursive types-  , withBaseCase-  , BaseCase (..)-     -- * 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-  , Sizing (..)-  , setSized-  , setUnsized-  , (:+) (..)-#if __GLASGOW_HASKELL__ >= 800-  , FieldGen (..)-  , fieldGen-#endif-  , Gen1 (..)-  , Gen1_ (..)-  , setGenerators -    -- * Public classes+    -- *** Advanced options+    -- | See 'Coherence'+  , CohUnsizedOpts+  , cohUnsizedOpts+  , CohSizedOpts+  , cohSizedOpts++    -- * Generic classes   , GArbitrary   , GUniformWeight -    -- * Helpful combinators-  , listOf'-  , listOf1'-  , vectorOf'+  -- * 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/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/Internal/BaseCase.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-}  {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}@@ -13,19 +12,22 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif +-- | 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-#if __GLASGOW_HASKELL__ >= 800 import Data.Proxy-#endif-#if __GLASGOW_HASKELL__ < 710-import Data.Word-#endif+import Data.Kind (Type) import GHC.Generics import GHC.TypeLits import Test.QuickCheck@@ -37,7 +39,9 @@ -- -- > genericArbitrary' (17 % 19 % 23 % ()) :: Gen a ----- N.B.: This replaces fields of type @[t]@ with @'listOf'' arbitrary@.+-- 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@@ -46,9 +50,11 @@  -- | Equivalent to @'genericArbitrary'' 'uniform'@. ----- > genericArbitraryU :: Gen a+-- > genericArbitraryU' :: Gen a ----- N.B.: This replaces fields of type @[t]@ with @'listOf'' arbitrary@.+-- 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@@ -70,7 +76,7 @@ -- -- @e@ is the original type the search started with, that @a@ appears in. -- It is used for error reporting.-class BaseCaseSearch (a :: *) (z :: Nat) (y :: Maybe Nat) (e :: *) where+class BaseCaseSearch (a :: Type) (z :: Nat) (y :: Maybe Nat) (e :: Type) where   baseCaseSearch :: prox y -> proxy '(z, e) -> IfM y Gen Proxy a  @@ -175,14 +181,16 @@ type instance MinOf 'LT m n = m  class Alternative (IfM y Weighted Proxy)-  => GBCS (f :: k -> *) (z :: Nat) (y :: Maybe Nat) (e :: *) where+  => 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-  ( GBCSSum f g z e yf yg+  ( 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)@@ -230,7 +238,9 @@   gbcsSumCompare _ _ _ g = fmap R1 g  instance-  ( GBCSProduct f g z e yf yg+  ( 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)@@ -284,7 +294,6 @@ instance (y ~ 'Just 0) => GBCS U1 z y e where   gbcs _ _ = pure U1 -#if __GLASGOW_HASKELL__ >= 800 instance {-# INCOHERENT #-}   ( TypeError       (     'Text "Unrecognized Rep: "@@ -298,7 +307,6 @@   , Alternative (IfM y Weighted Proxy)   ) => GBCS f z y e where   gbcs = error "Type error"-#endif  class GBaseCaseSearch a z y e where   gBaseCaseSearch :: prox y -> proxy '(z, e) -> IfM y Gen Proxy a@@ -306,21 +314,8 @@ instance (Generic a, GBCS (Rep a) z y e, IsMaybe y)   => GBaseCaseSearch a z y e where   gBaseCaseSearch y z = ifMmap y-    (\(Weighted (Just (g, n))) -> choose (0, n-1) >>= fmap to . g)+    (\(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)--#if __GLASGOW_HASKELL__ < 800-data Proxy a = Proxy--instance Functor Proxy where-  fmap _ _ = Proxy--instance Applicative Proxy where-  pure _ = Proxy-  _ <*> _ = Proxy--instance Alternative Proxy where-  empty = Proxy-  _ <|> _ = Proxy-#endif
src/Generic/Random/Internal/Generic.hs view
@@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE CPP #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}@@ -12,36 +12,34 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE IncoherentInstances #-}-#endif +-- | 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 -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif import Control.Applicative (Alternative(..), liftA2)-import Data.Coerce (coerce)-#if __GLASGOW_HASKELL__ >= 800+import Data.Coerce (Coercible, coerce) import Data.Kind (Type)-#endif+ import Data.Proxy (Proxy(..))-#if __GLASGOW_HASKELL__ >= 800-import GHC.Generics hiding (S)-#else-import GHC.Generics hiding (S, Arity)-#endif+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) -#if __GLASGOW_HASKELL__ < 800-#define Type *-#endif- -- * Random generators  -- | Pick a constructor with a given distribution, and fill its fields@@ -82,7 +80,9 @@ -- -- > genericArbitraryRec (7 % 11 % 13 % ()) :: Gen a ----- N.B.: This replaces fields of type @[t]@ with @'listOf'' arbitrary@.+-- 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@@ -95,21 +95,19 @@ -- -- > genericArbitraryG customGens (17 % 19 % ()) ----- where, for example to override generators for 'String' and 'Int' fields,+-- where, the generators for 'String' and 'Int' fields are overridden as+-- follows, for example: -- -- @--- customGens :: 'GenList' '[String, Int]+-- customGens :: Gen String ':+' Gen Int -- customGens =---   (filter (/= '\NUL') '<$>' arbitrary) ':@'---   (getNonNegative '<$>' arbitrary) ':@'---   'Nil'+--   (filter (/= '\NUL') '<$>' arbitrary) ':+'+--   (getNonNegative '<$>' arbitrary) -- @ -- -- === Note on multiple matches ----- If the list contains multiple matching types for a field @x@ of type @a@--- (i.e., either @a@ or @'Field' "x" a@), the generator for the first--- match will be picked.+-- Multiple generators may match a given field: the first will be chosen. genericArbitraryG   :: (GArbitrary (SetGens genList UnsizedOpts) a)   => genList@@ -155,14 +153,10 @@  -- * 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-#if __GLASGOW_HASKELL__ >= 800   Weights_ (M1 C ('MetaCons c _i _j) _f) = L c-#else-  Weights_ (M1 C _c _f) = L ""-#endif  data a :| b = N a Int b data L (c :: Symbol) = L@@ -219,7 +213,7 @@ class WeightBuilder' w where    -- | A binary constructor for building up trees of weights.-  (%) :: W (First' w) -> Prec' w -> w+  (%) :: (c ~ First' w) => W c -> Prec' w -> w  instance WeightBuilder (Weights_ (Rep a)) => WeightBuilder' (Weights a) where   w % prec = weights (w %. prec)@@ -230,7 +224,7 @@ class WeightBuilder a where   type Prec a r -  (%.) :: W (First a) -> Prec a r -> (a, Int, r)+  (%.) :: (c ~ First a) => W c -> Prec a r -> (a, Int, r)  infixr 1 % @@ -274,10 +268,52 @@   -- | Type-level options for 'GArbitrary'.-newtype Options (s :: Sizing) (genList :: Type) = Options+--+-- 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 ()@@ -286,30 +322,94 @@ sizedOpts :: SizedOpts sizedOpts = Options () --- | Default options overriding the list generator using `listOf'`.+-- | 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 () --- | Whether to decrease the size parameter before generating fields.-data Sizing = Sized | Unsized+-- | Like 'sizedOpts' but using coherent instances by default.+cohSizedOpts :: CohSizedOpts+cohSizedOpts = Options () -type UnsizedOpts = Options 'Unsized ()-type SizedOpts = Options 'Sized ()-type SizedOptsDef = Options 'Sized (Gen1 [] :+ ()) +-- | 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 s _g) = s+type instance SizingOf (Options _c s _g) = s -proxySizing :: opts -> Proxy (SizingOf opts)-proxySizing _ = Proxy+type family SetSized (o :: Type) :: Type+type instance SetSized (Options c s g) = Options c 'Sized g -setSized :: Options s g -> Options '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 s g -> Options 'Unsized g+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 @@ -317,47 +417,71 @@   type family GeneratorsOf opts :: Type-type instance GeneratorsOf (Options _s g) = g+type instance GeneratorsOf (Options _c _s g) = g  class HasGenerators opts where   generators :: opts -> GeneratorsOf opts -instance HasGenerators (Options s g) where+instance HasGenerators (Options c s g) where   generators = _generators -setGenerators :: genList -> Options s g0 -> Options s genList+-- | 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 s _g) = Options s g+type instance SetGens g (Options c s _g) = Options c s g -#if __GLASGOW_HASKELL__ >= 800--- | A generator which overrides a specific field named @s@.++-- | Custom generator for record fields named @s@. ----- /Available only for @base >= 4.9@./+-- 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 } --- | 'Field' constructor with the field name given via a proxy.+-- | 'FieldGen' constructor with the field name given via a proxy. fieldGen :: proxy s -> Gen a -> FieldGen s a fieldGen _ = FieldGen-#endif --- | Generators for containers of kind @* -> *@, parameterized by--- the generator for each element.+-- | 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) } --- | Generators for unary type constructors that are not containers.+-- | 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 'listOf' that divides the size parameter by the--- length of the list.+-- | 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]@@ -365,8 +489,8 @@   i <- geom n   vectorOf' i g --- | An alternative to 'listOf1' (nonempty lists) that divides the size--- parameter by the length of the list.+-- | 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]@@ -403,8 +527,8 @@   ga = gaSum'   {-# INLINE ga #-} -instance GAProduct (SizingOf opts) opts f => GA opts (M1 C c f) where-  ga z _ _ = fmap M1 (gaProduct (proxySizing z) z)+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)@@ -422,55 +546,59 @@     | otherwise = fmap R1 (gaSum z (i - n) b)   {-# INLINE gaSum #-} -instance GAProduct (SizingOf opts) opts f => GASum opts (M1 i c f) where-  gaSum z _ _ = fmap M1 (gaProduct (proxySizing z) z)+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) opts f where-  gaProduct :: proxys s -> opts -> Gen (f p)+class GAProduct (s :: Sizing) (c :: Maybe Symbol) opts f where+  gaProduct :: proxys '(s, c) -> opts -> Gen (f p) -instance GAProduct' opts f => GAProduct 'Unsized opts f where-  gaProduct _ = gaProduct'+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' opts (S1 d f)-  => GAProduct 'Sized opts (S1 d f) where-  gaProduct _ = scale (\n -> max 0 (n-1)) . gaProduct'+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' opts f, KnownNat (Arity f)) => GAProduct 'Sized opts f where-  gaProduct _ = scale (`div` arity) . 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 {-# OVERLAPPING #-} GAProduct 'Sized opts U1 where+instance {-# OVERLAPPING #-} GAProduct 'Sized c opts U1 where   gaProduct _ _ = pure U1   {-# INLINE gaProduct #-}  -class GAProduct' opts f where-  gaProduct' :: opts -> Gen (f p)+class GAProduct' (c :: Maybe Symbol) (i :: Nat) opts f where+  gaProduct' :: proxy '(c, i) -> opts -> Gen (f p) -instance GAProduct' opts U1 where-  gaProduct' _ = pure U1+instance GAProduct' c i opts U1 where+  gaProduct' _ _ = pure U1   {-# INLINE gaProduct' #-}  instance   ( HasGenerators opts-  , ArbitraryOr gs gs (SelectorName d) c-  , gs ~ GeneratorsOf opts )-  => GAProduct' opts (S1 d (K1 i c)) where-  gaProduct' opts = fmap (M1 . K1) (arbitraryOr sel gs gs)+  , 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-      sel = Proxy :: Proxy (SelectorName d)+      is = Proxy :: Proxy 'Shift+      s = Proxy :: Proxy ('S gs coh '(c, i, Name d))       gs = generators opts   {-# INLINE gaProduct' #-} -instance (GAProduct' opts f, GAProduct' opts g) => GAProduct' opts (f :*: g) where+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' opts = (liftA2 . liftA2) (:*:) gaProduct' gaProduct' opts+  gaProduct' px = (liftA2 . liftA2) (:*:)+    (gaProduct' px)+    (gaProduct' (Proxy :: Proxy '(c, i + Arity f)))   {-# INLINE gaProduct' #-}  @@ -478,41 +606,160 @@   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 -class ArbitraryOr (fullGenList :: Type) (genList :: Type) (sel :: Maybe Symbol) a where-  arbitraryOr :: proxy sel -> fullGenList -> genList -> Gen a+data AInstr = Shift | Match Coherence | MatchCoh Bool+data AStore = S Type Coherence ASel -instance {-# INCOHERENT #-} ArbitraryOr fg (Gen a :+ g) sel a where-  arbitraryOr _ _ (gen :+ _) = gen-  {-# INLINE arbitraryOr #-}+type ASel = (Maybe Symbol, Nat, Maybe Symbol) -instance {-# OVERLAPPABLE #-} ArbitraryOr fg g sel a => ArbitraryOr fg (b :+ g) sel a where-  arbitraryOr sel fg (_ :+ gens) = arbitraryOr sel fg gens-  {-# INLINE arbitraryOr #-}+iShift :: Proxy 'Shift+iShift = Proxy -instance Arbitrary a => ArbitraryOr fg () sel a where-  arbitraryOr _ _ _ = arbitrary-  {-# INLINE arbitraryOr #-}+type family FullGenListOf (s :: AStore) :: Type where+  FullGenListOf ('S fg _coh _sel) = fg -#if __GLASGOW_HASKELL__ >= 800-instance {-# INCOHERENT #-} ArbitraryOr fg (FieldGen n a :+ g) ('Just n) a where-  arbitraryOr _ _ (FieldGen gen :+ _) = gen-  {-# INLINE arbitraryOr #-}+type family ACoherenceOf (s :: AStore) :: Coherence where+  ACoherenceOf ('S _fg coh _sel) = coh -type family SelectorName (d :: Meta) :: Maybe Symbol-type instance SelectorName ('MetaSel mn su ss ds) = mn-#else-type SelectorName d = (Nothing :: Maybe Symbol)-#endif+type family ASelOf (s :: AStore) :: ASel where+  ASelOf ('S _fg _coh sel) = sel -instance {-# INCOHERENT #-} ArbitraryOr fg (Gen1_ f :+ g) sel (f a) where-  arbitraryOr _ _ (Gen1_ gen :+ _) = gen+-- | All candidates have been exhausted+instance Arbitrary a => FindGen 'Shift s () () a where+  findGen _ _ _ = arbitrary+  {-# INLINEABLE findGen #-} -instance {-# INCOHERENT #-} ArbitraryOr fg fg 'Nothing a-  => ArbitraryOr fg (Gen1 f :+ g) sel (f a) where-  arbitraryOr _ fg (Gen1 gen :+ _) = gen (arbitraryOr noSel fg fg)-    where noSel = Proxy :: Proxy 'Nothing+-- | 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 @@ -520,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
src/Generic/Random/Tutorial.hs view
@@ -11,7 +11,7 @@ --   deriving 'GHC.Generics.Generic' -- @ ----- Pick an 'arbitrary' implementation, specifying the required distribution of+-- Pick an 'Test.QuickCheck.arbitrary' implementation, specifying the required distribution of -- data constructors. -- -- @@@ -19,18 +19,20 @@ --   arbitrary = 'genericArbitrary' (9 '%' 8 '%' ()) -- @ ----- @arbitrary :: 'Gen' (Tree a)@ picks a @Leaf@ with probability 9\/17, or a+-- 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@, 'genericArbitrary' produces code equivalent to the following:+-- 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)+--     [ (x, Leaf '<$>' arbitrary)+--     , (y, Node '<$>' arbitrary '<*>' arbitrary) --     ] -- @ --@@ -38,16 +40,16 @@ -- -- 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 proportional to its weight;+-- 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. The uniform distribution can be obtained with 'uniform'.+-- definition. -- -- == Uniform distribution ----- You can specify the uniform distribution (all weights equal) with 'uniform'.+-- You can specify the uniform distribution (all weights equal to 1) with 'uniform'. -- ('genericArbitraryU' is available as a shorthand for -- @'genericArbitrary' 'uniform'@.) --@@ -56,20 +58,19 @@ -- -- == Typed weights ----- /GHC 8.0.1 and above only (base ≥ 4.9)./--- -- 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.+-- constructor. The constructors must appear in the same order as in the+-- original type definition. ----- This will type-check.+-- This will type-check: -- -- @ -- ((x :: 'W' \"Leaf\") '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) -- ( x              '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) -- @ ----- This will not.+-- This will not: -- -- @ -- ((x :: 'W' \"Node\") '%' y '%' ()) :: 'Weights' (Tree a)@@ -84,15 +85,15 @@ -- 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,--- to be used together with 'withBaseCase'.+-- 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`:+-- 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)+--     ``withBaseCase`` (Leaf '<$>' arbitrary) -- @ -- -- That is equivalent to the following definition. Note the@@ -107,18 +108,18 @@ --   else --     -- genericArbitraryRec --     frequency---       [ (1, resize (max 0 (n - 1)) (Leaf \<$\> arbitrary))---       , (2, resize (n \`div\` 2)     (Node \<$\> arbitrary \<*\> arbitrary))+--       [ (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 'Gen' is divided among the fields of the chosen--- constructor, or decreases by one if the constructor is unary.+-- 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--- close to the initial size parameter passed to 'Gen'.+-- bounded by the initial size parameter passed to 'Test.QuickCheck.Gen'. -- -- == Automatic base case discovery --@@ -151,17 +152,17 @@ -- where the depth of a constructor is defined as @1 + max(0, depths of fields)@, -- e.g., @Leaf ()@ has depth 2. ----- == Note about lists+-- == 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 'arbitrary' without decreasing the size parameter.+-- recursive calls to 'Test.QuickCheck.arbitrary' without decreasing the size parameter. -- Hence, as a default, 'genericArbitraryRec' also detects fields which are--- lists to replace 'arbitrary' with a different generator that divides+-- lists to replace 'Test.QuickCheck.arbitrary' with a different generator that divides -- the size parameter by the length of the list before generating each--- eleement. This uses the customizable mechanism shown in the next section.+-- element. This uses the customizable mechanism shown in the next section. ----- If you really want to use 'arbitrary' for lists in the derived instances,+-- If you really want to use 'Test.QuickCheck.arbitrary' for lists in the derived instances, -- substitute @'genericArbitraryRec'@ with @'genericArbitraryRecG' ()@. -- -- @@@ -174,7 +175,9 @@ -- -- = Custom generators for some fields ----- Sometimes, a few fields may need custom generators instead of 'arbitrary'.+-- == 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.@@ -187,6 +190,8 @@ --   } 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;@@ -195,14 +200,13 @@ --   are big or change often). -- -- Using generic-random, we can declare a (heterogeneous) list of generators to--- be used when generating certain fields (remember to end lists with @()@).+-- be used instead of 'Test.QuickCheck.arbitrary' when generating certain fields. -- -- @--- customGens :: 'FieldGen' "userId" Int ':+' Gen String ':+' ()+-- customGens :: 'FieldGen' "userId" Int ':+' 'Test.QuickCheck.Gen' String -- customGens =---   ('FieldGen' . 'getNonNegative' \<$\> arbitrary) ':+'---   ('listOf' ('elements' (filter isAlphaNum [minBound .. maxBound]))) ':+'---   ()+--   '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@@ -212,24 +216,71 @@ --   alphanumeric strings; -- - the field @"userId"@ of type @Int@ will use the generator --   of nonnegative integers;--- - everything else defaults to 'arbitrary'.+-- - 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 field name and type;--- - 'Gen1': a generator for containers, parameterized by a generator+-- - '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
+ 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
@@ -1,8 +1,11 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE+    DataKinds,+    DeriveGeneric,+    FlexibleContexts,+    FlexibleInstances,+    LambdaCase,+    TypeFamilies,+    UndecidableInstances #-}  import Control.Monad (replicateM) import Control.DeepSeq (NFData, force)@@ -13,6 +16,21 @@  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@@ -20,10 +38,8 @@  instance NFData a => NFData (T a) -f :: Gen (T (T Int))-f = arbitrary -+-- 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@@ -33,14 +49,28 @@  eval :: NFData a => String -> Gen a -> IO () eval name g = do-  x <- timeout (10 ^ 6) $ do-    xs <- replicateM 100 (generate g)+  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 ()))+  ]