generic-random 0.1.1.0 → 1.5.0.1
raw patch · 19 files changed
Files
- CHANGELOG.md +101/−0
- README.md +51/−27
- bench/binaryTree.hs +0/−78
- generic-random.cabal +75/−37
- src/Data/Random/Generics.hs +0/−302
- src/Data/Random/Generics/Internal.hs +0/−146
- src/Data/Random/Generics/Internal/Oracle.hs +0/−539
- src/Data/Random/Generics/Internal/Solver.hs +0/−65
- src/Data/Random/Generics/Internal/Types.hs +0/−191
- src/Generic/Random.hs +246/−0
- src/Generic/Random/DerivingVia.hs +334/−0
- src/Generic/Random/Internal/BaseCase.hs +321/−0
- src/Generic/Random/Internal/Generic.hs +790/−0
- src/Generic/Random/Tutorial.hs +287/−0
- test/Inspect.hs +47/−0
- test/Inspect/DerivingVia.hs +33/−0
- test/Unit.hs +76/−0
- test/coherence.hs +126/−0
- test/tree.hs +0/−59
+ CHANGELOG.md view
@@ -0,0 +1,101 @@+# Changelog++Latest version: https://github.com/Lysxia/generic-random/blob/master/changelog.md++# 1.5.1.0++- Support GHC 9.2++# 1.5.0.0++- Add newtypes for `DerivingVia` (thanks, blackheaven)+- Drop compatibility with GHC 8.0 and 8.2++# 1.4.0.0++- Add option to use only coherent instances+- Export `SetSized` and `SetUnsized`+- Drop compatibility with GHC 7++# 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'`
README.md view
@@ -1,41 +1,65 @@ Generic random generators [](https://hackage.haskell.org/package/generic-random) [](https://travis-ci.org/Lysxia/generic-random) ========================= -Define sized random generators for almost any type.+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 DeriveDataTypeable #-}- import Data.Data- import Test.QuickCheck- import Data.Random.Generics+{-# LANGUAGE DeriveGeneric #-} - data Term = Lambda Int Term | App Term Term | Var Int- deriving (Show, Data)+import GHC.Generics (Generic)+import Test.QuickCheck+import Generic.Random - instance Arbitrary Term where- arbitrary = sized $ generatorPWith [positiveInts]+data Tree a = Leaf | Node (Tree a) a (Tree a)+ deriving (Show, Generic) - positiveInts :: Alias Gen- positiveInts =- alias $ \() -> fmap getPositive arbitrary :: Gen Int+instance Arbitrary a => Arbitrary (Tree a) where+ arbitrary = genericArbitraryRec uniform `withBaseCase` return Leaf - main = sample (arbitrary :: Gen Term)+-- 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 ())) ``` -- Objects of the same size (number of constructors) occur with the same- probability (see Duchon et al., references below).-- Implements rejection sampling and pointing.-- Works with QuickCheck and MonadRandom.-- Can be extended or modified with user defined generators.+Related+------- -References-----------+- The following two packages also derive random generators, but only with a uniform+ distribution of constructors: -- The core theory of Boltzmann samplers is described in- [Boltzmann Samplers for the Random Generation of Combinatorial Structures](http://algo.inria.fr/flajolet/Publications/DuFlLoSc04.pdf),- P. Duchon, P. Flajolet, G. Louchard, G. Schaeffer.+ + [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) -- The numerical evaluation of recursively defined generating functions- is taken from- [Boltzmann Oracle for Combinatorial Systems](http://www.dmtcs.org/pdfpapers/dmAI0132.pdf),- C. Pivoteau, B. Salvy, M. Soria.+- [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).
− bench/binaryTree.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}-module Main where--import Control.Applicative-import Control.Monad-import Control.Monad.Trans.Class-import Data.Bool-import Data.Data-import Data.Functor-import GHC.Generics-import Control.DeepSeq-import Criterion.Main-import Test.QuickCheck-import Test.QuickCheck.Gen-import Test.QuickCheck.Random-import Control.Exception ( evaluate )-import Data.Random.Generics-import Data.Random.Generics.Internal-import Data.Random.Generics.Internal.Types--data T = N T T | L- deriving (Eq, Ord, Show, Data, Generic)--instance NFData T--gen1 :: Int -> Gen T-gen1 n = runRejectT (tolerance epsilon (n + 1)) gen'- where- gen' = incr >> lift arbitrary >>= bool (return L) (liftA2 N gen' gen')--gen2 :: Int -> Gen T-gen2 n = g- where- (minSize, maxSize) = tolerance epsilon (n + 1)- g = gen' 0 (\m t -> if m < minSize then g else return t)- gen' n k | n >= maxSize = g- gen' n k =- arbitrary >>= bool- (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]]-- -- 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'-- -- Pointed generator- , bg "P" generatorP'-- -- Pointed generator with rejection sampling- , bg "PR" generatorPR'-- -- 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- where- gg = gen n--bg' name gen n gs =- bench (name ++ "_" ++ show n) $- nf (fmap (\(n, g) -> unGen (gen n) g 0)) (fmap ((,) n) gs)--getGs :: IO [QCGen]-getGs = replicateM 100 newQCGen
generic-random.cabal view
@@ -1,66 +1,104 @@ name: generic-random-version: 0.1.1.0-synopsis: Generic random generators-description: Please see the README below.+version: 1.5.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: Experimental+stability: Stable author: Li-yao Xia maintainer: lysxia@gmail.com category: Generics, Testing build-type: Simple-extra-source-files: README.md+extra-source-files: README.md CHANGELOG.md cabal-version: >=1.10-tested-with: GHC == 7.10.3+tested-with: GHC == 8.4.1, GHC == 8.6.1, GHC == 8.8.4, GHC == 8.10.5, GHC == 9.0.1, GHC == 9.2.1 library hs-source-dirs: src exposed-modules:- Data.Random.Generics- Data.Random.Generics.Internal- Data.Random.Generics.Internal.Oracle- Data.Random.Generics.Internal.Solver- Data.Random.Generics.Internal.Types+ Generic.Random+ Generic.Random.DerivingVia+ Generic.Random.Internal.BaseCase+ Generic.Random.Internal.Generic+ Generic.Random.Tutorial build-depends:- base >= 4.8 && < 5,- containers,- hashable,- unordered-containers,- ieee754,- ad,- hmatrix,- vector,- mtl,- transformers,- MonadRandom,- QuickCheck+ base >= 4.11 && < 5,+ QuickCheck >= 2.14+ -- exports RecursivelyShrink default-language: Haskell2010 ghc-options: -Wall -fno-warn-name-shadowing -test-suite test-tree- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: tree.hs+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 coherence+ hs-source-dirs: test+ main-is: coherence.hs build-depends: base,+ deepseq, QuickCheck, generic-random+ type: exitcode-stdio-1.0+ default-language: Haskell2010 -benchmark bench-binarytree- type: exitcode-stdio-1.0- hs-source-dirs: bench- main-is: binaryTree.hs+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 !flag(enable-inspect)+ buildable: False+ else+ build-depends: random < 1.2+ -- TODO: this test fails with newer versions of random++test-suite inspect-derivingvia+ hs-source-dirs: test+ main-is: Inspect/DerivingVia.hs build-depends: base,- criterion,- deepseq, QuickCheck,- transformers,+ inspection-testing, generic-random+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ if !flag(enable-inspect)+ buildable: False+ else+ build-depends: random < 1.2+ -- TODO: this test fails with newer versions of random -source-repository head- type: git- location: https://github.com/lysxia/generic-random+flag enable-inspect+ description: Enable inspection tests+ default: False+ manual: True
− src/Data/Random/Generics.hs
@@ -1,302 +0,0 @@--- | Generic Boltzmann samplers.------ Here, the words "/sampler/" and "/generator/" are used interchangeably.------ Given an algebraic datatype:------ > data A = A1 B C | A2 D------ a Boltzmann sampler is recursively defined by choosing a constructor with--- some fixed distribution, and /independently/ generating values for the--- corresponding fields with the same method.------ A key component is the aforementioned distribution, defined for every type--- such that the resulting generator produces a finite value in the end. These--- distributions are obtained from a precomputed object called /oracle/, which--- we will not describe further here.------ Oracles depend on the target size of the generated data (except for singular--- samplers), and can be fairly expensive to compute repeatedly, hence some of--- the functions below attempt to avoid (re)computing too many of them even--- when the required size changes.------ When these functions are specialized, oracles are memoized and will be--- reused for different sizes.--module Data.Random.Generics (- Size',- -- * Main functions- -- $sized- generatorSR,- generatorP,- generatorPR,- generatorR,- -- ** Fixed size- -- $fixed- generatorP',- generatorPR',- generatorR',- generator',- -- * Generators with aliases- -- $aliases- generatorSRWith,- generatorPWith,- generatorPRWith,- generatorRWith,- -- ** Fixed size- generatorPWith',- generatorPRWith',- generatorRWith',- generatorWith',- -- * Other generators- -- $other- Points,- generatorM,- generatorMR,- generator_,- generatorR_,- -- * Auxiliary definitions- -- ** Type classes- MonadRandomLike (..),- AMonadRandom (..),- -- ** Alias- alias,- aliasR,- coerceAlias,- coerceAliases,- Alias (..),- AliasR,- ) where--import Data.Data-import Data.Random.Generics.Internal-import Data.Random.Generics.Internal.Types---- * Main functions---- $sized------ === Suffixes------ [@S@] Singular sampler.------ This works with recursive tree-like structures, as opposed to (lists of)--- structures with bounded size. More precisely, the generating function of--- the given type should have a finite radius of convergence, with a--- singularity of a certain kind (see Duchon et al., reference in the--- README), so that the oracle can be evaluated at that point.------ This has the advantage of using the same oracle for all size parameters,--- which simply specify a target size interval.------ [@P@] Generator of pointed values.------ It usually has a flatter distribution of sizes than a simple Boltzmann--- sampler, making it an efficient alternative to rejection sampling.------ It also works on more types, particularly lists and finite types,--- but relies on multiple oracles.------ [@R@] Rejection sampling.------ These generators filter out values whose sizes are not within some--- interval. In the first two sections, that interval is implicit:--- @[(1-'epsilon')*size', (1+'epsilon')*size']@, for @'epsilon' = 0.1@.------ The generator restarts as soon as it has produced more constructors than--- the upper bound, this strategy is called /ceiled rejection sampling/.------ = Pointing------ The /pointing/ of a type @t@ is a derived type whose values are essentially--- values of type @t@, with one of their constructors being "pointed".--- Alternatively, we may turn every constructor into variants that indicate--- the position of points.------ @--- -- Original type--- data Tree = Node Tree Tree | Leaf--- -- Pointing of Tree--- data Tree'--- = Tree' Tree -- Point at the root--- | Node'0 Tree' Tree -- Point to the left--- | Node'1 Tree Tree' -- Point to the right--- @------ Pointed values are easily mapped back to the original type by erasing the--- point. Pointing makes larger values occur much more frequently, while--- preserving the uniformness of the distribution conditionally to a fixed--- size.------- | @--- 'generatorSR' :: Int -> 'Gen' a--- 'asMonadRandom' . 'generatorSR' :: 'MonadRandom' m => Int -> m a--- @------ Singular ceiled rejection sampler.-generatorSR :: (Data a, MonadRandomLike m) => Size' -> m a-generatorSR = generatorSRWith []---- | @--- 'generatorP' :: Int -> 'Gen' a--- 'asMonadRandom' . 'generatorP' :: 'MonadRandom' m => Int -> m a--- @------ Generator of pointed values.--generatorP :: (Data a, MonadRandomLike m) => Size' -> m a-generatorP = generatorPWith []---- | Pointed generator with rejection.-generatorPR :: (Data a, MonadRandomLike m) => Size' -> m a-generatorPR = generatorPRWith []---- | Generator with rejection and dynamic average size.-generatorR :: (Data a, MonadRandomLike m) => Size' -> m a-generatorR = generatorRWith []---- ** Fixed size---- $fixed--- The @'@ suffix indicates functions which do not do any--- precomputation before passing the size parameter.------ This means that oracles are computed from scratch for every size value,--- which may incur a significant overhead.---- | Pointed generator.-generatorP' :: (Data a, MonadRandomLike m) => Size' -> m a-generatorP' = generatorPWith' []---- | Pointed generator with rejection.-generatorPR' :: (Data a, MonadRandomLike m) => Size' -> m a-generatorPR' = generatorPRWith' []---- | Ceiled rejection sampler with given average size.-generatorR' :: (Data a, MonadRandomLike m) => Size' -> m a-generatorR' = generatorRWith' []---- | Basic boltzmann sampler with no optimization.-generator' :: (Data a, MonadRandomLike m) => Size' -> m a-generator' = generatorWith' []---- * Generators with aliases---- $aliases--- Boltzmann samplers can normally be defined only for types @a@ such that:------ - they are instances of 'Data';--- - the set of types of subterms of values of type @a@ is finite;--- - and all of these types have at least one finite value (i.e., values with--- finitely many constructors).------ Examples of misbehaving types are:------ - @a -> b -- Not Data@--- - @data E a = L a | R (E [a]) -- Contains a, [a], [[a]], [[[a]]], etc.@--- - @data I = C I -- No finite value@------ = Alias------ The 'Alias' type works around these limitations ('AliasR' for rejection--- samplers).--- This existential wrapper around a user-defined function @f :: a -> m b@--- makes @generic-random@ view occurences of the type @b@ as @a@ when--- processing a recursive system of types, possibly stopping some infinite--- unrolling of type definitions. When a value of type @b@ needs to be--- generated, it generates an @a@ which is passed to @f@.------ @--- let--- as = ['aliasR' $ \\() -> return (L []) :: 'Gen' (E [[Int]])]--- in--- 'generatorSRWith' as 'asGen' :: 'Size' -> 'Gen' (E Int)--- @------ Another use case is to plug in user-defined generators where the default is--- not satisfactory, for example, to get positive @Int@s:------ @--- let--- as = ['alias' $ \\() -> 'choose' (0, 100) :: 'Gen' Int)]--- in--- 'generatorPWith' as 'asGen' :: 'Size' -> 'Gen' [Int]--- @--generatorSRWith- :: (Data a, MonadRandomLike m) => [AliasR m] -> Size' -> m a-generatorSRWith aliases =- generatorR_ aliases 0 Nothing . tolerance epsilon--generatorPRWith- :: (Data a, MonadRandomLike m) => [AliasR m] -> Size' -> m a-generatorPRWith aliases size' =- generatorMR aliases 1 size' (tolerance epsilon size')--generatorPWith- :: (Data a, MonadRandomLike m) => [Alias m] -> Size' -> m a-generatorPWith aliases = generatorM aliases 1--generatorRWith- :: (Data a, MonadRandomLike m) => [AliasR m] -> Size' -> m a-generatorRWith aliases size' =- generatorMR aliases 0 size' (tolerance epsilon size')---- ** Fixed size--generatorPWith'- :: (Data a, MonadRandomLike m) => [Alias m] -> Size' -> m a-generatorPWith' aliases = generator_ aliases 1 . Just--generatorPRWith'- :: (Data a, MonadRandomLike m) => [AliasR m] -> Size' -> m a-generatorPRWith' aliases size' =- generatorR_ aliases 1 (Just size') (tolerance epsilon size')--generatorRWith'- :: (Data a, MonadRandomLike m) => [AliasR m] -> Size' -> m a-generatorRWith' aliases size' =- generatorR_ aliases 0 (Just size') (tolerance epsilon size')--generatorWith'- :: (Data a, MonadRandomLike m) => [Alias m] -> Size' -> m a-generatorWith' aliases = generator_ aliases 0 . Just---- * Other generators---- $other Used in the implementation of the generators above.--- These also allow to apply pointing more than once.------ === Suffixes------ [@M@] Sized generators are memoized for some sparsely chosen values of--- sizes. Subsequently supplied sizes are approximated by the closest larger--- value. This strategy avoids recomputing too many oracles. Aside from--- singular samplers, all other generators above not marked by @'@ use this.------ [@_@] If the size parameter is @Nothing@, produces the singular generator--- (associated with the suffix @S@); otherwise the generator produces values--- with average size equal to the given value.--generatorM- :: (Data a, MonadRandomLike m)- => [Alias m] -> Points -> Size' -> m a-generatorM = memo make apply--generatorMR- :: (Data a, MonadRandomLike m)- => [AliasR m] -> Points -> Size' -> (Size', Size') -> m a-generatorMR = memo makeR applyR---- | Boltzmann sampler without rejection.-generator_- :: (Data a, MonadRandomLike m)- => [Alias m] -> Points -> Maybe Size' -> m a-generator_ aliases = apply (make aliases [])---- | Boltzmann sampler with rejection.-generatorR_- :: (Data a, MonadRandomLike m)- => [AliasR m] -> Points -> Maybe Size' -> (Size', Size') -> m a-generatorR_ aliases = applyR (makeR aliases [])
− src/Data/Random/Generics/Internal.hs
@@ -1,146 +0,0 @@-{-# LANGUAGE RecordWildCards, DeriveFunctor #-}-module Data.Random.Generics.Internal where--import Control.Arrow ( (&&&) )-import Control.Applicative-import Data.Data-import Data.Foldable-import Data.Maybe-import qualified Data.HashMap.Lazy as HashMap-import Data.Random.Generics.Internal.Oracle-import Data.Random.Generics.Internal.Types---- | Sized generator.-data SG r = SG- { minSize :: Size- , maxSizeM :: Maybe Size- , runSG :: Points -> Maybe Double -> r- , runSmallG :: Points -> r- } deriving Functor---- | Number of pointing iterations.-type Points = Int--rangeSG :: SG r -> (Size, Maybe Size)-rangeSG = minSize &&& maxSizeM---- | For documentation.-applySG :: SG r -> Points -> Maybe Double -> r-applySG SG{..} k sizeM- | Just minSize == maxSizeM = runSG k (fmap fromIntegral maxSizeM)- | Just size <- sizeM, size <= fromIntegral minSize =- error "Target size too small."- | Just True <- liftA2 ((<=) . fromIntegral) maxSizeM sizeM =- error "Target size too large."- | Nothing <- sizeM, Just _ <- maxSizeM =- error "Cannot make singular sampler for finite type."- | otherwise = runSG k sizeM---- * Helper functions--make :: (Data a, MonadRandomLike m)- => [Alias m] -> proxy a -> SG (m a)-make aliases a =- SG minSize maxSizeM make' makeSmall- where- dd = collectTypes aliases a- t = typeRep a- i = case index dd #! t of- Left j -> fst (xedni' dd #! j)- Right i -> i- minSize = natToInt $ fst (lTerm dd #! i)- maxSizeM = HashMap.lookup i (degree dd)- make' k sizeM = getGenerator dd' generators a k- where- dd' = dds !! k- oracle = makeOracle dd' t sizeM- generators = makeGenerators dd' oracle- makeSmall k = getSmallGenerator dd' (smallGenerators dd') a- where- dd' = dds !! k- dds = iterate point dd--makeR :: (Data a, MonadRandomLike m)- => [AliasR m] -> proxy a- -> SG ((Size, Size) -> m a)-makeR aliases a = fmap (flip runRejectT) (make aliases a)---- | The size of a value is its number of constructors.------ Here, however, the 'Size'' type is interpreted differently to make better--- use of QuickCheck's size parameter provided by the 'Test.QuickCheck.sized'--- combinator, so that we generate non-trivial data even at very small size--- values.------ For infinite types, with objects of unbounded sizes @> minSize@, given a--- parameter @delta :: 'Size''@, the produced values have an average size close--- to @minSize + delta@.------ For example, values of type @Either () [Bool]@ have at least two constructors,--- so------ @--- 'generator' delta :: 'Gen' (Either () [Bool])--- @------ will target sizes close to @2 + delta@;--- the offset becomes less noticeable as @delta@ grows to infinity.------ For finite types with sizes in @[minSize, maxSize]@, the target expected--- size is obtained by clamping a 'Size'' to @[0, 99]@ and applying an affine--- mapping.-type Size' = Int--rescale :: SG r -> Size' -> Double-rescale (SG minSize (Just maxSize) _ _) size' =- fromIntegral minSize + fromIntegral (min 99 size' * (maxSize - minSize)) / 100-rescale (SG minSize Nothing _ _) size' = fromIntegral (minSize + size')--apply :: SG r -> Points -> Maybe Size' -> r-apply sg k (Just 0) = runSmallG sg k-apply sg k size' = runSG sg k (fmap (rescale sg) size')--applyR :: SG ((Size, Size) -> r) -> Points -> Maybe Size' -> (Size', Size') -> r-applyR sg k size' = apply sg k size' . rescaleInterval sg--rescaleInterval :: SG r -> (Size', Size') -> (Size, Size)-rescaleInterval sg (a', b') = (a, b)- where- a = (clamp . floor .rescale sg) a'- b = (clamp . ceiling . rescale sg) b'- clamp x- | Just maxSize <- maxSizeM sg, x >= 100 = maxSize- | otherwise = x---- | > 'epsilon' = 0.1------ Default approximation ratio.-epsilon :: Double-epsilon = 0.1---- | > (size * (1 - epsilon), size * (1 + epsilon))-tolerance :: Double -> Int -> (Int, Int)-tolerance epsilon size = (size - delta, size + delta)- where- delta = ceiling (fromIntegral size * epsilon)---- * Auxiliary definitions--memo- :: (t -> [t2] -> SG r)- -> (SG r -> t1 -> Maybe Int -> a)- -> t -> t1 -> Int -> a-memo make apply aliases k = generators- where- sg = make aliases []- generators = sparseSized (apply sg k . Just) (99 <$ maxSizeM sg)---- Oracles are computed only for sizes that are a power of two away from--- the minimum size of the datatype @minSize + 2 ^ e@.-sparseSized :: (Int -> a) -> Maybe Int -> Int -> a-sparseSized f maxSizeM =- maybe a0 snd . \size' -> find ((>= size') . fst) as- where- as = [ (s, f s) | s <- ss ]- ss = 0 : maybe id (takeWhile . (>)) maxSizeM [ 2 ^ e | e <- [ 0 :: Int ..] ]- a0 = f (fromJust maxSizeM)
− src/Data/Random/Generics/Internal/Oracle.hs
@@ -1,539 +0,0 @@-{-# LANGUAGE FlexibleContexts, GADTs, RankNTypes, ScopedTypeVariables #-}-{-# LANGUAGE DeriveGeneric, ImplicitParams #-}-{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}-module Data.Random.Generics.Internal.Oracle where--import Control.Applicative-import Control.Monad-import Control.Monad.Fix-import Control.Monad.Reader-import Control.Monad.State-import Data.Bifunctor-import Data.Data-import Data.Hashable ( Hashable )-import Data.HashMap.Lazy ( HashMap )-import qualified Data.HashMap.Lazy as HashMap-import Data.Maybe ( fromJust, isJust )-import Data.Monoid-import qualified Data.Vector as V-import qualified Data.Vector.Storable as S-import GHC.Generics ( Generic )-import Numeric.AD-import Data.Random.Generics.Internal.Types-import Data.Random.Generics.Internal.Solver---- | We build a dictionary which reifies type information in order to--- create a Boltzmann generator.------ We denote by @n@ (or 'count') the number of types in the dictionary.------ Every type has an index @0 <= i < n@; the variable @X i@ represents its--- generating function @C_i(x)@, and @X (i + k*n)@ the GF of its @k@-th--- "pointing" @C_i[k](x)@; we have------ @--- C_i[0](x) = C_i(x)--- C_i[k+1](x) = x * C_i[k]'(x)--- @------ where @C_i[k]'@ is the derivative of @C_i[k]@. See also 'point'.------ The /order/ (or /valuation/) of a power series is the index of the first--- non-zero coefficient, called the /leading coefficient/.--data DataDef m = DataDef- { count :: Int -- ^ Number of registered types- , points :: Int -- ^ Number of iterations of the pointing operator- , index :: HashMap TypeRep (Either Aliased Ix) -- ^ Map from types to indices- , xedni :: HashMap Ix SomeData' -- ^ Inverse map from indices to types- , xedni' :: HashMap Aliased (Ix, Alias m) -- ^ Inverse map to aliases- , types :: HashMap C [(Integer, Constr, [C'])]- -- ^ Structure of types and their pointings (up to 'points', initially 0)- --- -- Primitive types and empty types are mapped to an empty constructor list, and- -- can be distinguished using 'Data.Data.dataTypeRep' on the 'SomeData'- -- associated to it by 'xedni'.- --- -- The integer is a multiplicity which can be > 1 for pointings.- , lTerm :: HashMap Ix (Nat, Integer)- -- ^ Leading term @a * x ^ u@ of the generating functions @C_i[k](x)@ in the- -- form (u, a).- --- -- [Order @u@] Smallest size of objects of a given type.- -- [Leading coefficient @a@] number of objects of smallest size.- , degree :: HashMap Ix Int- -- ^ Degrees of the generating functions, when applicable: greatest size of- -- objects of a given type.- } deriving Show---- | A pair @C i k@ represents the @k@-th "pointing" of the type at index @i@,--- with generating function @C_i[k](x)@.-data C = C Ix Int- deriving (Eq, Ord, Show, Generic)--instance Hashable C--data AC = AC Aliased Int- deriving (Eq, Ord, Show, Generic)--instance Hashable AC--type C' = (Maybe Aliased, C)--newtype Aliased = Aliased Int- deriving (Eq, Ord, Show, Generic)--instance Hashable Aliased--type Ix = Int--data Nat = Zero | Succ Nat- deriving (Eq, Ord, Show)--instance Monoid Nat where- mempty = Zero- mappend (Succ n) = Succ . mappend n- mappend Zero = id--natToInt :: Nat -> Int-natToInt Zero = 0-natToInt (Succ n) = 1 + natToInt n--infinity :: Nat-infinity = Succ infinity--dataDef :: [Alias m] -> DataDef m-dataDef as = DataDef- { count = 0- , points = 0- , index = index- , xedni = HashMap.empty- , xedni' = xedni'- , types = HashMap.empty- , lTerm = HashMap.empty- , degree = HashMap.empty- } where- xedni' = HashMap.fromList (fmap (\(i, a) -> (i, (-1, a))) as')- index = HashMap.fromList (fmap (\(i, a) -> (ofType a, Left i)) as')- as' = zip (fmap Aliased [0 ..]) as- ofType (Alias f) = typeRep (f undefined)---- | Find all types that may be types of subterms of a value of type @a@.------ This will loop if there are infinitely many such types.-collectTypes :: Data a => [Alias m] -> proxy a -> DataDef m-collectTypes as a = collectTypesM a `execState` dataDef as---- | Primitive datatypes have @C(x) = x@: they are considered as--- having a single object (@lCoef@) of size 1 (@order@)).-primOrder :: Int-primOrder = 1--primOrder' :: Nat-primOrder' = Succ Zero--primlCoef :: Integer-primlCoef = 1---- | The type of the first argument of 'Data.Data.gunfold'.-type GUnfold m = forall b r. Data b => m (b -> r) -> m r---- | Type of 'xedni''.-type AMap m = HashMap Aliased (Ix, Alias m)--collectTypesM :: Data a => proxy a- -> State (DataDef m) (Either Aliased Ix, ((Nat, Integer), Maybe Int))-collectTypesM a = chaseType a (const id)--chaseType :: Data a => proxy a- -> ((Maybe (Alias m), Ix) -> AMap m -> AMap m)- -> State (DataDef m) (Either Aliased Ix, ((Nat, Integer), Maybe Int))-chaseType a k = do- let t = typeRep a- dd@DataDef{..} <- get- let- lookup i r =- let- lTerm_i = lTerm #! i- degree_i = HashMap.lookup i degree- in return (r, (lTerm_i, degree_i))- case HashMap.lookup t index of- Nothing -> do- let i = count- put dd- { count = i + 1- , index = HashMap.insert t (Right i) index- , xedni = HashMap.insert i (someData' a) xedni- , xedni' = k (Nothing, i) xedni'- }- traverseType a i -- Updates lTerm and degree- Just (Right i) -> do- put dd { xedni' = k (Nothing, i) xedni' }- lookup i (Right i)- Just (Left j) ->- case xedni' #! j of- (-1, Alias f) -> do- (_, ld) <- chaseType (ofType f) $ \(alias, i) ->- let- alias' = case alias of- Nothing -> Alias f- Just (Alias g) -> Alias (composeCastM f g)- in- k (Just alias', i) . HashMap.insert j (i, alias')- return (Left j, ld)- (i, _) -> lookup i (Left j)- where- ofType :: (m a -> m b) -> m a- ofType _ = undefined---- | Traversal of the definition of a datatype.-traverseType- :: Data a => proxy a -> Ix- -> State (DataDef m) (Either Aliased Ix, ((Nat, Integer), Maybe Int))-traverseType a i = do- let d = withProxy dataTypeOf a- mfix $ \ ~(_, (lTerm_i0, _)) -> do- modify $ \dd@DataDef{..} -> dd- { lTerm = HashMap.insert i lTerm_i0 lTerm- }- (types_i, ld@(_, degree_i)) <- traverseType' a d- modify $ \dd@DataDef{..} -> dd- { types = HashMap.insert (C i 0) types_i types- , degree = maybe id (HashMap.insert i) degree_i degree- }- return (Right i, ld)--traverseType'- :: Data a => proxy a -> DataType- -> State (DataDef m)- ([(Integer, Constr, [(Maybe Aliased, C)])], ((Nat, Integer), Maybe Int))-traverseType' a d | isAlgType d = do- let- constrs = dataTypeConstrs d- collect- :: GUnfold (StateT- ([Either Aliased Ix], (Nat, Integer), Maybe Int)- (State (DataDef m)))- collect mkCon = do- f <- mkCon- let ofType :: (b -> a) -> Proxy b- ofType _ = Proxy- b = ofType f- (j, (lTerm_, degree_)) <- lift (collectTypesM b)- modify $ \(js, lTerm', degree') ->- (j : js, lMul lTerm_ lTerm', liftA2 (+) degree_ degree')- return (withProxy f b)- tlds <- forM constrs $ \constr -> do- (js, lTerm', degree') <-- gunfold collect return constr `proxyType` a- `execStateT` ([], (Zero, 1), Just 1)- dd <- get- let- c (Left j) = (Just j, C (fst (xedni' dd #! j)) 0)- c (Right i) = (Nothing, C i 0)- return ((1, constr, [ c j | j <- js]), lTerm', degree')- let- (types_i, ls, ds) = unzip3 tlds- lTerm_i = first Succ (lSum ls)- degree_i = maxDegree ds- return (types_i, (lTerm_i, degree_i))-traverseType' _ _ =- return ([], ((primOrder', primlCoef), Just primOrder))---- | If @(u, a)@ represents a power series of leading term @a * x ^ u@, and--- similarly for @(u', a')@, this finds the leading term of their sum.------ The comparison of 'Nat' is unrolled here for maximum laziness.-lPlus :: (Nat, Integer) -> (Nat, Integer) -> (Nat, Integer)-lPlus (Zero, lCoef) (Zero, lCoef') = (Zero, lCoef + lCoef')-lPlus (Zero, lCoef) _ = (Zero, lCoef)-lPlus _ (Zero, lCoef') = (Zero, lCoef')-lPlus (Succ order, lCoef) (Succ order', lCoef') =- first Succ $ lPlus (order, lCoef) (order', lCoef')---- | Sum of a list of series.-lSum :: [(Nat, Integer)] -> (Nat, Integer)-lSum [] = (infinity, 0)-lSum ls = foldl1 lPlus ls---- | Leading term of a product of series.-lMul :: (Nat, Integer) -> (Nat, Integer) -> (Nat, Integer)-lMul (order, lCoef) (order', lCoef') = (order <> order', lCoef * lCoef')--lProd :: [(Nat, Integer)] -> (Nat, Integer)-lProd = foldl lMul (Zero, 1)--maxDegree :: [Maybe Int] -> Maybe Int-maxDegree = foldl (liftA2 max) (Just minBound)---- | Pointing operator.------ Populates a 'DataDef' with one more level of pointings.--- ('collectTypes' produces a dictionary at level 0.)------ The "pointing" of a type @t@ is a derived type whose values are essentially--- values of type @t@, with one of their constructors being "pointed".--- Alternatively, we may turn every constructor into variants that indicate--- the position of points.------ @--- -- Original type--- data Tree = Node Tree Tree | Leaf--- -- Pointing of Tree--- data Tree'--- = Tree' Tree -- Point at the root--- | Node'0 Tree' Tree -- Point to the left--- | Node'1 Tree Tree' -- Point to the right--- -- Pointing of the pointing--- -- Notice that the "points" introduced by both applications of pointing--- -- are considered different: exchanging their positions (when different)--- -- produces a different tree.--- data Tree''--- = Tree'' Tree' -- Point 2 at the root, the inner Tree' places point 1--- | Node'0' Tree' Tree -- Point 1 at the root, point 2 to the left--- | Node'1' Tree Tree' -- Point 1 at the root, point 2 to the right--- | Node'0'0 Tree'' Tree -- Points 1 and 2 to the left--- | Node'0'1 Tree' Tree' -- Point 1 to the left, point 2 to the right--- | Node'1'0 Tree' Tree' -- Point 1 to the right, point 2 to the left--- | Node'0'1 Tree Tree'' -- Points 1 and 2 to the right--- @------ If we ignore points, some constructors are equivalent. Thus we may simply--- calculate their multiplicity instead of duplicating them.------ Given a constructor with @c@ arguments @C x_1 ... x_c@, and a sequence--- @p_0 + p_1 + ... + p_c = k@ corresponding to a distribution of @k@ points--- (@p_0@ are assigned to the constructor @C@ itself, and for @i > 0@, @p_i@--- points are assigned within the @i@-th subterm), the multiplicity of the--- constructor paired with that distribution is the multinomial coefficient--- @multinomial k [p_1, ..., p_c]@.--point :: DataDef m -> DataDef m-point dd@DataDef{..} = dd- { points = points'- , types = foldl g types [0 .. count-1]- } where- points' = points + 1- g types i = HashMap.insert (C i points') (types' i) types- types' i = types #! C i 0 >>= h- h (_, constr, js) = do- ps <- partitions points' (length js)- let- mult = multinomial points' ps- js' = zipWith (\(j', C i _) p -> (j', C i p)) js ps- return (mult, constr, js')---- | An oracle gives the values of the generating functions at some @x@.-type Oracle = HashMap C Double---- | Find the value of @x@ such that the average size of the generator--- for the @k-1@-th pointing is equal to @size@, and produce the associated--- oracle. If the size is @Nothing@, find the radius of convergence.------ The search evaluates the generating functions for some values of @x@ in--- order to run a binary search. The evaluator is implemented using Newton's--- method, the convergence of which has been shown for relevant systems in--- /Boltzmann Oracle for Combinatorial Systems/,--- C. Pivoteau, B. Salvy, M. Soria.-makeOracle :: DataDef m -> TypeRep -> Maybe Double -> Oracle-makeOracle dd0 t size' =- seq v- HashMap.fromList (zip cs (S.toList v))- where- -- We need the next pointing to capture the average size in an equation.- dd@DataDef{..} = if isJust size' then point dd0 else dd0- cs = flip C <$> [0 .. points] <*> [0 .. count - 1]- m = count * (points + 1)- k = points - 1- i = case index #! t of- Left j -> fst (xedni' #! j)- Right i -> i- checkSize _ (Just ys) | S.any (< 0) ys = False- -- There may be solutions outside of the radius- -- of convergence, but with negative components.- checkSize (Just size) (Just ys) =- size >= size_- where- size_ = ys S.! j' / ys S.! j- j = dd ? C i k- j' = dd ? C i (k + 1)- checkSize Nothing (Just _) = True- checkSize _ Nothing = False- -- Equations defining C_i(x) for all types with indices i- phis :: Num a => V.Vector (a -> V.Vector a -> a)- phis = V.fromList [ phi dd c (types #! c) | c <- listCs dd ]- eval' :: Double -> Maybe (S.Vector Double)- eval' x = fixedPoint defSolveArgs phi' (S.replicate m 0)- where- phi' :: (Mode a, Scalar a ~ Double) => V.Vector a -> V.Vector a- phi' y = fmap (\f -> f (auto x) y) phis- v = fromJust (search eval' (checkSize size'))---- | Generating function definition. This defines a @Phi_i[k]@ function--- associated with the @k@-th pointing of the type at index @i@, such that:------ > C_i[k](x)--- > = Phi_i[k](x, C_0[0](x), ..., C_(n-1)[0](x),--- > ..., C_0[k](x), ..., C_(n-1)[k](x))------ Primitive datatypes have @C(x) = x@: they are considered as--- having a single object ('lCoef') of size 1 ('order')).-phi :: Num a => DataDef m -> C -> [(Integer, constr, [C'])]- -> a -> V.Vector a -> a-phi DataDef{..} (C i _) [] =- case xedni #! i of- SomeData a ->- case (dataTypeRep . withProxy dataTypeOf) a of- AlgRep _ -> \_ _ -> 0- _ -> \x _ -> fromInteger primlCoef * x ^ primOrder-phi dd@DataDef{..} _ tyInfo = f- where- f x y = x * (sum . fmap (toProd y)) tyInfo- toProd y (w, _, js) =- fromInteger w * product [ y V.! (dd ? j) | (_, j) <- js ]---- | Maps a key representing a type @a@ (or one of its pointings) to a--- generator @m a@.-type Generators m = (HashMap AC (SomeData m), HashMap C (SomeData m))---- | Build all involved generators at once.-makeGenerators- :: forall m. MonadRandomLike m- => DataDef m -> Oracle -> Generators m-makeGenerators DataDef{..} oracle =- seq oracle- (generatorsL, generatorsR)- where- f (C i _) tyInfo = case xedni #! i of- SomeData a -> SomeData $ incr >>- case tyInfo of- [] -> defGen- _ -> frequencyWith doubleR (fmap g tyInfo) `proxyType` a- g :: Data a => (Integer, Constr, [C']) -> (Double, m a)- g (v, constr, js) =- ( fromInteger v * w- , gunfold generate return constr `runReaderT` gs)- where- gs = fmap (\(j', i) -> m j' i) js- m = maybe (generatorsR #!) m'- m' j (C _ k) = (generatorsL #! AC j k)- w = product $ fmap ((oracle #!) . snd) js- h (j, (i, Alias f)) k =- (AC j k, applyCast f (generatorsR #! C i k))- generatorsL = HashMap.fromList (liftA2 h (HashMap.toList xedni') [0 .. points])- generatorsR = HashMap.mapWithKey f types--type SmallGenerators m =- (HashMap Aliased (SomeData m), HashMap Ix (SomeData m))---- | Generators of values of minimal sizes.-smallGenerators- :: forall m. MonadRandomLike m => DataDef m -> SmallGenerators m-smallGenerators DataDef{..} = (generatorsL, generatorsR)- where- f i (SomeData a) = SomeData $ incr >>- case types #! C i 0 of- [] -> defGen- tyInfo ->- let gs = (tyInfo >>= g (fst (lTerm #! i))) in- frequencyWith integerR gs `proxyType` a- g :: Data a => Nat -> (Integer, Constr, [C']) -> [(Integer, m a)]- g minSize (_, constr, js) =- guard (minSize == Succ size) *>- [(weight, gunfold generate return constr `runReaderT` gs)]- where- (size, weight) = lProd [ lTerm #! i | (_, C i _) <- js ]- gs = fmap lookup js- lookup (j', C i _) = maybe (generatorsR #! i) (generatorsL #!) j'- h (j, (i, Alias f)) = (j, applyCast f (generatorsR #! i))- generatorsL = (HashMap.fromList . fmap h . HashMap.toList) xedni'- generatorsR = HashMap.mapWithKey f xedni--generate :: Applicative m => GUnfold (ReaderT [SomeData m] m)-generate rest = ReaderT $ \(g : gs) ->- rest `runReaderT` gs <*> unSomeData g--defGen :: (Data a, MonadRandomLike m) => m a-defGen = gen- where- gen =- let dt = withProxy dataTypeOf gen in- case dataTypeRep dt of- IntRep -> fromConstr . mkIntegralConstr dt <$> int- FloatRep -> fromConstr . mkRealConstr dt <$> double- CharRep -> fromConstr . mkCharConstr dt <$> char- AlgRep _ -> error "Cannot generate for empty type."- NoRep -> error "No representation."---- * Short operators--(?) :: DataDef m -> C -> Int-dd ? C i k = i + k * count dd---- | > dd ? (listCs dd !! i) = i-listCs :: DataDef m -> [C]-listCs dd = liftA2 (flip C) [0 .. points dd] [0 .. count dd - 1]--ix :: C -> Int-ix (C i _) = i---- | > dd ? (dd ?! i) = i-(?!) :: DataDef m -> Int -> C-dd ?! j = C i k- where (k, i) = j `divMod` count dd--getGenerator :: (Functor m, Data a)- => DataDef m -> Generators m -> proxy a -> Int -> m a-getGenerator dd (l, r) a k = unSomeData $- case index dd #! typeRep a of- Right i -> (r #! C i k)- Left j -> (l #! AC j k)--getSmallGenerator :: (Functor m, Data a)- => DataDef m -> SmallGenerators m -> proxy a -> m a-getSmallGenerator dd (l, r) a = unSomeData $- case index dd #! typeRep a of- Right i -> (r #! i)- Left j -> (l #! j)---- * General helper functions--frequencyWith- :: (Show r, Ord r, Num r, Monad m) => (r -> m r) -> [(r, m a)] -> m a-frequencyWith _ [(_, a)] = a-frequencyWith randomR as = randomR total >>= select as- where- total = (sum . fmap fst) as- select ((w, a) : as) x- | x < w = a- | otherwise = select as (x - w)- select _ _ = (snd . head) as- -- That should not happen in theory, but floating point might be funny.--(#!) :: (Eq k, Hashable k)- => HashMap k v -> k -> v-(#!) = (HashMap.!)---- | @partitions k n@: lists of non-negative integers of length @n@ with sum--- less than or equal to @k@.-partitions :: Int -> Int -> [[Int]]-partitions _ 0 = [[]]-partitions k n = do- p <- [0 .. k]- (p :) <$> partitions (k - p) (n - 1)---- | Multinomial coefficient.------ > multinomial n ps == factorial n `div` product [factorial p | p <- ps]-multinomial :: Int -> [Int] -> Integer-multinomial _ [] = 1-multinomial n (p : ps) = binomial n p * multinomial (n - p) ps---- | Binomial coefficient.------ > binomial n k == factorial n `div` (factorial k * factorial (n-k))-binomial :: Int -> Int -> Integer-binomial = \n k -> pascal !! n !! k- where- pascal = [1] : fmap nextRow pascal- nextRow r = zipWith (+) (0 : r) (r ++ [0])
− src/Data/Random/Generics/Internal/Solver.hs
@@ -1,65 +0,0 @@--- | Solve systems of equations--{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RankNTypes, FlexibleContexts, TypeFamilies #-}-module Data.Random.Generics.Internal.Solver where--import Control.Applicative-import Data.AEq ( (~==) )-import Numeric.AD.Mode-import Numeric.AD.Mode.Forward-import Numeric.LinearAlgebra-import qualified Data.Vector as V-import qualified Data.Vector.Storable as S--data SolveArgs = SolveArgs- { accuracy :: Double- , numIterations :: Int- } deriving (Eq, Ord, Show)--defSolveArgs :: SolveArgs-defSolveArgs = SolveArgs 1e-8 20--findZero- :: SolveArgs- -> (forall s. V.Vector (AD s (Forward R)) -> V.Vector (AD s (Forward R)))- -> Vector R- -> Maybe (Vector R)-findZero SolveArgs{..} f = newton numIterations- where- newton 0 _ = Nothing- newton n x- | norm_y == 1/0 = Nothing- | norm_y > accuracy = newton (n - 1) (x - jacobian <\> y)- | otherwise = Just x- where- norm_y = norm_Inf y- jacobian = (fromRows . V.toList . fmap (V.convert . snd)) yj- y = (V.convert . fmap fst) yj- yj = jacobian' f (S.convert x)--fixedPoint- :: SolveArgs- -> (forall a. (Mode a, Scalar a ~ R) => V.Vector a -> V.Vector a)- -> Vector R- -> Maybe (Vector R)-fixedPoint args f = findZero args (liftA2 (V.zipWith (-)) f id)---- | Assuming @p . f@ is satisfied only for positive values in some interval--- @(0, r]@, find @f r@.-search :: (Double -> a) -> (a -> Bool) -> a-search f p = search' e0 (0 : [2 ^ n | n <- [0 .. 100 :: Int]])- where- search' y (x : xs@(x' : _))- | p y' = search' y' xs- | otherwise = search'' y x x'- where y' = f x'- search' _ _ = error "Solution not found. Uncontradictable predicate?"- search'' y x x'- | x ~== x' = y- | p y_ = search'' y_ x_ x'- | otherwise = search'' y x x_- where- x_ = (x + x') / 2- y_ = f x_- e0 = error "Solution not found. Unsatisfiable predicate?"
− src/Data/Random/Generics/Internal/Types.hs
@@ -1,191 +0,0 @@-{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, ImplicitParams #-}-{-# LANGUAGE TypeOperators, GeneralizedNewtypeDeriving #-}-module Data.Random.Generics.Internal.Types where--import Control.Monad.Random-import Control.Monad.Trans-import Data.Coerce-import Data.Data-import Data.Function-import Test.QuickCheck--data SomeData m where- SomeData :: Data a => m a -> SomeData m--type SomeData' = SomeData Proxy---- | Dummy instance for debugging.-instance Show (SomeData m) where- show _ = "SomeData"--data Alias m where- Alias :: (Data a, Data b) => !(m a -> m b) -> Alias m--type AliasR m = Alias (RejectT m)---- | Dummy instance for debugging.-instance Show (Alias m) where- show _ = "Alias"---- | Main constructor for 'Alias'.-alias :: (Monad m, Data a, Data b) => (a -> m b) -> Alias m-alias = Alias . (=<<)---- | Main constructor for 'AliasR'.-aliasR :: (Monad m, Data a, Data b) => (a -> m b) -> AliasR m-aliasR = Alias . (=<<) . fmap lift---- | > coerceAlias :: Alias m -> Alias (AMonadRandom m)-coerceAlias :: Coercible m n => Alias m -> Alias n-coerceAlias = coerce---- | > coerceAliases :: [Alias m] -> [Alias (AMonadRandom m)]-coerceAliases :: Coercible m n => [Alias m] -> [Alias n]-coerceAliases = coerce---- | > composeCast f g = f . g-composeCastM :: forall a b c d m- . (Typeable b, Typeable c)- => (m c -> d) -> (a -> m b) -> (a -> d)-composeCastM f g | Just Refl <- eqT :: Maybe (b :~: c) = f . g-composeCastM _ _ = castError ([] :: [b]) ([] :: [c])--castM :: forall a b m- . (Typeable a, Typeable b)- => m a -> m b-castM a | Just Refl <- eqT :: Maybe (a :~: b) = a-castM a = let x = castError a x in x--unSomeData :: Typeable a => SomeData m -> m a-unSomeData (SomeData a) = castM a--applyCast :: (Typeable a, Data b) => (m a -> m b) -> SomeData m -> SomeData m-applyCast f = SomeData . f . unSomeData--castError :: (Typeable a, Typeable b)- => proxy a -> proxy' b -> c-castError a b = error $ unlines- [ "Error trying to cast"- , " " ++ show (typeRep a)- , "to"- , " " ++ show (typeRep b)- ]--withProxy :: (a -> b) -> proxy a -> b-withProxy f _ =- f (error "This should not be evaluated\n")--reproxy :: proxy a -> Proxy a-reproxy _ = Proxy--proxyType :: m a -> proxy a -> m a-proxyType = const--someData' :: Data a => proxy a -> SomeData'-someData' = SomeData . reproxy---- | Size as the number of constructors.-type Size = Int---- | Internal transformer for rejection sampling.------ > ReaderT Size (StateT Size (MaybeT m)) a-newtype RejectT m a = RejectT- { unRejectT :: forall r. Size -> Size -> m r -> (Size -> a -> m r) -> m r- }--instance Functor (RejectT m) where- fmap f (RejectT go) = RejectT $ \maxSize size retry cont ->- go maxSize size retry $ \size a -> cont size (f a)--instance Applicative (RejectT m) where- pure a = RejectT $ \_maxSize size _retry cont ->- cont size a- RejectT f <*> RejectT x = RejectT $ \maxSize size retry cont ->- f maxSize size retry $ \size f_ ->- x maxSize size retry $ \size x_ ->- cont size (f_ x_)--instance Monad (RejectT m) where- RejectT x >>= f = RejectT $ \maxSize size retry cont ->- x maxSize size retry $ \size x_ ->- unRejectT (f x_) maxSize size retry cont--instance MonadTrans RejectT where- lift m = RejectT $ \_maxSize size _retry cont ->- m >>= cont size---- | Set lower bound-runRejectT :: Monad m => (Size, Size) -> RejectT m a -> m a-runRejectT (minSize, maxSize) (RejectT m) = fix $ \go ->- m maxSize 0 go $ \size a ->- if size < minSize then- go- else- return a---runRejectT (minSize, maxSize) (RejectT m) = fix $ \go -> do--- x' <- runMaybeT (m `runReaderT` maxSize `runStateT` 0)--- case x' of--- Just (x, size) | size >= minSize -> return x--- _ -> go--newtype AMonadRandom m a = AMonadRandom- { asMonadRandom :: m a- } deriving (Functor, Applicative, Monad)--instance MonadTrans AMonadRandom where- lift = AMonadRandom---- ** Dictionaries---- | @'MonadRandomLike' m@ defines basic components to build generators,--- allowing the implementation to remain abstract over both the--- 'Test.QuickCheck.Gen' type and 'MonadRandom' instances.------ For the latter, the wrapper 'AMonadRandom' is provided to avoid--- overlapping instances.-class Monad m => MonadRandomLike m where- -- | Called for every constructor. Counter for ceiled rejection sampling.- incr :: m ()- incr = return ()-- -- | @doubleR upperBound@: generates values in @[0, upperBound]@.- doubleR :: Double -> m Double-- -- | @integerR upperBound@: generates values in @[0, upperBound-1]@.- integerR :: Integer -> m Integer-- -- | Default @Int@ generator.- int :: m Int-- -- | Default @Double@ generator.- double :: m Double-- -- | Default @Char@ generator.- char :: m Char--instance MonadRandomLike Gen where- doubleR x = choose (0, x)- integerR x = choose (0, x-1)- int = arbitrary- double = arbitrary- char = arbitrary--instance MonadRandomLike m => MonadRandomLike (RejectT m) where- incr = RejectT $ \maxSize size retry cont ->- if size >= maxSize then- retry- else- cont (size + 1) ()- doubleR = lift . doubleR- integerR = lift . integerR- int = lift int- double = lift double- char = lift char--instance MonadRandom m => MonadRandomLike (AMonadRandom m) where- doubleR x = lift $ getRandomR (0, x)- integerR x = lift $ getRandomR (0, x-1)- int = lift getRandom- double = lift getRandom- char = lift getRandom
+ src/Generic/Random.hs view
@@ -0,0 +1,246 @@+-- | "GHC.Generics"-based 'Test.QuickCheck.arbitrary' generators.+--+-- = Basic usage+--+-- @+-- {-\# LANGUAGE DeriveGeneric \#-}+--+-- 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.+-- shrink = 'Test.QuickCheck.genericShrink' -- Generic shrinking is provided by the QuickCheck library.+-- @+--+-- Or derive standalone generators (the fields must still be instances of+-- 'Test.QuickCheck.Arbitrary', or use custom generators).+--+-- @+-- genFoo :: Gen Foo+-- genFoo = 'genericArbitrary' 'uniform'+-- @+--+-- === Using @DerivingVia@+--+-- @+-- {-\# LANGUAGE DerivingVia, TypeOperators \#-}+--+-- data Foo = A | B | C+-- deriving 'GHC.Generics.Generic'+-- deriving Arbitrary via ('GenericArbitraryU' `'AndShrinking'` Foo)+-- @+--+-- For more information:+--+-- - "Generic.Random.Tutorial"+-- - http://blog.poisson.chat/posts/2018-01-05-generic-random-tour.html++{-# LANGUAGE ExplicitNamespaces #-}++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++ -- | Custom generators can be specified in a list constructed with @(':+')@,+ -- and passed to functions such as 'genericArbitraryG' to override how certain+ -- fields are generated.+ --+ -- Example:+ --+ -- @+ -- customGens :: Gen String ':+' Gen Int+ -- customGens =+ -- (filter (/= '\NUL') '<$>' arbitrary) ':+'+ -- (getNonNegative '<$>' arbitrary)+ -- @+ --+ -- There are also different types of generators, other than 'Test.QuickCheck.Gen', providing+ -- more ways to select the fields the generator than by simply comparing types:+ --+ -- - @'Test.QuickCheck.Gen' a@: override fields of type @a@;+ -- - @'Gen1' f@: override fields of type @f x@ for some @x@, requiring a generator for @x@;+ -- - @'Gen1_' f@: override fields of type @f x@ for some @x@, __not__ requiring a generator for @x@;+ -- - @'FieldGen' s a@: override record fields named @s@, which must have type @a@;+ -- - @'ConstrGen' c i a@: override the field at index @i@ of constructor @c@,+ -- which must have type @a@ (0-indexed);+ --+ -- Multiple generators may match a given field: the first, leftmost+ -- generator in the list will be chosen.+ , (:+) (..)+ , FieldGen (..)+ , fieldGen+ , ConstrGen (..)+ , constrGen+ , Gen1 (..)+ , Gen1_ (..)++ -- * Helpful combinators+ , listOf'+ , listOf1'+ , vectorOf'++ -- * Base cases for recursive types+ , withBaseCase+ , BaseCase (..)++ -- * Full options+ , Options ()+ , genericArbitraryWith++ -- ** Setters+ , SetOptions+ , type (<+)+ , setOpts++ -- ** Size modifiers+ , Sizing (..)+ , SetSized+ , SetUnsized+ , setSized+ , setUnsized++ -- ** Custom generators+ , SetGens+ , setGenerators++ -- ** Coherence options+ , Coherence (..)+ , Incoherent (..)++ -- ** Common options+ , SizedOpts+ , sizedOpts+ , SizedOptsDef+ , sizedOptsDef+ , UnsizedOpts+ , unsizedOpts++ -- *** Advanced options+ -- | See 'Coherence'+ , CohUnsizedOpts+ , cohUnsizedOpts+ , CohSizedOpts+ , cohSizedOpts++ -- * Generic classes+ , GArbitrary+ , GUniformWeight++ -- * Newtypes for DerivingVia++ -- | These newtypes correspond to the variants of 'genericArbitrary' above.++ , GenericArbitrary (..)+ , GenericArbitraryU (..)+ , GenericArbitrarySingle (..)+ , GenericArbitraryRec (..)+ , GenericArbitraryG (..)+ , GenericArbitraryUG (..)+ , GenericArbitrarySingleG (..)+ , GenericArbitraryRecG (..)+ , GenericArbitraryWith (..)+ , AndShrinking (..)++ -- ** Helpers typeclasses+ , TypeLevelGenList (..)+ , TypeLevelOpts (..)+ ) where++import Generic.Random.Internal.BaseCase+import Generic.Random.Internal.Generic+import Generic.Random.DerivingVia
+ src/Generic/Random/DerivingVia.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++module Generic.Random.DerivingVia+ ( GenericArbitrary (..),+ GenericArbitraryU (..),+ GenericArbitrarySingle (..),+ GenericArbitraryRec (..),+ GenericArbitraryG (..),+ GenericArbitraryUG (..),+ GenericArbitrarySingleG (..),+ GenericArbitraryRecG (..),+ GenericArbitraryWith (..),+ AndShrinking (..),+ TypeLevelGenList (..),+ TypeLevelOpts (..),+ )+where++import Data.Coerce (Coercible, coerce)+import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import GHC.Generics (Generic(..))+import GHC.TypeLits (KnownNat, natVal)+import Generic.Random.Internal.Generic+import Test.QuickCheck (Arbitrary (..), Gen, genericShrink)+import Test.QuickCheck.Arbitrary (RecursivelyShrink, GSubterms)++-- * Newtypes for DerivingVia++-- | Pick a constructor with a given distribution, and fill its fields+-- with recursive calls to 'Test.QuickCheck.arbitrary'.+--+-- === Example+--+-- > data X = ...+-- > deriving Arbitrary via (GenericArbitrary '[2, 3, 5] X)+--+-- Picks the first constructor with probability @2/10@,+-- the second with probability @3/10@, the third with probability @5/10@.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitrary'.+--+-- @since 1.5.0.0+newtype GenericArbitrary weights a = GenericArbitrary {unGenericArbitrary :: a} deriving (Eq, Show)++instance+ ( GArbitrary UnsizedOpts a,+ TypeLevelWeights' weights a+ ) =>+ Arbitrary (GenericArbitrary weights a)+ where+ arbitrary = GenericArbitrary <$> genericArbitrary (typeLevelWeights @weights)++-- | Pick every constructor with equal probability.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryU'.+--+-- @since 1.5.0.0+newtype GenericArbitraryU a = GenericArbitraryU {unGenericArbitraryU :: a} deriving (Eq, Show)++instance+ ( GArbitrary UnsizedOpts a,+ GUniformWeight a+ ) =>+ Arbitrary (GenericArbitraryU a)+ where+ arbitrary = GenericArbitraryU <$> genericArbitraryU++-- | @arbitrary@ for types with one constructor.+-- Equivalent to 'GenericArbitraryU', with a stricter type.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitrarySingle'.+--+-- @since 1.5.0.0+newtype GenericArbitrarySingle a = GenericArbitrarySingle {unGenericArbitrarySingle :: a} deriving (Eq, Show)++instance+ ( GArbitrary UnsizedOpts a,+ Weights_ (Rep a) ~ L c0+ ) =>+ Arbitrary (GenericArbitrarySingle a)+ where+ arbitrary = GenericArbitrarySingle <$> genericArbitrarySingle++-- | Decrease size at every recursive call, but don't do anything different+-- at size 0.+--+-- > data X = ...+-- > deriving Arbitrary via (GenericArbitraryRec '[2, 3, 5] X)+--+-- 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).+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryRec'.+--+-- @since 1.5.0.0+newtype GenericArbitraryRec weights a = GenericArbitraryRec {unGenericArbitraryRec :: a} deriving (Eq, Show)++instance+ ( GArbitrary SizedOptsDef a,+ TypeLevelWeights' weights a+ ) =>+ Arbitrary (GenericArbitraryRec weights a)+ where+ arbitrary = GenericArbitraryRec <$> genericArbitraryRec (typeLevelWeights @weights)++-- | 'GenericArbitrary' with explicit generators.+--+-- === Example+--+-- > data X = ...+-- > deriving Arbitrary via (GenericArbitraryG CustomGens '[2, 3, 5] X)+--+-- where, for example, custom generators to override 'String' and 'Int' fields+-- might look as follows:+--+-- @+-- type CustomGens = CustomString ':+' CustomInt+-- @+--+-- === Note on multiple matches+--+-- Multiple generators may match a given field: the first will be chosen.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryG'.+--+-- @since 1.5.0.0+newtype GenericArbitraryG genList weights a = GenericArbitraryG {unGenericArbitraryG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList UnsizedOpts) a,+ GUniformWeight a,+ TypeLevelWeights' weights a,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitraryG genList' weights a)+ where+ arbitrary = GenericArbitraryG <$> genericArbitraryG (toGenList $ Proxy @genList') (typeLevelWeights @weights)++-- | 'GenericArbitraryU' with explicit generators.+-- See also 'GenericArbitraryG'.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryUG'.+--+-- @since 1.5.0.0+newtype GenericArbitraryUG genList a = GenericArbitraryUG {unGenericArbitraryUG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList UnsizedOpts) a,+ GUniformWeight a,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitraryUG genList' a)+ where+ arbitrary = GenericArbitraryUG <$> genericArbitraryUG (toGenList $ Proxy @genList')++-- | 'genericArbitrarySingle' with explicit generators.+-- See also 'GenericArbitraryG'.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitrarySingleG'.+--+-- @since 1.5.0.0+newtype GenericArbitrarySingleG genList a = GenericArbitrarySingleG {unGenericArbitrarySingleG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList UnsizedOpts) a,+ Weights_ (Rep a) ~ L c0,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitrarySingleG genList' a)+ where+ arbitrary = GenericArbitrarySingleG <$> genericArbitrarySingleG (toGenList $ Proxy @genList')++-- | 'genericArbitraryRec' with explicit generators.+-- See also 'genericArbitraryG'.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryRecG'.+--+-- @since 1.5.0.0+newtype GenericArbitraryRecG genList weights a = GenericArbitraryRecG {unGenericArbitraryRecG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList SizedOpts) a,+ TypeLevelWeights' weights a,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitraryRecG genList' weights a)+ where+ arbitrary = GenericArbitraryRecG <$> genericArbitraryRecG (toGenList $ Proxy @genList') (typeLevelWeights @weights)++-- | General generic generator with custom options.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryWith'.+--+-- @since 1.5.0.0+newtype GenericArbitraryWith opts weights a = GenericArbitraryWith {unGenericArbitraryWith :: a} deriving (Eq, Show)++instance+ ( GArbitrary opts a,+ TypeLevelWeights' weights a,+ TypeLevelOpts opts',+ opts ~ TypeLevelOpts' opts'+ ) =>+ Arbitrary (GenericArbitraryWith opts' weights a)+ where+ arbitrary = GenericArbitraryWith <$> genericArbitraryWith (toOpts $ Proxy @opts') (typeLevelWeights @weights)++-- | Add generic shrinking to a newtype wrapper for 'Arbitrary', using 'genericShrink'.+--+-- @+-- data X = ...+-- deriving Arbitrary via ('GenericArbitrary' '[1,2,3] `'AndShrinking'` X)+-- @+--+-- Equivalent to:+--+-- @+-- instance Arbitrary X where+-- arbitrary = 'genericArbitrary' (1 % 2 % 3 % ())+-- shrink = 'Test.QuickCheck.genericShrink'+-- @+--+-- @since 1.5.0.0+newtype AndShrinking f a = AndShrinking a deriving (Eq, Show)++instance+ ( Arbitrary (f a), Coercible (f a) a, Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a+ ) => Arbitrary (AndShrinking f a) where+ arbitrary = coerce (arbitrary :: Gen (f a))+ shrink = coerce (genericShrink :: a -> [a])++-- * Internal++-- |+-- @since 1.5.0.0+type TypeLevelWeights' weights a = TypeLevelWeights weights (Weights_ (Rep a))++typeLevelWeights ::+ forall weights a.+ TypeLevelWeights weights (Weights_ (Rep a)) =>+ Weights a+typeLevelWeights =+ let (w, n) = typeLevelWeightsBuilder @weights+ in Weights w n++-- |+-- @since 1.5.0.0+class TypeLevelWeights weights a where+ typeLevelWeightsBuilder :: (a, Int)++instance+ ( KnownNat weight,+ TypeLevelWeights weights a+ ) =>+ TypeLevelWeights (weight ': weights) (L x :| a)+ where+ typeLevelWeightsBuilder =+ let (a, m) = (L, fromIntegral $ natVal $ Proxy @weight)+ (b, n) = typeLevelWeightsBuilder @weights @a+ in (N a m b, m + n)++instance+ ( KnownNat weight+ ) =>+ TypeLevelWeights (weight ': '[]) (L x)+ where+ typeLevelWeightsBuilder = (L, fromIntegral $ natVal $ Proxy @weight)++instance+ TypeLevelWeights (w ': ws) (t :| (u :| v)) =>+ TypeLevelWeights (w ': ws) ((t :| u) :| v)+ where+ typeLevelWeightsBuilder =+ let (N t nt (N u nu v), m) = typeLevelWeightsBuilder @(w ': ws) @(t :| (u :| v))+ in (N (N t nt u) (nt + nu) v, m)++instance TypeLevelWeights '[] () where+ typeLevelWeightsBuilder = ((), 1)++-- |+-- @since 1.5.0.0+class TypeLevelGenList a where+ type TypeLevelGenList' a :: Type+ toGenList :: Proxy a -> TypeLevelGenList' a++instance Arbitrary a => TypeLevelGenList (Gen a) where+ type TypeLevelGenList' (Gen a) = Gen a+ toGenList _ = arbitrary++instance (TypeLevelGenList a, TypeLevelGenList b) => TypeLevelGenList (a :+ b) where+ type TypeLevelGenList' (a :+ b) = TypeLevelGenList' a :+ TypeLevelGenList' b+ toGenList _ = toGenList (Proxy @a) :+ toGenList (Proxy @b)++-- |+-- @since 1.5.0.0+class TypeLevelOpts a where+ type TypeLevelOpts' a :: Type+ toOpts :: Proxy a -> TypeLevelOpts' a
+ src/Generic/Random/Internal/BaseCase.hs view
@@ -0,0 +1,321 @@+{-# OPTIONS_HADDOCK not-home #-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | 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+import Data.Proxy+import Data.Kind (Type)+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 :: Type) (z :: Nat) (y :: Maybe Nat) (e :: Type) 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 -> Type) (z :: Nat) (y :: Maybe Nat) (e :: Type) 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+ ( Alternative (IfM y Weighted Proxy) -- logically redundant, but GHC isn't clever+ -- enough to deduce; see #32+ , 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+ ( Alternative (IfM y Weighted Proxy) -- logically redundant, but GHC isn't clever+ -- enough to deduce; see #32+ , 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++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"++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 gn) -> case gn of+ Just (g, n) -> choose (0, n-1) >>= fmap to . g+ Nothing -> error "How could this happen?")+ (\Proxy -> Proxy)+ (gbcs y z)
+ src/Generic/Random/Internal/Generic.hs view
@@ -0,0 +1,790 @@+{-# OPTIONS_HADDOCK not-home #-}++{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | 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++import Control.Applicative (Alternative(..), liftA2)+import Data.Coerce (Coercible, coerce)+import Data.Kind (Type)++import Data.Proxy (Proxy(..))+import Data.Type.Bool (type (&&))+import Data.Type.Equality (type (==))++import GHC.Generics hiding (S, prec)+import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), natVal)+import Test.QuickCheck (Arbitrary(..), Gen, choose, scale, sized, vectorOf)++-- * 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, the generators for 'String' and 'Int' fields are overridden as+-- follows, for example:+--+-- @+-- customGens :: Gen String ':+' Gen Int+-- customGens =+-- (filter (/= '\NUL') '<$>' arbitrary) ':+'+-- (getNonNegative '<$>' arbitrary)+-- @+--+-- === Note on multiple matches+--+-- Multiple generators may match a given field: the first will be chosen.+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+ Weights_ (M1 C ('MetaCons c _i _j) _f) = L c++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\") '%' ())+-- @+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++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'.+--+-- Note: it is recommended to avoid referring to the 'Options' type+-- explicitly in code, as the set of options may change in the future.+-- Instead, use the provided synonyms ('UnsizedOpts', 'SizedOpts', 'SizedOptsDef')+-- and the setter 'SetOptions' (abbreviated as @('<+')@).+newtype Options (c :: Coherence) (s :: Sizing) (genList :: Type) = Options+ { _generators :: genList+ }++-- | Setter for 'Options'.+--+-- This subsumes the other setters: 'SetSized', 'SetUnsized', 'SetGens'.+--+-- @since 1.4.0.0+type family SetOptions (x :: k) (o :: Type) :: Type+type instance SetOptions (s :: Sizing) (Options c _s g) = Options c s g+type instance SetOptions (c :: Coherence) (Options _c s g) = Options c s g+type instance SetOptions (g :: Type) (Options c s _g) = Options c s g++-- | Infix flipped synonym for 'Options'.+--+-- @since 1.4.0.0+type (<+) o x = SetOptions x o+infixl 1 <++++type UnsizedOpts = Options 'INCOHERENT 'Unsized ()+type SizedOpts = Options 'INCOHERENT 'Sized ()+type SizedOptsDef = Options 'INCOHERENT 'Sized (Gen1 [] :+ ())++-- | Like 'UnsizedOpts', but using coherent instances by default.+--+-- @since 1.4.0.0+type CohUnsizedOpts = Options 'COHERENT 'Unsized ()++-- | Like 'SizedOpts', but using coherent instances by default.+--+-- @since 1.4.0.0+type CohSizedOpts = Options 'COHERENT 'Sized ()++-- | Coerce an 'Options' value between types with the same representation.+--+-- @since 1.4.0.0+setOpts :: forall x o. (Coercible o (SetOptions x o)) => o -> SetOptions x o+setOpts = coerce++-- | 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' :+ ())++-- | Like 'unsizedOpts', but using coherent instances by default.+cohUnsizedOpts :: CohUnsizedOpts+cohUnsizedOpts = Options ()++-- | Like 'sizedOpts' but using coherent instances by default.+cohSizedOpts :: CohSizedOpts+cohSizedOpts = Options ()+++-- | Whether to decrease the size parameter before generating fields.+--+-- The 'Sized' option makes the size parameter decrease in the following way:+-- - Constructors with one field decrease the size parameter by 1 to generate+-- that field.+-- - Constructors with more than one field split the size parameter among all+-- fields; the size parameter is rounded down to then be divided equally.+data Sizing+ = Sized -- ^ Decrease the size parameter when running generators for fields+ | Unsized -- ^ Don't touch the size parameter++type family SizingOf opts :: Sizing+type instance SizingOf (Options _c s _g) = s++type family SetSized (o :: Type) :: Type+type instance SetSized (Options c s g) = Options c 'Sized g++type family SetUnsized (o :: Type) :: Type+type instance SetUnsized (Options c s g) = Options c 'Unsized g++setSized :: Options c s g -> Options c 'Sized g+setSized = coerce++setUnsized :: Options c s g -> Options c 'Unsized g+setUnsized = coerce+++-- | For custom generators to work with parameterized types, incoherent+-- instances must be used internally.+-- In practice, the resulting behavior is what users want 100% of the time,+-- so you should forget this option even exists.+--+-- === __Details__+--+-- The default configuration of generic-random does a decent job if+-- we trust GHC implements precisely the instance resolution algorithm as+-- described in the GHC manual:+--+-- - https://downloads.haskell.org/ghc/latest/docs/html/users_guide/glasgow_exts.html#overlapping-instances+--+-- While that assumption holds in practice, it is overly context-dependent+-- (to know the context leading to a particular choice, we must replay the+-- whole resolution algorithm).+-- In particular, this algorithm may find one solution, but it is not+-- guaranteed to be unique: the behavior of the program is dependent on+-- implementation details.+--+-- An notable property to consider of an implicit type system (such as type+-- classes) is coherence: the behavior of the program is stable under+-- specialization.+--+-- This sounds nice on paper, but actually leads to surprising behavior for+-- generic implementations with parameterized types, such as generic-random.+--+-- To address that, the coherence property can be relaxd by users, by+-- explicitly allowing some custom generators to be chosen incoherently. With+-- appropriate precautions, it is possible to ensure a weaker property which+-- nevertheless helps keep type inference predictable: when a solution is+-- found, it is unique.+-- (This is assuredly weaker, i.e., is not stable under specialization.)+--+-- @since 1.4.0.0+data Coherence+ = INCOHERENT -- ^ Match custom generators incoherently.+ | COHERENT+ -- ^ Match custom generators coherently by default+ -- (can be manually bypassed with 'Incoherent').++type family CoherenceOf (o :: Type) :: Coherence+type instance CoherenceOf (Options c _s _g) = c++-- | Match this generator incoherently when the 'COHERENT' option is set.+newtype Incoherent g = Incoherent g+++-- | Heterogeneous list of generators.+data a :+ b = a :+ b++infixr 1 :++++type family GeneratorsOf opts :: Type+type instance GeneratorsOf (Options _c _s g) = g++class HasGenerators opts where+ generators :: opts -> GeneratorsOf opts++instance HasGenerators (Options c s g) where+ generators = _generators++-- | Define the set of custom generators.+--+-- Note: for recursive types which can recursively appear inside lists or other+-- containers, you may want to include a custom generator to decrease the size+-- when generating such containers.+--+-- See also the Note about lists in "Generic.Random.Tutorial#notelists".+setGenerators :: genList -> Options c s g0 -> Options c s genList+setGenerators gens (Options _) = Options gens++type family SetGens (g :: Type) opts+type instance SetGens g (Options c s _g) = Options c s g+++-- | Custom generator for record fields named @s@.+--+-- If there is a field named @s@ with a different type,+-- this will result in a type error.+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@.+-- Fields are 0-indexed.+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++-- | 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@. The generator for @x@ will be+-- constructed using the list of custom generators if possible, otherwise+-- an instance @Arbitrary x@ will be required.+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+ , FindGen 'Shift ('S gs coh '(c, i, Name d)) () gs a+ , gs ~ GeneratorsOf opts+ , coh ~ CoherenceOf opts )+ => GAProduct' c i opts (S1 d (K1 _k a)) where+ gaProduct' _ opts = fmap (M1 . K1) (findGen (is, s, gs) () gs)+ where+ is = Proxy :: Proxy 'Shift+ s = Proxy :: Proxy ('S gs coh '(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 @g :+ 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 g matches, else ((), gs)+-- > FieldGen a, gs | idem+-- > ConstrGen a, gs | idem+-- > Gen1 a, gs | idem+-- > Gen1_ a, gs | idem+class FindGen (i :: AInstr) (s :: AStore) (g :: Type) (gs :: Type) (a :: Type) where+ findGen :: (Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a++data AInstr = Shift | Match Coherence | MatchCoh Bool+data AStore = S Type Coherence ASel++type ASel = (Maybe Symbol, Nat, Maybe Symbol)++iShift :: Proxy 'Shift+iShift = Proxy++type family FullGenListOf (s :: AStore) :: Type where+ FullGenListOf ('S fg _coh _sel) = fg++type family ACoherenceOf (s :: AStore) :: Coherence where+ ACoherenceOf ('S _fg coh _sel) = coh++type family ASelOf (s :: AStore) :: ASel where+ ASelOf ('S _fg _coh sel) = sel++-- | All candidates have been exhausted+instance Arbitrary a => FindGen 'Shift s () () a where+ findGen _ _ _ = arbitrary+ {-# INLINEABLE findGen #-}++-- | Examine the next candidate+instance FindGen 'Shift s b g a => FindGen 'Shift s () (b :+ g) a where+ findGen p () (b :+ gens) = findGen p b gens+ {-# INLINEABLE findGen #-}++-- | Examine the last candidate (@g@ is not of the form @_ :+ _@)+instance {-# OVERLAPS #-} FindGen 'Shift s g () a => FindGen 'Shift s () g a where+ findGen p () g = findGen p g ()++-- | This can happen if the generators form a tree rather than a list, for whatever reason.+instance FindGen 'Shift s g (h :+ gs) a => FindGen 'Shift s (g :+ h) gs a where+ findGen p (g :+ h) gs = findGen p g (h :+ gs)++instance FindGen ('Match 'INCOHERENT) s g gs a => FindGen 'Shift s (Incoherent g) gs a where+ findGen (_, s, fg) (Incoherent g) = findGen (im, s, fg) g where+ im = Proxy :: Proxy ('Match 'INCOHERENT)++-- | If none of the above matches, then @g@ should be a simple generator,+-- and we test whether it matches the type @a@.+instance {-# OVERLAPPABLE #-} FindGen ('Match (ACoherenceOf s)) s g gs a+ => FindGen 'Shift s g gs a where+ findGen (_, s, fg) = findGen (im, s, fg) where+ im = Proxy :: Proxy ('Match (ACoherenceOf s))++-- INCOHERENT++-- | None of the INCOHERENT instances match, discard the candidate @g@ and look+-- at the rest of the list @gs@.+instance FindGen 'Shift s () gs a+ => FindGen ('Match 'INCOHERENT) s _g gs a where+ findGen (_, s, fg) _ = findGen (iShift, s, fg) () where++-- | Matching custom generator for @a@.+instance {-# INCOHERENT #-} FindGen ('Match 'INCOHERENT) s (Gen a) gs a where+ findGen _ gen _ = gen+ {-# INLINEABLE findGen #-}++-- | Matching custom generator for non-container @f@.+instance {-# INCOHERENT #-} FindGen ('Match 'INCOHERENT) s (Gen1_ f) gs (f a) where+ findGen _ (Gen1_ gen) _ = gen++-- | Matching custom generator for container @f@. Start the search for containee @a@,+-- discarding field information.+instance {-# INCOHERENT #-} FindGen 'Shift ('S fg coh DummySel) () fg a+ => FindGen ('Match 'INCOHERENT) ('S fg coh _sel) (Gen1 f) gs (f a) where+ findGen (_, _, fg) (Gen1 gen) _ = gen (findGen (iShift, s, fg) () fg) where+ s = Proxy :: Proxy ('S fg coh DummySel)++type DummySel = '( 'Nothing, 0, 'Nothing)++-- | Matching custom generator for field @s@.+instance {-# INCOHERENT #-} (a ~ a')+ => FindGen ('Match 'INCOHERENT) ('S _fg _coh '(con, i, 'Just s)) (FieldGen s a) gs a' where+ findGen _ (FieldGen gen) _ = gen+ {-# INLINEABLE findGen #-}++-- | Matching custom generator for @i@-th field of constructor @c@.+instance {-# INCOHERENT #-} (a ~ a')+ => FindGen ('Match 'INCOHERENT) ('S _fg _coh '( 'Just c, i, s)) (ConstrGen c i a) gs a' where+ findGen _ (ConstrGen gen) _ = gen+ {-# INLINEABLE findGen #-}++-- | 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++-- COHERENT++-- Use a type famaily to do the matching coherently.+instance FindGen ('MatchCoh (Matches (ASelOf s) g a)) s g gs a+ => FindGen ('Match 'COHERENT) s g gs a where+ findGen (_, s, fg) = findGen (im, s, fg) where+ im = Proxy :: Proxy ('MatchCoh (Matches (ASelOf s) g a))++type family Matches (s :: ASel) (g :: Type) (a :: Type) :: Bool where+ Matches _sel (Gen b) a = b == a+ Matches _sel (Gen1_ f) (f a) = 'True+ Matches _sel (Gen1_ f) a = 'False+ Matches _sel (Gen1 f) (f a) = 'True+ Matches _sel (Gen1 f) a = 'False+ Matches '(_c, i, s) (FieldGen s1 b) a = s == 'Just s1 && b == a+ Matches '( c, i, _s) (ConstrGen c1 j b) a = c == 'Just c1 && i == j && b == a++-- If there is no match, skip and shift.+instance FindGen 'Shift s () gs a => FindGen ('MatchCoh 'False) s _g gs a where+ findGen (_, s, fg) _ = findGen (iShift, s, fg) () where++-- If there is a match, the search terminates++instance (a ~ a') => FindGen ('MatchCoh 'True) s (Gen a) gs a' where+ findGen _ g _ = g++instance (f x ~ a') => FindGen ('MatchCoh 'True) s (Gen1_ f) gs a' where+ findGen _ (Gen1_ g) _ = g++instance (f x ~ a', FindGen 'Shift ('S fg coh DummySel) () fg x)+ => FindGen ('MatchCoh 'True) ('S fg coh _sel) (Gen1 f) gs a' where+ findGen (_, _, fg) (Gen1 gen) _ = gen (findGen (iShift, s, fg) () fg) where+ s = Proxy :: Proxy ('S fg coh DummySel)++-- | Matching custom generator for field @s@.+instance (a ~ a')+ => FindGen ('MatchCoh 'True) s (FieldGen sn a) gs a' where+ findGen _ (FieldGen gen) _ = gen++-- | Matching custom generator for @i@-th field of constructor @c@.+instance (a ~ a')+ => FindGen ('MatchCoh 'True) s (ConstrGen c i a) gs a' where+ findGen _ (ConstrGen gen) _ = gen++--++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))+
+ src/Generic/Random/Tutorial.hs view
@@ -0,0 +1,287 @@+-- | 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 @p_C@ proportional to its weight @weight_C@;+-- 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 to 1) 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+--+-- 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.+-- It is 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 #notelists#+--+-- 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!+-- <https://github.com/Lysxia/generic-random/issues The issue tracker is this way.>++{-# OPTIONS_GHC -Wno-unused-imports #-}++module Generic.Random.Tutorial () where++import Generic.Random
+ test/Inspect.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -dsuppress-all #-}+{-# 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'
+ test/Inspect/DerivingVia.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE+ DataKinds,+ DeriveGeneric,+ DerivingVia,+ TypeOperators,+ TemplateHaskell+ #-}++import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary(arbitrary), Gen)++import Test.Inspection (inspect, (==-))++import Generic.Random++data T = A | B | C Int [Bool]+ deriving Generic+ deriving Arbitrary via (GenericArbitrary '[1,2,3] T)++arbT :: Gen T+arbT = genericArbitrary (1 % 2 % 3 % ())++arbT' :: Gen T+arbT' = arbitrary++data T1 = A1 | B1 | C1 Int [Bool]+ deriving Generic+ deriving Arbitrary via (GenericArbitrary '[1,2,3] `AndShrinking` T1)++main :: IO ()+main = pure ()++inspect $ 'arbT ==- 'arbT'
+ test/Unit.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE+ 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++-- Binary trees+data B = BL | BN B B+ deriving (Eq, Ord, Show, Generic)++size :: B -> Int+size (BN l r) = 1 + size l + size r+size BL = 0++instance Arbitrary B where+ arbitrary = genericArbitrary ((9 :: W "BL") % (3 :: W "BN") % ())++instance NFData B+++-- Messing with base cases+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)+++-- Rose tree for testing the custom list generator that's inserted by default.+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"++-- 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++main :: IO ()+main = do+ eval "B" (arbitrary :: Gen B)+ eval "T" (arbitrary :: Gen (T (T Int)))+ eval "NTree" (arbitrary :: Gen NTree)+ quickCheck . whenFail (putStrLn "Tree2") $ isLeftBiased
+ test/coherence.hs view
@@ -0,0 +1,126 @@+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-}+{-# LANGUAGE+ BangPatterns,+ DataKinds,+ DeriveGeneric,+ ScopedTypeVariables,+ TypeOperators,+ RebindableSyntax,+ TypeApplications #-}++import Control.Monad (replicateM)+import Control.Exception+import System.Exit (exitFailure)+import Data.Foldable (find, traverse_)+import Data.Maybe (catMaybes)++import GHC.Generics ( Generic )+import Test.QuickCheck (Arbitrary (..), Gen, sample, generate)+import Prelude++import Generic.Random++-- @T0@, @T1@: Override the @Int@ generator in the presence of a type parameter @a@.++-- Counterexample that's not supposed to type check.+-- Use BangPatterns so we can force it with just seq.+data T0 a = N0 !a !Int+ deriving (Generic, Show)++instance Arbitrary a => Arbitrary (T0 a) where+ arbitrary = genericArbitraryWith+ (setGenerators customGens cohSizedOpts)+ uniform+ where+ customGens :: Gen Int+ customGens = pure 33+++-- This one works.+data T1 a = N1 a Int+ deriving (Generic, Show)++instance Arbitrary a => Arbitrary (T1 a) where+ arbitrary = genericArbitraryWith+ (setGenerators customGens cohSizedOpts)+ uniform+ where+ customGens :: Incoherent (Gen a) :+ Gen Int+ customGens = Incoherent arbitrary :+ pure 33++check1 :: T1 a -> Bool+check1 (N1 _ n) = n == 33+++-- A bigger example to cover the remaining generator types.+data T2 a = N2+ { f2a :: a+ , f2b :: Int+ , f2c :: [Int]+ , f2d :: Maybe Int+ , f2e :: Int+ , f2g :: Int+ , f2h :: [a]+ } deriving (Show, Generic)++instance Arbitrary a => Arbitrary (T2 a) where+ arbitrary = genericArbitraryWith+ (setGenerators customGens cohSizedOpts)+ uniform+ where+ -- Hack to allow annotating each generator in the list while avoiding parentheses+ (>>) = (:+)+ customGens = do+ Incoherent arbitrary :: Incoherent (Gen a)+ Incoherent (FieldGen ((: []) <$> arbitrary))+ :: Incoherent (FieldGen "f2h" [a])+ Gen1_ (pure Nothing) :: Gen1_ Maybe+ Gen1 (fmap (\x -> [x, x])) :: Gen1 []+ ConstrGen (pure 88) :: ConstrGen "N2" 4 Int+ FieldGen (pure 77) :: FieldGen "f2g" Int+ pure 33 :: Gen Int++check2 :: T2 a -> Bool+check2 t =+ f2b t == 33+ && length (f2c t) == 2+ && f2d t == Nothing+ && f2e t == 88+ && f2g t == 77+ && length (f2h t) == 1+++type Error = String++expectTypeError :: IO a -> IO (Maybe Error)+expectTypeError gen = do+ r <- try (gen >>= evaluate)+ case r of+ Left (e :: TypeError) -> pure Nothing -- success+ Right _ -> (pure . Just) "Unexpected evaluation (expected a type error)"+++sample_ :: Show a => (a -> Bool) -> Gen a -> IO (Maybe Error)+sample_ check g = do+ xs <- generate (replicateM 100 g)+ case find (not . check) xs of+ Nothing -> pure Nothing+ Just x -> (pure . Just) ("Invalid value: " ++ show x)+++collectErrors :: [IO (Maybe Error)] -> IO ()+collectErrors xs = do+ es <- sequence xs+ case catMaybes es of+ [] -> pure ()+ es@(_ : _) -> do+ putStrLn "Test failed. Errors:"+ traverse_ putStrLn es+ exitFailure++main :: IO ()+main = collectErrors+ [ expectTypeError (generate (arbitrary :: Gen (T0 ())))+ , sample_ check1 (arbitrary :: Gen (T1 ()))+ , sample_ check2 (arbitrary :: Gen (T2 ()))+ ]
− test/tree.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-import Control.Monad-import Data.Data-import Data.Foldable-import Data.List-import Test.QuickCheck-import Data.Random.Generics--data T = N T T | L- deriving (Eq, Ord, Show, Data)---- size-s :: T -> Int-s (N l r) = 1 + s l + s r-s L = 0--main =- for_ [ 4 ^ e | e <- [2 .. 4] ] $ \n ->- for_- [ ("reject ", generatorSR)- , ("rejectSimple ", generatorR')- , ("point ", generatorP')- , ("pointReject ", generatorPR')- ] $ \(name, g) ->- stats (name ++ show n) s (g n)--stats :: String -> (a -> Int) -> Gen a -> IO ()-stats s f g = do- putStrLn s- xs <- replicateM 1000 (fmap f (generate g))- putStrLn $ "Mean: " ++ show (mean xs)- pp (histogram xs)- putStrLn ""--histogram xs' = (bounds, bins)- where- (xs, ys) = splitAt (95 * length xs' `div` 100) (sort xs')- xMin = minimum xs- xMax = maximum xs- bounds- | xMax - xMin < 20 = [xMin .. xMax]- | otherwise = [xMin, xMin + (xMax - xMin) `div` 10 .. xMax]- bins = f bounds xs- f (_ : b1 : bs) xs =- let (a, ys) = span (< b1) xs- in length a : f (b1 : bs) ys- f _ xs = [length xs + length ys]--pp :: ([Int], [Int]) -> IO ()-pp (vs, bs) = do- putStrLn $ vs >>= \v -> three v ++ " - "- putStrLn $ bs >>= \b -> " | " ++ three b--three x = replicate (3 - length s) ' ' ++ s- where- s = show x--mean :: Foldable v => v Int -> Double-mean xs = fromIntegral (sum xs) / fromIntegral (length xs)