generic-random 1.3.0.1 → 1.4.0.0

raw patch · 9 files changed

+498/−158 lines, 9 filesdep +randomdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: random

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• generic-random.cabal +23/−4
• src/Generic/Random.hs +45/−3
• src/Generic/Random/Internal/BaseCase.hs +0/−26
• src/Generic/Random/Internal/Generic.hs +271/−106
• src/Generic/Random/Tutorial.hs +7/−13
• test/Inspect.hs +1/−0
• test/Unit.hs +19/−6
• test/coherence.hs +126/−0

@@ -1,5 +1,11 @@ https://github.com/Lysxia/generic-random/blob/master/changelog.md +# 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,5 +1,5 @@ name:                generic-random-version:             1.3.0.1+version:             1.4.0.0 synopsis:            Generic random generators for QuickCheck description:     Derive instances of @Arbitrary@ for QuickCheck,@@ -23,7 +23,7 @@ build-type:          Simple extra-source-files:  README.md CHANGELOG.md cabal-version:       >=1.10-tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.1, GHC == 8.4.1, GHC == 8.6.1+tested-with:         GHC == 8.0.1, GHC == 8.0.2, GHC == 8.2.1, GHC == 8.4.1, GHC == 8.6.1  library   hs-source-dirs:      src@@ -33,7 +33,7 @@     Generic.Random.Internal.Generic     Generic.Random.Tutorial   build-depends:-    base >= 4.7 && < 5,+    base >= 4.9 && < 5,     QuickCheck   default-language:    Haskell2010   ghc-options: -Wall -fno-warn-name-shadowing@@ -53,6 +53,17 @@   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@@ -63,5 +74,13 @@     generic-random   type: exitcode-stdio-1.0   default-language: Haskell2010-  if !impl(ghc >= 8.0.2)+  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

@@ -27,7 +27,7 @@ -- - "Generic.Random.Tutorial" -- - http://blog.poisson.chat/posts/2018-01-05-generic-random-tour.html -{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitNamespaces #-}  module Generic.Random   (@@ -122,13 +122,37 @@   , 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 'Gen', providing+    -- more ways to select the fields the generator than by simply comparing types:+    --+    -- - @'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.   , (:+) (..)-#if __GLASGOW_HASKELL__ >= 800   , FieldGen (..)   , fieldGen   , ConstrGen (..)   , constrGen-#endif   , Gen1 (..)   , Gen1_ (..) @@ -145,8 +169,15 @@   , Options ()   , genericArbitraryWith +    -- ** Setters+  , SetOptions+  , type (<+)+  , setOpts+     -- ** Size modifiers   , Sizing (..)+  , SetSized+  , SetUnsized   , setSized   , setUnsized @@ -154,6 +185,10 @@   , SetGens   , setGenerators +    -- ** Coherence options+  , Coherence (..)+  , Incoherent (..)+     -- ** Common options   , SizedOpts   , sizedOpts@@ -161,6 +196,13 @@   , sizedOptsDef   , UnsizedOpts   , unsizedOpts++    -- *** Advanced options+    -- | See 'Coherence'+  , CohUnsizedOpts+  , cohUnsizedOpts+  , CohSizedOpts+  , cohSizedOpts      -- * Generic classes   , GArbitrary

@@ -1,7 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-}  {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-}@@ -13,9 +12,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif  -- | Base case discovery. --@@ -30,12 +26,7 @@ module Generic.Random.Internal.BaseCase where  import Control.Applicative-#if __GLASGOW_HASKELL__ >= 800 import Data.Proxy-#endif-#if __GLASGOW_HASKELL__ < 710-import Data.Word-#endif import GHC.Generics import GHC.TypeLits import Test.QuickCheck@@ -298,7 +289,6 @@ instance (y ~ 'Just 0) => GBCS U1 z y e where   gbcs _ _ = pure U1 -#if __GLASGOW_HASKELL__ >= 800 instance {-# INCOHERENT #-}   ( TypeError       (     'Text "Unrecognized Rep: "@@ -312,7 +302,6 @@   , Alternative (IfM y Weighted Proxy)   ) => GBCS f z y e where   gbcs = error "Type error"-#endif  class GBaseCaseSearch a z y e where   gBaseCaseSearch :: prox y -> proxy '(z, e) -> IfM y Gen Proxy a@@ -323,18 +312,3 @@     (\(Weighted (Just (g, n))) -> choose (0, n-1) >>= fmap to . g)     (\Proxy -> Proxy)     (gbcs y z)--#if __GLASGOW_HASKELL__ < 800-data Proxy a = Proxy--instance Functor Proxy where-  fmap _ _ = Proxy--instance Applicative Proxy where-  pure _ = Proxy-  _ <*> _ = Proxy--instance Alternative Proxy where-  empty = Proxy-  _ <|> _ = Proxy-#endif

