generic-random 0.3.0.0 → 0.4.0.0

raw patch · 8 files changed

+493/−262 lines, 8 filesdep +optparse-genericdep +testing-featdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: optparse-generic, testing-feat

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +3/−3
• bench/binaryTree.hs +37/−19
• generic-random.cabal +30/−14
• src/Generic/Random/Generic.hs +187/−8
• src/Generic/Random/Internal/Generic.hs +218/−216
• test/Test/Tree.hs +1/−1
• test/tree.hs +11/−1

@@ -1,3 +1,9 @@+# 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

@@ -1,4 +1,4 @@-Generic 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.svg?branch=master)+Generic 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.Data`@@ -50,7 +50,7 @@       deriving (Show, Generic)      instance Arbitrary a => Arbitrary (Tree a) where-      arbitrary = genericArbitrary' Z+      arbitrary = genericArbitrary' Z uniform      -- Equivalent to     -- > arbitrary =@@ -66,7 +66,7 @@     main = sample (arbitrary :: Gen (Tree ())) ``` -- User-specified distribution of constructors.+- User-specified distribution of constructors, with compile-time checks. - A simple (optional) strategy to ensure termination: `Test.QuickCheck.Gen`'s   size parameter decreases at every recursive `genericArbitrary'` call; when it   reaches zero, sample directly from a finite set of finite values.

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell #-} module Main where  import Control.Applicative@@ -10,6 +10,7 @@ import GHC.Generics import Control.DeepSeq import Criterion.Main+import Test.Feat import Test.QuickCheck import Test.QuickCheck.Gen import Test.QuickCheck.Random@@ -19,10 +20,16 @@ import Generic.Random.Internal.Types  data T = N T T | L-  deriving (Eq, Ord, Show, Data, Generic)+  deriving (Eq, Ord, Show, Data, Typeable, Generic)  instance NFData T +deriveEnumerable ''T++size :: Num a => T -> a+size L = 1+size (N l r) = 1 + size l + size r+ gen1 :: Int -> Gen T gen1 n = runRejectT (tolerance epsilon (n + 1)) gen'   where@@ -39,19 +46,17 @@         (k (n+1) L)         (gen' (n+1) $ \m l -> gen' m $ \m r -> k m (N l r)) -main = getGs >>= \gs -> defaultMain $ liftA2 (\n f -> f n gs)-  [4 ^ e | e <- [1 .. 5]]+genFeat :: Int -> Gen T+genFeat = uniform +main = newQCGen >>= \g -> defaultMain $ liftA2 (\n f -> f n g)+  [4 ^ e | e <- [1 .. 6]]+   -- Singular rejection sampling   [ bg "handwritten1" gen1   , bg "handwritten2" gen2-  , bg "SR" generatorSR -  -- Sized rejection sampling-  , bg "R" generatorR'--  -- Sized rejection sampling, not memoizing oracle-  , bg' "R-recomp" generatorR'+  , bg "feat" genFeat    -- Pointed generator   , bg "P" generatorP'@@ -59,20 +64,33 @@   -- Pointed generator with rejection sampling   , bg "PR" generatorPR' +  , bg "SR" generatorSR++  -- Sized rejection sampling+  , bg "R" generatorR'++  -- Sized rejection sampling, not memoizing oracle+  , bg' "R-recomp" generatorR'+   -- Pointed generator, not memoizing oracle   , bg' "P-recomp" generatorP'   ] -bg, bg' :: String -> (Int -> Gen T) -> Int -> [QCGen] -> Benchmark-bg name gen n gs =-  bench (name ++ "_" ++ show n) $-    nf (fmap (\g -> unGen gg g 0)) gs+bg, bg' :: String -> (Int -> Gen T) -> Int -> QCGen -> Benchmark+bg name gen n g =+  bench (name ++ "_" ++ show n) $ nf f g   where+    go 0 = return (0 :: Int)+    go k = liftA2 (\t s -> size t + s) gg (go (k-1))     gg = gen n+    f g = unGen (go 100) g 0 -bg' name gen n gs =-  bench (name ++ "_" ++ show n) $-    nf (fmap (\(n, g) -> unGen (gen n) g 0)) (fmap ((,) n) gs)+bg' name gen n g =+  bench (name ++ "_" ++ show n) $ nf f (n, g)+  where+    go n 0 = return (0 :: Int)+    go n k = liftA2 (\t s -> size t + s) (gen n) (go n (k-1))+    f (n, g) = unGen (go n 100) g 0 -getGs :: IO [QCGen]-getGs = replicateM 100 newQCGen+avgSize :: [T] -> Double+avgSize ts = sum (fmap size ts) / fromIntegral (length ts)

@@ -1,5 +1,5 @@ name:                generic-random-version:             0.3.0.0+version:             0.4.0.0 synopsis:            Generic random generators description:         Please see the README. homepage:            http://github.com/lysxia/generic-random@@ -12,8 +12,15 @@ build-type:          Simple extra-source-files:  README.md CHANGELOG.md cabal-version:       >=1.10-tested-with:         GHC == 7.10.3, GHC == 8.0.1+tested-with:         GHC == 8.0.1 +flag test+  Description:+    Enable testing. Disabled by default because the current test suite+    is slow and can fail with non-zero probability.+  Manual:  True+  Default: False+ library   hs-source-dirs:      src   exposed-modules:@@ -27,7 +34,7 @@     Generic.Random.Internal.Solver     Generic.Random.Internal.Types   build-depends:-    base >= 4.8 && < 5,+    base >= 4.9 && < 4.10,     containers,     hashable,     unordered-containers,@@ -47,26 +54,35 @@   hs-source-dirs:   test   main-is:          tree.hs   default-language: Haskell2010-  build-depends:-    base,-    QuickCheck,-    generic-random   other-modules:     Test.Stats,     Test.Tree+  if flag(test)+    build-depends:+      base,+      QuickCheck,+      optparse-generic,+      generic-random+  else+    buildable: False  benchmark bench-binarytree   type:             exitcode-stdio-1.0   hs-source-dirs:   bench   main-is:          binaryTree.hs   default-language: Haskell2010-  build-depends:-    base,-    criterion,-    deepseq,-    QuickCheck,-    transformers,-    generic-random+  ghc-options: -O2+  if flag(test)+    build-depends:+      base,+      criterion,+      deepseq,+      QuickCheck,+      transformers,+      testing-feat,+      generic-random+  else+    buildable: False  source-repository head   type:     git

@@ -2,34 +2,213 @@ -- -- Here is an example. Define your type. ----- > data Tree a = Leaf a | Node (Tree a) (Tree a)--- >   deriving Generic+-- @+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+--   deriving Generic+-- @ ----- Pick an arbitrary implementation.+-- Pick an 'arbitrary' implementation. ----- > instance Arbitrary a => Arbitrary (Tree a) where--- >   arbitrary = genericArbitraryFrequency [9, 8]+-- @+-- instance Arbitrary a => Arbitrary (Tree a) where+--   arbitrary = 'genericArbitrary' ('weights' (9 '%' 8 '%' ()))+-- @ -- -- @arbitrary :: 'Gen' (Tree a)@ picks a @Leaf@ with probability 9\/17, or a -- @Node@ with probability 8\/17, and recursively fills their fields with -- @arbitrary@.+--+-- == Distribution of constructors+--+-- The distribution of constructors can be specified using 'weights' applied to+-- 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.+--+-- For @Tree@, 'genericArbitrary' produces code equivalent to the following:+--+-- @+-- 'genericArbitrary' :: Arbitrary a => 'Weights' (Tree a) -> Gen (Tree a)+-- 'genericArbitrary' ('weighted' (x '%' y '%' ())) =+--   frequency+--     [ (x, Leaf \<$\> arbitrary)+--     , (y, Node \<$\> arbitrary \<*\> arbitrary)+--     ]+-- @+--+-- The weights actually have type @'W' \"ConstructorName\"@ (just a newtype+-- around 'Int'), so that you can annotate a weight with its corresponding+-- constructor, and it will be checked that you got the order right.+--+-- This will type-check.+--+-- @+-- 'weighted' ((x :: 'W' \"Leaf\") '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a)+-- 'weighted' (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.+--+-- @+-- 'weighted' ((x :: 'W' \"Node\") '%' y '%' ()) :: 'Weights' (Tree a)+-- 'weighted' (x '%' y '%' z '%' ()) :: 'Weights' (Tree a)+-- @+--+-- === Uniform distribution+--+-- You can specify the uniform distribution with 'uniform'.+--+-- For @Tree@, @'genericArbitrary' 'uniform'@ produces code equivalent to the+-- following:+--+-- @+-- 'genericArbitrary' 'uniform' :: Arbitrary a => Gen (Tree a)+-- 'genericArbitrary' 'uniform' =+--   oneof+--     [ Leaf \<$\> arbitrary                -- Uses Arbitrary a+--     , Node \<$\> arbitrary \<*\> arbitrary  -- Uses Arbitrary (Tree a)+--     ]+-- @+--+-- Note that for many types, a uniform distribution tends to produce big+-- values. For instance for @Tree a@, generated values are finite but the+-- __average__ number of @Leaf@ and @Node@ constructors is __infinite__.+--+-- == Ensuring termination+--+-- As was just mentioned, one must be careful with recursive types+-- to avoid producing extremely large values.+--+-- The alternative '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 finite term whenever it can find any of the given type.  This+-- generally ensures that the number of constructors remains close to the+-- initial size parameter passed to 'Gen'.+--+-- A natural number @n@ determines the maximum /depth/ of terms that can be+-- used to end recursion.+-- It is encoded using @'Z' :: 'Z'@ and @'S' :: n -> 'S' n@.+--+-- @+-- 'genericArbitrary'' n ('weights' (...))+-- @+--+-- With @n = 'Z'@, the generator looks for a simple nullary constructor.  If none+-- exist at the current type, as is the case for our @Tree@ type, it carries on+-- as in 'genericArbitrary'.+--+-- @+-- 'genericArbitrary'' 'Z' :: Arbitrary a => 'Weights' (Tree a) -> Gen (Tree a)+-- 'genericArbitrary'' 'Z' ('weights' (x '%' y '%' ())) =+--   frequency+--     [ (x, Leaf \<$\> arbitrary)+--     , (y, scale (\`div\` 2) $ Node \<$\> arbitrary \<*\> arbitrary)+--     -- 2 because Node is 2-ary.+--     ]+-- @+--+-- Here is another example with nullary constructors:+--+-- @+-- data Tree' = Leaf1 | Leaf2 | Node3 Tree' Tree' Tree'+--   deriving Generic+--+-- instance Arbitrary Tree' where+--   arbitrary = 'genericArbitrary'' 'Z' ('weights' (1 '%' 2 '%' 3 '%' ()))+-- @+--+-- Here, @'genericArbitrary'' 'Z'@ is equivalent to:+--+-- @+-- 'genericArbitrary'' 'Z' :: 'Weights' Tree' -> Gen Tree'+-- 'genericArbitrary'' 'Z' ('weights' (x '%' y '%' z '%' ())) =+--   sized $ \n ->+--     if n == 0 then+--       -- If the size parameter is zero, the non-nullary alternative is discarded.+--       frequency $+--         [ (x, return Leaf1)+--         , (y, return 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+-- @+--+-- To increase the chances of termination when no nullary constructor is directly+-- available, such as in @Tree@, we can pass a larger depth @n@. The effectiveness+-- of this parameter depends on the concrete type the generator is used for.+--+-- For instance, if we want to generate a value of type @Tree ()@, there is a+-- value of depth 1 (represented by @'S' 'Z'@) that we can use to end+-- recursion: @Leaf ()@.+--+-- @+-- 'genericArbitrary'' ('S' 'Z') :: 'Weights' (Tree ()) -> Gen (Tree ())+-- 'genericArbitrary'' ('S' 'Z') ('weights' (x '%' y '%' ())) =+--   sized $ \n ->+--     if n == 0 then+--       return (Leaf ())+--     else+--       frequency+--         [ (x, Leaf \<$\> arbitrary)+--         , (y, scale (\`div\` 2) $ Node \<$\> arbitrary \<*\> arbitrary)+--         ]+-- @+--+-- 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.+--+-- @UndecidableInstances@ is also required.+--+-- @+-- instance (Arbitrary a, Generic a, 'ListBaseCases' 'Z' (Rep a))+--   => Arbitrary (Tree a) where+--   arbitrary = 'genericArbitrary'' ('S' 'Z') ('weights' (1 '%' 2 '%' ()))+-- @+--+-- A synonym is provided for brevity.+--+-- @+-- instance (Arbitrary a, 'BaseCases'' Z a) => Arbitrary (Tree a) where+--   arbitrary = 'genericArbitrary'' ('S' 'Z') ('weights' (1 '%' 2 '%' ()))+-- @ + module Generic.Random.Generic   (     -- * Arbitrary implementations     genericArbitrary-  , genericArbitraryFrequency-  , genericArbitraryFrequency'   , genericArbitrary' +    -- * Specifying finite distributions+  , Weights+  , W+  , weights+  , (%)+  , uniform+     -- * Type-level natural numbers     -- $nat   , Z (..)   , S (..) -    -- * Generic class for finite values+    -- * Generic classes for finite values   , BaseCases'   , BaseCases+  , ListBaseCases   ) where  import Generic.Random.Internal.Generic

@@ -1,259 +1,212 @@-{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+ module Generic.Random.Internal.Generic where  import Control.Applicative import Data.Coerce+import GHC.Exts (Proxy#, proxy#) import GHC.Generics hiding ( S )+import GHC.TypeLits import Test.QuickCheck  -- * Random generators --- | Pick a constructor with uniform probability, and fill its fields+-- | Pick a constructor with a given distribution, and fill its fields -- recursively.------ An equivalent definition for @Tree@ is:------ > genericArbitrary :: Arbitrary a => Gen (Tree a)--- > genericArbitrary =--- >   oneof--- >     [ Leaf <$> arbitrary                -- Uses Arbitrary a--- >     , Node <$> arbitrary <*> arbitrary  -- Uses Arbitrary (Tree a)--- >     ]------ Note that for many types, 'genericArbitrary' tends to produce big values.--- For instance for @Tree a@ values are finite but the average number of--- @Leaf@ and @Node@ constructors is infinite.+genericArbitrary+  :: forall a+  .  (Generic a, GA Unsized (Rep a))+  => Weights a+  -> Gen a+genericArbitrary (Weights w n) = (unGen' . fmap to) (ga w n :: Gen' Unsized (Rep a p)) -genericArbitrary :: forall a. (Generic a, GA Unsized (Rep a)) => Gen a-genericArbitrary =-  (($ repeat 1) . unFreq . fmap to) (ga :: Freq Unsized (Rep a p))+-- | Like 'genericArbitrary'', with bounded size to ensure termination for+-- recursive types.+genericArbitrary'+  :: forall n a+  . (Generic a, GA (Sized n) (Rep a))+  => n+  -> Weights a  -- ^ List of weights for every constructor+  -> Gen a+genericArbitrary' _ (Weights w n) =+  (unGen' . fmap to) (ga w n :: Gen' (Sized n) (Rep a p))  --- | This allows to specify the probability distribution of constructors--- as a list of weights, in the same order as the data type definition.------ An equivalent definition for @Tree@ is:------ > genericArbitraryFrequency :: Arbitrary a => [Int] -> Gen (Tree a)--- > genericArbitraryFrequency [x, y] =--- >   frequency--- >     [ (x, Leaf <$> arbitrary)--- >     , (y, Node <$> arbitrary <*> arbitrary)--- >     ]+-- * Internal -genericArbitraryFrequency-  :: forall a. (Generic a, GA Unsized (Rep a))-  => [Int]  -- ^ List of weights for every constructor-  -> Gen a-genericArbitraryFrequency = (unFreq . fmap to) (ga :: Freq Unsized (Rep a p))+type family Weights_ (f :: * -> *) :: * where+  Weights_ (f :+: g) = Weights_ f :| Weights_ g+  Weights_ (M1 D _c f) = Weights_ f+  Weights_ (M1 C ('MetaCons c _i _j) _f) = L c +data a :| b = N a Int b+data L (c :: Symbol) = L --- | The size parameter of 'Gen' is divided among the fields of the chosen--- constructor.  When it reaches zero, the generator selects a finite term--- whenever it can find any of the given type.------ The natural number @n@ determines the maximum /depth/ of terms that can be--- used to end recursion.--- It is encoded using @'Z' :: 'Z'@ and @'S' :: n -> 'S' n@.------ > genericArbitraryFrequency' n weights------ With @n = 'Z'@, the generator looks for a simple nullary constructor.  If none--- exist at the current type, as is the case for our @Tree@ type, it carries on--- as in 'genericArbitraryFrequency'.------ > genericArbitraryFrequency' Z :: Arbitrary a => [Int] -> Gen (Tree a)--- > genericArbitraryFrequency' Z [x, y] =--- >   frequency--- >     [ (x, Leaf <$> arbitrary)--- >     , (y, scale (`div` 2) $ Node <$> arbitrary <*> arbitrary)--- >     ]--- >     -- 2 because Node is 2-ary.------ Here is another example:------ > data Tree' = Leaf1 | Leaf2 | Node3 Tree' Tree' Tree'--- >   deriving Generic--- >--- > instance Arbitrary Tree' where--- >   arbitrary = genericArbitraryFrequency' Z [1, 2, 3]------ 'genericArbitraryFrequency'' is equivalent to:------ > genericArbitraryFrequency' Z :: [Int] -> Gen Tree'--- > genericArbitraryFrequency' Z [x, y, z] =--- >   sized $ \n ->--- >     if n == 0 then--- >       -- If the size parameter is zero, the non-nullary alternative is discarded.--- >       frequency $--- >         [ (x, return Leaf1)--- >         , (y, return 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------ To increase the chances of termination when no nullary constructor is directly--- available, such as in @Tree@, we can pass a larger depth @n@. The effectiveness--- of this parameter depends on the concrete type the generator is used for.------ For instance, if we want to generate a value of type @Tree ()@, there is a--- value of depth 1 (represented by @'S' 'Z'@) that we can use to end--- recursion: @Leaf ()@.------ > genericArbitraryFrequency' (S Z) :: [Int] -> Gen (Tree ())--- > genericArbitraryFrequency' (S Z) [x, y] =--- >   sized $ \n ->--- >     if n == 0 then--- >       return (Leaf ())--- >     else--- >       frequency--- >         [ (x, Leaf <$> arbitrary)--- >         , (y, scale (`div` 2) $ Node <$> arbitrary <*> arbitrary)--- >         ]+-- | Trees of weights assigned to constructors of type @a@,+-- rescaled to obtain a probability distribution. ----- 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.+-- Two ways of constructing them. ----- @FlexibleContexts@ and @UndecidableInstances@ are also required.+-- @+-- 'weights' (x1 '%' x2 '%' ... '%' xn '%' ()) :: 'Weights' a+-- 'uniform' :: 'Weights' a+-- @ ----- > instance (Arbitrary a, Generic a, BaseCases Z (Rep a))--- >   => Arbitrary (Tree a) where--- >   arbitrary = genericArbitraryFrequency' (S Z) [1, 2]+-- Using @weights@, there must be exactly as many weights as+-- there are constructors. ----- A synonym is provided for brevity.+-- 'uniform' is equivalent to @'weights' (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. ----- > instance (Arbitrary a, BaseCases' Z a) => Arbitrary (Tree a) where--- >   arbitrary = genericArbitraryFrequency' (S Z) [1, 2]+-- @+-- 'weights' ((9 :: 'W' \"Leaf\") '%' (8 :: 'W' \"Node\") '%' ())+-- @+newtype W (c :: Symbol) = W Int deriving Num -genericArbitraryFrequency'-  :: forall n a-  . (Generic a, GA (Sized n) (Rep a))-  => n-  -> [Int]  -- ^ List of weights for every constructor-  -> Gen a-genericArbitraryFrequency' _ =-  (unFreq . fmap to) (ga :: Freq (Sized n) (Rep a p))+-- | A smart constructor to specify a custom distribution.+weights :: (Weights_ (Rep a), Int, ()) -> Weights a+weights (w, n, ()) = Weights w n +-- | Uniform distribution.+uniform :: UniformWeight (Weights_ (Rep a)) => Weights a+uniform =+  let (w, n) = uniformWeight+  in Weights w n --- | Like 'genericArbitraryFrequency'', but with uniformly distributed--- constructors.+type family First a :: Symbol where+  First (a :| _b) = First a+  First (L c) = c -genericArbitrary'-  :: forall n a-  . (Generic a, GA (Sized n) (Rep a)) => n -> Gen a-genericArbitrary' _ =-  (($ repeat 1) . unFreq . fmap to) (ga :: Freq (Sized n) (Rep a p))+class WeightBuilder a where+  type Prec a r +  -- | A binary constructor for building up trees of weights.+  (%) :: W (First a) -> Prec a r -> (a, Int, r) --- * Internal+infixr 1 % -newtype Freq sized a = Freq { unFreq :: [Int] -> Gen a }-  deriving Functor+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 Applicative (Freq sized) where-  pure = Freq . pure . pure-  Freq f <*> Freq x = Freq (liftA2 (<*>) f x)+instance WeightBuilder (L c) where+  type Prec (L c) r = r+  W m % prec = (L, 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)+ newtype Gen' sized a = Gen' { unGen' :: Gen a }-  deriving (Functor, Applicative)+  deriving (Functor, Applicative, Monad)  data Sized n data Unsized -liftGen :: Gen a -> Freq sized a-liftGen = Freq . const+sized' :: (Int -> Gen' sized a) -> Gen' sized a+sized' g = Gen' . sized $ \sz -> unGen' (g sz)  -- | Generic Arbitrary class GA sized f where-  ga :: Freq sized (f p)+  ga :: Weights_ f -> Int -> Gen' sized (f p) -instance GA sized U1 where-  ga = pure U1+instance GA sized f => GA sized (M1 D c f) where+  ga w n = fmap M1 (ga w n) -instance Arbitrary c => GA sized (K1 i c) where-  ga = liftGen . fmap K1 $ arbitrary+instance GAProduct f => GA Unsized (M1 C c f) where+  ga _ _ = (Gen' . fmap M1) gaProduct -instance GA sized f => GA sized (M1 i c f) where-  ga = fmap M1 ga+instance (GAProduct f, KnownNat (Arity f)) => GA (Sized n) (M1 C c f) where+  ga _ _ = Gen' (scale (`div` arity) gaProduct)+    where+      arity = fromInteger (natVal' (proxy# :: Proxy# (Arity f)))  instance (GASum (Sized n) f, GASum (Sized n) g, BaseCases n f, BaseCases n g)   => GA (Sized n) (f :+: g) where-  ga = frequency' gaSum baseCases-    where-      frequency' :: [Gen' sized a] -> Tagged n [[a]] -> Freq sized a-      frequency' as (Tagged a0s) = Freq $ \ws ->-        let-          units = [(w, elements a0) | (w, a0@(_ : _)) <- zip ws a0s]-        in-          sized $ \sz -> frequency $-            if sz == 0 && not (null units) then-              units-            else-              [(w, a) | (w, Gen' a) <- zip ws as]+  ga w n = sized' $ \sz ->+    case unTagged (baseCases w n :: Tagged n (Weighted ((f :+: g) p))) of+      Weighted (Just (bc, n)) | sz == 0 -> Gen' (choose (0, n - 1) >>= bc)+      _ -> gaSum' w n  instance (GASum Unsized f, GASum Unsized g) => GA Unsized (f :+: g) where-  ga = frequency' gaSum-    where-      frequency' :: [Gen' sized a] -> Freq sized a-      frequency' as = Freq $ \ws -> frequency-        [(w, a) | (w, Gen' a) <- zip ws as]--instance (GA Unsized f, GA Unsized g) => GA Unsized (f :*: g) where-  ga = liftA2 (:*:) ga ga--instance (GAProduct f, GAProduct g) => GA (Sized n) (f :*: g) where-  ga = constScale' a-    where-      constScale' :: Gen' Unsized a -> Freq (Sized n) a-      constScale' = Freq . const . scale (`div` arity) . unGen'-      (arity, a) = gaProduct-+  ga = gaSum' -gArbitrarySingle :: forall sized f p . GA sized f => Gen' sized (f p)-gArbitrarySingle = Gen' (unFreq (ga :: Freq sized (f p)) [1])+gArbitrarySingle+  :: forall sized f p c0+  .  (GA sized f, Weights_ f ~ L c0)+  => Gen' sized (f p)+gArbitrarySingle = ga L 0 +gaSum' :: GASum sized f => Weights_ f -> Int -> Gen' sized (f p)+gaSum' w n = do+  i <- Gen' $ choose (0, n-1)+  gaSum i w  class GASum sized f where-  gaSum :: [Gen' sized (f p)]+  gaSum :: Int -> Weights_ f -> Gen' sized (f p)  instance (GASum sized f, GASum sized g) => GASum sized (f :+: g) where-  gaSum = (fmap . fmap) L1 gaSum ++ (fmap . fmap) R1 gaSum+  gaSum i (N a n b)+    | i < n = fmap L1 (gaSum i a)+    | otherwise = fmap R1 (gaSum (i - n) b) -instance GA sized f => GASum sized (M1 i c f) where-  gaSum = [gArbitrarySingle]+instance GAProduct f => GASum sized (M1 i c f) where+  gaSum _ _ = Gen' gaProduct   class GAProduct f where-  gaProduct :: (Int, Gen' Unsized (f p))+  gaProduct :: Gen (f p) -instance GA Unsized f => GAProduct (M1 i c f) where-  gaProduct = (1, gArbitrarySingle)+instance GAProduct U1 where+  gaProduct = pure U1 +instance Arbitrary c => GAProduct (K1 i c) where+  gaProduct = fmap K1 arbitrary++instance GAProduct f => GAProduct (M1 i c f) where+  gaProduct = fmap M1 gaProduct+ instance (GAProduct f, GAProduct g) => GAProduct (f :*: g) where-  gaProduct = (m + n, liftA2 (:*:) a b)-    where-      (m, a) = gaProduct-      (n, b) = gaProduct+  gaProduct = liftA2 (:*:) gaProduct gaProduct +type family Arity f :: Nat where+  Arity (f :*: g) = Arity f + Arity g+  Arity (M1 _i _c _f) = 1 + newtype Tagged a b = Tagged { unTagged :: b }+  deriving Functor  -- $nat -- Use the 'Z' and 'S' data types to define the depths of values used--- by 'genericArbitraryFrequency'' and 'genericArbitrary'' to make--- generators terminate.+-- by 'genericArbitrary'' to make generators terminate.  -- | Zero data Z = Z@@ -261,38 +214,87 @@ -- | Successor data S n = S n --- | A @BaseCases n ('Rep' a)@ constraint basically provides the list of values--- of type @a@ with depth at most @n@.+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 (f, m) (a, n) =+        ( \i ->+            let (j, k) = i `divMod` m+            in f j <*> a 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 )+ class BaseCases n f where-  baseCases :: Tagged n [[f p]]+  baseCases :: Weights_ f -> Int -> Tagged n (Weighted (f p)) --- | For convenience.-type BaseCases' n a = (Generic a, BaseCases n (Rep a))+instance (BaseCases n f, BaseCases n g) => BaseCases n (f :+: g) where+  baseCases (N a m b) n =+    concat+      ((fmap . fmap) L1 (baseCases a m))+      ((fmap . fmap) R1 (baseCases b (n - m)))+    where+      concat :: Alternative u => Tagged n (u a) -> Tagged n (u a) -> Tagged n (u a)+      concat (Tagged a) (Tagged b) = Tagged (a <|> b) -baseCases' :: forall n f p. BaseCases n f => Tagged n [f p]-baseCases' = (Tagged . concat . unTagged) (baseCases :: Tagged n [[f p]])+instance ListBaseCases n f => BaseCases n (M1 i c f) where+  baseCases _ n = fmap reweigh listBaseCases+    where+      reweigh :: Weighted a -> Weighted a+      reweigh (Weighted h) = Weighted (fmap (\(g, _) -> (g, n)) h) -instance BaseCases n U1 where-  baseCases = Tagged [[U1]]+-- | A @ListBaseCases n ('Rep' a)@ constraint basically provides the list of+-- values of type @a@ with depth at most @n@.+class ListBaseCases n f where+  listBaseCases :: Alternative u => Tagged n (u (f p)) -instance BaseCases n f => BaseCases n (M1 i c f) where-  baseCases = (coerce :: Tagged n [[f p]] -> Tagged n [[M1 i c f p]]) baseCases+-- | For convenience.+type BaseCases' n a = (Generic a, ListBaseCases n (Rep a)) -instance BaseCases Z (K1 i c) where-  baseCases = Tagged [[]]+instance ListBaseCases n U1 where+  listBaseCases = Tagged (pure U1) -instance (Generic c, BaseCases n (Rep c)) => BaseCases (S n) (K1 i c) where-  baseCases =-    (Tagged . (fmap . fmap) (K1 . to) . unTagged)-      (baseCases :: Tagged n [[Rep c p]])+instance ListBaseCases n f => ListBaseCases n (M1 i c f) where+  listBaseCases = (fmap . fmap) M1 listBaseCases -instance (BaseCases n f, BaseCases n g) => BaseCases n (f :+: g) where-  baseCases = Tagged $-    ((fmap . fmap) L1 . unTagged) (baseCases :: Tagged n [[f p]]) ++-    ((fmap . fmap) R1 . unTagged) (baseCases :: Tagged n [[g p]])+instance ListBaseCases Z (K1 i c) where+  listBaseCases = Tagged empty -instance (BaseCases n f, BaseCases n g) => BaseCases n (f :*: g) where-  baseCases = Tagged-    [ liftA2 (:*:)-        (unTagged (baseCases' :: Tagged n [f p]))-        (unTagged (baseCases' :: Tagged n [g p])) ]+instance (Generic c, ListBaseCases n (Rep c)) => ListBaseCases (S n) (K1 i c) where+  listBaseCases = (retag . (fmap . fmap) (K1 . to)) listBaseCases+    where+      retag :: Tagged n a -> Tagged (S n) a+      retag = coerce++instance (ListBaseCases n f, ListBaseCases n g) => ListBaseCases n (f :+: g) where+  listBaseCases =+    concat+      ((fmap . fmap) L1 listBaseCases)+      ((fmap . fmap) R1 listBaseCases)+    where+      concat :: Alternative u => Tagged n (u a) -> Tagged n (u a) -> Tagged n (u a)+      concat (Tagged a) (Tagged b) = Tagged (a <|> b)++instance (ListBaseCases n f, ListBaseCases n g) => ListBaseCases n (f :*: g) where+  listBaseCases = liftedP listBaseCases listBaseCases+    where+      liftedP+        :: Applicative u+        => Tagged n (u (f p))+        -> Tagged n (u (g p))+        -> Tagged n (u ((f :*: g) p))+      liftedP (Tagged f) (Tagged g) = Tagged (liftA2 (:*:) f g)

@@ -16,4 +16,4 @@ size L = 0  instance Arbitrary T where-  arbitrary = genericArbitraryFrequency [9, 8]+  arbitrary = genericArbitrary (weights (9 % 8 % ()))

@@ -1,3 +1,7 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}+ import Control.Monad import Data.Data import Data.Foldable@@ -6,6 +10,8 @@ import System.Exit import System.IO +import Options.Generic+ import Generic.Random.Data import Generic.Random.Internal.Data @@ -23,10 +29,14 @@     when (x `mod` 1000 == 0) $ putStr "." >> hFlush stdout   gen +-- | Invocation: stack test [--test-arguments TEST_SIZE]+type Input = Maybe (Int <?> "Test size")+ main = do+  n_ <- getRecord "Test program" :: IO Input   success <- newIORef True -  let n = 64+  let n = maybe 10 unHelpful n_       range = tolerance epsilon n    for_