generic-random 1.4.0.0 → 1.5.0.1
raw patch · 7 files changed
Files
- CHANGELOG.md +12/−1
- generic-random.cabal +22/−4
- src/Generic/Random.hs +35/−3
- src/Generic/Random/DerivingVia.hs +334/−0
- src/Generic/Random/Internal/BaseCase.hs +12/−5
- src/Generic/Random/Internal/Generic.hs +1/−1
- test/Inspect/DerivingVia.hs +33/−0
CHANGELOG.md view
@@ -1,4 +1,15 @@-https://github.com/Lysxia/generic-random/blob/master/changelog.md+# 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
generic-random.cabal view
@@ -1,5 +1,5 @@ name: generic-random-version: 1.4.0.0+version: 1.5.0.1 synopsis: Generic random generators for QuickCheck description: Derive instances of @Arbitrary@ for QuickCheck,@@ -23,18 +23,20 @@ build-type: Simple extra-source-files: README.md CHANGELOG.md cabal-version: >=1.10-tested-with: GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.1, GHC == 8.6.1+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.Random.DerivingVia Generic.Random.Internal.BaseCase Generic.Random.Internal.Generic Generic.Random.Tutorial build-depends:- base >= 4.9 && < 5,- QuickCheck+ base >= 4.11 && < 5,+ QuickCheck >= 2.14+ -- exports RecursivelyShrink default-language: Haskell2010 ghc-options: -Wall -fno-warn-name-shadowing @@ -67,6 +69,22 @@ 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,
src/Generic/Random.hs view
@@ -3,6 +3,8 @@ -- = Basic usage -- -- @+-- {-\# LANGUAGE DeriveGeneric \#-}+-- -- data Foo = A | B | C -- some generic data type -- deriving 'GHC.Generics.Generic' -- @@@ -11,7 +13,8 @@ -- -- @ -- instance Arbitrary Foo where--- arbitrary = 'genericArbitrary' 'uniform' -- give a distribution of constructors+-- 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@@ -22,6 +25,16 @@ -- 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"@@ -136,10 +149,10 @@ -- (getNonNegative '<$>' arbitrary) -- @ --- -- There are also different types of generators, other than 'Gen', providing+ -- 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: --- -- - @'Gen' a@: override fields of type @a@;+ -- - @'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@;@@ -208,7 +221,26 @@ , GArbitrary , GUniformWeight + -- * Newtypes for DerivingVia++ -- | These newtypes correspond to the variants of 'genericArbitrary' above.++ , GenericArbitrary (..)+ , GenericArbitraryU (..)+ , GenericArbitrarySingle (..)+ , GenericArbitraryRec (..)+ , GenericArbitraryG (..)+ , GenericArbitraryUG (..)+ , GenericArbitrarySingleG (..)+ , GenericArbitraryRecG (..)+ , GenericArbitraryWith (..)+ , AndShrinking (..)++ -- ** Helpers typeclasses+ , TypeLevelGenList (..)+ , TypeLevelOpts (..) ) where import Generic.Random.Internal.BaseCase import Generic.Random.Internal.Generic+import Generic.Random.DerivingVia
+ src/Generic/Random/DerivingVia.hs view
@@ -0,0 +1,334 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_HADDOCK not-home #-}++module Generic.Random.DerivingVia+ ( GenericArbitrary (..),+ GenericArbitraryU (..),+ GenericArbitrarySingle (..),+ GenericArbitraryRec (..),+ GenericArbitraryG (..),+ GenericArbitraryUG (..),+ GenericArbitrarySingleG (..),+ GenericArbitraryRecG (..),+ GenericArbitraryWith (..),+ AndShrinking (..),+ TypeLevelGenList (..),+ TypeLevelOpts (..),+ )+where++import Data.Coerce (Coercible, coerce)+import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import GHC.Generics (Generic(..))+import GHC.TypeLits (KnownNat, natVal)+import Generic.Random.Internal.Generic+import Test.QuickCheck (Arbitrary (..), Gen, genericShrink)+import Test.QuickCheck.Arbitrary (RecursivelyShrink, GSubterms)++-- * Newtypes for DerivingVia++-- | Pick a constructor with a given distribution, and fill its fields+-- with recursive calls to 'Test.QuickCheck.arbitrary'.+--+-- === Example+--+-- > data X = ...+-- > deriving Arbitrary via (GenericArbitrary '[2, 3, 5] X)+--+-- Picks the first constructor with probability @2/10@,+-- the second with probability @3/10@, the third with probability @5/10@.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitrary'.+--+-- @since 1.5.0.0+newtype GenericArbitrary weights a = GenericArbitrary {unGenericArbitrary :: a} deriving (Eq, Show)++instance+ ( GArbitrary UnsizedOpts a,+ TypeLevelWeights' weights a+ ) =>+ Arbitrary (GenericArbitrary weights a)+ where+ arbitrary = GenericArbitrary <$> genericArbitrary (typeLevelWeights @weights)++-- | Pick every constructor with equal probability.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryU'.+--+-- @since 1.5.0.0+newtype GenericArbitraryU a = GenericArbitraryU {unGenericArbitraryU :: a} deriving (Eq, Show)++instance+ ( GArbitrary UnsizedOpts a,+ GUniformWeight a+ ) =>+ Arbitrary (GenericArbitraryU a)+ where+ arbitrary = GenericArbitraryU <$> genericArbitraryU++-- | @arbitrary@ for types with one constructor.+-- Equivalent to 'GenericArbitraryU', with a stricter type.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitrarySingle'.+--+-- @since 1.5.0.0+newtype GenericArbitrarySingle a = GenericArbitrarySingle {unGenericArbitrarySingle :: a} deriving (Eq, Show)++instance+ ( GArbitrary UnsizedOpts a,+ Weights_ (Rep a) ~ L c0+ ) =>+ Arbitrary (GenericArbitrarySingle a)+ where+ arbitrary = GenericArbitrarySingle <$> genericArbitrarySingle++-- | Decrease size at every recursive call, but don't do anything different+-- at size 0.+--+-- > data X = ...+-- > deriving Arbitrary via (GenericArbitraryRec '[2, 3, 5] X)+--+-- N.B.: This replaces the generator for fields of type @[t]@ with+-- @'listOf'' arbitrary@ instead of @'Test.QuickCheck.listOf' arbitrary@ (i.e., @arbitrary@ for+-- lists).+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryRec'.+--+-- @since 1.5.0.0+newtype GenericArbitraryRec weights a = GenericArbitraryRec {unGenericArbitraryRec :: a} deriving (Eq, Show)++instance+ ( GArbitrary SizedOptsDef a,+ TypeLevelWeights' weights a+ ) =>+ Arbitrary (GenericArbitraryRec weights a)+ where+ arbitrary = GenericArbitraryRec <$> genericArbitraryRec (typeLevelWeights @weights)++-- | 'GenericArbitrary' with explicit generators.+--+-- === Example+--+-- > data X = ...+-- > deriving Arbitrary via (GenericArbitraryG CustomGens '[2, 3, 5] X)+--+-- where, for example, custom generators to override 'String' and 'Int' fields+-- might look as follows:+--+-- @+-- type CustomGens = CustomString ':+' CustomInt+-- @+--+-- === Note on multiple matches+--+-- Multiple generators may match a given field: the first will be chosen.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryG'.+--+-- @since 1.5.0.0+newtype GenericArbitraryG genList weights a = GenericArbitraryG {unGenericArbitraryG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList UnsizedOpts) a,+ GUniformWeight a,+ TypeLevelWeights' weights a,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitraryG genList' weights a)+ where+ arbitrary = GenericArbitraryG <$> genericArbitraryG (toGenList $ Proxy @genList') (typeLevelWeights @weights)++-- | 'GenericArbitraryU' with explicit generators.+-- See also 'GenericArbitraryG'.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryUG'.+--+-- @since 1.5.0.0+newtype GenericArbitraryUG genList a = GenericArbitraryUG {unGenericArbitraryUG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList UnsizedOpts) a,+ GUniformWeight a,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitraryUG genList' a)+ where+ arbitrary = GenericArbitraryUG <$> genericArbitraryUG (toGenList $ Proxy @genList')++-- | 'genericArbitrarySingle' with explicit generators.+-- See also 'GenericArbitraryG'.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitrarySingleG'.+--+-- @since 1.5.0.0+newtype GenericArbitrarySingleG genList a = GenericArbitrarySingleG {unGenericArbitrarySingleG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList UnsizedOpts) a,+ Weights_ (Rep a) ~ L c0,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitrarySingleG genList' a)+ where+ arbitrary = GenericArbitrarySingleG <$> genericArbitrarySingleG (toGenList $ Proxy @genList')++-- | 'genericArbitraryRec' with explicit generators.+-- See also 'genericArbitraryG'.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryRecG'.+--+-- @since 1.5.0.0+newtype GenericArbitraryRecG genList weights a = GenericArbitraryRecG {unGenericArbitraryRecG :: a} deriving (Eq, Show)++instance+ ( GArbitrary (SetGens genList SizedOpts) a,+ TypeLevelWeights' weights a,+ TypeLevelGenList genList',+ genList ~ TypeLevelGenList' genList'+ ) =>+ Arbitrary (GenericArbitraryRecG genList' weights a)+ where+ arbitrary = GenericArbitraryRecG <$> genericArbitraryRecG (toGenList $ Proxy @genList') (typeLevelWeights @weights)++-- | General generic generator with custom options.+--+-- This newtype does no shrinking. To add generic shrinking, use 'AndShrinking'.+--+-- Uses 'genericArbitraryWith'.+--+-- @since 1.5.0.0+newtype GenericArbitraryWith opts weights a = GenericArbitraryWith {unGenericArbitraryWith :: a} deriving (Eq, Show)++instance+ ( GArbitrary opts a,+ TypeLevelWeights' weights a,+ TypeLevelOpts opts',+ opts ~ TypeLevelOpts' opts'+ ) =>+ Arbitrary (GenericArbitraryWith opts' weights a)+ where+ arbitrary = GenericArbitraryWith <$> genericArbitraryWith (toOpts $ Proxy @opts') (typeLevelWeights @weights)++-- | Add generic shrinking to a newtype wrapper for 'Arbitrary', using 'genericShrink'.+--+-- @+-- data X = ...+-- deriving Arbitrary via ('GenericArbitrary' '[1,2,3] `'AndShrinking'` X)+-- @+--+-- Equivalent to:+--+-- @+-- instance Arbitrary X where+-- arbitrary = 'genericArbitrary' (1 % 2 % 3 % ())+-- shrink = 'Test.QuickCheck.genericShrink'+-- @+--+-- @since 1.5.0.0+newtype AndShrinking f a = AndShrinking a deriving (Eq, Show)++instance+ ( Arbitrary (f a), Coercible (f a) a, Generic a, RecursivelyShrink (Rep a), GSubterms (Rep a) a+ ) => Arbitrary (AndShrinking f a) where+ arbitrary = coerce (arbitrary :: Gen (f a))+ shrink = coerce (genericShrink :: a -> [a])++-- * Internal++-- |+-- @since 1.5.0.0+type TypeLevelWeights' weights a = TypeLevelWeights weights (Weights_ (Rep a))++typeLevelWeights ::+ forall weights a.+ TypeLevelWeights weights (Weights_ (Rep a)) =>+ Weights a+typeLevelWeights =+ let (w, n) = typeLevelWeightsBuilder @weights+ in Weights w n++-- |+-- @since 1.5.0.0+class TypeLevelWeights weights a where+ typeLevelWeightsBuilder :: (a, Int)++instance+ ( KnownNat weight,+ TypeLevelWeights weights a+ ) =>+ TypeLevelWeights (weight ': weights) (L x :| a)+ where+ typeLevelWeightsBuilder =+ let (a, m) = (L, fromIntegral $ natVal $ Proxy @weight)+ (b, n) = typeLevelWeightsBuilder @weights @a+ in (N a m b, m + n)++instance+ ( KnownNat weight+ ) =>+ TypeLevelWeights (weight ': '[]) (L x)+ where+ typeLevelWeightsBuilder = (L, fromIntegral $ natVal $ Proxy @weight)++instance+ TypeLevelWeights (w ': ws) (t :| (u :| v)) =>+ TypeLevelWeights (w ': ws) ((t :| u) :| v)+ where+ typeLevelWeightsBuilder =+ let (N t nt (N u nu v), m) = typeLevelWeightsBuilder @(w ': ws) @(t :| (u :| v))+ in (N (N t nt u) (nt + nu) v, m)++instance TypeLevelWeights '[] () where+ typeLevelWeightsBuilder = ((), 1)++-- |+-- @since 1.5.0.0+class TypeLevelGenList a where+ type TypeLevelGenList' a :: Type+ toGenList :: Proxy a -> TypeLevelGenList' a++instance Arbitrary a => TypeLevelGenList (Gen a) where+ type TypeLevelGenList' (Gen a) = Gen a+ toGenList _ = arbitrary++instance (TypeLevelGenList a, TypeLevelGenList b) => TypeLevelGenList (a :+ b) where+ type TypeLevelGenList' (a :+ b) = TypeLevelGenList' a :+ TypeLevelGenList' b+ toGenList _ = toGenList (Proxy @a) :+ toGenList (Proxy @b)++-- |+-- @since 1.5.0.0+class TypeLevelOpts a where+ type TypeLevelOpts' a :: Type+ toOpts :: Proxy a -> TypeLevelOpts' a
src/Generic/Random/Internal/BaseCase.hs view
@@ -27,6 +27,7 @@ import Control.Applicative import Data.Proxy+import Data.Kind (Type) import GHC.Generics import GHC.TypeLits import Test.QuickCheck@@ -75,7 +76,7 @@ -- -- @e@ is the original type the search started with, that @a@ appears in. -- It is used for error reporting.-class BaseCaseSearch (a :: *) (z :: Nat) (y :: Maybe Nat) (e :: *) where+class BaseCaseSearch (a :: Type) (z :: Nat) (y :: Maybe Nat) (e :: Type) where baseCaseSearch :: prox y -> proxy '(z, e) -> IfM y Gen Proxy a @@ -180,14 +181,16 @@ type instance MinOf 'LT m n = m class Alternative (IfM y Weighted Proxy)- => GBCS (f :: k -> *) (z :: Nat) (y :: Maybe Nat) (e :: *) where+ => 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- ( GBCSSum f g z e yf yg+ ( 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)@@ -235,7 +238,9 @@ gbcsSumCompare _ _ _ g = fmap R1 g instance- ( GBCSProduct f g z e yf yg+ ( 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)@@ -309,6 +314,8 @@ instance (Generic a, GBCS (Rep a) z y e, IsMaybe y) => GBaseCaseSearch a z y e where gBaseCaseSearch y z = ifMmap y- (\(Weighted (Just (g, n))) -> choose (0, n-1) >>= fmap to . g)+ (\(Weighted gn) -> case gn of+ Just (g, n) -> choose (0, n-1) >>= fmap to . g+ Nothing -> error "How could this happen?") (\Proxy -> Proxy) (gbcs y z)
src/Generic/Random/Internal/Generic.hs view
@@ -406,7 +406,7 @@ type family CoherenceOf (o :: Type) :: Coherence type instance CoherenceOf (Options c _s _g) = c --- | Match this generator incoherently when the 'INCOHERENT' option is set.+-- | Match this generator incoherently when the 'COHERENT' option is set. newtype Incoherent g = Incoherent g
+ test/Inspect/DerivingVia.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE+ DataKinds,+ DeriveGeneric,+ DerivingVia,+ TypeOperators,+ TemplateHaskell+ #-}++import GHC.Generics (Generic)+import Test.QuickCheck (Arbitrary(arbitrary), Gen)++import Test.Inspection (inspect, (==-))++import Generic.Random++data T = A | B | C Int [Bool]+ deriving Generic+ deriving Arbitrary via (GenericArbitrary '[1,2,3] T)++arbT :: Gen T+arbT = genericArbitrary (1 % 2 % 3 % ())++arbT' :: Gen T+arbT' = arbitrary++data T1 = A1 | B1 | C1 Int [Bool]+ deriving Generic+ deriving Arbitrary via (GenericArbitrary '[1,2,3] `AndShrinking` T1)++main :: IO ()+main = pure ()++inspect $ 'arbT ==- 'arbT'