generic-random 1.1.0.2 → 1.2.0.0

raw patch · 8 files changed

+273/−161 lines, 8 filesdep +deepseqdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−0
• generic-random.cabal +4/−4
• src/Generic/Random.hs +12/−3
• src/Generic/Random/Generic.hs +0/−7
• src/Generic/Random/Internal/BaseCase.hs +6/−2
• src/Generic/Random/Internal/Generic.hs +114/−45
• src/Generic/Random/Tutorial.hs +94/−89
• test/Unit.hs +28/−11

@@ -1,5 +1,20 @@ https://github.com/Lysxia/generic-random/blob/master/changelog.md +# 1.2.0.0++- Fix a bug where generators did not decrease the size parameter with+  single-field constructors++- The sized generators now use a custom generator for lists.+  Use `genericArbitraryRecG ()` to disable that.++- Lists of custom generators are now constructed using `(:+)` instead of+  `GenList`+- Rename `Field` to `FieldGen`+- Add `Gen1`, `Gen1_` (custom generators for unary type constructors)+- Add `listOf'`, `listOf1'`, `vectorOf'`+- Remove deprecated module `Generic.Random.Generic`+ # 1.1.0.2  - Improved performance

@@ -1,5 +1,5 @@ name:                generic-random-version:             1.1.0.2+version:             1.2.0.0 synopsis:            Generic random generators description:     For more information@@ -20,18 +20,17 @@ build-type:          Simple extra-source-files:  README.md CHANGELOG.md cabal-version:       >=1.10-tested-with:         GHC == 8.0.1, GHC == 8.2.1+tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.1, GHC == 8.4.1  library   hs-source-dirs:      src   exposed-modules:     Generic.Random-    Generic.Random.Generic     Generic.Random.Internal.BaseCase     Generic.Random.Internal.Generic     Generic.Random.Tutorial   build-depends:-    base >= 4.7 && < 4.11,+    base >= 4.7 && < 4.12,     QuickCheck   default-language:    Haskell2010   ghc-options: -Wall -fno-warn-name-shadowing@@ -45,6 +44,7 @@   Main-is:         Unit.hs   Build-depends:       base,+      deepseq,       QuickCheck,       generic-random   Type: exitcode-stdio-1.0

@@ -37,21 +37,30 @@   , Options ()   , SizedOpts   , sizedOpts+  , SizedOptsDef+  , sizedOptsDef   , UnsizedOpts   , unsizedOpts   , Sizing (..)   , setSized   , setUnsized-  , GenList (..)+  , (:+) (..) #if __GLASGOW_HASKELL__ >= 800-  , Field (..)-  , field+  , FieldGen (..)+  , fieldGen #endif+  , Gen1 (..)+  , Gen1_ (..)   , setGenerators      -- * Public classes   , GArbitrary   , GUniformWeight++    -- * Helpful combinators+  , listOf'+  , listOf1'+  , vectorOf'   ) where  import Generic.Random.Internal.BaseCase