@@ -1,6 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE CPP #-}+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}@@ -12,12 +12,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE IncoherentInstances #-}-#endif  -- | Core implementation. --@@ -31,27 +28,18 @@  module Generic.Random.Internal.Generic where -#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif import Control.Applicative (Alternative(..), liftA2)-import Data.Coerce (coerce)-#if __GLASGOW_HASKELL__ >= 800+import Data.Coerce (Coercible, coerce) import Data.Kind (Type)-#endif+ import Data.Proxy (Proxy(..))-#if __GLASGOW_HASKELL__ >= 800+import Data.Type.Bool (type (&&))+import Data.Type.Equality (type (==))+ import GHC.Generics hiding (S, prec)-#else-import GHC.Generics hiding (S, Arity, prec)-#endif import GHC.TypeLits (KnownNat, Nat, Symbol, type (+), natVal) import Test.QuickCheck (Arbitrary(..), Gen, choose, scale, sized, vectorOf) -#if __GLASGOW_HASKELL__ < 800-#define Type *-#endif- -- * Random generators  -- | Pick a constructor with a given distribution, and fill its fields@@ -107,7 +95,8 @@ -- -- > genericArbitraryG customGens (17 % 19 % ()) ----- where, for example to override generators for 'String' and 'Int' fields,+-- where, the generators for 'String' and 'Int' fields are overridden as+-- follows, for example: -- -- @ -- customGens :: Gen String ':+' Gen Int@@ -118,9 +107,7 @@ -- -- === Note on multiple matches ----- If the list contains multiple matching types for a field @x@ of type @a@--- (i.e., either @Gen a@ or @'FieldGen' "x" a@), the generator for the first--- match will be picked.+-- Multiple generators may match a given field: the first will be chosen. genericArbitraryG   :: (GArbitrary (SetGens genList UnsizedOpts) a)   => genList@@ -169,11 +156,7 @@ type family Weights_ (f :: Type -> Type) :: Type where   Weights_ (f :+: g) = Weights_ f :| Weights_ g   Weights_ (M1 D _c f) = Weights_ f-#if __GLASGOW_HASKELL__ >= 800   Weights_ (M1 C ('MetaCons c _i _j) _f) = L c-#else-  Weights_ (M1 C _c _f) = L ""-#endif  data a :| b = N a Int b data L (c :: Symbol) = L@@ -201,9 +184,6 @@ -- @ -- ((9 :: 'W' \"Leaf\") '%' (8 :: 'W' \"Node\") '%' ()) -- @------ Note: these annotations are only checked on GHC 8.0 or newer. They are--- ignored on older GHCs. newtype W (c :: Symbol) = W Int deriving Num  -- | A smart constructor to specify a custom distribution.@@ -230,20 +210,10 @@   Prec' (Weights a) = Prec (Weights_ (Rep a)) ()   Prec' (a, Int, r) = Prec a r --- | A synonym for @(~)@, except on GHC 7.10 and older, where it's the trivial--- constraint. See note on 'W'.-#if __GLASGOW_HASKELL__ >= 800-class (a ~ b) => a ~. b-instance (a ~ b) => a ~. b-#else-class a ~. b-instance a ~. b-#endif- class WeightBuilder' w where    -- | A binary constructor for building up trees of weights.-  (%) :: (c ~. First' w) => W c -> Prec' w -> w+  (%) :: (c ~ First' w) => W c -> Prec' w -> w  instance WeightBuilder (Weights_ (Rep a)) => WeightBuilder' (Weights a) where   w % prec = weights (w %. prec)@@ -254,7 +224,7 @@ class WeightBuilder a where   type Prec a r -  (%.) :: (c ~. First a) => W c -> Prec a r -> (a, Int, r)+  (%.) :: (c ~ First a) => W c -> Prec a r -> (a, Int, r)  infixr 1 % @@ -298,10 +268,52 @@   -- | Type-level options for 'GArbitrary'.-newtype Options (s :: Sizing) (genList :: Type) = Options+--+-- Note: it is recommended to avoid referring to the 'Options' type+-- explicitly in code, as the set of options may change in the future.+-- Instead, use the provided synonyms ('UnsizedOpts', 'SizedOpts', 'SizedOptsDef')+-- and the setter 'SetOptions' (abbreviated as @('<+')@).+newtype Options (c :: Coherence) (s :: Sizing) (genList :: Type) = Options   { _generators :: genList   } +-- | Setter for 'Options'.+--+-- This subsumes the other setters: 'SetSized', 'SetUnsized', 'SetGens'.+--+-- @since 1.4.0.0+type family SetOptions (x :: k) (o :: Type) :: Type+type instance SetOptions (s :: Sizing) (Options c _s g) = Options c s g+type instance SetOptions (c :: Coherence) (Options _c s g) = Options c s g+type instance SetOptions (g :: Type) (Options c s _g) = Options c s g++-- | Infix flipped synonym for 'Options'.+--+-- @since 1.4.0.0+type (<+) o x = SetOptions x o+infixl 1 <++++type UnsizedOpts = Options 'INCOHERENT 'Unsized ()+type SizedOpts = Options 'INCOHERENT 'Sized ()+type SizedOptsDef = Options 'INCOHERENT 'Sized (Gen1 [] :+ ())++-- | Like 'UnsizedOpts', but using coherent instances by default.+--+-- @since 1.4.0.0+type CohUnsizedOpts = Options 'COHERENT 'Unsized ()++-- | Like 'SizedOpts', but using coherent instances by default.+--+-- @since 1.4.0.0+type CohSizedOpts = Options 'COHERENT 'Sized ()++-- | Coerce an 'Options' value between types with the same representation.+--+-- @since 1.4.0.0+setOpts :: forall x o. (Coercible o (SetOptions x o)) => o -> SetOptions x o+setOpts = coerce+ -- | Default options for unsized generators. unsizedOpts :: UnsizedOpts unsizedOpts = Options ()@@ -314,23 +326,90 @@ sizedOptsDef :: SizedOptsDef sizedOptsDef = Options (Gen1 listOf' :+ ()) +-- | Like 'unsizedOpts', but using coherent instances by default.+cohUnsizedOpts :: CohUnsizedOpts+cohUnsizedOpts = Options () --- | Whether to decrease the size parameter before generating fields.-data Sizing = Sized | Unsized+-- | Like 'sizedOpts' but using coherent instances by default.+cohSizedOpts :: CohSizedOpts+cohSizedOpts = Options () -type UnsizedOpts = Options 'Unsized ()-type SizedOpts = Options 'Sized ()-type SizedOptsDef = Options 'Sized (Gen1 [] :+ ()) +-- | 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 s _g) = s+type instance SizingOf (Options _c s _g) = s -setSized :: Options s g -> Options 'Sized g+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 s g -> Options 'Unsized g+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 'INCOHERENT' option is set.+newtype Incoherent g = Incoherent g++ -- | Heterogeneous list of generators. data a :+ b = a :+ b @@ -338,25 +417,32 @@   type family GeneratorsOf opts :: Type-type instance GeneratorsOf (Options _s g) = g+type instance GeneratorsOf (Options _c _s g) = g  class HasGenerators opts where   generators :: opts -> GeneratorsOf opts -instance HasGenerators (Options s g) where+instance HasGenerators (Options c s g) where   generators = _generators -setGenerators :: genList -> Options s g0 -> Options s genList+-- | 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 s _g) = Options s g+type instance SetGens g (Options c s _g) = Options c s g -#if __GLASGOW_HASKELL__ >= 800+ -- | Custom generator for record fields named @s@. ----- /Available only for @base >= 4.9@ (@GHC >= 8.0.1@)./+-- 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.@@ -364,20 +450,20 @@ fieldGen _ = FieldGen  -- | Custom generator for the @i@-th field of the constructor named @c@.------ /Available only for @base >= 4.9@ (@GHC >= 8.0.1@)./+-- 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-#endif  -- | 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@.+-- 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\",@@ -387,6 +473,7 @@ -- 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]@@ -496,12 +583,14 @@  instance   ( HasGenerators opts-  , ArbitraryOr gs () gs '(c, i, Name d) a-  , gs ~ GeneratorsOf 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) (arbitraryOr sel gs () gs)+  gaProduct' _ opts = fmap (M1 . K1) (findGen (is, s, gs) () gs)     where-      sel = Proxy :: Proxy '(c, i, Name d)+      is = Proxy :: Proxy 'Shift+      s = Proxy :: Proxy ('S gs coh '(c, i, Name d))       gs = generators opts   {-# INLINE gaProduct' #-} @@ -517,8 +606,8 @@   Arity (f :*: g) = Arity f + Arity g   Arity (M1 _i _c _f) = 1 --- | Given a list of custom generators @gs@, find one that applies, or use--- @Arbitrary a@ by default.+-- | 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: --@@ -528,72 +617,148 @@ -- >          (), g :+ gs | g, gs -- >          (),      g  | g, () when g is not (_ :+ _) -- >      g :+ h,      gs | g, h :+ gs--- >       Gen a,      gs | END if matching, else (), 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 ArbitraryOr (fullGenList :: Type) (g :: Type) (gs :: Type)-        (sel :: (Maybe Symbol, Nat, Maybe Symbol)) a where-  arbitraryOr :: proxy sel -> fullGenList -> g -> gs -> Gen a+class FindGen (i :: AInstr) (s :: AStore) (g :: Type) (gs :: Type) (a :: Type) where+  findGen :: (Proxy i, Proxy s, FullGenListOf s) -> g -> gs -> Gen a +data AInstr = Shift | Match Coherence | MatchCoh Bool+data AStore = S Type Coherence ASel++type ASel = (Maybe Symbol, Nat, Maybe Symbol)++iShift :: Proxy 'Shift+iShift = Proxy++type family FullGenListOf (s :: AStore) :: Type where+  FullGenListOf ('S fg _coh _sel) = fg++type family ACoherenceOf (s :: AStore) :: Coherence where+  ACoherenceOf ('S _fg coh _sel) = coh++type family ASelOf (s :: AStore) :: ASel where+  ASelOf ('S _fg _coh sel) = sel+ -- | All candidates have been exhausted-instance Arbitrary a => ArbitraryOr fg () () sel a where-  arbitraryOr _ _ _ _ = arbitrary-  {-# INLINE arbitraryOr #-}+instance Arbitrary a => FindGen 'Shift s () () a where+  findGen _ _ _ = arbitrary+  {-# INLINEABLE findGen #-}  -- | Examine the next candidate-instance ArbitraryOr fg b g sel a => ArbitraryOr fg () (b :+ g) sel a where-  arbitraryOr sel fg () (b :+ gens) = arbitraryOr sel fg b gens-  {-# INLINE arbitraryOr #-}+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 #-} ArbitraryOr fg g () sel a => ArbitraryOr fg () g sel a where-  arbitraryOr sel fg () g = arbitraryOr sel fg g ()+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 ArbitraryOr fg g (h :+ gs) sel a => ArbitraryOr fg (g :+ h) gs sel a where-  arbitraryOr sel fg (g :+ h) gs = arbitraryOr sel fg g (h :+ gs)+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 {-# OVERLAPPABLE #-} ArbitraryOr fg () gs sel a => ArbitraryOr fg g gs sel a where-  arbitraryOr sel fg _ = arbitraryOr sel fg ()+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 #-} ArbitraryOr fg (Gen a) g sel a where-  arbitraryOr _ _ gen _ = gen-  {-# INLINE arbitraryOr #-}+instance {-# INCOHERENT #-} FindGen ('Match 'INCOHERENT) s (Gen a) gs a where+  findGen _ gen _ = gen+  {-# INLINEABLE findGen #-} -#if __GLASGOW_HASKELL__ >= 800+-- | 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') => ArbitraryOr fg (FieldGen s a) g '(con, i, 'Just s) a' where-  arbitraryOr _ _ (FieldGen gen) _ = gen-  {-# INLINE arbitraryOr #-}+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') => ArbitraryOr fg (ConstrGen c i a) g '( 'Just c, i, s) a' where-  arbitraryOr _ _ (ConstrGen gen) _ = gen-  {-# INLINE arbitraryOr #-}+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-#else-type Name d = (Nothing :: Maybe Symbol)-#endif --- | Matching custom generator for non-container @f@-instance {-# INCOHERENT #-} ArbitraryOr fg (Gen1_ f) g sel (f a) where-  arbitraryOr _ _ (Gen1_ gen) _ = gen+-- COHERENT --- | Matching custom generator for container @f@. Start the search for containee @a@,--- discarding field information.-instance {-# INCOHERENT #-} ArbitraryOr fg () fg '( 'Nothing, 0, 'Nothing) a-  => ArbitraryOr fg (Gen1 f) g sel (f a) where-  arbitraryOr _ fg (Gen1 gen) _ = gen (arbitraryOr noSel fg () fg)-    where noSel = Proxy :: Proxy '( 'Nothing, 0, 'Nothing)+-- 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

