generic-random-1.3.0.1/src/0000755000000000000000000000000013101147144013515 5ustar0000000000000000generic-random-1.3.0.1/src/Generic/0000755000000000000000000000000013535014315015075 5ustar0000000000000000generic-random-1.3.0.1/src/Generic/Random/0000755000000000000000000000000013635517422016325 5ustar0000000000000000generic-random-1.3.0.1/src/Generic/Random/Internal/0000755000000000000000000000000013535043455020100 5ustar0000000000000000generic-random-1.3.0.1/test/0000755000000000000000000000000013540015467013716 5ustar0000000000000000generic-random-1.3.0.1/src/Generic/Random.hs0000644000000000000000000001062613535014315016656 0ustar0000000000000000-- | "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 {-# 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 -- * Specifying finite distributions , Weights , W , (%) , uniform -- * Custom generators , (:+) (..) #if __GLASGOW_HASKELL__ >= 800 , FieldGen (..) , fieldGen , ConstrGen (..) , constrGen #endif , Gen1 (..) , Gen1_ (..) -- * 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 import Generic.Random.Internal.Generic generic-random-1.3.0.1/src/Generic/Random/Internal/BaseCase.hs0000644000000000000000000002335513535023760022107 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# 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 GHC.Generics import GHC.TypeLits import Test.QuickCheck import Generic.Random.Internal.Generic -- | Decrease size to ensure termination for -- recursive types, looking for base cases once the size reaches 0. -- -- > genericArbitrary' (17 % 19 % 23 % ()) :: Gen a -- -- N.B.: This replaces the generator for fields of type @[t]@ with -- @'Test.QuickCheck.listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for -- lists). genericArbitrary' :: (GArbitrary SizedOptsDef a, BaseCase a) => Weights a -- ^ List of weights for every constructor -> Gen a genericArbitrary' w = genericArbitraryRec w `withBaseCase` baseCase -- | Equivalent to @'genericArbitrary'' 'uniform'@. -- -- > genericArbitraryU' :: Gen a -- -- N.B.: This replaces the generator for fields of type @[t]@ with -- @'Test.QuickCheck.listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for -- lists). genericArbitraryU' :: (GArbitrary SizedOptsDef a, BaseCase a, GUniformWeight a) => Gen a genericArbitraryU' = genericArbitrary' uniform -- | Run the first generator if the size is positive. -- Run the second if the size is zero. -- -- > defaultGen `withBaseCase` baseCaseGen withBaseCase :: Gen a -> Gen a -> Gen a withBaseCase def bc = sized $ \sz -> if sz > 0 then def else bc -- | Find a base case of type @a@ with maximum depth @z@, -- recursively using 'BaseCaseSearch' instances to search deeper levels. -- -- @y@ is the depth of a base case, if found. -- -- @e@ is the original type the search started with, that @a@ appears in. -- It is used for error reporting. class BaseCaseSearch (a :: *) (z :: Nat) (y :: Maybe Nat) (e :: *) where baseCaseSearch :: prox y -> proxy '(z, e) -> IfM y Gen Proxy a instance {-# OVERLAPPABLE #-} GBaseCaseSearch a z y e => BaseCaseSearch a z y e where baseCaseSearch = gBaseCaseSearch instance (y ~ 'Just 0) => BaseCaseSearch Char z y e where baseCaseSearch _ _ = arbitrary instance (y ~ 'Just 0) => BaseCaseSearch Int z y e where baseCaseSearch _ _ = arbitrary instance (y ~ 'Just 0) => BaseCaseSearch Integer z y e where baseCaseSearch _ _ = arbitrary instance (y ~ 'Just 0) => BaseCaseSearch Float z y e where baseCaseSearch _ _ = arbitrary instance (y ~ 'Just 0) => BaseCaseSearch Double z y e where baseCaseSearch _ _ = arbitrary instance (y ~ 'Just 0) => BaseCaseSearch Word z y e where baseCaseSearch _ _ = arbitrary instance (y ~ 'Just 0) => BaseCaseSearch () z y e where baseCaseSearch _ _ = arbitrary instance (y ~ 'Just 0) => BaseCaseSearch Bool z y e where baseCaseSearch _ _ = arbitrary instance (y ~ 'Just 0) => BaseCaseSearch [a] z y e where baseCaseSearch _ _ = return [] instance (y ~ 'Just 0) => BaseCaseSearch Ordering z y e where baseCaseSearch _ _ = arbitrary -- Either and (,) use Generics class BaseCaseSearching_ a z y where baseCaseSearching_ :: proxy y -> proxy2 '(z, a) -> IfM y Gen Proxy a -> Gen a instance BaseCaseSearching_ a z ('Just m) where baseCaseSearching_ _ _ = id instance BaseCaseSearching a (z + 1) => BaseCaseSearching_ a z 'Nothing where baseCaseSearching_ _ _ _ = baseCaseSearching (Proxy :: Proxy '(z + 1, a)) -- | Progressively increase the depth bound for 'BaseCaseSearch'. class BaseCaseSearching a z where baseCaseSearching :: proxy '(z, a) -> Gen a instance (BaseCaseSearch a z y a, BaseCaseSearching_ a z y) => BaseCaseSearching a z where baseCaseSearching z = baseCaseSearching_ y z (baseCaseSearch y z) where y = Proxy :: Proxy y -- | Custom instances can override the default behavior. class BaseCase a where -- | Generator of base cases. baseCase :: Gen a -- | Overlappable instance {-# OVERLAPPABLE #-} BaseCaseSearching a 0 => BaseCase a where baseCase = baseCaseSearching (Proxy :: Proxy '(0, a)) type family IfM (b :: Maybe t) (c :: k) (d :: k) :: k type instance IfM ('Just t) c d = c type instance IfM 'Nothing c d = d type (==) m n = IsEQ (CmpNat m n) type family IsEQ (e :: Ordering) :: Bool type instance IsEQ 'EQ = 'True type instance IsEQ 'GT = 'False type instance IsEQ 'LT = 'False type family (||?) (b :: Maybe Nat) (c :: Maybe Nat) :: Maybe Nat type instance 'Just m ||? 'Just n = 'Just (Min m n) type instance m ||? 'Nothing = m type instance 'Nothing ||? n = n type family (&&?) (b :: Maybe Nat) (c :: Maybe Nat) :: Maybe Nat type instance 'Just m &&? 'Just n = 'Just (Max m n) type instance m &&? 'Nothing = 'Nothing type instance 'Nothing &&? n = 'Nothing type Max m n = MaxOf (CmpNat m n) m n type family MaxOf (e :: Ordering) (m :: k) (n :: k) :: k type instance MaxOf 'GT m n = m type instance MaxOf 'EQ m n = m type instance MaxOf 'LT m n = n type Min m n = MinOf (CmpNat m n) m n type family MinOf (e :: Ordering) (m :: k) (n :: k) :: k type instance MinOf 'GT m n = n type instance MinOf 'EQ m n = n type instance MinOf 'LT m n = m class Alternative (IfM y Weighted Proxy) => GBCS (f :: k -> *) (z :: Nat) (y :: Maybe Nat) (e :: *) 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 , GBCS f z yf e , GBCS g z yg e , y ~ (yf ||? yg) ) => GBCS (f :+: g) z y e where gbcs _ z = gbcsSum (Proxy :: Proxy '(yf, yg)) z (gbcs (Proxy :: Proxy yf) z) (gbcs (Proxy :: Proxy yg) z) class Alternative (IfM (yf ||? yg) Weighted Proxy) => GBCSSum f g z e yf yg where gbcsSum :: prox '(yf, yg) -> proxy '(z, e) -> IfM yf Weighted Proxy (f p) -> IfM yg Weighted Proxy (g p) -> IfM (yf ||? yg) Weighted Proxy ((f :+: g) p) instance GBCSSum f g z e 'Nothing 'Nothing where gbcsSum _ _ _ _ = Proxy instance GBCSSum f g z e ('Just m) 'Nothing where gbcsSum _ _ f _ = fmap L1 f instance GBCSSum f g z e 'Nothing ('Just n) where gbcsSum _ _ _ g = fmap R1 g instance GBCSSumCompare f g z e (CmpNat m n) => GBCSSum f g z e ('Just m) ('Just n) where gbcsSum _ = gbcsSumCompare (Proxy :: Proxy (CmpNat m n)) class GBCSSumCompare f g z e o where gbcsSumCompare :: proxy0 o -> proxy '(z, e) -> Weighted (f p) -> Weighted (g p) -> Weighted ((f :+: g) p) instance GBCSSumCompare f g z e 'EQ where gbcsSumCompare _ _ f g = fmap L1 f <|> fmap R1 g instance GBCSSumCompare f g z e 'LT where gbcsSumCompare _ _ f _ = fmap L1 f instance GBCSSumCompare f g z e 'GT where gbcsSumCompare _ _ _ g = fmap R1 g instance ( GBCSProduct f g z e yf yg , GBCS f z yf e , GBCS g z yg e , y ~ (yf &&? yg) ) => GBCS (f :*: g) z y e where gbcs _ z = gbcsProduct (Proxy :: Proxy '(yf, yg)) z (gbcs (Proxy :: Proxy yf) z) (gbcs (Proxy :: Proxy yg) z) class Alternative (IfM (yf &&? yg) Weighted Proxy) => GBCSProduct f g z e yf yg where gbcsProduct :: prox '(yf, yg) -> proxy '(z, e) -> IfM yf Weighted Proxy (f p) -> IfM yg Weighted Proxy (g p) -> IfM (yf &&? yg) Weighted Proxy ((f :*: g) p) instance {-# OVERLAPPABLE #-} ((yf &&? yg) ~ 'Nothing) => GBCSProduct f g z e yf yg where gbcsProduct _ _ _ _ = Proxy instance GBCSProduct f g z e ('Just m) ('Just n) where gbcsProduct _ _ f g = liftA2 (:*:) f g class IsMaybe b where ifMmap :: proxy b -> (c a -> c' a') -> (d a -> d' a') -> IfM b c d a -> IfM b c' d' a' ifM :: proxy b -> c a -> d a -> IfM b c d a instance IsMaybe ('Just t) where ifMmap _ f _ a = f a ifM _ f _ = f instance IsMaybe 'Nothing where ifMmap _ _ g a = g a ifM _ _ g = g instance {-# OVERLAPPABLE #-} ( BaseCaseSearch c (z - 1) y e , (z == 0) ~ 'False , Alternative (IfM y Weighted Proxy) , IsMaybe y ) => GBCS (K1 i c) z y e where gbcs y _ = fmap K1 (ifMmap y liftGen (id :: Proxy c -> Proxy c) (baseCaseSearch y (Proxy :: Proxy '(z - 1, e)))) instance (y ~ 'Nothing) => GBCS (K1 i c) 0 y e where gbcs _ _ = empty instance (y ~ 'Just 0) => GBCS U1 z y e where gbcs _ _ = pure U1 #if __GLASGOW_HASKELL__ >= 800 instance {-# INCOHERENT #-} ( TypeError ( 'Text "Unrecognized Rep: " ':<>: 'ShowType f ':$$: 'Text "Possible causes:" ':$$: 'Text " Missing (" ':<>: 'ShowType (BaseCase e) ':<>: 'Text ") constraint" ':$$: 'Text " Missing Generic instance" ) , Alternative (IfM y Weighted Proxy) ) => GBCS f z y e where gbcs = error "Type error" #endif class GBaseCaseSearch a z y e where gBaseCaseSearch :: prox y -> proxy '(z, e) -> IfM y Gen Proxy a instance (Generic a, GBCS (Rep a) z y e, IsMaybe y) => GBaseCaseSearch a z y e where gBaseCaseSearch y z = ifMmap y (\(Weighted (Just (g, n))) -> choose (0, n-1) >>= fmap to . g) (\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 generic-random-1.3.0.1/src/Generic/Random/Internal/Generic.hs0000644000000000000000000004540513535043455022020 0ustar0000000000000000{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# 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.Kind (Type) #endif import Data.Proxy (Proxy(..)) #if __GLASGOW_HASKELL__ >= 800 import GHC.Generics hiding (S, prec) #else 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) #if __GLASGOW_HASKELL__ < 800 #define Type * #endif -- * Random generators -- | Pick a constructor with a given distribution, and fill its fields -- with recursive calls to 'arbitrary'. -- -- === Example -- -- > genericArbitrary (2 % 3 % 5 % ()) :: Gen a -- -- Picks the first constructor with probability @2/10@, -- the second with probability @3/10@, the third with probability @5/10@. genericArbitrary :: (GArbitrary UnsizedOpts a) => Weights a -- ^ List of weights for every constructor -> Gen a genericArbitrary = genericArbitraryWith unsizedOpts -- | Pick every constructor with equal probability. -- Equivalent to @'genericArbitrary' 'uniform'@. -- -- > genericArbitraryU :: Gen a genericArbitraryU :: (GArbitrary UnsizedOpts a, GUniformWeight a) => Gen a genericArbitraryU = genericArbitrary uniform -- | 'arbitrary' for types with one constructor. -- Equivalent to 'genericArbitraryU', with a stricter type. -- -- > genericArbitrarySingle :: Gen a genericArbitrarySingle :: (GArbitrary UnsizedOpts a, Weights_ (Rep a) ~ L c0) => Gen a genericArbitrarySingle = genericArbitraryU -- | Decrease size at every recursive call, but don't do anything different -- at size 0. -- -- > genericArbitraryRec (7 % 11 % 13 % ()) :: Gen a -- -- N.B.: This replaces the generator for fields of type @[t]@ with -- @'listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for -- lists). genericArbitraryRec :: (GArbitrary SizedOptsDef a) => Weights a -- ^ List of weights for every constructor -> Gen a genericArbitraryRec = genericArbitraryWith sizedOptsDef -- | 'genericArbitrary' with explicit generators. -- -- === Example -- -- > genericArbitraryG customGens (17 % 19 % ()) -- -- where, for example to override generators for 'String' and 'Int' fields, -- -- @ -- customGens :: Gen String ':+' Gen Int -- customGens = -- (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 @Gen a@ or @'FieldGen' "x" a@), the generator for the first -- match will be picked. genericArbitraryG :: (GArbitrary (SetGens genList UnsizedOpts) a) => genList -> Weights a -> Gen a genericArbitraryG gs = genericArbitraryWith opts where opts = setGenerators gs unsizedOpts -- | 'genericArbitraryU' with explicit generators. -- See also 'genericArbitraryG'. genericArbitraryUG :: (GArbitrary (SetGens genList UnsizedOpts) a, GUniformWeight a) => genList -> Gen a genericArbitraryUG gs = genericArbitraryG gs uniform -- | 'genericArbitrarySingle' with explicit generators. -- See also 'genericArbitraryG'. genericArbitrarySingleG :: (GArbitrary (SetGens genList UnsizedOpts) a, Weights_ (Rep a) ~ L c0) => genList -> Gen a genericArbitrarySingleG = genericArbitraryUG -- | 'genericArbitraryRec' with explicit generators. -- See also 'genericArbitraryG'. genericArbitraryRecG :: (GArbitrary (SetGens genList SizedOpts) a) => genList -> Weights a -- ^ List of weights for every constructor -> Gen a genericArbitraryRecG gs = genericArbitraryWith opts where opts = setGenerators gs sizedOpts -- | General generic generator with custom options. genericArbitraryWith :: (GArbitrary opts a) => opts -> Weights a -> Gen a genericArbitraryWith opts (Weights w n) = fmap to (ga opts w n) -- * Internal type family Weights_ (f :: Type -> Type) :: Type where Weights_ (f :+: g) = Weights_ f :| Weights_ g Weights_ (M1 D _c f) = Weights_ f #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 -- | Trees of weights assigned to constructors of type @a@, -- rescaled to obtain a probability distribution. -- -- Two ways of constructing them. -- -- @ -- (x1 '%' x2 '%' ... '%' xn '%' ()) :: 'Weights' a -- 'uniform' :: 'Weights' a -- @ -- -- Using @('%')@, there must be exactly as many weights as -- there are constructors. -- -- 'uniform' is equivalent to @(1 '%' ... '%' 1 '%' ())@ -- (automatically fills out the right number of 1s). data Weights a = Weights (Weights_ (Rep a)) Int -- | Type of a single weight, tagged with the name of the associated -- constructor for additional compile-time checking. -- -- @ -- ((9 :: 'W' \"Leaf\") '%' (8 :: 'W' \"Node\") '%' ()) -- @ -- -- 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. -- It can be omitted for the '%' operator is overloaded to -- insert it. weights :: (Weights_ (Rep a), Int, ()) -> Weights a weights (w, n, ()) = Weights w n -- | Uniform distribution. uniform :: UniformWeight_ (Rep a) => Weights a uniform = let (w, n) = uniformWeight in Weights w n type family First a :: Symbol where First (a :| _b) = First a First (L c) = c type family First' w where First' (Weights a) = First (Weights_ (Rep a)) First' (a, Int, r) = First a type family Prec' w where Prec' (Weights a) = Prec (Weights_ (Rep a)) () Prec' (a, Int, r) = Prec a r -- | 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. (%) :: (c ~. First' w) => W c -> Prec' w -> w instance WeightBuilder (Weights_ (Rep a)) => WeightBuilder' (Weights a) where w % prec = weights (w %. prec) instance WeightBuilder a => WeightBuilder' (a, Int, r) where (%) = (%.) class WeightBuilder a where type Prec a r (%.) :: (c ~. First a) => W c -> Prec a r -> (a, Int, r) infixr 1 % instance WeightBuilder a => WeightBuilder (a :| b) where type Prec (a :| b) r = Prec a (b, Int, r) m %. prec = let (a, n, (b, p, r)) = m % prec in (N a n b, n + p, r) instance WeightBuilder (L c) where type Prec (L c) r = r W m %. prec = (L, m, prec) instance WeightBuilder () where type Prec () r = r W m %. prec = ((), m, prec) class UniformWeight a where uniformWeight :: (a, Int) instance (UniformWeight a, UniformWeight b) => UniformWeight (a :| b) where uniformWeight = let (a, m) = uniformWeight (b, n) = uniformWeight in (N a m b, m + n) instance UniformWeight (L c) where uniformWeight = (L, 1) instance UniformWeight () where uniformWeight = ((), 1) class UniformWeight (Weights_ f) => UniformWeight_ f instance UniformWeight (Weights_ f) => UniformWeight_ f -- | Derived uniform distribution of constructors for @a@. class UniformWeight_ (Rep a) => GUniformWeight a instance UniformWeight_ (Rep a) => GUniformWeight a -- | Type-level options for 'GArbitrary'. newtype Options (s :: Sizing) (genList :: Type) = Options { _generators :: genList } -- | Default options for unsized generators. unsizedOpts :: UnsizedOpts unsizedOpts = Options () -- | Default options for sized generators. sizedOpts :: SizedOpts sizedOpts = Options () -- | Default options overriding the list generator using 'listOf''. sizedOptsDef :: SizedOptsDef sizedOptsDef = Options (Gen1 listOf' :+ ()) -- | Whether to decrease the size parameter before generating fields. data Sizing = Sized | Unsized 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 setSized :: Options s g -> Options 'Sized g setSized = coerce setUnsized :: Options s g -> Options 'Unsized g setUnsized = coerce -- | Heterogeneous list of generators. data a :+ b = a :+ b infixr 1 :+ type family GeneratorsOf opts :: Type type instance GeneratorsOf (Options _s g) = g class HasGenerators opts where generators :: opts -> GeneratorsOf opts instance HasGenerators (Options s g) where generators = _generators setGenerators :: genList -> Options s g0 -> Options s genList setGenerators gens (Options _) = Options gens type family SetGens (g :: Type) opts type instance SetGens g (Options s _g) = Options s g #if __GLASGOW_HASKELL__ >= 800 -- | Custom generator for record fields named @s@. -- -- /Available only for @base >= 4.9@ (@GHC >= 8.0.1@)./ newtype FieldGen (s :: Symbol) a = FieldGen { unFieldGen :: Gen a } -- | 'FieldGen' constructor with the field name given via a proxy. fieldGen :: proxy s -> Gen a -> FieldGen s a fieldGen _ = FieldGen -- | Custom generator for the @i@-th field of the constructor named @c@. -- -- /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 -- | 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) } -- | Custom generators for unary type constructors that are not \"containers\", -- i.e., which don't require a generator of @a@ to generate an @f a@. -- -- A custom generator @'Gen1_' f@ will be used for any field whose type has the -- form @f x@. newtype Gen1_ f = Gen1_ { unGen1_ :: forall a. Gen (f a) } -- | An alternative to 'vectorOf' that divides the size parameter by the -- length of the list. vectorOf' :: Int -> Gen a -> Gen [a] vectorOf' 0 = \_ -> pure [] vectorOf' i = scale (`div` i) . vectorOf i -- | An alternative to 'Test.QuickCheck.listOf' that divides the size parameter -- by the length of the list. -- The length follows a geometric distribution of parameter -- @1/(sqrt size + 1)@. listOf' :: Gen a -> Gen [a] listOf' g = sized $ \n -> do i <- geom n vectorOf' i g -- | An alternative to 'Test.QuickCheck.listOf1' (nonempty lists) that divides -- the size parameter by the length of the list. -- The length (minus one) follows a geometric distribution of parameter -- @1/(sqrt size + 1)@. listOf1' :: Gen a -> Gen [a] listOf1' g = liftA2 (:) g (listOf' g) -- | Geometric distribution of parameter @1/(sqrt n + 1)@ (@n >= 0@). geom :: Int -> Gen Int geom 0 = pure 0 geom n = go 0 where n' = fromIntegral n p = 1 / (sqrt n' + 1) :: Double go r = do x <- choose (0, 1) if x < p then pure r else go $! (r + 1) --- -- | Generic Arbitrary class GA opts f where ga :: opts -> Weights_ f -> Int -> Gen (f p) -- | Generic Arbitrary class (Generic a, GA opts (Rep a)) => GArbitrary opts a instance (Generic a, GA opts (Rep a)) => GArbitrary opts a instance GA opts f => GA opts (M1 D c f) where ga z w n = fmap M1 (ga z w n) {-# INLINE ga #-} instance (GASum opts f, GASum opts g) => GA opts (f :+: g) where ga = gaSum' {-# INLINE ga #-} instance GAProduct (SizingOf opts) (Name c) opts f => GA opts (M1 C c f) where ga z _ _ = fmap M1 (gaProduct (Proxy :: Proxy '(SizingOf opts, Name c)) z) {-# INLINE ga #-} gaSum' :: GASum opts f => opts -> Weights_ f -> Int -> Gen (f p) gaSum' z w n = do i <- choose (0, n-1) gaSum z i w {-# INLINE gaSum' #-} class GASum opts f where gaSum :: opts -> Int -> Weights_ f -> Gen (f p) instance (GASum opts f, GASum opts g) => GASum opts (f :+: g) where gaSum z i (N a n b) | i < n = fmap L1 (gaSum z i a) | otherwise = fmap R1 (gaSum z (i - n) b) {-# INLINE gaSum #-} instance GAProduct (SizingOf opts) (Name c) opts f => GASum opts (M1 C c f) where gaSum z _ _ = fmap M1 (gaProduct (Proxy :: Proxy '(SizingOf opts, Name c)) z) {-# INLINE gaSum #-} class GAProduct (s :: Sizing) (c :: Maybe Symbol) opts f where gaProduct :: proxys '(s, c) -> opts -> Gen (f p) instance GAProduct' c 0 opts f => GAProduct 'Unsized c opts f where gaProduct _ = gaProduct' (Proxy :: Proxy '(c, 0)) {-# INLINE gaProduct #-} -- Single-field constructors: decrease size by 1. instance {-# OVERLAPPING #-} GAProduct' c 0 opts (S1 d f) => GAProduct 'Sized c opts (S1 d f) where gaProduct _ = scale (\n -> max 0 (n-1)) . gaProduct' (Proxy :: Proxy '(c, 0)) instance (GAProduct' c 0 opts f, KnownNat (Arity f)) => GAProduct 'Sized c opts f where gaProduct _ = scale (`div` arity) . gaProduct' (Proxy :: Proxy '(c, 0)) where arity = fromInteger (natVal (Proxy :: Proxy (Arity f))) {-# INLINE gaProduct #-} instance {-# OVERLAPPING #-} GAProduct 'Sized c opts U1 where gaProduct _ _ = pure U1 {-# INLINE gaProduct #-} class GAProduct' (c :: Maybe Symbol) (i :: Nat) opts f where gaProduct' :: proxy '(c, i) -> opts -> Gen (f p) instance GAProduct' c i opts U1 where gaProduct' _ _ = pure U1 {-# INLINE gaProduct' #-} instance ( HasGenerators opts , ArbitraryOr gs () gs '(c, i, Name d) a , gs ~ GeneratorsOf opts ) => GAProduct' c i opts (S1 d (K1 _k a)) where gaProduct' _ opts = fmap (M1 . K1) (arbitraryOr sel gs () gs) where sel = Proxy :: Proxy '(c, i, Name d) gs = generators opts {-# INLINE gaProduct' #-} instance (GAProduct' c i opts f, GAProduct' c (i + Arity f) opts g) => GAProduct' c i opts (f :*: g) where -- TODO: Why does this inline better than eta-reducing? (GHC-8.2) gaProduct' px = (liftA2 . liftA2) (:*:) (gaProduct' px) (gaProduct' (Proxy :: Proxy '(c, i + Arity f))) {-# INLINE gaProduct' #-} type family Arity f :: Nat where Arity (f :*: g) = Arity f + Arity g Arity (M1 _i _c _f) = 1 -- | Given a list of custom generators @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 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 -- | All candidates have been exhausted instance Arbitrary a => ArbitraryOr fg () () sel a where arbitraryOr _ _ _ _ = arbitrary {-# INLINE arbitraryOr #-} -- | 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 #-} -- | 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 -- | 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 #-} -- | 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 Name d = (Nothing :: Maybe Symbol) #endif -- | Matching custom generator for non-container @f@ instance {-# INCOHERENT #-} ArbitraryOr fg (Gen1_ f) g sel (f a) where arbitraryOr _ _ (Gen1_ gen) _ = gen -- | 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 instance Applicative Weighted where pure a = Weighted (Just ((pure . pure) a, 1)) Weighted f <*> Weighted a = Weighted $ liftA2 g f a where g (f1, m) (a1, n) = ( \i -> let (j, k) = i `divMod` m in f1 j <*> a1 k , m * n ) instance Alternative Weighted where empty = Weighted Nothing a <|> Weighted Nothing = a Weighted Nothing <|> b = b Weighted (Just (a, m)) <|> Weighted (Just (b, n)) = Weighted . Just $ ( \i -> if i < m then a i else b (i - m) , m + n ) liftGen :: Gen a -> Weighted a liftGen g = Weighted (Just (\_ -> g, 1)) generic-random-1.3.0.1/src/Generic/Random/Tutorial.hs0000644000000000000000000002366413635517422020477 0ustar0000000000000000-- | Generic implementations of -- [QuickCheck](https://hackage.haskell.org/package/QuickCheck)'s -- @arbitrary@. -- -- = Example -- -- Define your type. -- -- @ -- data Tree a = Leaf a | Node (Tree a) (Tree a) -- deriving 'GHC.Generics.Generic' -- @ -- -- Pick an 'Test.QuickCheck.arbitrary' implementation, specifying the required distribution of -- data constructors. -- -- @ -- instance Arbitrary a => Arbitrary (Tree a) where -- arbitrary = 'genericArbitrary' (9 '%' 8 '%' ()) -- @ -- -- That random generator @arbitrary :: 'Test.QuickCheck.Gen' (Tree a)@ picks a -- @Leaf@ with probability 9\/17, or a -- @Node@ with probability 8\/17, and recursively fills their fields with -- @arbitrary@. -- -- For @Tree@, the generic implementation 'genericArbitrary' is equivalent to -- the following: -- -- @ -- 'genericArbitrary' :: Arbitrary a => 'Weights' (Tree a) -> Gen (Tree a) -- 'genericArbitrary' (x '%' y '%' ()) = -- frequency -- [ (x, Leaf '<$>' arbitrary) -- , (y, Node '<$>' arbitrary '<*>' arbitrary) -- ] -- @ -- -- = Distribution of constructors -- -- The distribution of constructors can be specified as -- a special list of /weights/ in the same order as the data type definition. -- This assigns to each constructor a probability proportional to its weight; -- in other words, @p_C = weight_C / sumOfWeights@. -- -- The list of weights is built up with the @('%')@ operator as a cons, and using -- the unit @()@ as the empty list, in the order corresponding to the data type -- definition. -- -- == Uniform distribution -- -- You can specify the uniform distribution (all weights equal) with 'uniform'. -- ('genericArbitraryU' is available as a shorthand for -- @'genericArbitrary' 'uniform'@.) -- -- Note that for many recursive types, a uniform distribution tends to produce -- big or even infinite values. -- -- == Typed weights -- -- /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. The constructors must appear in the same order as in the -- original type definition. -- -- This will type-check. -- -- @ -- ((x :: 'W' \"Leaf\") '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) -- ( x '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) -- @ -- -- This will not. -- -- @ -- ((x :: 'W' \"Node\") '%' y '%' ()) :: 'Weights' (Tree a) -- -- Requires an order of constructors different from the definition of the @Tree@ type. -- -- ( x '%' y '%' z '%' ()) :: 'Weights' (Tree a) -- -- Doesn't have the right number of weights. -- @ -- -- = Ensuring termination -- -- As mentioned earlier, one must be careful with recursive types -- to avoid producing extremely large values. -- The alternative generator 'genericArbitraryRec' decreases the size -- parameter at every call to keep values at reasonable sizes, -- to be used together with 'withBaseCase'. -- -- For example, we may provide a base case consisting of only @Leaf@: -- -- @ -- instance Arbitrary a => Arbitrary (Tree a) where -- arbitrary = 'genericArbitraryRec' (1 '%' 2 '%' ()) -- ``withBaseCase`` (Leaf '<$>' arbitrary) -- @ -- -- That is equivalent to the following definition. Note the -- 'Test.QuickCheck.resize' modifier. -- -- @ -- arbitrary :: Arbitrary a => Gen (Tree a) -- arbitrary = sized $ \\n -> -- -- "if" condition from withBaseCase -- if n == 0 then -- Leaf \<$\> arbitrary -- else -- -- genericArbitraryRec -- frequency -- [ (1, resize (max 0 (n - 1)) (Leaf '<$>' arbitrary)) -- , (2, resize (n \`div\` 2) (Node '<$>' arbitrary '<*>' arbitrary)) -- ] -- @ -- -- The resizing strategy is as follows: -- the size parameter of 'Test.QuickCheck.Gen' is divided among the fields of -- the chosen constructor, or decreases by one if the constructor is unary. -- @'withBaseCase' defG baseG@ is equal to @defG@ as long as the size parameter -- is nonzero, and it becomes @baseG@ once the size reaches zero. -- This combination generally ensures that the number of constructors remains -- bounded by the initial size parameter passed to 'Test.QuickCheck.Gen'. -- -- == Automatic base case discovery -- -- In some situations, generic-random can also construct base cases automatically. -- This works best with fully concrete types (no type parameters). -- -- @ -- {-\# LANGUAGE FlexibleInstances #-} -- -- instance Arbitrary (Tree ()) where -- arbitrary = 'genericArbitrary'' (1 '%' 2 '%' ()) -- @ -- -- The above instance will infer the value @Leaf ()@ as a base case. -- -- To discover values of type @Tree a@, we must inspect the type argument @a@, -- thus we incur some extra constraints if we want polymorphism. -- It is preferrable to apply the type class 'BaseCase' to the instance head -- (@Tree a@) as follows, as it doesn't reduce to something worth seeing. -- -- @ -- {-\# LANGUAGE FlexibleContexts, UndecidableInstances \#-} -- -- instance (Arbitrary a, 'BaseCase' (Tree a)) -- => Arbitrary (Tree a) where -- arbitrary = 'genericArbitrary'' (1 '%' 2 '%' ()) -- @ -- -- The 'BaseCase' type class finds values of minimal depth, -- where the depth of a constructor is defined as @1 + max(0, depths of fields)@, -- e.g., @Leaf ()@ has depth 2. -- -- == Note about lists -- -- The @Arbitrary@ instance for lists can be problematic for this way -- of implementing recursive sized generators, because they make a lot of -- recursive calls to 'Test.QuickCheck.arbitrary' without decreasing the size parameter. -- Hence, as a default, 'genericArbitraryRec' also detects fields which are -- lists to replace 'Test.QuickCheck.arbitrary' with a different generator that divides -- the size parameter by the length of the list before generating each -- element. This uses the customizable mechanism shown in the next section. -- -- If you really want to use 'Test.QuickCheck.arbitrary' for lists in the derived instances, -- substitute @'genericArbitraryRec'@ with @'genericArbitraryRecG' ()@. -- -- @ -- arbitrary = 'genericArbitraryRecG' () -- ``withBaseCase`` baseGen -- @ -- -- Some combinators are available for further tweaking: 'listOf'', 'listOf1'', -- 'vectorOf''. -- -- = Custom generators for some fields -- -- == Example 1 ('Test.QuickCheck.Gen', 'FieldGen') -- -- Sometimes, a few fields may need custom generators instead of 'Test.QuickCheck.arbitrary'. -- For example, imagine here that @String@ is meant to represent -- alphanumerical strings only, and that IDs are meant to be nonnegative, -- whereas balances can have any sign. -- -- @ -- data User = User { -- userName :: String, -- userId :: Int, -- userBalance :: Int -- } deriving 'GHC.Generics.Generic' -- @ -- -- A naive approach has the following problems: -- -- - @'Test.QuickCheck.Arbitrary' String@ may generate any unicode character, -- alphanumeric or not; -- - @'Test.QuickCheck.Arbitrary' Int@ may generate negative values; -- - using @newtype@ wrappers or passing generators explicitly to properties -- may be impractical (the maintenance overhead can be high because the types -- are big or change often). -- -- Using generic-random, we can declare a (heterogeneous) list of generators to -- be used instead of 'Test.QuickCheck.arbitrary' when generating certain fields. -- -- @ -- customGens :: 'FieldGen' "userId" Int ':+' 'Test.QuickCheck.Gen' String -- customGens = -- 'FieldGen' ('Test.QuickCheck.getNonNegative' '<$>' arbitrary) ':+' -- 'Test.QuickCheck.listOf' ('Test.QuickCheck.elements' (filter isAlphaNum [minBound .. maxBound])) -- @ -- -- Now we use the 'genericArbitraryG' combinator and other @G@-suffixed -- variants that accept those explicit generators. -- -- - All @String@ fields will use the provided generator of -- alphanumeric strings; -- - the field @"userId"@ of type @Int@ will use the generator -- of nonnegative integers; -- - everything else defaults to 'Test.QuickCheck.arbitrary'. -- -- @ -- instance Arbitrary User where -- arbitrary = 'genericArbitrarySingleG' customGens -- @ -- -- == Example 2 ('ConstrGen') -- -- Here's the @Tree@ type from the beginning again. -- -- @ -- data Tree a = Leaf a | Node (Tree a) (Tree a) -- deriving 'GHC.Generics.Generic' -- @ -- -- We will generate "right-leaning linear trees", which look like this: -- -- > Node (Leaf 1) -- > (Node (Leaf 2) -- > (Node (Leaf 3) -- > (Node (Leaf 4) -- > (Leaf 5)))) -- -- To do so, we force every left child of a @Node@ to be a @Leaf@: -- -- @ -- {-\# LANGUAGE ScopedTypeVariables \#-} -- -- instance Arbitrary a => Arbitrary (Tree a) where -- arbitrary = 'genericArbitraryUG' customGens -- where -- -- Generator for the left field (i.e., at index 0) of constructor Node, -- -- which must have type (Tree a). -- customGens :: 'ConstrGen' \"Node\" 0 (Tree a) -- customGens = 'ConstrGen' (Leaf '<$>' arbitrary) -- @ -- -- That instance is equivalent to the following: -- -- @ -- instance Arbitrary a => Arbitrary (Tree a) where -- arbitrary = oneof -- [ Leaf '<$>' arbitrary -- , Node '<$>' (Leaf '<$>' arbitrary) '<*>' arbitrary -- -- ^ recursive call -- ] -- @ -- -- == Custom generators reference -- -- The custom generator modifiers that can occur in the list are: -- -- - 'Test.QuickCheck.Gen': a generator for a specific type; -- - 'FieldGen': a generator for a record field; -- - 'ConstrGen': a generator for a field of a given constructor; -- - 'Gen1': a generator for \"containers\", parameterized by a generator -- for individual elements; -- - 'Gen1_': a generator for unary type constructors that are not -- containers. -- -- Suggestions to add more modifiers or otherwise improve this tutorial are welcome! -- {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-unused-imports #-} #endif module Generic.Random.Tutorial () where import Generic.Random generic-random-1.3.0.1/test/Inspect.hs0000644000000000000000000000144113540015467015657 0ustar0000000000000000{-# LANGUAGE DeriveGeneric, TemplateHaskell #-} import GHC.Generics (Generic) import Test.QuickCheck (Arbitrary(arbitrary), Gen, choose) import Test.Inspection (inspect, (===)) import Generic.Random arbMaybe :: Arbitrary a => Gen (Maybe a) arbMaybe = genericArbitraryU arbMaybe' :: Arbitrary a => Gen (Maybe a) arbMaybe' = do i <- choose (0, 1 :: Int) if i < 1 then pure Nothing else Just <$> arbitrary data T = A | B | C Int [Bool] deriving Generic arbT :: Gen T arbT = genericArbitrary (1 % 2 % 3 % ()) arbT' :: Gen T arbT' = do i <- choose (0, 5 :: Int) if i < 1 then pure A else if i - 1 < 2 then pure B else C <$> arbitrary <*> arbitrary main :: IO () main = pure () inspect $ 'arbMaybe === 'arbMaybe' inspect $ 'arbT === 'arbT' generic-random-1.3.0.1/test/Unit.hs0000644000000000000000000000277313534552070015201 0ustar0000000000000000{-# LANGUAGE CPP, DataKinds, DeriveGeneric, FlexibleContexts, FlexibleInstances, LambdaCase, TypeFamilies, UndecidableInstances #-} import Control.Monad (replicateM) import Control.DeepSeq (NFData, force) import GHC.Generics (Generic) import System.Timeout (timeout) import Test.QuickCheck import Generic.Random 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) data NTree = Leaf | Node [NTree] deriving (Generic, Show) instance Arbitrary NTree where arbitrary = genericArbitraryU' instance NFData NTree eval :: NFData a => String -> Gen a -> IO () eval name g = do x <- timeout (10 ^ (6 :: Int)) $ do xs <- generate (replicateM 100 g) return $! force xs case x of Just _ -> return () Nothing -> fail $ name ++ ": did not finish on time" #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 generic-random-1.3.0.1/LICENSE0000644000000000000000000000206612701300312013730 0ustar0000000000000000The MIT License (MIT) Copyright (c) 2016 Li-yao Xia Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. generic-random-1.3.0.1/Setup.hs0000644000000000000000000000005612701300312014354 0ustar0000000000000000import Distribution.Simple main = defaultMain generic-random-1.3.0.1/generic-random.cabal0000644000000000000000000000333013636272360016617 0ustar0000000000000000name: generic-random version: 1.3.0.1 synopsis: Generic random generators for QuickCheck description: Derive instances of @Arbitrary@ for QuickCheck, with various options to customize implementations. . For more information . - See the README . - "Generic.Random.Tutorial" . - http://blog.poisson.chat/posts/2018-01-05-generic-random-tour.html homepage: http://github.com/lysxia/generic-random license: MIT license-file: LICENSE stability: Stable author: Li-yao Xia maintainer: lysxia@gmail.com category: Generics, Testing build-type: Simple extra-source-files: README.md CHANGELOG.md cabal-version: >=1.10 tested-with: GHC == 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 exposed-modules: Generic.Random Generic.Random.Internal.BaseCase Generic.Random.Internal.Generic Generic.Random.Tutorial build-depends: base >= 4.7 && < 5, QuickCheck default-language: Haskell2010 ghc-options: -Wall -fno-warn-name-shadowing source-repository head type: git location: https://github.com/lysxia/generic-random test-suite unit hs-source-dirs: test main-is: Unit.hs build-depends: base, deepseq, QuickCheck, generic-random type: exitcode-stdio-1.0 default-language: Haskell2010 test-suite 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 !impl(ghc >= 8.0.2) buildable: False generic-random-1.3.0.1/README.md0000644000000000000000000000450013635251565014223 0ustar0000000000000000Generic random generators [![Hackage](https://img.shields.io/hackage/v/generic-random.svg)](https://hackage.haskell.org/package/generic-random) [![Build Status](https://travis-ci.org/Lysxia/generic-random.svg)](https://travis-ci.org/Lysxia/generic-random) ========================= Generic random generators to implement `Arbitrary` instances for [QuickCheck](https://hackage.haskell.org/package/QuickCheck) Automating the `arbitrary` boilerplate also ensures that when a type changes to have more or fewer constructors, then the generator either fixes itself to generate that new case (when using the `uniform` distribution) or causes a compilation error so you remember to fix it (when using an explicit distribution). This package also offers a simple (optional) strategy to ensure termination for recursive types: make `Test.QuickCheck.Gen`'s size parameter decrease at every recursive call; when it reaches zero, sample directly from a trivially terminating generator given explicitly (`genericArbitraryRec` and `withBaseCase`) or implicitly (`genericArbitrary'`). Example ------- ```haskell {-# LANGUAGE DeriveGeneric #-} import GHC.Generics (Generic) import Test.QuickCheck import Generic.Random data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Show, Generic) instance Arbitrary a => Arbitrary (Tree a) where arbitrary = genericArbitraryRec uniform `withBaseCase` return Leaf -- Equivalent to -- > arbitrary = -- > sized $ \n -> -- > if n == 0 then -- > return Leaf -- > else -- > oneof -- > [ return Leaf -- > , resize (n `div` 3) $ -- > Node <$> arbitrary <*> arbitrary <*> arbitrary -- > ] main :: IO () main = sample (arbitrary :: Gen (Tree ())) ``` Related ------- - The following two packages also derive random generators, but only with a uniform distribution of constructors: + [quickcheck-arbitrary-template](https://hackage.haskell.org/package/quickcheck-arbitrary-template) (TH) + [generic-arbitrary](https://hackage.haskell.org/package/generic-arbitrary-0.1.0) (GHC Generics) - [testing-feat](http://hackage.haskell.org/package/testing-feat): derive enumerations for algebraic data types, which can be turned into random generators (TH). - [boltzmann-samplers](https://hackage.haskell.org/package/boltzmann-samplers): derive Boltzmann samplers (SYB). generic-random-1.3.0.1/CHANGELOG.md0000644000000000000000000000510613635517212014552 0ustar0000000000000000https://github.com/Lysxia/generic-random/blob/master/changelog.md # 1.3.0.1 - Fix small typos in documentation. # 1.3.0.0 - Add `ConstrGen` (custom generators for fields specified by constructor name and index). - Stop requiring custom generators lists to be terminated by `:+ ()`, or to be lists at all. - Breaking minor change: when a record field has a different type than a `FieldGen` custom generator for the same field name, this is now a compilation error. This was simply ignored before. - Miscellaneous documentation improvements in `Generic.Random` module. # 1.2.0.0 - Fix a bug where generators did not decrease the size parameter with single-field constructors - The sized generators now use a custom generator for lists. Use `genericArbitraryRecG ()` to disable that. See tutorial for more information. - Lists of custom generators are now constructed using `(:+)` instead of `GenList` - Rename `Field` to `FieldGen` - Add `Gen1`, `Gen1_` (custom generators for unary type constructors) - Add `listOf'`, `listOf1'`, `vectorOf'` - Remove deprecated module `Generic.Random.Generic` # 1.1.0.2 - Improved performance # 1.1.0.1 - Fix build for GHC<8 # 1.1.0.0 - Add option to specify custom generators for certain fields, overriding Arbitrary instances + Add `genericArbitraryG`, `genericArbitraryUG`, `genericArbitrarySingleG`, `genericArbitraryRecG` - Add `GArbitrary` and `GUniformWeight` synonyms - Deprecate `Generic.Random.Generic` - Remove `weights` from the external API # 1.0.0.0 - Make the main module `Generic.Random` - Rework generic base case generation + You can explicitly provide a trivial generator (e.g., returning a nullary constructor) using `withBaseCase` + Generically derive `BaseCaseSearch` and let `BaseCase` find small values, no depth parameter must be specified anymore - Add `genericArbitrarySingle`, `genericArbitraryRec`, `genericArbitraryU'` - Deprecate `weights` - Fixed bug with `genericArbitrary'` not dividing the size parameter # 0.5.0.0 - Turn off dependency on boltzmann-samplers by default - Add `genericArbitraryU`, `genericArbitraryU0` and `genericArbitraryU1` - Compatible with GHC 7.8.4 and GHC 7.10.3 # 0.4.1.0 - Move Boltzmann sampler modules to another package: boltzmann-samplers # 0.4.0.0 - Check well-formedness of constructor distributions at compile time. - No longer support GHC 7.10.3 (the above feature relies on Generic information which does not exist before GHC 8) # 0.3.0.0 - Support GHC 7.10.3 - Replace `TypeApplications` with ad-hoc data types in `genericArbitraryFrequency'`/`genericArbitrary'`