@@ -1,7 +0,0 @@--- | Reexport of "Generic.Random", for backwards-compatibility.--module Generic.Random.Generic-       {-# DEPRECATED "Use Generic.Random instead" #-}-       ( module Generic.Random ) where--import Generic.Random

@@ -36,8 +36,10 @@ -- recursive types, looking for base cases once the size reaches 0. -- -- > genericArbitrary' (17 % 19 % 23 % ()) :: Gen a+--+-- N.B.: This replaces fields of type @[t]@ with @'listOf'' arbitrary@. genericArbitrary'-  :: (GArbitrary SizedOpts a, BaseCase a)+  :: (GArbitrary SizedOptsDef a, BaseCase a)   => Weights a  -- ^ List of weights for every constructor   -> Gen a genericArbitrary' w = genericArbitraryRec w `withBaseCase` baseCase@@ -45,8 +47,10 @@ -- | Equivalent to @'genericArbitrary'' 'uniform'@. -- -- > genericArbitraryU :: Gen a+--+-- N.B.: This replaces fields of type @[t]@ with @'listOf'' arbitrary@. genericArbitraryU'-  :: (GArbitrary SizedOpts a, BaseCase a, GUniformWeight a)+  :: (GArbitrary SizedOptsDef a, BaseCase a, GUniformWeight a)   => Gen a genericArbitraryU' = genericArbitrary' uniform 

@@ -8,6 +8,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}@@ -34,7 +36,7 @@ import GHC.Generics hiding (S, Arity) #endif import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), natVal)-import Test.QuickCheck (Arbitrary(..), Gen, choose, resize, sized)+import Test.QuickCheck (Arbitrary(..), Gen, choose, scale, sized, vectorOf)  #if __GLASGOW_HASKELL__ < 800 #define Type *@@ -79,11 +81,13 @@ -- at size 0. -- -- > genericArbitraryRec (7 % 11 % 13 % ()) :: Gen a+--+-- N.B.: This replaces fields of type @[t]@ with @'listOf'' arbitrary@. genericArbitraryRec-  :: (GArbitrary SizedOpts a)+  :: (GArbitrary SizedOptsDef a)   => Weights a  -- ^ List of weights for every constructor   -> Gen a-genericArbitraryRec = genericArbitraryWith sizedOpts+genericArbitraryRec = genericArbitraryWith sizedOptsDef  -- | 'genericArbitrary' with explicit generators. --@@ -107,8 +111,8 @@ -- (i.e., either @a@ or @'Field' "x" a@), the generator for the first -- match will be picked. genericArbitraryG-  :: (GArbitrary (SetGens g UnsizedOpts) a)-  => GenList g+  :: (GArbitrary (SetGens genList UnsizedOpts) a)+  => genList   -> Weights a   -> Gen a genericArbitraryG gs = genericArbitraryWith opts@@ -118,24 +122,24 @@ -- | 'genericArbitraryU' with explicit generators. -- See also 'genericArbitraryG'. genericArbitraryUG-  :: (GArbitrary (SetGens g UnsizedOpts) a, GUniformWeight a)-  => GenList g+  :: (GArbitrary (SetGens genList UnsizedOpts) a, GUniformWeight a)+  => genList   -> Gen a genericArbitraryUG gs = genericArbitraryG gs uniform  -- | 'genericArbitrarySingle' with explicit generators. -- See also 'genericArbitraryG'. genericArbitrarySingleG-  :: (GArbitrary (SetGens g UnsizedOpts) a, Weights_ (Rep a) ~ L c0)-  => GenList g+  :: (GArbitrary (SetGens genList UnsizedOpts) a, Weights_ (Rep a) ~ L c0)+  => genList   -> Gen a genericArbitrarySingleG = genericArbitraryUG  -- | 'genericArbitraryRec' with explicit generators. -- See also 'genericArbitraryG'. genericArbitraryRecG-  :: (GArbitrary (SetGens g SizedOpts) a)-  => GenList g+  :: (GArbitrary (SetGens genList SizedOpts) a)+  => genList   -> Weights a  -- ^ List of weights for every constructor   -> Gen a genericArbitraryRecG gs = genericArbitraryWith opts@@ -270,22 +274,29 @@   -- | Type-level options for 'GArbitrary'.-newtype Options (s :: Sizing) (g :: [Type]) = Options-  { _generators :: GenList g+newtype Options (s :: Sizing) (genList :: Type) = Options+  { _generators :: genList   } +-- | Default options for unsized generators. unsizedOpts :: UnsizedOpts-unsizedOpts = Options Nil+unsizedOpts = Options () +-- | Default options for sized generators. sizedOpts :: SizedOpts-sizedOpts = Options Nil+sizedOpts = Options () +-- | Default options overriding the list generator using `listOf'`.+sizedOptsDef :: SizedOptsDef+sizedOptsDef = Options (Gen1 listOf' :+ ()) + -- | Whether to decrease the size parameter before generating fields. data Sizing = Sized | Unsized -type UnsizedOpts = (Options 'Unsized '[] :: Type)-type SizedOpts = (Options 'Sized '[] :: Type)+type UnsizedOpts = Options 'Unsized ()+type SizedOpts = Options 'Sized ()+type SizedOptsDef = Options 'Sized (Gen1 [] :+ ())  type family SizingOf opts :: Sizing type instance SizingOf (Options s _g) = s@@ -300,41 +311,82 @@ setUnsized = coerce  -- | Heterogeneous list of generators.-data GenList (g :: [Type]) where-  Nil :: GenList '[]-  (:@) :: Gen a -> GenList g -> GenList (a ': g)+data a :+ b = a :+ b -infixr 3 :@+infixr 1 :+ -type family GeneratorsOf opts :: [Type]++type family GeneratorsOf opts :: Type type instance GeneratorsOf (Options _s g) = g  class HasGenerators opts where-  generators :: opts -> GenList (GeneratorsOf opts)+  generators :: opts -> GeneratorsOf opts  instance HasGenerators (Options s g) where   generators = _generators -setGenerators :: GenList g -> Options s g0 -> Options s g+setGenerators :: genList -> Options s g0 -> Options s genList setGenerators gens (Options _) = Options gens  -type family SetGens (g :: [Type]) opts+type family SetGens (g :: Type) opts type instance SetGens g (Options s _g) = Options s g  #if __GLASGOW_HASKELL__ >= 800--- | A marker for a generator which overrides a specific field--- named @s@.+-- | A generator which overrides a specific field named @s@. -- -- /Available only for @base >= 4.9@./-newtype Field (s :: Symbol) a = Field { unField :: a }+newtype FieldGen (s :: Symbol) a = FieldGen { unFieldGen :: Gen a }  -- | 'Field' constructor with the field name given via a proxy.-field :: proxy s -> a -> Field s a-field _ = Field+fieldGen :: proxy s -> Gen a -> FieldGen s a+fieldGen _ = FieldGen #endif +-- | Generators for containers of kind @* -> *@, parameterized by+-- the generator for each element.+newtype Gen1 f = Gen1 { unGen1 :: forall a. Gen a -> Gen (f a) } +-- | Generators for unary type constructors that are not containers.+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.+-- The length follows a geometric distribution of parameter+-- @1/(sqrt size + 1)@.+listOf' :: Gen a -> Gen [a]+listOf' g = sized $ \n -> do+  i <- geom n+  vectorOf' i g++-- | An alternative to 'listOf1' (nonempty lists) that divides the size+-- parameter by the length of the list.+-- The length (minus one) follows a geometric distribution of parameter+-- @1/(sqrt size + 1)@.+listOf1' :: Gen a -> Gen [a]+listOf1' g = liftA2 (:) g (listOf' g)++-- | Geometric distribution of parameter @1/(sqrt n + 1)@ (@n >= 0@).+geom :: Int -> Gen Int+geom 0 = pure 0+geom n = go 0 where+  n' = fromIntegral n+  p = 1 / (sqrt n' + 1) :: Double+  go r = do+    x <- choose (0, 1)+    if x < p then+      pure r+    else+      go $! (r + 1)++---+ -- | Generic Arbitrary class GA opts f where   ga :: opts -> Weights_ f -> Int -> Gen (f p)@@ -382,8 +434,13 @@   gaProduct _ = gaProduct'   {-# 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 (GAProduct' opts f, KnownNat (Arity f)) => GAProduct 'Sized opts f where-  gaProduct _ opts = sized $ \n -> resize (n `div` arity) (gaProduct' opts)+  gaProduct _ = scale (`div` arity) . gaProduct'     where       arity = fromInteger (natVal (Proxy :: Proxy (Arity f)))   {-# INLINE gaProduct #-}@@ -400,10 +457,15 @@   gaProduct' _ = pure U1   {-# INLINE gaProduct' #-} -instance (HasGenerators opts, ArbitraryOr (GeneratorsOf opts) (SelectorName d) c)+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 (generators opts))-    where sel = Proxy :: Proxy (SelectorName d)+  gaProduct' opts = fmap (M1 . K1) (arbitraryOr sel gs gs)+    where+      sel = Proxy :: Proxy (SelectorName d)+      gs = generators opts   {-# INLINE gaProduct' #-}  instance (GAProduct' opts f, GAProduct' opts g) => GAProduct' opts (f :*: g) where@@ -417,32 +479,39 @@   Arity (M1 _i _c _f) = 1  -class ArbitraryOr (g :: [Type]) (sel :: Maybe Symbol) a where-  arbitraryOr :: proxy sel -> GenList g -> Gen a+class ArbitraryOr (fullGenList :: Type) (genList :: Type) (sel :: Maybe Symbol) a where+  arbitraryOr :: proxy sel -> fullGenList -> genList -> Gen a -instance {-# INCOHERENT #-} ArbitraryOr (a ': g) sel a where-  arbitraryOr _ (gen :@ _) = gen+instance {-# INCOHERENT #-} ArbitraryOr fg (Gen a :+ g) sel a where+  arbitraryOr _ _ (gen :+ _) = gen   {-# INLINE arbitraryOr #-} -instance {-# OVERLAPPABLE #-} ArbitraryOr g sel a => ArbitraryOr (b ': g) sel a where-  arbitraryOr sel (_ :@ gens) = arbitraryOr sel gens+instance {-# OVERLAPPABLE #-} ArbitraryOr fg g sel a => ArbitraryOr fg (b :+ g) sel a where+  arbitraryOr sel fg (_ :+ gens) = arbitraryOr sel fg gens   {-# INLINE arbitraryOr #-} -instance Arbitrary a => ArbitraryOr '[] sel a where-  arbitraryOr _ _ = arbitrary+instance Arbitrary a => ArbitraryOr fg () sel a where+  arbitraryOr _ _ _ = arbitrary   {-# INLINE arbitraryOr #-}  #if __GLASGOW_HASKELL__ >= 800-instance {-# INCOHERENT #-} ArbitraryOr (Field n a ': g) ('Just n) a where-  arbitraryOr _ (gen :@ _) = coerce gen+instance {-# INCOHERENT #-} ArbitraryOr fg (FieldGen n a :+ g) ('Just n) a where+  arbitraryOr _ _ (FieldGen gen :+ _) = gen   {-# INLINE arbitraryOr #-}  type family SelectorName (d :: Meta) :: Maybe Symbol-type instance SelectorName (MetaSel mn su ss ds) = mn+type instance SelectorName ('MetaSel mn su ss ds) = mn #else type SelectorName d = (Nothing :: Maybe Symbol) #endif +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  newtype Weighted a = Weighted (Maybe (Int -> Gen a, Int))   deriving Functor

