Script 'mail_helper' called by obssrc
Hello community,
here is the log from the commit of package ghc-generic-deriving for
openSUSE:Factory checked in at 2022-10-13 15:42:02
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-generic-deriving (Old)
and /work/SRC/openSUSE:Factory/.ghc-generic-deriving.new.2275 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-generic-deriving"
Thu Oct 13 15:42:02 2022 rev:21 rq:1008466 version:1.14.2
Changes:
--------
---
/work/SRC/openSUSE:Factory/ghc-generic-deriving/ghc-generic-deriving.changes
2021-09-10 23:41:23.242564242 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-generic-deriving.new.2275/ghc-generic-deriving.changes
2022-10-13 15:42:07.670735891 +0200
@@ -1,0 +2,10 @@
+Sat Jul 23 18:16:44 UTC 2022 - Peter Simons <[email protected]>
+
+- Update generic-deriving to version 1.14.2.
+ # 1.14.2 [2022.07.23]
+ * Fix a bug in which `deriveAll1` could generate ill kinded code when using
+ `kindSigOptions=False`, or when using GHC 8.0 or earlier.
+ * Fix a bug in which `deriveAll1` would reject data types whose last type
+ variable has a kind besides `Type` or `k` on GHC 8.2 or later.
+
+-------------------------------------------------------------------
Old:
----
generic-deriving-1.14.1.tar.gz
New:
----
generic-deriving-1.14.2.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-generic-deriving.spec ++++++
--- /var/tmp/diff_new_pack.U2LObk/_old 2022-10-13 15:42:08.166736860 +0200
+++ /var/tmp/diff_new_pack.U2LObk/_new 2022-10-13 15:42:08.170736867 +0200
@@ -1,7 +1,7 @@
#
# spec file for package ghc-generic-deriving
#
-# Copyright (c) 2021 SUSE LLC
+# Copyright (c) 2022 SUSE LLC
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -19,7 +19,7 @@
%global pkg_name generic-deriving
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 1.14.1
+Version: 1.14.2
Release: 0
Summary: Generic programming library for generalised deriving
License: BSD-3-Clause
++++++ generic-deriving-1.14.1.tar.gz -> generic-deriving-1.14.2.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-deriving-1.14.1/CHANGELOG.md
new/generic-deriving-1.14.2/CHANGELOG.md
--- old/generic-deriving-1.14.1/CHANGELOG.md 2001-09-09 03:46:40.000000000
+0200
+++ new/generic-deriving-1.14.2/CHANGELOG.md 2001-09-09 03:46:40.000000000
+0200
@@ -1,3 +1,9 @@
+# 1.14.2 [2022.07.23]
+* Fix a bug in which `deriveAll1` could generate ill kinded code when using
+ `kindSigOptions=False`, or when using GHC 8.0 or earlier.
+* Fix a bug in which `deriveAll1` would reject data types whose last type
+ variable has a kind besides `Type` or `k` on GHC 8.2 or later.
+
# 1.14.1 [2021.08.30]
* Backport the `Generic(1)` instances introduced for tuples (8 through 15) in
`base-4.16`.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-deriving-1.14.1/generic-deriving.cabal
new/generic-deriving-1.14.2/generic-deriving.cabal
--- old/generic-deriving-1.14.1/generic-deriving.cabal 2001-09-09
03:46:40.000000000 +0200
+++ new/generic-deriving-1.14.2/generic-deriving.cabal 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,5 @@
name: generic-deriving
-version: 1.14.1
+version: 1.14.2
synopsis: Generic programming library for generalised deriving.
description:
@@ -81,8 +81,8 @@
, GHC == 8.6.5
, GHC == 8.8.4
, GHC == 8.10.7
- , GHC == 9.0.1
- , GHC == 9.2.*
+ , GHC == 9.0.2
+ , GHC == 9.2.2
extra-source-files: CHANGELOG.md
, README.md
@@ -129,7 +129,7 @@
build-depends: containers >= 0.1 && < 0.7
, ghc-prim < 1
- , template-haskell >= 2.4 && < 2.19
+ , template-haskell >= 2.4 && < 2.20
, th-abstraction >= 0.4 && < 0.5
default-language: Haskell2010
@@ -142,11 +142,13 @@
EmptyCaseSpec
ExampleSpec
T68Spec
+ T80Spec
+ T82Spec
TypeInTypeSpec
build-depends: base >= 4.3 && < 5
, generic-deriving
, hspec >= 2 && < 3
- , template-haskell >= 2.4 && < 2.19
+ , template-haskell >= 2.4 && < 2.20
build-tool-depends: hspec-discover:hspec-discover
hs-source-dirs: tests
default-language: Haskell2010
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/generic-deriving-1.14.1/src/Generics/Deriving/Base/Internal.hs
new/generic-deriving-1.14.2/src/Generics/Deriving/Base/Internal.hs
--- old/generic-deriving-1.14.1/src/Generics/Deriving/Base/Internal.hs
2001-09-09 03:46:40.000000000 +0200
+++ new/generic-deriving-1.14.2/src/Generics/Deriving/Base/Internal.hs
2001-09-09 03:46:40.000000000 +0200
@@ -995,7 +995,7 @@
prec Prefix = 10
prec (Infix _ n) = n
--- | Datatype to represent the associativy of a constructor
+-- | Datatype to represent the associativity of a constructor
data Associativity = LeftAssociative
| RightAssociative
| NotAssociative
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/generic-deriving-1.14.1/src/Generics/Deriving/TH/Internal.hs
new/generic-deriving-1.14.2/src/Generics/Deriving/TH/Internal.hs
--- old/generic-deriving-1.14.1/src/Generics/Deriving/TH/Internal.hs
2001-09-09 03:46:40.000000000 +0200
+++ new/generic-deriving-1.14.2/src/Generics/Deriving/TH/Internal.hs
2001-09-09 03:46:40.000000000 +0200
@@ -60,10 +60,15 @@
-- StarKindStatus
-------------------------------------------------------------------------------
--- | Whether a type is not of kind *, is of kind *, or is a kind variable.
-data StarKindStatus = NotKindStar
- | KindStar
+-- | Whether a type is of kind @*@, a kind variable, or some other kind. The
+-- kind variable case is given special treatment solely to support GHC 8.0 and
+-- earlier, in which Generic1 was not poly-kinded. In order to support deriving
+-- Generic1 instances on these versions of GHC, we must substitute such kinds
+-- with @*@ to ensure that the resulting instance is well kinded.
+-- See @Note [Generic1 is polykinded in base-4.10]@ in "Generics.Deriving.TH".
+data StarKindStatus = KindStar
| IsKindVar Name
+ | OtherKind
deriving Eq
-- | Does a Type have kind * or k (for some kind variable k)?
@@ -74,7 +79,7 @@
#if MIN_VERSION_template_haskell(2,8,0)
SigT _ (VarT k) -> IsKindVar k
#endif
- _ -> NotKindStar
+ _ -> OtherKind
-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it
exists.
-- Otherwise, returns 'Nothing'.
@@ -145,52 +150,61 @@
makeFunKind argKinds resKind = foldr' ArrowK resKind argKinds
#endif
--- | Detect if a Name occurs as an argument to some type family. This makes an
--- effort to exclude /oversaturated/ arguments to type families. For instance,
--- if one declared the following type family:
---
--- @
--- type family F a :: Type -> Type
--- @
---
--- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,
--- but not @b@.
-isInTypeFamilyApp :: Name -> Type -> [Type] -> Q Bool
-isInTypeFamilyApp name tyFun tyArgs =
- case tyFun of
- ConT tcName -> go tcName
- _ -> return False
+-- | Remove any outer `SigT` and `ParensT` constructors, and turn
+-- an outermost `InfixT` constructor into plain applications.
+dustOff :: Type -> Type
+dustOff (SigT ty _) = dustOff ty
+#if MIN_VERSION_template_haskell(2,11,0)
+dustOff (ParensT ty) = dustOff ty
+dustOff (InfixT ty1 n ty2) = ConT n `AppT` ty1 `AppT` ty2
+#endif
+dustOff ty = ty
+
+-- | Checks whether a type is an unsaturated type family
+-- application.
+isUnsaturatedType :: Type -> Q Bool
+isUnsaturatedType = go 0 . dustOff
where
- go :: Name -> Q Bool
- go tcName = do
+ -- Expects its argument to be dusted
+ go :: Int -> Type -> Q Bool
+ go d t = case t of
+ ConT tcName -> check d tcName
+ AppT f _ -> go (d + 1) (dustOff f)
+ _ -> return False
+
+ check :: Int -> Name -> Q Bool
+ check d tcName = do
+ mbinders <- getTypeFamilyBinders tcName
+ return $ case mbinders of
+ Just bndrs -> length bndrs > d
+ Nothing -> False
+
+-- | Given a name, check if that name is a type family. If
+-- so, return a list of its binders.
+getTypeFamilyBinders :: Name -> Q (Maybe [TyVarBndr_ ()])
+getTypeFamilyBinders tcName = do
info <- reify tcName
- case info of
+ return $ case info of
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _
- -> withinFirstArgs bndrs
+ -> Just bndrs
#elif MIN_VERSION_template_haskell(2,7,0)
FamilyI (FamilyD TypeFam _ bndrs _) _
- -> withinFirstArgs bndrs
+ -> Just bndrs
#else
TyConI (FamilyD TypeFam _ bndrs _)
- -> withinFirstArgs bndrs
+ -> Just bndrs
#endif
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _
- -> withinFirstArgs bndrs
+ -> Just bndrs
#elif MIN_VERSION_template_haskell(2,9,0)
FamilyI (ClosedTypeFamilyD _ bndrs _ _) _
- -> withinFirstArgs bndrs
+ -> Just bndrs
#endif
- _ -> return False
- where
- withinFirstArgs :: [a] -> Q Bool
- withinFirstArgs bndrs =
- let firstArgs = take (length bndrs) tyArgs
- argFVs = freeVariables firstArgs
- in return $ name `elem` argFVs
+ _ -> Nothing
-- | True if the type does not mention the Name
ground :: Type -> Name -> Bool
@@ -204,29 +218,6 @@
applyTyToTvbs :: Name -> [TyVarBndr_ flag] -> Type
applyTyToTvbs = List.foldl' (\a -> AppT a . tyVarBndrToType) . ConT
--- | Split an applied type into its individual components. For example, this:
---
--- @
--- Either Int Char
--- @
---
--- would split to this:
---
--- @
--- [Either, Int, Char]
--- @
-unapplyTy :: Type -> (Type, [Type])
-unapplyTy ty = go ty ty []
- where
- go :: Type -> Type -> [Type] -> (Type, [Type])
- go _ (AppT ty1 ty2) args = go ty1 ty1 (ty2:args)
- go origTy (SigT ty' _) args = go origTy ty' args
-#if MIN_VERSION_template_haskell(2,11,0)
- go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT`
ty2) args
- go origTy (ParensT ty') args = go origTy ty' args
-#endif
- go origTy _ args = (origTy, args)
-
-- | Split a type signature by the arrows on its spine. For example, this:
--
-- @
@@ -385,22 +376,40 @@
-- | Indicates whether Generic or Generic1 is being derived.
data GenericClass = Generic | Generic1 deriving Enum
--- | Like 'GenericArity', but bundling two things in the 'Gen1' case:
---
--- 1. The 'Name' of the last type parameter.
--- 2. If that last type parameter had kind k (where k is some kind variable),
--- then it has 'Just' the kind variable 'Name'. Otherwise, it has 'Nothing'.
-data GenericKind = Gen0
- | Gen1 Name (Maybe Name)
-
--- Determines the universally quantified type variables (possibly after
--- substituting * in the case of Generic1) and the last type parameter name
--- (if there is one).
-genericKind :: GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)
-genericKind gClass tySynVars =
+-- | Records information about the type variables of a data type with a
+-- 'Generic' or 'Generic1' instance.
+data GenericTvbs
+ -- | Information about a data type with a 'Generic' instance.
+ = Gen0
+ { gen0Tvbs :: [TyVarBndrUnit]
+ -- ^ All of the type variable arguments to the data type.
+ }
+ -- | Information about a data type with a 'Generic1' instance.
+ | Gen1
+ { gen1InitTvbs :: [TyVarBndrUnit]
+ -- ^ All of the type variable arguments to the data type except the
+ -- last one. In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the
+ -- 'gen1InitTvbs' would be @[a_1, ..., a_(n-1)]@.
+ , gen1LastTvbName :: Name
+ -- ^ The name of the last type variable argument to the data type.
+ -- In a @'Generic1' (T a_1 ... a_(n-1))@ instance, the
+ -- 'gen1LastTvbName' name would be @a_n@.
+ , gen1LastTvbKindVar :: Maybe Name
+ -- ^ If the 'gen1LastTvbName' has kind @k@, where @k@ is some kind
+ -- variable, then the 'gen1LastTvbKindVar' is @'Just' k@. Otherwise,
+ -- the 'gen1LastTvbKindVar' is 'Nothing'.
+ }
+
+-- | Compute 'GenericTvbs' from a 'GenericClass' and the type variable
+-- arguments to a data type.
+mkGenericTvbs :: GenericClass -> [Type] -> GenericTvbs
+mkGenericTvbs gClass tySynVars =
case gClass of
- Generic -> (freeVariablesWellScoped tySynVars, Gen0)
- Generic1 -> (freeVariablesWellScoped initArgs, Gen1 (varTToName lastArg)
mbLastArgKindName)
+ Generic -> Gen0{gen0Tvbs = freeVariablesWellScoped tySynVars}
+ Generic1 -> Gen1{ gen1InitTvbs = freeVariablesWellScoped initArgs
+ , gen1LastTvbName = varTToName lastArg
+ , gen1LastTvbKindVar = mbLastArgKindName
+ }
where
-- Everything below is only used for Generic1.
initArgs :: [Type]
@@ -413,6 +422,14 @@
mbLastArgKindName = starKindStatusToName
$ canRealizeKindStar lastArg
+-- | Return the type variable arguments to a data type that appear in a
+-- 'Generic' or 'Generic1' instance. For a 'Generic' instance, this consists of
+-- all the type variable arguments. For a 'Generic1' instance, this consists of
+-- all the type variable arguments except for the last one.
+genericInitTvbs :: GenericTvbs -> [TyVarBndrUnit]
+genericInitTvbs (Gen0{gen0Tvbs = tvbs}) = tvbs
+genericInitTvbs (Gen1{gen1InitTvbs = tvbs}) = tvbs
+
-- | A version of 'DatatypeVariant' in which the data family instance
-- constructors come equipped with the 'ConstructorInfo' of the first
-- constructor in the family instance (for 'Name' generation purposes).
@@ -469,7 +486,12 @@
( showString (nameBase tyConName)
. showString " ..."
)
- . showString "???\n\tClass Generic1 expects an argument of kind * -> *"
+ . showString "???\n\tClass Generic1 expects an argument of kind "
+#if MIN_VERSION_base(4,10,0)
+ . showString "k -> *"
+#else
+ . showString "* -> *"
+#endif
$ ""
-- | The data type mentions the last type variable in a place other
@@ -480,10 +502,18 @@
. showString " the last argument of a data type"
$ ""
+-- | The data type mentions the last type variable in a type family
+-- application.
+typeFamilyApplicationError :: Q a
+typeFamilyApplicationError = fail
+ . showString "Constructor must not apply its last type variable"
+ . showString " to an unsaturated type family"
+ $ ""
+
-- | Cannot have a constructor argument of form (forall a1 ... an. <type>)
-- when deriving Generic(1)
-rankNError :: a
-rankNError = error "Cannot have polymorphic arguments"
+rankNError :: Q a
+rankNError = fail "Cannot have polymorphic arguments"
-- | Boilerplate for top level splices.
--
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-deriving-1.14.1/src/Generics/Deriving/TH.hs
new/generic-deriving-1.14.2/src/Generics/Deriving/TH.hs
--- old/generic-deriving-1.14.1/src/Generics/Deriving/TH.hs 2001-09-09
03:46:40.000000000 +0200
+++ new/generic-deriving-1.14.2/src/Generics/Deriving/TH.hs 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,6 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
{- |
Module : Generics.Deriving.TH
@@ -118,57 +119,52 @@
{- $options
'Options' gives you a way to further tweak derived 'Generic' and 'Generic1'
instances:
-* 'RepOptions': By default, all derived 'Rep' and 'Rep1' type instances emit
the code
- directly (the 'InlineRep' option). One can also choose to emit a separate
type
- synonym for the 'Rep' type (this is the functionality of 'deriveRep0' and
- 'deriveRep1') and define a 'Rep' instance in terms of that type synonym (the
- 'TypeSynonymRep' option).
-
-* 'KindSigOptions': By default, all derived instances will use explicit kind
- signatures (when the 'KindSigOptions' is 'True'). You might wish to set the
- 'KindSigOptions' to 'False' if you want a 'Generic'/'Generic1' instance at
- a particular kind that GHC will infer correctly, but the functions in this
- module won't guess correctly. For example, the following example will only
- compile with 'KindSigOptions' set to 'False':
-
- @
- newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a))
- $('deriveAll1Options' False ''Compose)
- @
-
-* 'EmptyCaseOptions': By default, all derived instances for empty data types
- (i.e., data types with no constructors) use 'error' in @from(1)@/@to(1)@.
- For instance, @data Empty@ would have this derived 'Generic' instance:
-
- @
- instance Generic Empty where
- type Rep Empty = D1 ('MetaData ...) V1
- from _ = M1 (error "No generic representation for empty datatype Empty")
- to (M1 _) = error "No generic representation for empty datatype Empty"
- @
-
- This matches the behavior of GHC up until 8.4, when derived @Generic(1)@
- instances began to use the @EmptyCase@ extension. In GHC 8.4, the derived
- 'Generic' instance for @Empty@ would instead be:
-
- @
- instance Generic Empty where
- type Rep Empty = D1 ('MetaData ...) V1
- from x = M1 (case x of {})
- to (M1 x) = case x of {}
- @
-
- This is a slightly better encoding since, for example, any divergent
- computations passed to 'from' will actually diverge (as opposed to before,
- where the result would always be a call to 'error'). On the other hand, using
- this encoding in @generic-deriving@ has one large drawback: it requires
- enabling @EmptyCase@, an extension which was only introduced in GHC 7.8
- (and only received reliable pattern-match coverage checking in 8.2).
-
- The 'EmptyCaseOptions' field controls whether code should be emitted that
- uses @EmptyCase@ (i.e., 'EmptyCaseOptions' set to 'True') or not ('False').
- The default value is 'False'. Note that even if set to 'True', this option
- has no effect on GHCs before 7.8, as @EmptyCase@ did not exist then.
+* 'RepOptions': By default, all derived 'Rep' and 'Rep1' type instances emit
the code
+ directly (the 'InlineRep' option). One can also choose to emit a separate
type
+ synonym for the 'Rep' type (this is the functionality of 'deriveRep0' and
+ 'deriveRep1') and define a 'Rep' instance in terms of that type synonym
(the
+ 'TypeSynonymRep' option).
+
+* 'EmptyCaseOptions': By default, all derived instances for empty data types
+ (i.e., data types with no constructors) use 'error' in @from(1)@/@to(1)@.
+ For instance, @data Empty@ would have this derived 'Generic' instance:
+
+ @
+ instance Generic Empty where
+ type Rep Empty = D1 ('MetaData ...) V1
+ from _ = M1 (error "No generic representation for empty datatype Empty")
+ to (M1 _) = error "No generic representation for empty datatype Empty"
+ @
+
+ This matches the behavior of GHC up until 8.4, when derived @Generic(1)@
+ instances began to use the @EmptyCase@ extension. In GHC 8.4, the derived
+ 'Generic' instance for @Empty@ would instead be:
+
+ @
+ instance Generic Empty where
+ type Rep Empty = D1 ('MetaData ...) V1
+ from x = M1 (case x of {})
+ to (M1 x) = case x of {}
+ @
+
+ This is a slightly better encoding since, for example, any divergent
+ computations passed to 'from' will actually diverge (as opposed to before,
+ where the result would always be a call to 'error'). On the other hand,
using
+ this encoding in @generic-deriving@ has one large drawback: it requires
+ enabling @EmptyCase@, an extension which was only introduced in GHC 7.8
+ (and only received reliable pattern-match coverage checking in 8.2).
+
+ The 'EmptyCaseOptions' field controls whether code should be emitted that
+ uses @EmptyCase@ (i.e., 'EmptyCaseOptions' set to 'True') or not ('False').
+ The default value is 'False'. Note that even if set to 'True', this option
+ has no effect on GHCs before 7.8, as @EmptyCase@ did not exist then.
+
+* 'KindSigOptions': By default, all derived instances will use explicit kind
+ signatures (when the 'KindSigOptions' is 'True'). You might wish to set the
+ 'KindSigOptions' to 'False' if you want a 'Generic'/'Generic1' instance at
+ a particular kind that GHC will infer correctly, but the functions in this
+ module won't guess correctly. You probably won't ever need this option
+ unless you are a power user.
-}
-- | Additional options for configuring derived 'Generic'/'Generic1' instances
@@ -308,17 +304,18 @@
deriveRepCommon gClass useKindSigs n = do
i <- reifyDataInfo n
let (name, instTys, cons, dv) = either error id i
+ gt = mkGenericTvbs gClass instTys
-- See Note [Forcing buildTypeInstance]
!_ <- buildTypeInstance gClass useKindSigs name instTys
-- See Note [Kind signatures in derived instances]
- let (tySynVars, gk) = genericKind gClass instTys
+ let tySynVars = genericInitTvbs gt
tySynVars' = if useKindSigs
then tySynVars
else map unKindedTV tySynVars
fmap (:[]) $ tySynD (genRepName gClass dv name)
tySynVars'
- (repType gk dv name Map.empty cons)
+ (repType gt dv name Map.empty cons)
deriveInst :: GenericClass -> Options -> Name -> Q [Dec]
deriveInst Generic = deriveInstCommon genericTypeName repTypeName Generic
fromValName toValName
@@ -335,20 +332,24 @@
deriveInstCommon genericName repName gClass fromName toName opts n = do
i <- reifyDataInfo n
let (name, instTys, cons, dv) = either error id i
+ gt = mkGenericTvbs gClass instTys
useKindSigs = kindSigOptions opts
-- See Note [Forcing buildTypeInstance]
!(origTy, origKind) <- buildTypeInstance gClass useKindSigs name instTys
tyInsRHS <- if repOptions opts == InlineRep
- then makeRepInline gClass dv name instTys cons origTy
- else makeRepTySynApp gClass dv name origTy
+ then repType gt dv name Map.empty cons
+ else makeRepTySynApp gClass dv name origTy
let origSigTy = if useKindSigs
then SigT origTy origKind
else origTy
tyIns <- tySynInstDCompat repName Nothing [return origSigTy] (return
tyInsRHS)
let ecOptions = emptyCaseOptions opts
- mkBody maker = [clause [] (normalB $
- mkCaseExp gClass ecOptions name instTys cons maker) []]
+ mkBody maker = [clause []
+ (normalB $
+ mkCaseExp $
+ maker gt ecOptions name cons)
+ []]
fcs = mkBody mkFrom
tcs = mkBody mkTo
@@ -548,32 +549,32 @@
makeRepCommon gClass repOpts n mbQTy = do
i <- reifyDataInfo n
let (name, instTys, cons, dv) = either error id i
+ gt = mkGenericTvbs gClass instTys
-- See Note [Forcing buildTypeInstance]
!_ <- buildTypeInstance gClass False name instTys
case (mbQTy, repOpts) of
(Just qTy, TypeSynonymRep) -> qTy >>= makeRepTySynApp gClass dv name
- (Just qTy, InlineRep) -> qTy >>= makeRepInline gClass dv name
instTys cons
+ (Just qTy, InlineRep) -> qTy >>= makeRepInline gt dv name cons
(Nothing, TypeSynonymRep) -> conT $ genRepName gClass dv name
(Nothing, InlineRep) -> fail "makeRepCommon"
-makeRepInline :: GenericClass
+makeRepInline :: GenericTvbs
-> DatatypeVariant_
-> Name
- -> [Type]
-> [ConstructorInfo]
-> Type
-> Q Type
-makeRepInline gClass dv name instTys cons ty = do
+makeRepInline gt dv name cons ty = do
let instVars = freeVariablesWellScoped [ty]
- (tySynVars, gk) = genericKind gClass instTys
+ tySynVars = genericInitTvbs gt
typeSubst :: TypeSubst
typeSubst = Map.fromList $
zip (map tvName tySynVars)
(map (VarT . tvName) instVars)
- repType gk dv name typeSubst cons
+ repType gt dv name typeSubst cons
makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name
-> Type -> Q Type
@@ -626,15 +627,15 @@
makeTo1Options = makeFunCommon mkTo Generic1
makeFunCommon
- :: (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
- -> [ConstructorInfo] -> Q Match)
+ :: (GenericTvbs -> EmptyCaseOptions -> Name -> [ConstructorInfo] -> Q Match)
-> GenericClass -> EmptyCaseOptions -> Name -> Q Exp
makeFunCommon maker gClass ecOptions n = do
i <- reifyDataInfo n
let (name, instTys, cons, _) = either error id i
+ gt = mkGenericTvbs gClass instTys
-- See Note [Forcing buildTypeInstance]
buildTypeInstance gClass False name instTys
- `seq` mkCaseExp gClass ecOptions name instTys cons maker
+ `seq` mkCaseExp (maker gt ecOptions name cons)
genRepName :: GenericClass -> DatatypeVariant_
-> Name -> Name
@@ -646,26 +647,26 @@
. sanitizeName
$ nameBase n
-repType :: GenericKind
+repType :: GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> [ConstructorInfo]
-> Q Type
-repType gk dv dt typeSubst cs =
+repType gt dv dt typeSubst cs =
conT d1TypeName `appT` mkMetaDataType dv dt `appT`
- foldBal sum' (conT v1TypeName) (map (repCon gk dv dt typeSubst) cs)
+ foldBal sum' (conT v1TypeName) (map (repCon gt dv dt typeSubst) cs)
where
sum' :: Q Type -> Q Type -> Q Type
sum' a b = conT sumTypeName `appT` a `appT` b
-repCon :: GenericKind
+repCon :: GenericTvbs
-> DatatypeVariant_
-> Name
-> TypeSubst
-> ConstructorInfo
-> Q Type
-repCon gk dv dt typeSubst
+repCon gt dv dt typeSubst
(ConstructorInfo { constructorName = n
, constructorVars = vars
, constructorContext = ctxt
@@ -687,9 +688,9 @@
InfixConstructor -> True
RecordConstructor _ -> False
ssis <- reifySelStrictInfo n bangs
- repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix
+ repConWith gt dv dt n typeSubst mbSelNames ssis ts isRecord isInfix
-repConWith :: GenericKind
+repConWith :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
@@ -700,15 +701,15 @@
-> Bool
-> Bool
-> Q Type
-repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do
+repConWith gt dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do
let structureType :: Q Type
structureType = foldBal prodT (conT u1TypeName) f
f :: [Q Type]
f = case mbSelNames of
- Just selNames -> zipWith3 (repField gk dv dt n typeSubst .
Just)
+ Just selNames -> zipWith3 (repField gt dv dt n typeSubst .
Just)
selNames ssis ts
- Nothing -> zipWith (repField gk dv dt n typeSubst
Nothing)
+ Nothing -> zipWith (repField gt dv dt n typeSubst
Nothing)
ssis ts
conT c1TypeName
@@ -718,7 +719,7 @@
prodT :: Q Type -> Q Type -> Q Type
prodT a b = conT productTypeName `appT` a `appT` b
-repField :: GenericKind
+repField :: GenericTvbs
-> DatatypeVariant_
-> Name
-> Name
@@ -727,15 +728,15 @@
-> SelStrictInfo
-> Type
-> Q Type
-repField gk dv dt ns typeSubst mbF ssi t =
+repField gt dv dt ns typeSubst mbF ssi t =
conT s1TypeName
`appT` mkMetaSelType dv dt ns mbF ssi
- `appT` (repFieldArg gk =<< resolveTypeSynonyms t'')
+ `appT` (repFieldArg gt =<< resolveTypeSynonyms t'')
where
-- See Note [Generic1 is polykinded in base-4.10]
t', t'' :: Type
- t' = case gk of
- Gen1 _ (Just _kvName) ->
+ t' = case gt of
+ Gen1{gen1LastTvbKindVar = Just _kvName} ->
#if MIN_VERSION_base(4,10,0)
t
#else
@@ -744,53 +745,55 @@
_ -> t
t'' = applySubstitution typeSubst t'
-repFieldArg :: GenericKind -> Type -> Q Type
-repFieldArg _ ForallT{} = rankNError
-repFieldArg gk (SigT t _) = repFieldArg gk t
-repFieldArg Gen0 t = boxT t
-repFieldArg (Gen1 name _) (VarT t) | t == name = conT par1TypeName
-repFieldArg gk@(Gen1 name _) t = do
- let (tyHead, tyArgs) = unapplyTy t
- numLastArgs = min 1 $ length tyArgs
- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs
- rec0Type = boxT t
- phiType = return $ applyTyToTys tyHead lhsArgs
-
- inspectTy :: Type -> Q Type
- inspectTy (VarT a)
- | a == name
- = conT rec1TypeName `appT` phiType
- inspectTy (SigT ty _) = inspectTy ty
- inspectTy beta
- | not (ground beta name)
- = conT composeTypeName `appT` phiType
- `appT` repFieldArg gk beta
- inspectTy _ = rec0Type
-
- itf <- isInTypeFamilyApp name tyHead tyArgs
- if any (not . (`ground` name)) lhsArgs || itf
- then outOfPlaceTyVarError
- else case rhsArgs of
- [] -> rec0Type
- ty:_ -> inspectTy ty
+repFieldArg :: GenericTvbs -> Type -> Q Type
+repFieldArg Gen0{} t = boxT t
+repFieldArg (Gen1{gen1LastTvbName = name}) (dustOff -> t0) =
+ go t0 >>= \res -> case res of
+ NoPar -> boxT t0
+ ArgRes _ r -> return r
+ where
+ -- | Returns NoPar if the parameter doesn't appear.
+ -- Expects its argument to have been dusted.
+ go :: Type -> Q (ArgRes Type)
+ go ForallT{} = rankNError
+#if MIN_VERSION_template_haskell(2,16,0)
+ go ForallVisT{} = rankNError
+#endif
+ go (VarT t) | t == name = ArgRes True `fmap` conT par1TypeName
+ go (AppT f x) = do
+ when (not (f `ground` name)) outOfPlaceTyVarError
+ mxr <- go (dustOff x)
+ case mxr of
+ NoPar -> return NoPar
+ ArgRes arg_is_param xr -> do
+ itf <- isUnsaturatedType f
+ when itf typeFamilyApplicationError
+ ArgRes False `fmap`
+ if arg_is_param
+ then
+ conT rec1TypeName `appT` return f
+ else
+ conT composeTypeName `appT` return f `appT` return xr
+ go _ = return NoPar
+
+-- | The result of checking the argument. This NoPar
+-- means the parameter wasn't there. The Bool is True
+-- if the argument *is* the parameter, and False otherwise.
+data ArgRes a = NoPar | ArgRes !Bool a
boxT :: Type -> Q Type
boxT ty = case unboxedRepNames ty of
Just (boxTyName, _, _) -> conT boxTyName
Nothing -> conT rec0TypeName `appT` return ty
-mkCaseExp
- :: GenericClass -> EmptyCaseOptions -> Name -> [Type] -> [ConstructorInfo]
- -> (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
- -> [ConstructorInfo] -> Q Match)
- -> Q Exp
-mkCaseExp gClass ecOptions dt instTys cs matchmaker = do
+mkCaseExp :: Q Match -> Q Exp
+mkCaseExp qMatch = do
val <- newName "val"
- lam1E (varP val) $ caseE (varE val) [matchmaker gClass ecOptions 1 1 dt
instTys cs]
+ lam1E (varP val) $ caseE (varE val) [qMatch]
-mkFrom :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
+mkFrom :: GenericTvbs -> EmptyCaseOptions -> Name
-> [ConstructorInfo] -> Q Match
-mkFrom gClass ecOptions m i dt instTys cs = do
+mkFrom gt ecOptions dt cs = do
y <- newName "y"
match (varP y)
(normalB $ conE m1DataName `appE` caseE (varE y) cases)
@@ -798,9 +801,7 @@
where
cases = case cs of
[] -> errorFrom ecOptions dt
- _ -> zipWith (fromCon gk wrapE (length cs)) [1..] cs
- wrapE e = lrE i m e
- (_, gk) = genericKind gClass instTys
+ _ -> zipWith (fromCon gt id (length cs)) [1..] cs
errorFrom :: EmptyCaseOptions -> Name -> [Q Match]
errorFrom useEmptyCase dt
@@ -817,9 +818,9 @@
++ nameBase dt))
[]]
-mkTo :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
+mkTo :: GenericTvbs -> EmptyCaseOptions -> Name
-> [ConstructorInfo] -> Q Match
-mkTo gClass ecOptions m i dt instTys cs = do
+mkTo gt ecOptions dt cs = do
y <- newName "y"
match (conP m1DataName [varP y])
(normalB $ caseE (varE y) cases)
@@ -827,9 +828,7 @@
where
cases = case cs of
[] -> errorTo ecOptions dt
- _ -> zipWith (toCon gk wrapP (length cs)) [1..] cs
- wrapP p = lrP i m p
- (_, gk) = genericKind gClass instTys
+ _ -> zipWith (toCon gt id (length cs)) [1..] cs
errorTo :: EmptyCaseOptions -> Name -> [Q Match]
errorTo useEmptyCase dt
@@ -852,9 +851,9 @@
ghc7'8OrLater = False
#endif
-fromCon :: GenericKind -> (Q Exp -> Q Exp) -> Int -> Int
+fromCon :: GenericTvbs -> (Q Exp -> Q Exp) -> Int -> Int
-> ConstructorInfo -> Q Match
-fromCon gk wrap m i
+fromCon gt wrap m i
(ConstructorInfo { constructorName = cn
, constructorVars = vars
, constructorContext = ctxt
@@ -864,52 +863,56 @@
fNames <- newNameList "f" $ length ts
match (conP cn (map varP fNames))
(normalB $ wrap $ lrE i m $ conE m1DataName `appE`
- foldBal prodE (conE u1DataName) (zipWith (fromField gk) fNames ts))
[]
+ foldBal prodE (conE u1DataName) (zipWith (fromField gt) fNames ts))
[]
prodE :: Q Exp -> Q Exp -> Q Exp
prodE x y = conE productDataName `appE` x `appE` y
-fromField :: GenericKind -> Name -> Type -> Q Exp
-fromField gk nr t = conE m1DataName `appE` (fromFieldWrap gk nr =<<
resolveTypeSynonyms t)
+fromField :: GenericTvbs -> Name -> Type -> Q Exp
+fromField gt nr t = conE m1DataName `appE` (fromFieldWrap gt nr =<<
resolveTypeSynonyms t)
-fromFieldWrap :: GenericKind -> Name -> Type -> Q Exp
-fromFieldWrap _ _ ForallT{} = rankNError
-fromFieldWrap gk nr (SigT t _) = fromFieldWrap gk nr t
-fromFieldWrap Gen0 nr t = conE (boxRepName t) `appE` varE nr
-fromFieldWrap (Gen1 name _) nr t = wC t name `appE` varE nr
+fromFieldWrap :: GenericTvbs -> Name -> Type -> Q Exp
+fromFieldWrap _ _ ForallT{} = rankNError
+fromFieldWrap gt nr (SigT t _) = fromFieldWrap gt
nr t
+fromFieldWrap Gen0{} nr t = conE (boxRepName
t) `appE` varE nr
+fromFieldWrap (Gen1{gen1LastTvbName = name}) nr t = wC t name
`appE` varE nr
wC :: Type -> Name -> Q Exp
-wC (VarT t) name | t == name = conE par1DataName
-wC t name
- | ground t name = conE $ boxRepName t
- | otherwise = do
- let (tyHead, tyArgs) = unapplyTy t
- numLastArgs = min 1 $ length tyArgs
- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs
-
- inspectTy :: Type -> Q Exp
- inspectTy ForallT{} = rankNError
- inspectTy (SigT ty _) = inspectTy ty
- inspectTy (VarT a)
- | a == name
- = conE rec1DataName
- inspectTy beta = infixApp (conE comp1DataName)
- (varE composeValName)
- (varE fmapValName `appE` wC beta name)
-
- itf <- isInTypeFamilyApp name tyHead tyArgs
- if any (not . (`ground` name)) lhsArgs || itf
- then outOfPlaceTyVarError
- else case rhsArgs of
- [] -> conE $ boxRepName t
- ty:_ -> inspectTy ty
+wC (dustOff -> t0) name =
+ go t0 >>= \res -> case res of
+ NoPar -> conE $ boxRepName t0
+ ArgRes _ r -> return r
+ where
+ -- | Returns NoPar if the parameter doesn't appear.
+ -- Expects its argument to have been dusted.
+ go :: Type -> Q (ArgRes Exp)
+ go ForallT{} = rankNError
+#if MIN_VERSION_template_haskell(2,16,0)
+ go ForallVisT{} = rankNError
+#endif
+ go (VarT t) | t == name = ArgRes True `fmap` conE par1DataName
+ go (AppT f x) = do
+ when (not (f `ground` name)) outOfPlaceTyVarError
+ mxr <- go (dustOff x)
+ case mxr of
+ NoPar -> return NoPar
+ ArgRes arg_is_param xr -> do
+ itf <- isUnsaturatedType f
+ when itf typeFamilyApplicationError
+ ArgRes False `fmap`
+ if arg_is_param
+ then
+ conE rec1DataName
+ else
+ infixApp (conE comp1DataName) (varE composeValName) (varE
fmapValName `appE` return xr)
+ go _ = return NoPar
boxRepName :: Type -> Name
boxRepName = maybe k1DataName snd3 . unboxedRepNames
-toCon :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int
+toCon :: GenericTvbs -> (Q Pat -> Q Pat) -> Int -> Int
-> ConstructorInfo -> Q Match
-toCon gk wrap m i
+toCon gt wrap m i
(ConstructorInfo { constructorName = cn
, constructorVars = vars
, constructorContext = ctxt
@@ -918,49 +921,54 @@
checkExistentialContext cn vars ctxt
fNames <- newNameList "f" $ length ts
match (wrap $ lrP i m $ conP m1DataName
- [foldBal prod (conP u1DataName []) (zipWith (toField gk) fNames ts)])
+ [foldBal prod (conP u1DataName []) (zipWith (toField gt) fNames ts)])
(normalB $ foldl appE (conE cn)
- (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gk
nr)
+ (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gt
nr)
fNames ts)) []
where prod x y = conP productDataName [x,y]
-toConUnwC :: GenericKind -> Name -> Type -> Q Exp
-toConUnwC Gen0 nr _ = varE nr
-toConUnwC (Gen1 name _) nr t = unwC t name `appE` varE nr
+toConUnwC :: GenericTvbs -> Name -> Type -> Q Exp
+toConUnwC Gen0{} nr _ = varE nr
+toConUnwC (Gen1{gen1LastTvbName = name}) nr t = unwC t name `appE` varE nr
-toField :: GenericKind -> Name -> Type -> Q Pat
-toField gk nr t = conP m1DataName [toFieldWrap gk nr t]
+toField :: GenericTvbs -> Name -> Type -> Q Pat
+toField gt nr t = conP m1DataName [toFieldWrap gt nr t]
-toFieldWrap :: GenericKind -> Name -> Type -> Q Pat
-toFieldWrap Gen0 nr t = conP (boxRepName t) [varP nr]
+toFieldWrap :: GenericTvbs -> Name -> Type -> Q Pat
+toFieldWrap Gen0{} nr t = conP (boxRepName t) [varP nr]
toFieldWrap Gen1{} nr _ = varP nr
unwC :: Type -> Name -> Q Exp
-unwC (SigT t _) name = unwC t name
-unwC (VarT t) name | t == name = varE unPar1ValName
-unwC t name
- | ground t name = varE $ unboxRepName t
- | otherwise = do
- let (tyHead, tyArgs) = unapplyTy t
- numLastArgs = min 1 $ length tyArgs
- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs
-
- inspectTy :: Type -> Q Exp
- inspectTy ForallT{} = rankNError
- inspectTy (SigT ty _) = inspectTy ty
- inspectTy (VarT a)
- | a == name
- = varE unRec1ValName
- inspectTy beta = infixApp (varE fmapValName `appE` unwC beta name)
- (varE composeValName)
- (varE unComp1ValName)
-
- itf <- isInTypeFamilyApp name tyHead tyArgs
- if any (not . (`ground` name)) lhsArgs || itf
- then outOfPlaceTyVarError
- else case rhsArgs of
- [] -> varE $ unboxRepName t
- ty:_ -> inspectTy ty
+unwC (dustOff -> t0) name =
+ go t0 >>= \res -> case res of
+ NoPar -> varE $ unboxRepName t0
+ ArgRes _ r -> return r
+ where
+ -- | Returns NoPar if the parameter doesn't appear.
+ -- Expects its argument to have been dusted.
+ go :: Type -> Q (ArgRes Exp)
+ go ForallT{} = rankNError
+#if MIN_VERSION_template_haskell(2,16,0)
+ go ForallVisT{} = rankNError
+#endif
+ go (VarT t) | t == name = ArgRes True `fmap` varE unPar1ValName
+ go (AppT f x) = do
+ when (not (f `ground` name)) outOfPlaceTyVarError
+ mxr <- go (dustOff x)
+ case mxr of
+ NoPar -> return NoPar
+ ArgRes arg_is_param xr -> do
+ itf <- isUnsaturatedType f
+ when itf typeFamilyApplicationError
+ ArgRes False `fmap`
+ if arg_is_param
+ then
+ varE unRec1ValName
+ else
+ infixApp (varE fmapValName `appE` return xr)
+ (varE composeValName)
+ (varE unComp1ValName)
+ go _ = return NoPar
unboxRepName :: Type -> Name
unboxRepName = maybe unK1ValName trd3 . unboxedRepNames
@@ -1015,15 +1023,27 @@
let remainingLength :: Int
remainingLength = length varTysOrig - fromEnum gClass
+#if !(MIN_VERSION_base(4,10,0))
droppedTysExp :: [Type]
droppedTysExp = drop remainingLength varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = map canRealizeKindStar droppedTysExp
+#endif
- -- Check there are enough types to drop and that all of them are either of
- -- kind * or kind k (for some kind variable k). If not, throw an error.
- when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $
+ -- Check that:
+ --
+ -- 1. There are enough types to drop
+ --
+ -- 2. If using GHC 8.0 or earlier, all types are either of kind * or kind k
+ -- (for some kind variable k). See Note [Generic1 is polykinded in
base-4.10].
+ --
+ -- If either of these checks fail, throw an error.
+ when (remainingLength < 0
+#if !(MIN_VERSION_base(4,10,0))
+ || any (== OtherKind) droppedStarKindStati
+#endif
+ ) $
derivingKindError tyConName
-- Substitute kind * for any dropped kind variables
@@ -1128,52 +1148,32 @@
If we dropped the kind signature for a in a derived instance for Fam a, then
GHC
would have no way of knowing which instance we are talking about.
-Another motivation for explicit kind signatures is the -XTypeInType extension.
-With -XTypeInType, dropping kind signatures can completely change the meaning
-of some data types. For example, there is a substantial difference between
these
-two data types:
-
- data T k (a :: k) = T k
- data T k a = T k
-
-In addition to using explicit kind signatures on type variables, we also put
-explicit return kinds in the instance head, so generated instances will look
-something like this:
+In addition to using explicit kind signatures in the instance head, we also put
+explicit kinds in the associated Rep(1) instance. For example, this data type:
data S (a :: k) = S k
+
+Will have the following Generic1 instance generated for it:
+
instance Generic1 (S :: k -> *) where
type Rep1 (S :: k -> *) = ... (Rec0 k)
-Why do we do this? Imagine what the instance would be without the explicit
return kind:
+Why do we do this? Imagine what the instance would be without the explicit kind
+annotation in the Rep1 instance:
instance Generic1 S where
type Rep1 S = ... (Rec0 k)
This is an error, since the variable k is now out-of-scope!
-Although explicit kind signatures are the right thing to do in most cases,
there
-are sadly some degenerate cases where this isn't true. Consider this example:
-
- newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a))
-
-The Rep1 type instance in a Generic1 instance for Compose would involve the
type
-(f :.: Rec1 g), which forces (f :: * -> *). But this library doesn't have very
-sophisticated kind inference machinery (other than what is mentioned in
-Note [Generic1 is polykinded in base-4.10]), so at the moment we
-have no way of actually unifying k1 with *. So the na??ve generated Generic1
-instance would be:
-
- instance Generic1 (Compose (f :: k2 -> *) (g :: k1 -> k2)) where
- type Rep1 (Compose f g) = ... (f :.: Rec1 g)
-
-This is wrong, since f's kind is overly generalized. To get around this issue,
-there are variants of the TH functions that allow you to configure the
KindSigOptions.
-If KindSigOptions is set to False, then generated instances will not include
-explicit kind signatures, leaving it up to GHC's kind inference machinery to
-figure out the correct kinds.
+In the rare event that attaching explicit kind annotations does the wrong
+thing, there are variants of the TH functions that allow configuring the
+KindSigOptions. If KindSigOptions is set to False, then generated instances
+will not include explicit kind signatures, leaving it up to GHC's kind
+inference machinery to figure out the correct kinds.
Note [Generic1 is polykinded in base-4.10]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Prior to base-4.10, Generic1 :: (* -> *) -> Constraint. This means that if a
Generic1
instance is defined for a polykinded data type like so:
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-deriving-1.14.1/tests/T80Spec.hs
new/generic-deriving-1.14.2/tests/T80Spec.hs
--- old/generic-deriving-1.14.1/tests/T80Spec.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/generic-deriving-1.14.2/tests/T80Spec.hs 2001-09-09
03:46:40.000000000 +0200
@@ -0,0 +1,22 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+#if __GLASGOW_HASKELL__ >= 706
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+#endif
+
+module T80Spec (main, spec) where
+
+import Generics.Deriving.TH
+import Test.Hspec
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = return ()
+
+newtype T f a b = MkT (f a b)
+$(deriveAll1 ''T)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-deriving-1.14.1/tests/T82Spec.hs
new/generic-deriving-1.14.2/tests/T82Spec.hs
--- old/generic-deriving-1.14.1/tests/T82Spec.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/generic-deriving-1.14.2/tests/T82Spec.hs 2001-09-09
03:46:40.000000000 +0200
@@ -0,0 +1,25 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+
+#if __GLASGOW_HASKELL__ >= 800
+{-# LANGUAGE TypeInType #-}
+#endif
+
+module T82Spec (main, spec) where
+
+import Test.Hspec
+
+#if MIN_VERSION_base(4,10,0)
+import Generics.Deriving.TH
+import GHC.Exts (RuntimeRep, TYPE)
+
+data Code m (a :: TYPE (r :: RuntimeRep)) = Code
+$(deriveAll0And1 ''Code)
+#endif
+
+main :: IO ()
+main = hspec spec
+
+spec :: Spec
+spec = return ()
