Script 'mail_helper' called by obssrc
Hello community,
here is the log from the commit of package ghc-generic-random for
openSUSE:Factory checked in at 2021-06-01 10:39:06
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-generic-random (Old)
and /work/SRC/openSUSE:Factory/.ghc-generic-random.new.1898 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-generic-random"
Tue Jun 1 10:39:06 2021 rev:2 rq:896214 version:1.4.0.0
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-generic-random/ghc-generic-random.changes
2021-05-05 20:40:34.410767055 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-generic-random.new.1898/ghc-generic-random.changes
2021-06-01 10:40:44.225147626 +0200
@@ -1,0 +2,10 @@
+Mon May 17 09:47:47 UTC 2021 - psim...@suse.com
+
+- Update generic-random to version 1.4.0.0.
+ # 1.4.0.0
+
+ - Add option to use only coherent instances
+ - Export `SetSized` and `SetUnsized`
+ - Drop compatibility with GHC 7
+
+-------------------------------------------------------------------
Old:
----
generic-random-1.3.0.1.tar.gz
New:
----
generic-random-1.4.0.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-generic-random.spec ++++++
--- /var/tmp/diff_new_pack.i5UagY/_old 2021-06-01 10:40:44.649148347 +0200
+++ /var/tmp/diff_new_pack.i5UagY/_new 2021-06-01 10:40:44.649148347 +0200
@@ -19,7 +19,7 @@
%global pkg_name generic-random
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 1.3.0.1
+Version: 1.4.0.0
Release: 0
Summary: Generic random generators for QuickCheck
License: MIT
@@ -31,7 +31,6 @@
ExcludeArch: %{ix86}
%if %{with tests}
BuildRequires: ghc-deepseq-devel
-BuildRequires: ghc-inspection-testing-devel
%endif
%description
++++++ generic-random-1.3.0.1.tar.gz -> generic-random-1.4.0.0.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-random-1.3.0.1/CHANGELOG.md
new/generic-random-1.4.0.0/CHANGELOG.md
--- old/generic-random-1.3.0.1/CHANGELOG.md 2020-03-22 00:08:58.000000000
+0100
+++ new/generic-random-1.4.0.0/CHANGELOG.md 2001-09-09 03:46:40.000000000
+0200
@@ -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.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-random-1.3.0.1/generic-random.cabal
new/generic-random-1.4.0.0/generic-random.cabal
--- old/generic-random-1.3.0.1/generic-random.cabal 2020-03-24
03:48:16.000000000 +0100
+++ new/generic-random-1.4.0.0/generic-random.cabal 2001-09-09
03:46:40.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/generic-random-1.3.0.1/src/Generic/Random/Internal/BaseCase.hs
new/generic-random-1.4.0.0/src/Generic/Random/Internal/BaseCase.hs
--- old/generic-random-1.3.0.1/src/Generic/Random/Internal/BaseCase.hs
2019-09-07 23:58:08.000000000 +0200
+++ new/generic-random-1.4.0.0/src/Generic/Random/Internal/BaseCase.hs
2001-09-09 03:46:40.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/generic-random-1.3.0.1/src/Generic/Random/Internal/Generic.hs
new/generic-random-1.4.0.0/src/Generic/Random/Internal/Generic.hs
--- old/generic-random-1.3.0.1/src/Generic/Random/Internal/Generic.hs
2019-09-08 02:11:25.000000000 +0200
+++ new/generic-random-1.4.0.0/src/Generic/Random/Internal/Generic.hs
2001-09-09 03:46:40.000000000 +0200
@@ -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 ()
+
+-- | Like 'sizedOpts' but using coherent instances by default.
+cohSizedOpts :: CohSizedOpts
+cohSizedOpts = Options ()
--- | Whether to decrease the size parameter before generating fields.
-data Sizing = Sized | Unsized
-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
+
+type family SetSized (o :: Type) :: Type
+type instance SetSized (Options c s g) = Options c 'Sized g
-setSized :: Options s g -> Options '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 #-}
+
+-- | 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)
-#if __GLASGOW_HASKELL__ >= 800
-- | 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
--- | 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)
+-- 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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/generic-random-1.3.0.1/src/Generic/Random/Tutorial.hs
new/generic-random-1.4.0.0/src/Generic/Random/Tutorial.hs
--- old/generic-random-1.3.0.1/src/Generic/Random/Tutorial.hs 2020-03-22
00:11:14.000000000 +0100
+++ new/generic-random-1.4.0.0/src/Generic/Random/Tutorial.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-random-1.3.0.1/src/Generic/Random.hs
new/generic-random-1.4.0.0/src/Generic/Random.hs
--- old/generic-random-1.3.0.1/src/Generic/Random.hs 2019-09-07
22:53:33.000000000 +0200
+++ new/generic-random-1.4.0.0/src/Generic/Random.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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
@@ -162,6 +197,13 @@
, UnsizedOpts
, unsizedOpts
+ -- *** Advanced options
+ -- | See 'Coherence'
+ , CohUnsizedOpts
+ , cohUnsizedOpts
+ , CohSizedOpts
+ , cohSizedOpts
+
-- * Generic classes
, GArbitrary
, GUniformWeight
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-random-1.3.0.1/test/Inspect.hs
new/generic-random-1.4.0.0/test/Inspect.hs
--- old/generic-random-1.3.0.1/test/Inspect.hs 2019-09-17 01:31:03.000000000
+0200
+++ new/generic-random-1.4.0.0/test/Inspect.hs 2001-09-09 03:46:40.000000000
+0200
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -dsuppress-all #-}
{-# LANGUAGE
DeriveGeneric,
TemplateHaskell
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-random-1.3.0.1/test/Unit.hs
new/generic-random-1.4.0.0/test/Unit.hs
--- old/generic-random-1.3.0.1/test/Unit.hs 2019-09-06 23:48:40.000000000
+0200
+++ new/generic-random-1.4.0.0/test/Unit.hs 2001-09-09 03:46:40.000000000
+0200
@@ -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
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-random-1.3.0.1/test/coherence.hs
new/generic-random-1.4.0.0/test/coherence.hs
--- old/generic-random-1.3.0.1/test/coherence.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/generic-random-1.4.0.0/test/coherence.hs 2001-09-09
03:46:40.000000000 +0200
@@ -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 ()))
+ ]