@@ -2,13 +2,13 @@ -- [QuickCheck](https://hackage.haskell.org/package/QuickCheck)'s -- @arbitrary@. ----- == Example+-- = Example -- -- Define your type. -- -- @ -- data Tree a = Leaf a | Node (Tree a) (Tree a)---   deriving 'Generic'+--   deriving 'GHC.Generics.Generic' -- @ -- -- Pick an 'arbitrary' implementation, specifying the required distribution of@@ -16,7 +16,7 @@ -- -- @ -- instance Arbitrary a => Arbitrary (Tree a) where---   arbitrary = 'genericArbitrary' (8 '%' 9 '%' ())+--   arbitrary = 'genericArbitrary' (9 '%' 8 '%' ()) -- @ -- -- @arbitrary :: 'Gen' (Tree a)@ picks a @Leaf@ with probability 9\/17, or a@@ -34,7 +34,7 @@ --     ] -- @ ----- == Distribution of constructors+-- = Distribution of constructors -- -- The distribution of constructors can be specified as -- a special list of /weights/ in the same order as the data type definition.@@ -45,7 +45,7 @@ -- the unit @()@ as the empty list, in the order corresponding to the data type -- definition. The uniform distribution can be obtained with 'uniform'. ----- === Uniform distribution+-- == Uniform distribution -- -- You can specify the uniform distribution (all weights equal) with 'uniform'. -- ('genericArbitraryU' is available as a shorthand for@@ -54,7 +54,7 @@ -- Note that for many recursive types, a uniform distribution tends to produce -- big or even infinite values. ----- === Typed weights+-- == Typed weights -- -- /GHC 8.0.1 and above only (base ≥ 4.9)./ --@@ -66,7 +66,7 @@ -- -- @ -- ((x :: 'W' \"Leaf\") '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a)--- (x '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a)+-- ( x              '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) -- @ -- -- This will not.@@ -75,113 +75,107 @@ -- ((x :: 'W' \"Node\") '%' y '%' ()) :: 'Weights' (Tree a) -- -- Requires an order of constructors different from the definition of the @Tree@ type. ----- (x '%' y '%' z '%' ()) :: 'Weights' (Tree a)+-- ( x              '%' y '%' z '%' ()) :: 'Weights' (Tree a) -- -- Doesn't have the right number of weights. -- @ ----- == Ensuring termination+-- = Ensuring termination -- -- As mentioned earlier, one must be careful with recursive types -- to avoid producing extremely large values.+-- The alternative generator 'genericArbitraryRec' decreases the size+-- parameter at every call to keep values at reasonable sizes,+-- to be used together with 'withBaseCase'. ----- The alternative generator 'genericArbitrary'' implements a simple strategy to keep--- values at reasonable sizes: the size parameter of 'Gen' is divided among the--- fields of the chosen constructor. When it reaches zero, the generator--- selects a small term of the given type. This generally ensures that the--- number of constructors remains close to the initial size parameter passed to--- 'Gen'.+-- For example, we may provide a base case consisting of only `Leaf`: -- -- @--- 'genericArbitrary'' (x1 '%' ... '%' xn '%' ())+-- instance Arbitrary a => Arbitrary (Tree a) where+--   arbitrary = 'genericArbitraryRec' (1 '%' 2 '%' ())+--     ``withBaseCase`` (Leaf \<$\> arbitrary) -- @ ----- Here is an example with nullary constructors:+-- That is equivalent to the following definition. Note the+-- 'Test.QuickCheck.resize' modifier. -- -- @--- data Bush = Leaf1 | Leaf2 | Node3 Bush Bush Bush---   deriving Generic------ instance Arbitrary Bush where---   arbitrary = 'genericArbitrary'' (1 '%' 2 '%' 3 '%' ())+-- arbitrary :: Arbitrary a => Gen (Tree a)+-- arbitrary = sized $ \\n ->+--   -- "if" condition from withBaseCase+--   if n == 0 then+--     Leaf \<$\> arbitrary+--   else+--     -- genericArbitraryRec+--     frequency+--       [ (1, resize (max 0 (n - 1)) (Leaf \<$\> arbitrary))+--       , (2, resize (n \`div\` 2)     (Node \<$\> arbitrary \<*\> arbitrary))+--       ] -- @ ----- Here, 'genericArbitrary'' is equivalent to:+-- 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.+-- @'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'. ----- @--- 'genericArbitrary'' :: 'Weights' Bush -> Gen Bush--- 'genericArbitrary'' (x '%' y '%' z '%' ()) =---   sized $ \\n ->---     if n == 0 then---       -- If the size parameter is zero, only nullary alternatives are kept.---       elements [Leaf1, Leaf2]---     else---       frequency---         [ (x, return Leaf1)---         , (y, return Leaf2)---         , (z, resize (n \`div\` 3) node)  -- 3 because Node3 is 3-ary---         ]---   where---     node = Node3 \<$\> arbitrary \<*\> arbitrary \<*\> arbitrary--- @+-- == Automatic base case discovery ----- If we want to generate a value of type @Tree ()@, there is a--- value of depth 1 that we can use to end recursion: @Leaf ()@.+-- In some situations, generic-random can also construct base cases automatically.+-- This works best with fully concrete types (no type parameters). -- -- @--- 'genericArbitrary'' :: 'Weights' (Tree ()) -> Gen (Tree ())--- 'genericArbitrary'' (x '%' y '%' ()) =---   sized $ \\n ->---     if n == 0 then---       return (Leaf ())---     else---       frequency---         [ (x, Leaf \<$\> arbitrary)---         , (y, resize (n \`div\` 2) $ Node \<$\> arbitrary \<*\> arbitrary)---         ]+-- {-\# LANGUAGE FlexibleInstances #-}+--+-- instance Arbitrary (Tree ()) where+--   arbitrary = 'genericArbitrary'' (1 '%' 2 '%' ()) -- @ ----- Because the argument of @Tree@ must be inspected in order to discover--- values of type @Tree ()@, we incur some extra constraints if we want--- polymorphism.+-- The above instance will infer the value @Leaf ()@ as a base case. --+-- To discover values of type @Tree a@, we must inspect the type argument @a@,+-- thus we incur some extra constraints if we want polymorphism.+-- It is preferrable to apply the type class 'BaseCase' to the instance head+-- (@Tree a@) as follows, as it doesn't reduce to something worth seeing.+-- -- @ -- {-\# LANGUAGE FlexibleContexts, UndecidableInstances \#-} ----- instance (Arbitrary a, BaseCase (Tree a))+-- instance (Arbitrary a, 'BaseCase' (Tree a)) --   => Arbitrary (Tree a) where --   arbitrary = 'genericArbitrary'' (1 '%' 2 '%' ()) -- @ ----- By default, the 'BaseCase' type class looks for all values of minimal depth--- (constructors have depth @1 + max(0, depths of fields)@).------ This can easily be overriden by declaring a specialized 'BaseCase' instance,--- such as this one:+-- The 'BaseCase' type class finds values of minimal depth,+-- where the depth of a constructor is defined as @1 + max(0, depths of fields)@,+-- e.g., @Leaf ()@ has depth 2. ----- @--- instance Arbitrary a => 'BaseCase' (Tree a) where---   'baseCase' = oneof [leaf, simpleNode]---     where---       leaf = Leaf \<$\> arbitrary---       simpleNode = Node \<$\> leaf \<*\> leaf--- @+-- == Note about lists ----- An alternative base case can also be specified directly in the `arbitrary`--- definition with the 'withBaseCase' combinator.+-- 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.+-- Hence, as a default, 'genericArbitraryRec' also detects fields which are+-- lists to replace '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. ----- 'genericArbitraryRec' is a variant of 'genericArbitrary'' with no base case.+-- If you really want to use 'arbitrary' for lists in the derived instances,+-- substitute @'genericArbitraryRec'@ with @'genericArbitraryRecG' ()@. -- -- @--- instance Arbitrary Bush where---   arbitrary =---     'genericArbitraryRec' (1 '%' 2 '%' 3 '%' ())---       \`withBaseCase\` return Leaf1+-- arbitrary = 'genericArbitraryRecG' ()+--   ``withBaseCase`` baseGen -- @ ----- == Custom generators for some fields+-- Some combinators are available for further tweaking: 'listOf'', 'listOf1'',+-- 'vectorOf''. --+-- = Custom generators for some fields+-- -- Sometimes, a few fields may need custom generators instead of 'arbitrary'.--- For example, imagine here that String is meant to represent+-- 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. --@@ -190,42 +184,53 @@ --   userName :: String, --   userId :: Int, --   userBalance :: Int---   } deriving 'Generic'+--   } deriving 'GHC.Generics.Generic' -- @ ----- - @'Arbitrary' String@ may generate any unicode characters,+-- - @'Test.QuickCheck.Arbitrary' String@ may generate any unicode character, --   alphanumeric or not;--- - @'Arbitrary' Int@ may generate negative values;+-- - @'Test.QuickCheck.Arbitrary' Int@ may generate negative values; -- - using @newtype@ wrappers or passing generators explicitly to properties --   may be impractical (the maintenance overhead can be high because the types --   are big or change often). ----- Using generic-random, the alternative is to declare a (heterogeneous) list--- of generators to be used when generating certain fields...+-- Using generic-random, we can declare a (heterogeneous) list of generators to+-- be used when generating certain fields (remember to end lists with @()@). -- -- @--- customGens :: 'GenList' '['Field' "userId" Int, String]+-- customGens :: 'FieldGen' "userId" Int ':+' Gen String ':+' () -- customGens =---   ('Field' . 'getNonNegative' \<$\> arbitrary) ':@'---   ('listOf' ('elements' (filter isAlphaNum [minBound .. maxBound]))) ':@'---   'Nil'+--   ('FieldGen' . 'getNonNegative' \<$\> arbitrary) ':+'+--   ('listOf' ('elements' (filter isAlphaNum [minBound .. maxBound]))) ':+'+--   () -- @ ----- And to use the 'genericArbitraryG' and variants that accept those explicit--- generators.+-- Now we use the 'genericArbitraryG' combinator and other @G@-suffixed+-- variants that accept those explicit generators. -- -- - All @String@ fields will use the provided generator of --   alphanumeric strings; -- - the field @"userId"@ of type @Int@ will use the generator---   of nonnegative integers (the 'Field' type is special);+--   of nonnegative integers; -- - everything else defaults to 'arbitrary'. -- -- @ -- instance Arbitrary User where --   arbitrary = 'genericArbitrarySingleG' customGens -- @+--+-- 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+--   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.>  module Generic.Random.Tutorial () where -import GHC.Generics import Generic.Random

@@ -1,29 +1,46 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif -import GHC.Generics+import Control.Monad (replicateM)+import Control.DeepSeq (NFData, force)+import GHC.Generics (Generic)+import System.Timeout (timeout)+ import Test.QuickCheck -import Generic.Random.Generic+import Generic.Random  newtype T a = W a deriving (Generic, Show)  instance (Arbitrary a, BaseCase (T a)) => Arbitrary (T a) where   arbitrary = genericArbitrary' uniform +instance NFData a => NFData (T a)+ f :: Gen (T (T Int)) f = arbitrary ++data NTree = Leaf | Node [NTree] deriving (Generic, Show)++instance Arbitrary NTree where+  arbitrary = genericArbitraryU'++instance NFData NTree++eval :: NFData a => String -> Gen a -> IO ()+eval name g = do+  x <- timeout (10 ^ 6) $ do+    xs <- replicateM 100 (generate g)+    return $! force xs+  case x of+    Just _ -> return ()+    Nothing -> fail $ name ++ ": did not finish on time"+ main :: IO ()-main = sample' f >>= force-  where-    force [] = return ()-    force (x : xs) = x `seq` force xs+main = do+  eval "T" (arbitrary :: Gen (T (T Int)))+  eval "NTree" (arbitrary :: Gen NTree)