generic-random 1.4.0.0 → 1.5.0.0

raw patch · 7 files changed

+436/−11 lines, 7 filesdep ~QuickCheckdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck, base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−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 +3/−2
• src/Generic/Random/Internal/Generic.hs +1/−1
• test/Inspect/DerivingVia.hs +33/−0

@@ -1,4 +1,11 @@-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.0.0++- Add newtypes for `DerivingVia`+- Drop compatibility with GHC 8.0 and 8.2  # 1.4.0.0 

@@ -1,5 +1,5 @@ name:                generic-random-version:             1.4.0.0+version:             1.5.0.0 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  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,

@@ -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

@@ -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

@@ -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,7 +181,7 @@ 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

@@ -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  

@@ -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'