generic-random 1.2.0.0 → 1.3.0.0

raw patch · 8 files changed

+430/−144 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• README.md +8/−5
• generic-random.cabal +3/−5
• src/Generic/Random.hs +128/−23
• src/Generic/Random/Internal/BaseCase.hs +17/−3
• src/Generic/Random/Internal/Generic.hs +153/−71
• src/Generic/Random/Tutorial.hs +81/−26
• test/Unit.hs +28/−11

@@ -1,5 +1,16 @@ https://github.com/Lysxia/generic-random/blob/master/changelog.md +# 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 +18,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`

@@ -3,12 +3,14 @@  Derive simple random generators for [QuickCheck](https://hackage.haskell.org/package/QuickCheck) using generics. -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 +44,6 @@ -- >             Node <$> arbitrary <*> arbitrary <*> arbitrary -- >         ] +main :: IO () main = sample (arbitrary :: Gen (Tree ())) ```

@@ -1,5 +1,5 @@ name:                generic-random-version:             1.2.0.0+version:             1.3.0.0 synopsis:            Generic random generators description:     For more information@@ -7,8 +7,6 @@     - "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@@ -20,7 +18,7 @@ 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 == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.1, GHC == 8.4.1, GHC == 8.6.1  library   hs-source-dirs:      src@@ -30,7 +28,7 @@     Generic.Random.Internal.Generic     Generic.Random.Tutorial   build-depends:-    base >= 4.7 && < 4.12,+    base >= 4.7 && < 5,     QuickCheck   default-language:    Haskell2010   ghc-options: -Wall -fno-warn-name-shadowing

@@ -1,66 +1,171 @@--- | Simple "GHC.Generics"-based 'arbitrary' generators.+-- | "GHC.Generics"-based 'Test.QuickCheck.arbitrary' generators. --+-- = Basic usage+--+-- @+-- 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+-- @+--+-- Or derive standalone generators (the fields must still be instances of+-- 'Test.QuickCheck.Arbitrary', or use custom generators).+--+-- @+-- genFoo :: Gen Foo+-- genFoo = 'genericArbitrary' 'uniform'+-- @+-- -- 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 #-}  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 -    -- * Full options-  , Options ()-  , SizedOpts-  , sizedOpts-  , SizedOptsDef-  , sizedOptsDef-  , UnsizedOpts-  , unsizedOpts-  , Sizing (..)-  , setSized-  , setUnsized+    -- * Custom generators   , (:+) (..) #if __GLASGOW_HASKELL__ >= 800   , FieldGen (..)   , fieldGen+  , ConstrGen (..)+  , constrGen #endif   , Gen1 (..)   , Gen1_ (..)-  , setGenerators -    -- * Public classes-  , GArbitrary-  , GUniformWeight-     -- * Helpful combinators   , listOf'   , listOf1'   , vectorOf'++    -- * Base cases for recursive types+  , withBaseCase+  , BaseCase (..)++    -- * Full options+  , Options ()+  , genericArbitraryWith++    -- ** Size modifiers+  , Sizing (..)+  , setSized+  , setUnsized++    -- ** Custom generators+  , SetGens+  , setGenerators++    -- ** Common options+  , SizedOpts+  , sizedOpts+  , SizedOptsDef+  , sizedOptsDef+  , UnsizedOpts+  , unsizedOpts++    -- * Generic classes+  , GArbitrary+  , GUniformWeight+   ) where  import Generic.Random.Internal.BaseCase

@@ -17,6 +17,16 @@ {-# 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@@ -37,7 +47,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 +58,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

@@ -19,6 +19,16 @@ {-# 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@@ -31,9 +41,9 @@ #endif import Data.Proxy (Proxy(..)) #if __GLASGOW_HASKELL__ >= 800-import GHC.Generics hiding (S)+import GHC.Generics hiding (S, prec) #else-import GHC.Generics hiding (S, Arity)+import GHC.Generics hiding (S, Arity, prec) #endif import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), natVal) import Test.QuickCheck (Arbitrary(..), Gen, choose, scale, sized, vectorOf)@@ -82,7 +92,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@@ -98,17 +110,17 @@ -- where, for example to override generators for 'String' and 'Int' fields, -- -- @--- 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+-- (i.e., either @a@ or @'FieldGen' "x" a@), the generator for the first -- match will be picked. genericArbitraryG   :: (GArbitrary (SetGens genList UnsizedOpts) a)@@ -155,7 +167,7 @@  -- * 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@@ -190,6 +202,9 @@ -- @ -- ((9 :: 'W' \"Leaf\") '%' (8 :: 'W' \"Node\") '%' ()) -- @+--+-- Note: these annotations are only checked on GHC 8.0 or newer. They are+-- ignored on older GHCs. newtype W (c :: Symbol) = W Int deriving Num  -- | A smart constructor to specify a custom distribution.@@ -216,10 +231,20 @@   Prec' (Weights a) = Prec (Weights_ (Rep a)) ()   Prec' (a, Int, r) = Prec a r +-- | A synonym for @(~)@, except on GHC 7.10 and older, where it's the trivial+-- constraint. See note on 'W'.+#if __GLASGOW_HASKELL__ >= 800+class (a ~ b) => a ~. b+instance (a ~ b) => a ~. b+#else+class a ~. b+instance a ~. b+#endif+ 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 +255,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 % @@ -286,7 +311,7 @@ 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' :+ ()) @@ -301,9 +326,6 @@ type family SizingOf opts :: Sizing type instance SizingOf (Options s _g) = s -proxySizing :: opts -> Proxy (SizingOf opts)-proxySizing _ = Proxy- setSized :: Options s g -> Options 'Sized g setSized = coerce @@ -333,21 +355,37 @@ type instance SetGens g (Options s _g) = Options 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@./+-- /Available only for @base >= 4.9@ (@GHC >= 8.0.1@)./ 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++-- | Custom generator for the @i@-th field of the constructor named @c@.+--+-- /Available only for @base >= 4.9@ (@GHC >= 8.0.1@)./+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 #endif --- | Generators for containers of kind @* -> *@, parameterized by--- the generator for each element.+-- | 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@. 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@@ -356,8 +394,8 @@ 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 +403,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 +441,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 +460,57 @@     | 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+  , ArbitraryOr gs () gs '(c, i, Name d) a   , gs ~ GeneratorsOf opts )-  => GAProduct' opts (S1 d (K1 i c)) where-  gaProduct' opts = fmap (M1 . K1) (arbitraryOr sel gs gs)+  => GAProduct' c i opts (S1 d (K1 _k a)) where+  gaProduct' _ opts = fmap (M1 . K1) (arbitraryOr sel gs () gs)     where-      sel = Proxy :: Proxy (SelectorName d)+      sel = Proxy :: Proxy '(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,40 +518,82 @@   Arity (f :*: g) = Arity f + Arity g   Arity (M1 _i _c _f) = 1 --class ArbitraryOr (fullGenList :: Type) (genList :: Type) (sel :: Maybe Symbol) a where-  arbitraryOr :: proxy sel -> fullGenList -> genList -> Gen a+-- | Given a list of custom generators @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 :+ h,      gs | g, h :+ gs+-- >       Gen a,      gs | END if matching, else (), gs+-- >  FieldGen a,      gs | idem+-- > ConstrGen a,      gs | idem+-- >      Gen1 a,      gs | idem+-- >     Gen1_ a,      gs | idem+class ArbitraryOr (fullGenList :: Type) (g :: Type) (gs :: Type)+        (sel :: (Maybe Symbol, Nat, Maybe Symbol)) a where+  arbitraryOr :: proxy sel -> fullGenList -> g -> gs -> Gen a -instance {-# INCOHERENT #-} ArbitraryOr fg (Gen a :+ g) sel a where-  arbitraryOr _ _ (gen :+ _) = gen+-- | All candidates have been exhausted+instance Arbitrary a => ArbitraryOr fg () () sel a where+  arbitraryOr _ _ _ _ = arbitrary   {-# INLINE arbitraryOr #-} -instance {-# OVERLAPPABLE #-} ArbitraryOr fg g sel a => ArbitraryOr fg (b :+ g) sel a where-  arbitraryOr sel fg (_ :+ gens) = arbitraryOr sel fg gens+-- | Examine the next candidate+instance ArbitraryOr fg b g sel a => ArbitraryOr fg () (b :+ g) sel a where+  arbitraryOr sel fg () (b :+ gens) = arbitraryOr sel fg b gens   {-# INLINE arbitraryOr #-} -instance Arbitrary a => ArbitraryOr fg () sel a where-  arbitraryOr _ _ _ = arbitrary+-- | Examine the last candidate (@g@ is not of the form @_ :+ _@)+instance {-# OVERLAPS #-} ArbitraryOr fg g () sel a => ArbitraryOr fg () g sel a where+  arbitraryOr sel fg () g = arbitraryOr sel fg g ()++-- | This can happen if the generators form a tree rather than a list, for whatever reason.+instance ArbitraryOr fg g (h :+ gs) sel a => ArbitraryOr fg (g :+ h) gs sel a where+  arbitraryOr sel fg (g :+ h) gs = arbitraryOr sel fg g (h :+ gs)++-- | None of the INCOHERENT instances match, discard the candidate @g@ and look+-- at the rest of the list @gs@.+instance {-# OVERLAPPABLE #-} ArbitraryOr fg () gs sel a => ArbitraryOr fg g gs sel a where+  arbitraryOr sel fg _ = arbitraryOr sel fg ()++-- | Matching custom generator for @a@.+instance {-# INCOHERENT #-} ArbitraryOr fg (Gen a) g sel a where+  arbitraryOr _ _ gen _ = gen   {-# INLINE arbitraryOr #-}  #if __GLASGOW_HASKELL__ >= 800-instance {-# INCOHERENT #-} ArbitraryOr fg (FieldGen n a :+ g) ('Just n) a where-  arbitraryOr _ _ (FieldGen gen :+ _) = gen+-- | Matching custom generator for field @s@.+instance {-# INCOHERENT #-} (a ~ a') => ArbitraryOr fg (FieldGen s a) g '(con, i, 'Just s) a' where+  arbitraryOr _ _ (FieldGen gen) _ = gen   {-# INLINE arbitraryOr #-} -type family SelectorName (d :: Meta) :: Maybe Symbol-type instance SelectorName ('MetaSel mn su ss ds) = mn+-- | Matching custom generator for @i@-th field of constructor @c@.+instance {-# INCOHERENT #-} (a ~ a') => ArbitraryOr fg (ConstrGen c i a) g '( 'Just c, i, s) a' where+  arbitraryOr _ _ (ConstrGen gen) _ = gen+  {-# INLINE arbitraryOr #-}++-- | 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 #else-type SelectorName d = (Nothing :: Maybe Symbol)+type Name d = (Nothing :: Maybe Symbol) #endif -instance {-# INCOHERENT #-} ArbitraryOr fg (Gen1_ f :+ g) sel (f a) where-  arbitraryOr _ _ (Gen1_ gen :+ _) = gen+-- | Matching custom generator for non-container @f@+instance {-# INCOHERENT #-} ArbitraryOr fg (Gen1_ f) g sel (f a) where+  arbitraryOr _ _ (Gen1_ gen) _ = gen -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+-- | Matching custom generator for container @f@. Start the search for containee @a@,+-- discarding field information.+instance {-# INCOHERENT #-} ArbitraryOr fg () fg '( 'Nothing, 0, '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, 0, 'Nothing)  newtype Weighted a = Weighted (Maybe (Int -> Gen a, Int))   deriving Functor@@ -520,10 +602,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

@@ -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,7 +19,7 @@ --   arbitrary = 'genericArbitrary' (9 '%' 8 '%' ()) -- @ ----- @arbitrary :: 'Gen' (Tree a)@ picks a @Leaf@ with probability 9\/17, or a+-- @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@. --@@ -29,8 +29,8 @@ -- '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) --     ] -- @ --@@ -56,11 +56,13 @@ -- -- == Typed weights ----- /GHC 8.0.1 and above only (base ≥ 4.9)./+-- /GHC 8.0.1 and above only (base ≥ 4.9)./ For compatibility, the annotations+-- are still allowed on older GHC versions, but ignored. -- -- 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. --@@ -87,12 +89,12 @@ -- parameter at every call to keep values at reasonable sizes, -- 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 +109,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 --@@ -155,13 +157,13 @@ -- -- 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 +176,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 +191,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 +201,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 +217,74 @@ --   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.>++{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-unused-imports #-}+#endif  module Generic.Random.Tutorial () where 

@@ -1,8 +1,12 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE+    CPP,+    DataKinds,+    DeriveGeneric,+    FlexibleContexts,+    FlexibleInstances,+    LambdaCase,+    TypeFamilies,+    UndecidableInstances #-}  import Control.Monad (replicateM) import Control.DeepSeq (NFData, force)@@ -20,10 +24,6 @@  instance NFData a => NFData (T a) -f :: Gen (T (T Int))-f = arbitrary-- data NTree = Leaf | Node [NTree] deriving (Generic, Show)  instance Arbitrary NTree where@@ -33,14 +33,31 @@  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" +#if __GLASGOW_HASKELL__ >= 800+-- 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+#endif+ main :: IO () main = do   eval "T" (arbitrary :: Gen (T (T Int)))   eval "NTree" (arbitrary :: Gen NTree)+#if __GLASGOW_HASKELL__ >= 800+  quickCheck . whenFail (putStrLn "Tree2") $ isLeftBiased+#endif