diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,89 @@ +# 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 @@ -11,5 +97,5 @@ # 0.3.0.0 - Support GHC 7.10.3 -- Replace TypeApplications with ad-hoc data types in - genericArbitraryFrequency'/genericArbitrary' +- Replace `TypeApplications` with ad-hoc data types in + `genericArbitraryFrequency'`/`genericArbitrary'` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,37 +1,65 @@ Generic random generators [![Hackage](https://img.shields.io/hackage/v/generic-random.svg)](https://hackage.haskell.org/package/generic-random) [![Build Status](https://travis-ci.org/Lysxia/generic-random.svg)](https://travis-ci.org/Lysxia/generic-random) ========================= -Say goodbye to `Constructor <$> arbitrary <*> arbitrary <*> arbitrary`-boilerplate. +Generic random generators +to implement `Arbitrary` instances for [QuickCheck](https://hackage.haskell.org/package/QuickCheck) +Automating the `arbitrary` boilerplate also ensures that when a type changes to +have more or fewer constructors, then the generator either fixes itself to +generate that new case (when using the `uniform` distribution) or causes a +compilation error so you remember to fix it (when using an explicit +distribution). + +This package also offers a simple (optional) strategy to ensure termination for +recursive types: +make `Test.QuickCheck.Gen`'s size parameter decrease at every recursive call; +when it reaches zero, sample directly from a trivially terminating generator +given explicitly (`genericArbitraryRec` and `withBaseCase`) or implicitly +(`genericArbitrary'`). + +Example +------- + ```haskell - {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} - import GHC.Generics ( Generic ) - import Test.QuickCheck - import Generic.Random.Generic +import GHC.Generics (Generic) +import Test.QuickCheck +import Generic.Random - data Tree a = Leaf | Node (Tree a) a (Tree a) - deriving (Show, Generic) +data Tree a = Leaf | Node (Tree a) a (Tree a) + deriving (Show, Generic) - instance Arbitrary a => Arbitrary (Tree a) where - arbitrary = genericArbitrary' Z uniform +instance Arbitrary a => Arbitrary (Tree a) where + arbitrary = genericArbitraryRec uniform `withBaseCase` return Leaf - -- Equivalent to - -- > arbitrary = - -- > sized $ \n -> - -- > if n == 0 then - -- > return Leaf - -- > else - -- > oneof - -- > [ return Leaf - -- > , Node <$> arbitrary <*> arbitrary <*> arbitrary - -- > ] +-- Equivalent to +-- > arbitrary = +-- > sized $ \n -> +-- > if n == 0 then +-- > return Leaf +-- > else +-- > oneof +-- > [ return Leaf +-- > , resize (n `div` 3) $ +-- > Node <$> arbitrary <*> arbitrary <*> arbitrary +-- > ] - main = sample (arbitrary :: Gen (Tree ())) +main :: IO () +main = sample (arbitrary :: Gen (Tree ())) ``` -- User-specified distribution of constructors, with a compile-time check that - weights have been specified for all constructors. -- A simple (optional) strategy to ensure termination: `Test.QuickCheck.Gen`'s - size parameter decreases at every recursive `genericArbitrary'` call; when it - reaches zero, sample directly from a finite set of finite values. +Related +------- + +- The following two packages also derive random generators, but only with a uniform + distribution of constructors: + + + [quickcheck-arbitrary-template](https://hackage.haskell.org/package/quickcheck-arbitrary-template) (TH) + + [generic-arbitrary](https://hackage.haskell.org/package/generic-arbitrary-0.1.0) (GHC Generics) + +- [testing-feat](http://hackage.haskell.org/package/testing-feat): + derive enumerations for algebraic data types, which can be turned into random generators (TH). + +- [boltzmann-samplers](https://hackage.haskell.org/package/boltzmann-samplers): + derive Boltzmann samplers (SYB). diff --git a/generic-random.cabal b/generic-random.cabal --- a/generic-random.cabal +++ b/generic-random.cabal @@ -1,42 +1,104 @@ name: generic-random -version: 0.4.1.0 -synopsis: Generic random generators -description: Please see the README. +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 CHANGELOG.md cabal-version: >=1.10 -tested-with: GHC == 8.0.1 - -flag boltzmann - Description: - Dependency on boltzmann-samplers for backwards compatibility. - Manual: False - Default: True +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: - Generic.Random.Generic + Generic.Random + Generic.Random.DerivingVia + Generic.Random.Internal.BaseCase Generic.Random.Internal.Generic + Generic.Random.Tutorial build-depends: - base >= 4.9 && < 4.10, - QuickCheck - if flag(boltzmann) - exposed-modules: - Generic.Random.Boltzmann - Generic.Random.Data - build-depends: - boltzmann-samplers <= 0.2 + base >= 4.11 && < 5, + QuickCheck >= 2.14 + -- exports RecursivelyShrink default-language: Haskell2010 ghc-options: -Wall -fno-warn-name-shadowing source-repository head type: git location: https://github.com/lysxia/generic-random + +test-suite unit + hs-source-dirs: test + main-is: Unit.hs + build-depends: + base, + deepseq, + QuickCheck, + generic-random + type: exitcode-stdio-1.0 + default-language: Haskell2010 + +test-suite coherence + hs-source-dirs: test + main-is: coherence.hs + build-depends: + base, + deepseq, + QuickCheck, + generic-random + type: exitcode-stdio-1.0 + default-language: Haskell2010 + +test-suite inspect + hs-source-dirs: test + main-is: Inspect.hs + build-depends: + base, + QuickCheck, + inspection-testing, + generic-random + type: exitcode-stdio-1.0 + default-language: Haskell2010 + if !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, + 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 + +flag enable-inspect + description: Enable inspection tests + default: False + manual: True diff --git a/src/Generic/Random.hs b/src/Generic/Random.hs new file mode 100644 --- /dev/null +++ b/src/Generic/Random.hs @@ -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 diff --git a/src/Generic/Random/Boltzmann.hs b/src/Generic/Random/Boltzmann.hs deleted file mode 100644 --- a/src/Generic/Random/Boltzmann.hs +++ /dev/null @@ -1,7 +0,0 @@ - -module Generic.Random.Boltzmann - {-# DEPRECATED "Directly use \"Boltzmann.Species\" from @boltzmann-samplers@ instead." #-} - ( module Boltzmann.Species - ) where - -import Boltzmann.Species diff --git a/src/Generic/Random/Data.hs b/src/Generic/Random/Data.hs deleted file mode 100644 --- a/src/Generic/Random/Data.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Generic.Random.Data - {-# DEPRECATED "Directly use \"Boltzmann.Data\" from @boltzmann-samplers@ instead." #-} - ( module Boltzmann.Data - ) where - -import Boltzmann.Data diff --git a/src/Generic/Random/DerivingVia.hs b/src/Generic/Random/DerivingVia.hs new file mode 100644 --- /dev/null +++ b/src/Generic/Random/DerivingVia.hs @@ -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 diff --git a/src/Generic/Random/Generic.hs b/src/Generic/Random/Generic.hs deleted file mode 100644 --- a/src/Generic/Random/Generic.hs +++ /dev/null @@ -1,214 +0,0 @@ --- | Simple 'GHC.Generics'-based 'arbitrary' generators. --- --- Here is an example. Define your type. --- --- @ --- data Tree a = Leaf a | Node (Tree a) (Tree a) --- deriving Generic --- @ --- --- Pick an 'arbitrary' implementation. --- --- @ --- instance Arbitrary a => Arbitrary (Tree a) where --- arbitrary = 'genericArbitrary' ('weights' (9 '%' 8 '%' ())) --- @ --- --- @arbitrary :: 'Gen' (Tree a)@ picks a @Leaf@ with probability 9\/17, or a --- @Node@ with probability 8\/17, and recursively fills their fields with --- @arbitrary@. --- --- == Distribution of constructors --- --- The distribution of constructors can be specified using 'weights' applied to --- a special list of /weights/ in the same order as the data type definition. --- This assigns to each constructor a probability proportional to its weight; --- in other words, @p_C = weight_C / sumOfWeights@. --- --- The list of weights is built up with the @('%')@ operator as a cons, and using --- the unit @()@ as the empty list, in the order corresponding to the data type --- definition. --- --- For @Tree@, 'genericArbitrary' produces code equivalent to the following: --- --- @ --- 'genericArbitrary' :: Arbitrary a => 'Weights' (Tree a) -> Gen (Tree a) --- 'genericArbitrary' ('weighted' (x '%' y '%' ())) = --- frequency --- [ (x, Leaf \<$\> arbitrary) --- , (y, Node \<$\> arbitrary \<*\> arbitrary) --- ] --- @ --- --- The weights actually have type @'W' \"ConstructorName\"@ (just a newtype --- around 'Int'), so that you can annotate a weight with its corresponding --- constructor, and it will be checked that you got the order right. --- --- This will type-check. --- --- @ --- 'weighted' ((x :: 'W' \"Leaf\") '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) --- 'weighted' (x '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) --- @ --- --- This will not: the first requires an order of constructors different from --- the definition of the @Tree@ type; the second doesn't have the right number --- of weights. --- --- @ --- 'weighted' ((x :: 'W' \"Node\") '%' y '%' ()) :: 'Weights' (Tree a) --- 'weighted' (x '%' y '%' z '%' ()) :: 'Weights' (Tree a) --- @ --- --- === Uniform distribution --- --- You can specify the uniform distribution with 'uniform'. --- --- For @Tree@, @'genericArbitrary' 'uniform'@ produces code equivalent to the --- following: --- --- @ --- 'genericArbitrary' 'uniform' :: Arbitrary a => Gen (Tree a) --- 'genericArbitrary' 'uniform' = --- oneof --- [ Leaf \<$\> arbitrary -- Uses Arbitrary a --- , Node \<$\> arbitrary \<*\> arbitrary -- Uses Arbitrary (Tree a) --- ] --- @ --- --- Note that for many types, a uniform distribution tends to produce big --- values. For instance for @Tree a@, generated values are finite but the --- __average__ number of @Leaf@ and @Node@ constructors is __infinite__. --- --- == Ensuring termination --- --- As was just mentioned, one must be careful with recursive types --- to avoid producing extremely large values. --- --- The alternative 'genericArbitrary'' implements a simple strategy to keep --- values at reasonable sizes: the size parameter of 'Gen' is divided among the --- fields of the chosen constructor. When it reaches zero, the generator --- selects a finite term whenever it can find any of the given type. This --- generally ensures that the number of constructors remains close to the --- initial size parameter passed to 'Gen'. --- --- A natural number @n@ determines the maximum /depth/ of terms that can be --- used to end recursion. --- It is encoded using @'Z' :: 'Z'@ and @'S' :: n -> 'S' n@. --- --- @ --- 'genericArbitrary'' n ('weights' (...)) --- @ --- --- With @n = 'Z'@, the generator looks for a simple nullary constructor. If none --- exist at the current type, as is the case for our @Tree@ type, it carries on --- as in 'genericArbitrary'. --- --- @ --- 'genericArbitrary'' 'Z' :: Arbitrary a => 'Weights' (Tree a) -> Gen (Tree a) --- 'genericArbitrary'' 'Z' ('weights' (x '%' y '%' ())) = --- frequency --- [ (x, Leaf \<$\> arbitrary) --- , (y, scale (\`div\` 2) $ Node \<$\> arbitrary \<*\> arbitrary) --- -- 2 because Node is 2-ary. --- ] --- @ --- --- Here is another example with nullary constructors: --- --- @ --- data Tree' = Leaf1 | Leaf2 | Node3 Tree' Tree' Tree' --- deriving Generic --- --- instance Arbitrary Tree' where --- arbitrary = 'genericArbitrary'' 'Z' ('weights' (1 '%' 2 '%' 3 '%' ())) --- @ --- --- Here, @'genericArbitrary'' 'Z'@ is equivalent to: --- --- @ --- 'genericArbitrary'' 'Z' :: 'Weights' Tree' -> Gen Tree' --- 'genericArbitrary'' 'Z' ('weights' (x '%' y '%' z '%' ())) = --- sized $ \n -> --- if n == 0 then --- -- If the size parameter is zero, the non-nullary alternative is discarded. --- frequency $ --- [ (x, return Leaf1) --- , (y, return Leaf2) --- ] --- else --- frequency $ --- [ (x, return Leaf1) --- , (y, return Leaf2) --- , (z, resize (n \`div\` 3) node) -- 3 because Node3 is 3-ary --- ] --- where --- node = Node3 \<$\> arbitrary \<*\> arbitrary \<*\> arbitrary --- @ --- --- To increase the chances of termination when no nullary constructor is directly --- available, such as in @Tree@, we can pass a larger depth @n@. The effectiveness --- of this parameter depends on the concrete type the generator is used for. --- --- For instance, if we want to generate a value of type @Tree ()@, there is a --- value of depth 1 (represented by @'S' 'Z'@) that we can use to end --- recursion: @Leaf ()@. --- --- @ --- 'genericArbitrary'' ('S' 'Z') :: 'Weights' (Tree ()) -> Gen (Tree ()) --- 'genericArbitrary'' ('S' 'Z') ('weights' (x '%' y '%' ())) = --- sized $ \n -> --- if n == 0 then --- return (Leaf ()) --- else --- frequency --- [ (x, Leaf \<$\> arbitrary) --- , (y, scale (\`div\` 2) $ Node \<$\> arbitrary \<*\> arbitrary) --- ] --- @ --- --- Because the argument of @Tree@ must be inspected in order to discover --- values of type @Tree ()@, we incur some extra constraints if we want --- polymorphism. --- --- @UndecidableInstances@ is also required. --- --- @ --- instance (Arbitrary a, Generic a, 'ListBaseCases' 'Z' (Rep a)) --- => Arbitrary (Tree a) where --- arbitrary = 'genericArbitrary'' ('S' 'Z') ('weights' (1 '%' 2 '%' ())) --- @ --- --- A synonym is provided for brevity. --- --- @ --- instance (Arbitrary a, 'BaseCases'' Z a) => Arbitrary (Tree a) where --- arbitrary = 'genericArbitrary'' ('S' 'Z') ('weights' (1 '%' 2 '%' ())) --- @ - - -module Generic.Random.Generic - ( - -- * Arbitrary implementations - genericArbitrary - , genericArbitrary' - - -- * Specifying finite distributions - , Weights - , W - , weights - , (%) - , uniform - - -- * Type-level natural numbers - -- $nat - , Z (..) - , S (..) - - -- * Generic classes for finite values - , BaseCases' - , BaseCases - , ListBaseCases - ) where - -import Generic.Random.Internal.Generic diff --git a/src/Generic/Random/Internal/BaseCase.hs b/src/Generic/Random/Internal/BaseCase.hs new file mode 100644 --- /dev/null +++ b/src/Generic/Random/Internal/BaseCase.hs @@ -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) diff --git a/src/Generic/Random/Internal/Generic.hs b/src/Generic/Random/Internal/Generic.hs --- a/src/Generic/Random/Internal/Generic.hs +++ b/src/Generic/Random/Internal/Generic.hs @@ -1,51 +1,159 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# OPTIONS_HADDOCK not-home #-} + +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MagicHash #-} {-# 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 -import Data.Coerce -import GHC.Exts (Proxy#, proxy#) -import GHC.Generics hiding ( S ) -import GHC.TypeLits -import Test.QuickCheck +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 --- recursively. +-- 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 - :: forall a - . (Generic a, GA Unsized (Rep a)) - => Weights a + :: (GArbitrary UnsizedOpts a) + => Weights a -- ^ List of weights for every constructor -> Gen a -genericArbitrary (Weights w n) = (unGen' . fmap to) (ga w n :: Gen' Unsized (Rep a p)) +genericArbitrary = genericArbitraryWith unsizedOpts --- | Like 'genericArbitrary'', with bounded size to ensure termination for --- recursive types. -genericArbitrary' - :: forall n a - . (Generic a, GA (Sized n) (Rep a)) - => n +-- | 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 -genericArbitrary' _ (Weights w n) = - (unGen' . fmap to) (ga w n :: Gen' (Sized n) (Rep a p)) +genericArbitraryRecG gs = genericArbitraryWith opts + where + opts = setGenerators gs sizedOpts +-- | General generic generator with custom options. +genericArbitraryWith + :: (GArbitrary opts a) + => opts -> Weights a -> Gen a +genericArbitraryWith opts (Weights w n) = + fmap to (ga opts w n) -- * Internal -type family Weights_ (f :: * -> *) :: * where +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 @@ -59,14 +167,14 @@ -- Two ways of constructing them. -- -- @ --- 'weights' (x1 '%' x2 '%' ... '%' xn '%' ()) :: 'Weights' a +-- (x1 '%' x2 '%' ... '%' xn '%' ()) :: 'Weights' a -- 'uniform' :: 'Weights' a -- @ -- --- Using @weights@, there must be exactly as many weights as +-- Using @('%')@, there must be exactly as many weights as -- there are constructors. -- --- 'uniform' is equivalent to @'weights' (1 '%' ... '%' 1 '%' ())@ +-- 'uniform' is equivalent to @(1 '%' ... '%' 1 '%' ())@ -- (automatically fills out the right number of 1s). data Weights a = Weights (Weights_ (Rep a)) Int @@ -74,16 +182,18 @@ -- constructor for additional compile-time checking. -- -- @ --- 'weights' ((9 :: 'W' \"Leaf\") '%' (8 :: 'W' \"Node\") '%' ()) +-- ((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 (Weights_ (Rep a)) => Weights a +uniform :: UniformWeight_ (Rep a) => Weights a uniform = let (w, n) = uniformWeight in Weights w n @@ -92,24 +202,46 @@ 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 - -- | A binary constructor for building up trees of weights. - (%) :: W (First a) -> Prec a r -> (a, Int, 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 = + 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) + 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) @@ -124,96 +256,510 @@ instance UniformWeight (L c) where uniformWeight = (L, 1) -newtype Gen' sized a = Gen' { unGen' :: Gen a } - deriving (Functor, Applicative, Monad) +instance UniformWeight () where + uniformWeight = ((), 1) -data Sized n -data Unsized +class UniformWeight (Weights_ f) => UniformWeight_ f +instance UniformWeight (Weights_ f) => UniformWeight_ f -sized' :: (Int -> Gen' sized a) -> Gen' sized a -sized' g = Gen' . sized $ \sz -> unGen' (g sz) +-- | Derived uniform distribution of constructors for @a@. +class UniformWeight_ (Rep a) => GUniformWeight a +instance UniformWeight_ (Rep a) => GUniformWeight a --- | Generic Arbitrary -class GA sized f where - ga :: Weights_ f -> Int -> Gen' sized (f p) -instance GA sized f => GA sized (M1 D c f) where - ga w n = fmap M1 (ga w n) +-- | 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 + } -instance GAProduct f => GA Unsized (M1 C c f) where - ga _ _ = (Gen' . fmap M1) gaProduct +-- | 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 -instance (GAProduct f, KnownNat (Arity f)) => GA (Sized n) (M1 C c f) where - ga _ _ = Gen' (scale (`div` arity) gaProduct) - where - arity = fromInteger (natVal' (proxy# :: Proxy# (Arity f))) +-- | Infix flipped synonym for 'Options'. +-- +-- @since 1.4.0.0 +type (<+) o x = SetOptions x o +infixl 1 <+ -instance (GASum (Sized n) f, GASum (Sized n) g, BaseCases n f, BaseCases n g) - => GA (Sized n) (f :+: g) where - ga w n = sized' $ \sz -> - case unTagged (baseCases w n :: Tagged n (Weighted ((f :+: g) p))) of - Weighted (Just (bc, n)) | sz == 0 -> Gen' (choose (0, n - 1) >>= bc) - _ -> gaSum' w n -instance (GASum Unsized f, GASum Unsized g) => GA Unsized (f :+: g) where +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 #-} -gArbitrarySingle - :: forall sized f p c0 - . (GA sized f, Weights_ f ~ L c0) - => Gen' sized (f p) -gArbitrarySingle = ga L 0 +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 sized f => Weights_ f -> Int -> Gen' sized (f p) -gaSum' w n = do - i <- Gen' $ choose (0, n-1) - gaSum i w +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 sized f where - gaSum :: Int -> Weights_ f -> Gen' sized (f p) +class GASum opts f where + gaSum :: opts -> Int -> Weights_ f -> Gen (f p) -instance (GASum sized f, GASum sized g) => GASum sized (f :+: g) where - gaSum i (N a n b) - | i < n = fmap L1 (gaSum i a) - | otherwise = fmap R1 (gaSum (i - n) b) +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 f => GASum sized (M1 i c f) where - gaSum _ _ = Gen' gaProduct +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 f where - gaProduct :: Gen (f p) +class GAProduct (s :: Sizing) (c :: Maybe Symbol) opts f where + gaProduct :: proxys '(s, c) -> opts -> Gen (f p) -instance GAProduct U1 where - gaProduct = pure U1 +instance GAProduct' c 0 opts f => GAProduct 'Unsized c opts f where + gaProduct _ = gaProduct' (Proxy :: Proxy '(c, 0)) + {-# INLINE gaProduct #-} -instance Arbitrary c => GAProduct (K1 i c) where - gaProduct = fmap K1 arbitrary +-- 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 f => GAProduct (M1 i c f) where - gaProduct = fmap M1 gaProduct +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 (GAProduct f, GAProduct g) => GAProduct (f :*: g) where - gaProduct = liftA2 (:*:) gaProduct 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 -newtype Tagged a b = Tagged { unTagged :: b } - deriving Functor +data AInstr = Shift | Match Coherence | MatchCoh Bool +data AStore = S Type Coherence ASel --- $nat --- Use the 'Z' and 'S' data types to define the depths of values used --- by 'genericArbitrary'' to make generators terminate. +type ASel = (Maybe Symbol, Nat, Maybe Symbol) --- | Zero -data Z = Z +iShift :: Proxy 'Shift +iShift = Proxy --- | Successor -data S n = S n +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 @@ -221,10 +767,10 @@ pure a = Weighted (Just ((pure . pure) a, 1)) Weighted f <*> Weighted a = Weighted $ liftA2 g f a where - g (f, m) (a, n) = + g (f1, m) (a1, n) = ( \i -> let (j, k) = i `divMod` m - in f j <*> a k + in f1 j <*> a1 k , m * n ) instance Alternative Weighted where @@ -239,62 +785,6 @@ b (i - m) , m + n ) -class BaseCases n f where - baseCases :: Weights_ f -> Int -> Tagged n (Weighted (f p)) - -instance (BaseCases n f, BaseCases n g) => BaseCases n (f :+: g) where - baseCases (N a m b) n = - concat - ((fmap . fmap) L1 (baseCases a m)) - ((fmap . fmap) R1 (baseCases b (n - m))) - where - concat :: Alternative u => Tagged n (u a) -> Tagged n (u a) -> Tagged n (u a) - concat (Tagged a) (Tagged b) = Tagged (a <|> b) - -instance ListBaseCases n f => BaseCases n (M1 i c f) where - baseCases _ n = fmap reweigh listBaseCases - where - reweigh :: Weighted a -> Weighted a - reweigh (Weighted h) = Weighted (fmap (\(g, _) -> (g, n)) h) - --- | A @ListBaseCases n ('Rep' a)@ constraint basically provides the list of --- values of type @a@ with depth at most @n@. -class ListBaseCases n f where - listBaseCases :: Alternative u => Tagged n (u (f p)) - --- | For convenience. -type BaseCases' n a = (Generic a, ListBaseCases n (Rep a)) - -instance ListBaseCases n U1 where - listBaseCases = Tagged (pure U1) - -instance ListBaseCases n f => ListBaseCases n (M1 i c f) where - listBaseCases = (fmap . fmap) M1 listBaseCases - -instance ListBaseCases Z (K1 i c) where - listBaseCases = Tagged empty - -instance (Generic c, ListBaseCases n (Rep c)) => ListBaseCases (S n) (K1 i c) where - listBaseCases = (retag . (fmap . fmap) (K1 . to)) listBaseCases - where - retag :: Tagged n a -> Tagged (S n) a - retag = coerce - -instance (ListBaseCases n f, ListBaseCases n g) => ListBaseCases n (f :+: g) where - listBaseCases = - concat - ((fmap . fmap) L1 listBaseCases) - ((fmap . fmap) R1 listBaseCases) - where - concat :: Alternative u => Tagged n (u a) -> Tagged n (u a) -> Tagged n (u a) - concat (Tagged a) (Tagged b) = Tagged (a <|> b) +liftGen :: Gen a -> Weighted a +liftGen g = Weighted (Just (\_ -> g, 1)) -instance (ListBaseCases n f, ListBaseCases n g) => ListBaseCases n (f :*: g) where - listBaseCases = liftedP listBaseCases listBaseCases - where - liftedP - :: Applicative u - => Tagged n (u (f p)) - -> Tagged n (u (g p)) - -> Tagged n (u ((f :*: g) p)) - liftedP (Tagged f) (Tagged g) = Tagged (liftA2 (:*:) f g) diff --git a/src/Generic/Random/Tutorial.hs b/src/Generic/Random/Tutorial.hs new file mode 100644 --- /dev/null +++ b/src/Generic/Random/Tutorial.hs @@ -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! +-- + +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Generic.Random.Tutorial () where + +import Generic.Random diff --git a/test/Inspect.hs b/test/Inspect.hs new file mode 100644 --- /dev/null +++ b/test/Inspect.hs @@ -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' diff --git a/test/Inspect/DerivingVia.hs b/test/Inspect/DerivingVia.hs new file mode 100644 --- /dev/null +++ b/test/Inspect/DerivingVia.hs @@ -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' diff --git a/test/Unit.hs b/test/Unit.hs new file mode 100644 --- /dev/null +++ b/test/Unit.hs @@ -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 diff --git a/test/coherence.hs b/test/coherence.hs new file mode 100644 --- /dev/null +++ b/test/coherence.hs @@ -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 ())) + ]