diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/generic-random.cabal b/generic-random.cabal --- a/generic-random.cabal +++ b/generic-random.cabal @@ -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 diff --git a/src/Generic/Random.hs b/src/Generic/Random.hs --- a/src/Generic/Random.hs +++ b/src/Generic/Random.hs @@ -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 diff --git a/src/Generic/Random/Generic.hs b/src/Generic/Random/Generic.hs deleted file mode 100644 --- a/src/Generic/Random/Generic.hs +++ /dev/null @@ -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 diff --git a/src/Generic/Random/Internal/BaseCase.hs b/src/Generic/Random/Internal/BaseCase.hs --- a/src/Generic/Random/Internal/BaseCase.hs +++ b/src/Generic/Random/Internal/BaseCase.hs @@ -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 diff --git a/src/Generic/Random/Internal/Generic.hs b/src/Generic/Random/Internal/Generic.hs --- a/src/Generic/Random/Internal/Generic.hs +++ b/src/Generic/Random/Internal/Generic.hs @@ -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 diff --git a/src/Generic/Random/Tutorial.hs b/src/Generic/Random/Tutorial.hs --- a/src/Generic/Random/Tutorial.hs +++ b/src/Generic/Random/Tutorial.hs @@ -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! +-- module Generic.Random.Tutorial () where -import GHC.Generics import Generic.Random diff --git a/test/Unit.hs b/test/Unit.hs --- a/test/Unit.hs +++ b/test/Unit.hs @@ -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)