@@ -40,7 +40,7 @@ -- -- 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 proportional to its weight;+-- 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@@ -49,7 +49,7 @@ -- -- == Uniform distribution ----- You can specify the uniform distribution (all weights equal) with 'uniform'.+-- You can specify the uniform distribution (all weights equal to 1) with 'uniform'. -- ('genericArbitraryU' is available as a shorthand for -- @'genericArbitrary' 'uniform'@.) --@@ -58,22 +58,19 @@ -- -- == Typed weights ----- /GHC 8.0.1 and above only (base ≥ 4.9)./ For compatibility, the annotations--- are still allowed on older GHC versions, but ignored.--- -- 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.+-- This will type-check: -- -- @ -- ((x :: 'W' \"Leaf\") '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) -- ( x              '%' (y :: 'W' \"Node\") '%' ()) :: 'Weights' (Tree a) -- @ ----- This will not.+-- This will not: -- -- @ -- ((x :: 'W' \"Node\") '%' y '%' ()) :: 'Weights' (Tree a)@@ -88,8 +85,8 @@ -- 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,--- to be used together with 'withBaseCase'.+-- 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@: --@@ -155,7 +152,7 @@ -- where the depth of a constructor is defined as @1 + max(0, depths of fields)@, -- e.g., @Leaf ()@ has depth 2. ----- == Note about lists+-- == 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@@ -283,10 +280,7 @@ -- Suggestions to add more modifiers or otherwise improve this tutorial are welcome! -- <https://github.com/Lysxia/generic-random/issues The issue tracker is this way.> -{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-unused-imports #-}-#endif  module Generic.Random.Tutorial () where 

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -dsuppress-all #-} {-# LANGUAGE     DeriveGeneric,     TemplateHaskell

@@ -1,5 +1,4 @@ {-# LANGUAGE-    CPP,     DataKinds,     DeriveGeneric,     FlexibleContexts,@@ -17,6 +16,21 @@  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@@ -24,6 +38,8 @@  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@@ -40,24 +56,21 @@     Just _ -> return ()     Nothing -> fail $ name ++ ": did not finish on time" -#if __GLASGOW_HASKELL__ >= 800 -- 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))+  arbitrary = genericArbitraryUG (ConstrGen (Leaf2 <$> arbitrary) :: ConstrGen "Node2" 1 Tree2)  isLeftBiased :: Tree2 -> Bool isLeftBiased (Leaf2 _) = True isLeftBiased (Node2 t (Leaf2 _)) = isLeftBiased t isLeftBiased _ = False-#endif  main :: IO () main = do+  eval "B" (arbitrary :: Gen B)   eval "T" (arbitrary :: Gen (T (T Int)))   eval "NTree" (arbitrary :: Gen NTree)-#if __GLASGOW_HASKELL__ >= 800   quickCheck . whenFail (putStrLn "Tree2") $ isLeftBiased-#endif

@@ -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 ()))+  ]