generic-random 1.0.0.0 → 1.1.0.0

raw patch · 8 files changed

+355/−97 lines, 8 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +31/−29
• generic-random.cabal +8/−2
• src/Generic/Random.hs +30/−5
• src/Generic/Random/Generic.hs +3/−1
• src/Generic/Random/Internal/BaseCase.hs +4/−2
• src/Generic/Random/Internal/Generic.hs +218/−55
• src/Generic/Random/Tutorial.hs +51/−3

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

@@ -3,42 +3,44 @@  Derive simple random generators for [QuickCheck](https://hackage.haskell.org/package/QuickCheck) using generics. +Automating the `Arbitrary` boilerplate also ensures that if a type changes to+have more constructors, then the generator fixes itself to generate that new+case (with `uniform` distribution) or causes a compilation error (with an+explicit distribution).++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 #-}+{-# LANGUAGE DeriveGeneric #-} -    import GHC.Generics (Generic)-    import Test.QuickCheck-    import Generic.Random+import GHC.Generics (Generic)+import Test.QuickCheck+import Generic.Random -    data Tree a = Leaf | Node (Tree a) a (Tree a)-      deriving (Show, Generic)+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+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-    -- >         ]+-- Equivalent to+-- > arbitrary =+-- >   sized $ \n ->+-- >     if n == 0 then+-- >       return Leaf+-- >     else+-- >       oneof+-- >         [ return Leaf+-- >         , resize (n `div` 3) $+-- >             Node <$> arbitrary <*> arbitrary <*> arbitrary+-- >         ] -    main = sample (arbitrary :: Gen (Tree ()))+main = sample (arbitrary :: Gen (Tree ())) ```--Features------------ User-specified distribution of constructors.-- A simple (optional) strategy to ensure termination for recursive types:-  using `genericArbitrary'`, `Test.QuickCheck.Gen`'s size parameter decreases-  at every recursive call; when it reaches zero, sample directly from a-  trivially terminating generator.

@@ -1,7 +1,13 @@ name:                generic-random-version:             1.0.0.0+version:             1.1.0.0 synopsis:            Generic random generators-description:         Please see the README.+description:+    For more information+    .+    - "Generic.Random.Tutorial"+    .+    - https://byorgey.wordpress.com/2016/09/20/the-generic-random-library-part-1-simple-generic-arbitrary-instances/+ homepage:            http://github.com/lysxia/generic-random license:             MIT license-file:        LICENSE

@@ -5,27 +5,52 @@ -- - "Generic.Random.Tutorial" -- - https://byorgey.wordpress.com/2016/09/20/the-generic-random-library-part-1-simple-generic-arbitrary-instances/ +{-# LANGUAGE CPP #-}+ module Generic.Random   (     -- * Arbitrary implementations     genericArbitrary   , genericArbitraryU   , genericArbitrarySingle+  , genericArbitraryRec   , genericArbitrary'   , genericArbitraryU'-  , genericArbitraryRec+  , genericArbitraryG+  , genericArbitraryUG+  , genericArbitrarySingleG+  , genericArbitraryRecG+  , genericArbitraryWith +    -- * Base cases for recursive types+  , withBaseCase+  , BaseCase (..)+     -- * Specifying finite distributions   , Weights   , W   , (%)   , uniform -    -- * Base cases for recursive types-  , withBaseCase-  , BaseCase (..)+    -- * Full options+  , Options ()+  , SizedOpts+  , sizedOpts+  , UnsizedOpts+  , unsizedOpts+  , Sizing (..)+  , setSized+  , setUnsized+  , GenList (..)+#if __GLASGOW_HASKELL__ >= 800+  , Field (..)+  , field+#endif+  , setGenerators -  , weights+    -- * Public classes+  , GArbitrary+  , GUniformWeight   ) where  import Generic.Random.Internal.BaseCase

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

@@ -1,3 +1,5 @@+{-# OPTIONS_HADDOCK not-home #-}+ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}@@ -35,7 +37,7 @@ -- -- > genericArbitrary' (17 % 19 % 23 % ()) :: Gen a genericArbitrary'-  :: (Generic a, GA Sized (Rep a), BaseCase a)+  :: (GArbitrary SizedOpts a, BaseCase a)   => Weights a  -- ^ List of weights for every constructor   -> Gen a genericArbitrary' w = genericArbitraryRec w `withBaseCase` baseCase@@ -44,7 +46,7 @@ -- -- > genericArbitraryU :: Gen a genericArbitraryU'-  :: (Generic a, GA Sized (Rep a), BaseCase a, UniformWeight_ (Rep a))+  :: (GArbitrary SizedOpts a, BaseCase a, GUniformWeight a)   => Gen a genericArbitraryU' = genericArbitrary' uniform 

@@ -1,8 +1,12 @@+{-# OPTIONS_HADDOCK not-home #-}++{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -11,20 +15,32 @@ {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE IncoherentInstances #-} #endif  module Generic.Random.Internal.Generic where -import Control.Applicative-import Data.Proxy+#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) #else import GHC.Generics hiding (S, Arity) #endif-import GHC.TypeLits-import Test.QuickCheck+import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), natVal)+import Test.QuickCheck (Arbitrary(..), Gen, choose, resize, sized) +#if __GLASGOW_HASKELL__ < 800+#define Type *+#endif+ -- * Random generators  -- | Pick a constructor with a given distribution, and fill its fields@@ -37,17 +53,17 @@ -- Picks the first constructor with probability @2/10@, -- the second with probability @3/10@, the third with probability @5/10@. genericArbitrary-  :: (Generic a, GA Unsized (Rep a))+  :: (GArbitrary UnsizedOpts a)   => Weights a  -- ^ List of weights for every constructor   -> Gen a-genericArbitrary (Weights w n) = fmap to (ga (Proxy :: Proxy Unsized) w n)+genericArbitrary = genericArbitraryWith unsizedOpts  -- | Pick every constructor with equal probability. -- Equivalent to @'genericArbitrary' 'uniform'@. -- -- > genericArbitraryU :: Gen a genericArbitraryU-  :: (Generic a, GA Unsized (Rep a), UniformWeight_ (Rep a))+  :: (GArbitrary UnsizedOpts a, GUniformWeight a)   => Gen a genericArbitraryU = genericArbitrary uniform @@ -56,7 +72,7 @@ -- -- > genericArbitrarySingle :: Gen a genericArbitrarySingle-  :: (Generic a, GA Unsized (Rep a), Weights_ (Rep a) ~ L c0)+  :: (GArbitrary UnsizedOpts a, Weights_ (Rep a) ~ L c0)   => Gen a genericArbitrarySingle = genericArbitraryU @@ -65,13 +81,75 @@ -- -- > genericArbitraryRec (7 % 11 % 13 % ()) :: Gen a genericArbitraryRec-  :: forall a-  . (Generic a, GA Sized (Rep a))+  :: (GArbitrary SizedOpts a)   => Weights a  -- ^ List of weights for every constructor   -> Gen a-genericArbitraryRec (Weights w n) =-  fmap to (ga (Proxy :: Proxy Sized) w n :: Gen (Rep a p))+genericArbitraryRec = genericArbitraryWith sizedOpts +-- | 'genericArbitrary' with explicit generators.+--+-- === Example+--+-- > genericArbitraryG customGens (17 % 19 % ())+--+-- where, for example to override generators for 'String' and 'Int' fields,+--+-- @+-- customGens :: 'GenList' '[String, Int]+-- customGens =+--   (filter (/= '\NUL') '<$>' arbitrary) ':@'+--   (getNonNegative '<$>' arbitrary) ':@'+--   'Nil'+-- @+--+-- === Note on multiple matches+--+-- If the list contains multiple matching types for a field @x@ of type @a@+-- (i.e., either @a@ or @'Field' "x" a@), the generator for the first+-- match will be picked.+genericArbitraryG+  :: (GArbitrary (SetGens g UnsizedOpts) a)+  => GenList g+  -> Weights a+  -> Gen a+genericArbitraryG gs = genericArbitraryWith opts+  where+    opts = setGenerators gs unsizedOpts++-- | 'genericArbitraryU' with explicit generators.+-- See also 'genericArbitraryG'.+genericArbitraryUG+  :: (GArbitrary (SetGens g UnsizedOpts) a, GUniformWeight a)+  => GenList g+  -> 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+  -> Gen a+genericArbitrarySingleG = genericArbitraryUG++-- | 'genericArbitraryRec' with explicit generators.+-- See also 'genericArbitraryG'.+genericArbitraryRecG+  :: (GArbitrary (SetGens g SizedOpts) a)+  => GenList g+  -> 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 :: * -> *) :: * where@@ -111,8 +189,9 @@ -- @ newtype W (c :: Symbol) = W Int deriving Num -{-# DEPRECATED weights "Can be omitted" #-} -- | 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 @@ -186,84 +265,168 @@ class UniformWeight (Weights_ f) => UniformWeight_ f instance UniformWeight (Weights_ f) => UniformWeight_ f -data Sized-data Unsized+-- | Derived uniform distribution of constructors for @a@.+class UniformWeight_ (Rep a) => GUniformWeight a+instance UniformWeight_ (Rep a) => GUniformWeight a --- | Generic Arbitrary-class GA sized f where-  ga :: proxy sized -> Weights_ f -> Int -> Gen (f p) -instance GA sized f => GA sized (M1 D c f) where-  ga z w n = fmap M1 (ga z w n)+-- | Type-level options for 'GArbitrary'.+data Options (s :: Sizing) (g :: [Type]) = Options+  { _generators :: GenList g+  } -instance (GASum sized f, GASum sized g) => GA sized (f :+: g) where-  ga = gaSum'+unsizedOpts :: UnsizedOpts+unsizedOpts = Options Nil -instance GAProduct sized f => GA sized (M1 C c f) where-  ga z _ _ = fmap M1 (gaProduct z)+sizedOpts :: SizedOpts+sizedOpts = Options Nil ++-- | Whether to decrease the size parameter before generating fields.+data Sizing = Sized | Unsized++type UnsizedOpts = (Options 'Unsized '[] :: Type)+type SizedOpts = (Options 'Sized '[] :: Type)++type family SizingOf opts :: Sizing+type instance SizingOf (Options s _g) = s++proxySizing :: opts -> Proxy (SizingOf opts)+proxySizing _ = Proxy++setSized :: Options s g -> Options 'Sized g+setSized = coerce++setUnsized :: Options s g -> Options 'Unsized g+setUnsized = coerce++-- | Heterogeneous list of generators.+data GenList (g :: [Type]) where+  Nil :: GenList '[]+  (:@) :: Gen a -> GenList g -> GenList (a ': g)++infixr 3 :@++type family GeneratorsOf opts :: [Type]+type instance GeneratorsOf (Options _s g) = g++class HasGenerators opts where+  generators :: opts -> GenList (GeneratorsOf opts)++instance HasGenerators (Options s g) where+  generators = _generators++setGenerators :: GenList g -> Options s g0 -> Options s g+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-instance {-# INCOHERENT #-}-  TypeError-    (     'Text "Unrecognized Rep: "-    ':<>: 'ShowType f-    ':$$: 'Text "Possible cause: missing Generic instance"-    )-  => GA sized f where-  ga = error "Type error"+-- | A marker for a generator which overrides a specific field+-- named @s@.+--+-- /Available only for @base >= 4.9@./+newtype Field (s :: Symbol) a = Field { unField :: a }++-- | 'Field' constructor with the field name given via a proxy.+field :: proxy s -> a -> Field s a+field _ = Field #endif -gaSum' :: GASum sized f => proxy sized -> Weights_ f -> Int -> Gen (f p)++-- | 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)++instance (GASum opts f, GASum opts g) => GA opts (f :+: g) where+  ga = gaSum'++instance GAProduct (SizingOf opts) opts f => GA opts (M1 C c f) where+  ga z _ _ = fmap M1 (gaProduct (proxySizing z) z)++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 -class GASum sized f where-  gaSum :: proxy sized -> Int -> Weights_ f -> Gen (f p)+class GASum opts f where+  gaSum :: opts -> Int -> Weights_ f -> Gen (f p) -instance (GASum sized f, GASum sized g) => GASum sized (f :+: g) where+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) -instance GAProduct sized f => GASum sized (M1 i c f) where-  gaSum z _ _ = fmap M1 (gaProduct z)+instance GAProduct (SizingOf opts) opts f => GASum opts (M1 i c f) where+  gaSum z _ _ = fmap M1 (gaProduct (proxySizing z) z)  -class GAProduct sized f where-  gaProduct :: proxy sized -> Gen (f p)+class GAProduct (s :: Sizing) opts f where+  gaProduct :: proxys s -> opts -> Gen (f p) -instance GAProduct' f => GAProduct Unsized f where+instance GAProduct' opts f => GAProduct 'Unsized opts f where   gaProduct _ = gaProduct' -instance (GAProduct' f, KnownNat (Arity f)) => GAProduct Sized f where-  gaProduct _ = sized $ \n -> resize (n `div` arity) gaProduct'+instance (GAProduct' opts f, KnownNat (Arity f)) => GAProduct 'Sized opts f where+  gaProduct _ opts = sized $ \n -> resize (n `div` arity) (gaProduct' opts)     where       arity = fromInteger (natVal (Proxy :: Proxy (Arity f))) -instance {-# OVERLAPPING #-} GAProduct Sized U1 where-  gaProduct _ = pure U1+instance {-# OVERLAPPING #-} GAProduct 'Sized opts U1 where+  gaProduct _ _ = pure U1  -class GAProduct' f where-  gaProduct' :: Gen (f p)+class GAProduct' opts f where+  gaProduct' :: opts -> Gen (f p) -instance GAProduct' U1 where-  gaProduct' = pure U1+instance GAProduct' opts U1 where+  gaProduct' _ = pure U1 -instance Arbitrary c => GAProduct' (K1 i c) where-  gaProduct' = fmap K1 arbitrary -instance (GAProduct' f, GAProduct' g) => GAProduct' (f :*: g) where-  gaProduct' = liftA2 (:*:) gaProduct' gaProduct'+instance (HasGenerators opts, ArbitraryOr (GeneratorsOf opts) (SelectorName d) c)+  => GAProduct' opts (S1 d (K1 i c)) where+  gaProduct' opts = fmap (M1 . K1) (arbitraryOr sel (generators opts))+    where sel = Proxy :: Proxy (SelectorName d) -instance GAProduct' f => GAProduct' (M1 i c f) where-  gaProduct' = fmap M1 gaProduct'+instance (GAProduct' opts f, GAProduct' opts g) => GAProduct' opts (f :*: g) where+  gaProduct' = (liftA2 . liftA2) (:*:) gaProduct' gaProduct'   type family Arity f :: Nat where   Arity (f :*: g) = Arity f + Arity g   Arity (M1 _i _c _f) = 1+++class ArbitraryOr (g :: [Type]) (sel :: Maybe Symbol) a where+  arbitraryOr :: proxy sel -> GenList g -> Gen a++instance {-# INCOHERENT #-} ArbitraryOr (a ': g) sel a where+  arbitraryOr _ (gen :@ _) = gen++instance {-# OVERLAPPABLE #-} ArbitraryOr g sel a => ArbitraryOr (b ': g) sel a where+  arbitraryOr sel (_ :@ gens) = arbitraryOr sel gens++instance Arbitrary a => ArbitraryOr '[] sel a where+  arbitraryOr _ Nil = arbitrary++#if __GLASGOW_HASKELL__ >= 800+instance {-# INCOHERENT #-} ArbitraryOr (Field n a ': g) ('Just n) a where+  arbitraryOr _ (gen :@ _) = coerce gen++type family SelectorName (d :: Meta) :: Maybe Symbol+type instance SelectorName (MetaSel mn su ss ds) = mn+#else+type SelectorName d = Nothing+#endif   newtype Weighted a = Weighted (Maybe (Int -> Gen a, Int))

@@ -69,13 +69,14 @@ -- (x '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) -- @ ----- This will not: the first requires an order of constructors different from--- the definition of the @Tree@ type; the second doesn't have the right number--- of weights.+-- 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@@ -175,6 +176,53 @@ --   arbitrary = --     'genericArbitraryRec' (1 '%' 2 '%' 3 '%' ()) --       \`withBaseCase\` return Leaf1+-- @+--+-- == 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+-- 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 'Generic'+-- @+--+-- - @'Arbitrary' String@ may generate any unicode characters,+--   alphanumeric or not;+-- - @'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...+--+-- @+-- customGens :: 'GenList' '['Field' "userId" Int, String]+-- customGens =+--   ('Field' . 'getNonNegative' \<$\> arbitrary) ':@'+--   ('listOf' ('elements' (filter isAlphaNum [minBound .. maxBound]))) ':@'+--   'Nil'+-- @+--+-- And to use the 'genericArbitraryG' and 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);+-- - everything else defaults to 'arbitrary'.+--+-- @+-- instance Arbitrary User where+--   arbitrary = 'genericArbitrarySingleG' customGens -- @  module Generic.Random.Tutorial () where