generic-deriving 1.14.1 → 1.14.2
raw patch · 7 files changed
+389/−304 lines, 7 filesdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: template-haskell
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- generic-deriving.cabal +7/−5
- src/Generics/Deriving/Base/Internal.hs +1/−1
- src/Generics/Deriving/TH.hs +224/−224
- src/Generics/Deriving/TH/Internal.hs +104/−74
- tests/T80Spec.hs +22/−0
- tests/T82Spec.hs +25/−0
CHANGELOG.md view
@@ -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`.
generic-deriving.cabal view
@@ -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
src/Generics/Deriving/Base/Internal.hs view
@@ -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
src/Generics/Deriving/TH.hs view
@@ -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':+* '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). - @- 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: -* '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"+ @ - @- 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: - 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 {}+ @ - @- 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). - 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. - 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+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 - itf <- isInTypeFamilyApp name tyHead tyArgs- if any (not . (`ground` name)) lhsArgs || itf- then outOfPlaceTyVarError- else case rhsArgs of- [] -> rec0Type- ty:_ -> inspectTy ty+-- | 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:+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 T k (a :: k) = T k- data T k a = T k+ data S (a :: k) = S 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:+Will have the following Generic1 instance generated for it: - data S (a :: k) = S k 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:
src/Generics/Deriving/TH/Internal.hs view
@@ -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)+-- | 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'.+ } --- 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 =+-- | 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. --
+ tests/T80Spec.hs view
@@ -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)
+ tests/T82Spec.hs view
@@ -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 ()