[Git][ghc/ghc][wip/instd-quantifications] TH: handle explicit quantification in instances
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Fri Jan 27 17:25:14 UTC 2023
sheaf pushed to branch wip/instd-quantifications at Glasgow Haskell Compiler / GHC
Commits:
876c1918 by sheaf at 2023-01-27T18:25:08+01:00
TH: handle explicit quantification in instances
This patch adds support for explicitly-written quantification in
typeclass instances, such as:
instance forall {k} (a :: k). C a
deriving instance forall {k} (a :: k). D a
It does so by adding a field of type `Maybe (TyVarBndr Specificity)`
to both the `InstanceD` and `StandaloneDerivD` constructors of the
Template Haskell `Dec` datatype, and making appropriate use of it to
ensure that spliced declarations don't silently drop the user-written
quantification.
Fixes #21794
- - - - -
16 changed files:
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Var.hs
- docs/users_guide/9.8.1-notes.rst
- libraries/template-haskell/Language/Haskell/TH/Lib.hs
- libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- + testsuite/tests/th/T21794.hs
- + testsuite/tests/th/T21794.stderr
- testsuite/tests/th/all.T
Changes:
=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -70,8 +70,8 @@ templateHaskellNames = [
bindSName, letSName, noBindSName, parSName, recSName,
-- Dec
funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,
- classDName, instanceWithOverlapDName,
- standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
+ classDName, instanceWithAllDName,
+ standaloneDerivWithAllDName, sigDName, kiSigDName, forImpDName,
pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
@@ -356,9 +356,9 @@ recSName = libFun (fsLit "recS") recSIdKey
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,
- instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
+ instanceWithAllDName, sigDName, kiSigDName, forImpDName, pragInlDName,
pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
- pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
+ pragAnnDName, standaloneDerivWithAllDName, defaultSigDName, defaultDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
@@ -370,8 +370,8 @@ newtypeDName = libFun (fsLit "newtypeD")
typeDataDName = libFun (fsLit "typeDataD") typeDataDIdKey
tySynDName = libFun (fsLit "tySynD") tySynDIdKey
classDName = libFun (fsLit "classD") classDIdKey
-instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey
-standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
+instanceWithAllDName = libFun (fsLit "instanceWithAllD") instanceWithAllIdKey
+standaloneDerivWithAllDName = libFun (fsLit "standaloneDerivWithAllD") standaloneDerivWithAllDIdKey
sigDName = libFun (fsLit "sigD") sigDIdKey
kiSigDName = libFun (fsLit "kiSigD") kiSigDIdKey
defaultDName = libFun (fsLit "defaultD") defaultDIdKey
@@ -884,11 +884,11 @@ recSIdKey = mkPreludeMiscIdUnique 315
-- data Dec = ...
funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
- instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
+ instanceWithAllIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,
pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,
pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,
openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
- newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
+ newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithAllDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey :: Unique
@@ -898,7 +898,7 @@ dataDIdKey = mkPreludeMiscIdUnique 322
newtypeDIdKey = mkPreludeMiscIdUnique 323
tySynDIdKey = mkPreludeMiscIdUnique 324
classDIdKey = mkPreludeMiscIdUnique 325
-instanceWithOverlapDIdKey = mkPreludeMiscIdUnique 326
+instanceWithAllIdKey = mkPreludeMiscIdUnique 326
instanceDIdKey = mkPreludeMiscIdUnique 327
sigDIdKey = mkPreludeMiscIdUnique 328
forImpDIdKey = mkPreludeMiscIdUnique 329
@@ -918,7 +918,7 @@ infixLDIdKey = mkPreludeMiscIdUnique 342
infixRDIdKey = mkPreludeMiscIdUnique 343
infixNDIdKey = mkPreludeMiscIdUnique 344
roleAnnotDIdKey = mkPreludeMiscIdUnique 345
-standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346
+standaloneDerivWithAllDIdKey = mkPreludeMiscIdUnique 346
defaultSigDIdKey = mkPreludeMiscIdUnique 347
patSynDIdKey = mkPreludeMiscIdUnique 348
patSynSigDIdKey = mkPreludeMiscIdUnique 349
=====================================
compiler/GHC/Hs/Type.hs
=====================================
@@ -61,7 +61,8 @@ module GHC.Hs.Type (
mkAnonWildCardTy, pprAnonWildCard,
- hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,
+ hsOuterTyVarNames, hsOuterTyVarBndrs,
+ hsOuterExplicitBndrs, mapHsOuterImplicit,
mkHsOuterImplicit, mkHsOuterExplicit,
mkHsImplicitSigType, mkHsExplicitSigType,
mkHsWildCardBndrs, mkHsPatSigType,
@@ -106,7 +107,7 @@ import GHC.Types.Id ( Id )
import GHC.Types.SourceText
import GHC.Types.Name( Name, NamedThing(getName), tcName, dataName )
import GHC.Types.Name.Reader ( RdrName )
-import GHC.Types.Var ( VarBndr, visArgTypeLike )
+import GHC.Types.Var ( VarBndr(..), visArgTypeLike )
import GHC.Core.TyCo.Rep ( Type(..) )
import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )
import GHC.Core.Ppr ( pprOccWithTick)
@@ -237,6 +238,11 @@ hsOuterTyVarNames :: HsOuterTyVarBndrs flag GhcRn -> [Name]
hsOuterTyVarNames (HsOuterImplicit{hso_ximplicit = imp_tvs}) = imp_tvs
hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs}) = hsLTyVarNames bndrs
+hsOuterTyVarBndrs :: HsOuterTyVarBndrs Specificity GhcRn -> [LHsTyVarBndr Specificity GhcRn]
+hsOuterTyVarBndrs (HsOuterImplicit{hso_ximplicit = imp_tvs})
+ = [ noLocA $ UserTyVar noAnn SpecifiedSpec (noLocA tv) | tv <- imp_tvs ]
+hsOuterTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs
+
hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p)
-> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]
hsOuterExplicitBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs
@@ -765,7 +771,7 @@ splitLHsQualTy_KP body = (Nothing, body)
-- | Decompose a type class instance type (of the form
-- @forall <tvs>. context => instance_head@) into its constituent parts.
--- Note that the @[Name]@s returned correspond to either:
+-- Note that the @HsOuterTyVarBndrs at s returned correspond to either:
--
-- * The implicitly bound type variables (if the type lacks an outermost
-- @forall@), or
@@ -777,9 +783,11 @@ splitLHsQualTy_KP body = (Nothing, body)
-- See @Note [No nested foralls or contexts in instance types]@
-- for why this is important.
splitLHsInstDeclTy :: LHsSigType GhcRn
- -> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)
+ -> ( HsOuterTyVarBndrs Specificity GhcRn
+ , Maybe (LHsContext GhcRn)
+ , LHsType GhcRn)
splitLHsInstDeclTy (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = inst_ty})) =
- (hsOuterTyVarNames outer_bndrs, mb_cxt, body_ty)
+ (outer_bndrs, mb_cxt, body_ty)
where
(mb_cxt, body_ty) = splitLHsQualTy_KP inst_ty
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -643,7 +643,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
, cid_datafam_insts = adts
, cid_overlap_mode = overlap
})
- = addSimpleTyVarBinds FreshNamesOnly tvs $
+ = addHsTyVarBinds FreshNamesOnly tv_bndrs $ \tvs' ->
-- We must bring the type variables into scope, so their
-- occurrences don't fail, even though the binders don't
-- appear in the resulting data structure
@@ -653,7 +653,11 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
-- For example, the method names should be bound to
-- the selector Ids, not to fresh names (#5410)
--
- do { cxt1 <- repLContext cxt
+ do { elt_ty <- wrapName tyVarBndrSpecTyConName
+ ; tvs'' <- return $ case tv_outer of
+ HsOuterImplicit {} -> coreNothing' (mkListTy elt_ty)
+ HsOuterExplicit {} -> coreJust' (mkListTy elt_ty) tvs'
+ ; cxt1 <- repLContext cxt
; inst_ty1 <- repLTy inst_ty
-- See Note [Scoped type variables in quotes]
; (ss, sigs_binds) <- rep_meth_sigs_binds sigs binds
@@ -661,22 +665,28 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
; adts1 <- mapM (repDataFamInstD . unLoc) adts
; decls1 <- coreListM decTyConName (ats1 ++ adts1 ++ sigs_binds)
; rOver <- repOverlap (fmap unLoc overlap)
- ; decls2 <- repInst rOver cxt1 inst_ty1 decls1
+ ; decls2 <- repInst rOver tvs'' cxt1 inst_ty1 decls1
; wrapGenSyms ss decls2 }
where
- (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+ (tv_outer, cxt, inst_ty) = splitLHsInstDeclTy ty
+ tv_bndrs = hsOuterTyVarBndrs tv_outer
repStandaloneDerivD :: LDerivDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))
repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
, deriv_type = ty }))
- = do { dec <- repDerivStrategy strat $ \strat' ->
- addSimpleTyVarBinds FreshNamesOnly tvs $
- do { cxt' <- repLContext cxt
+ = do { dec <- repDerivStrategy strat $ \strat' ->
+ addHsTyVarBinds FreshNamesOnly tv_bndrs $ \tvs' ->
+ do { elt_ty <- wrapName tyVarBndrSpecTyConName
+ ; tvs'' <- return $ case tv_outer of
+ HsOuterImplicit {} -> coreNothing' (mkListTy elt_ty)
+ HsOuterExplicit {} -> coreJust' (mkListTy elt_ty) tvs'
+ ; cxt' <- repLContext cxt
; inst_ty' <- repLTy inst_ty
- ; repDeriv strat' cxt' inst_ty' }
+ ; repDeriv strat' tvs'' cxt' inst_ty' }
; return (locA loc, dec) }
where
- (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
+ (tv_outer, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)
+ tv_bndrs = hsOuterTyVarBndrs tv_outer
repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
@@ -2566,9 +2576,10 @@ repTySyn (MkC nm) (MkC tvs) (MkC rhs)
= rep2 tySynDName [nm, tvs, rhs]
repInst :: Core (Maybe TH.Overlap) ->
+ Core (Maybe [M (TH.TyVarBndr TH.Specificity)]) ->
Core (M TH.Cxt) -> Core (M TH.Type) -> Core [(M TH.Dec)] -> MetaM (Core (M TH.Dec))
-repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName
- [o, cxt, ty, ds]
+repInst (MkC o) (MkC tvs) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithAllDName
+ [o, tvs, cxt, ty, ds]
repDerivStrategy :: Maybe (LDerivStrategy GhcRn)
-> (Core (Maybe (M TH.DerivStrategy)) -> MetaM (Core (M a)))
@@ -2625,10 +2636,12 @@ repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)
= rep2 classDName [cxt, cls, tvs, fds, ds]
repDeriv :: Core (Maybe (M TH.DerivStrategy))
- -> Core (M TH.Cxt) -> Core (M TH.Type)
+ -> Core (Maybe [M (TH.TyVarBndr TH.Specificity)])
+ -> Core (M TH.Cxt)
+ -> Core (M TH.Type)
-> MetaM (Core (M TH.Dec))
-repDeriv (MkC ds) (MkC cxt) (MkC ty)
- = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]
+repDeriv (MkC ds) (MkC tvs) (MkC cxt) (MkC ty)
+ = rep2 standaloneDerivWithAllDName [ds, tvs, cxt, ty]
repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch
-> Core TH.Phases -> MetaM (Core (M TH.Dec))
=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -604,7 +604,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_datafam_insts = adts })
= do { checkInferredVars ctxt inf_err inst_ty
; (inst_ty', inst_fvs) <- rnHsSigType ctxt TypeLevel inst_ty
- ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
+ ; let (ktv_bndrs, _, head_ty') = splitLHsInstDeclTy inst_ty'
+ ktv_names = hsOuterTyVarNames ktv_bndrs
-- Check if there are any nested `forall`s or contexts, which are
-- illegal in the type of an instance declaration (see
-- Note [No nested foralls or contexts in instance types] in
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -2470,14 +2470,17 @@ reifyClassInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded
-- includes only *visible* tvs
-> ClsInst -> TcM TH.Dec
reifyClassInstance is_poly_tvs i
- = do { cxt <- reifyCxt theta
+ = do { th_tvs <- reifyTyVarBndrs [ Bndr tv () | tv <- tvs ]
+ -- Quantified type variables in an instance are always
+ -- invisible and specified.
+ ; cxt <- reifyCxt theta
; let vis_types = filterOutInvisibleTypes cls_tc types
; thtypes <- reifyTypes vis_types
; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes
; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes
- ; return $ (TH.InstanceD over cxt head_ty []) }
+ ; return $ (TH.InstanceD over (Just th_tvs) cxt head_ty []) }
where
- (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
+ (tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)
cls_tc = classTyCon cls
dfun = instanceDFunId i
over = case overlapMode (is_flag i) of
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -308,13 +308,17 @@ cvtDec (ClassD ctxt cl tvs fds decs)
-- no docs in TH ^^
}
-cvtDec (InstanceD o ctxt ty decs)
+cvtDec (InstanceD o tv_bndrs ctxt ty decs)
= do { (binds', sigs', fams', ats', adts') <- cvt_ci_decs InstanceDecl decs
; for_ (nonEmpty fams') $ \ bad_fams ->
failWith (IllegalDeclaration InstanceDecl $ IllegalFamDecls bad_fams)
+ ; tv_bndrs' <- traverse (cvtTvs . map mk_spec) tv_bndrs
; ctxt' <- cvtContext funPrec ctxt
; (L loc ty') <- cvtType ty
- ; let inst_ty' = L loc $ mkHsImplicitSigType $
+ ; let mk_sig_type = case tv_bndrs' of
+ Nothing -> mkHsImplicitSigType
+ Just tvs -> mkHsExplicitSigType noAnn tvs
+ ; let inst_ty' = L loc $ mk_sig_type $
mkHsQualTy ctxt loc ctxt' $ L loc ty'
; returnJustLA $ InstD noExtField $ ClsInstD noExtField $
ClsInstDecl { cid_ext = (noAnn, NoAnnSortKey), cid_poly_ty = inst_ty'
@@ -411,11 +415,15 @@ cvtDec (TH.RoleAnnotD tc roles)
; returnJustLA
$ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') }
-cvtDec (TH.StandaloneDerivD ds cxt ty)
- = do { cxt' <- cvtContext funPrec cxt
+cvtDec (TH.StandaloneDerivD ds tv_bndrs cxt ty)
+ = do { tv_bndrs' <- traverse (cvtTvs . map mk_spec) tv_bndrs
+ ; cxt' <- cvtContext funPrec cxt
; ds' <- traverse cvtDerivStrategy ds
; (L loc ty') <- cvtType ty
- ; let inst_ty' = L loc $ mkHsImplicitSigType $
+ ; let mk_sig_type = case tv_bndrs' of
+ Nothing -> mkHsImplicitSigType
+ Just tvs -> mkHsExplicitSigType noAnn tvs
+ ; let inst_ty' = L loc $ mk_sig_type $
mkHsQualTy cxt loc cxt' $ L loc ty'
; returnJustLA $ DerivD noExtField $
DerivDecl { deriv_ext = noAnn
@@ -1502,6 +1510,9 @@ cvt_tv (TH.KindedTV nm fl ki)
; ki' <- cvtKind ki
; returnLA $ KindedTyVar noAnn fl' nm' ki' }
+mk_spec :: TH.TyVarBndr () -> TH.TyVarBndr TH.Specificity
+mk_spec = fmap $ const TH.SpecifiedSpec
+
cvtRole :: TH.Role -> Maybe Coercion.Role
cvtRole TH.NominalR = Just Coercion.Nominal
cvtRole TH.RepresentationalR = Just Coercion.Representational
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -698,8 +698,8 @@ data VarBndr var argf = Bndr var argf
--
-- A 'TyVarBinder' is a binder with only TyVar
type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag
-type InvisTyBinder = VarBndr TyCoVar Specificity
-type ReqTyBinder = VarBndr TyCoVar ()
+type InvisTyBinder = VarBndr TyCoVar Specificity
+type ReqTyBinder = VarBndr TyCoVar ()
type TyVarBinder = VarBndr TyVar ForAllTyFlag
type InvisTVBinder = VarBndr TyVar Specificity
=====================================
docs/users_guide/9.8.1-notes.rst
=====================================
@@ -26,6 +26,16 @@ Runtime system
``base`` library
~~~~~~~~~~~~~~~~
+``template-haskell`` library
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+- The constructors ``InstanceD`` and ``StandaloneDerivD`` now take one extra
+ argument, of type ``Maybe (TyVarBndr ())``, in order to handle
+ instances with user-written quantification, such as: ::
+
+ instance forall k (a :: k). C a
+ deriving instance forall k (a :: k). D a
+
``ghc-prim`` library
~~~~~~~~~~~~~~~~~~~~
=====================================
libraries/template-haskell/Language/Haskell/TH/Lib.hs
=====================================
@@ -91,7 +91,7 @@ module Language.Haskell.TH.Lib (
stockStrategy, anyclassStrategy, newtypeStrategy,
viaStrategy, DerivStrategy(..),
-- **** Class
- classD, instanceD, instanceWithOverlapD, Overlap(..),
+ classD, instanceD, instanceWithOverlapD, instanceWithAllD, Overlap(..),
sigD, kiSigD, standaloneDerivD, standaloneDerivWithStrategyD, defaultSigD,
-- **** Role annotations
@@ -165,6 +165,7 @@ import Language.Haskell.TH.Lib.Internal hiding
, derivClause
, standaloneDerivWithStrategyD
+ , standaloneDerivWithAllD
, doE
, mdoE
@@ -331,10 +332,20 @@ derivClause mds p = do
return $ DerivClause mds p'
standaloneDerivWithStrategyD :: Quote m => Maybe DerivStrategy -> m Cxt -> m Type -> m Dec
-standaloneDerivWithStrategyD mds ctxt ty = do
+standaloneDerivWithStrategyD mds ctxt ty =
+ standaloneDerivWithAllD mds Nothing ctxt ty
+
+standaloneDerivWithAllD :: Quote m
+ => Maybe DerivStrategy
+ -> Maybe [m (TyVarBndr ())]
+ -> m Cxt
+ -> m Type
+ -> m Dec
+standaloneDerivWithAllD mds mtvs ctxt ty = do
+ mtvs' <- traverse sequenceA mtvs
ctxt' <- ctxt
ty' <- ty
- return $ StandaloneDerivD mds ctxt' ty'
+ return $ StandaloneDerivD mds mtvs' ctxt' ty'
-------------------------------------------------------------------------------
-- * Bytes literals
=====================================
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
=====================================
@@ -462,14 +462,16 @@ instanceD :: Quote m => m Cxt -> m Type -> [m Dec] -> m Dec
instanceD = instanceWithOverlapD Nothing
instanceWithOverlapD :: Quote m => Maybe Overlap -> m Cxt -> m Type -> [m Dec] -> m Dec
-instanceWithOverlapD o ctxt ty decs =
+instanceWithOverlapD o ctxt ty decs = instanceWithAllD o Nothing ctxt ty decs
+
+instanceWithAllD :: Quote m => Maybe Overlap -> Maybe [m (TyVarBndr ())] -> m Cxt -> m Type -> [m Dec] -> m Dec
+instanceWithAllD o ty_bndrs ctxt ty decs =
do
+ ty_bndrs1 <- traverse sequenceA ty_bndrs
ctxt1 <- ctxt
decs1 <- sequenceA decs
ty1 <- ty
- pure $ InstanceD o ctxt1 ty1 decs1
-
-
+ pure $ InstanceD o ty_bndrs1 ctxt1 ty1 decs1
sigD :: Quote m => Name -> m Type -> m Dec
sigD fun ty = liftA (SigD fun) $ ty
@@ -599,12 +601,16 @@ standaloneDerivD :: Quote m => m Cxt -> m Type -> m Dec
standaloneDerivD = standaloneDerivWithStrategyD Nothing
standaloneDerivWithStrategyD :: Quote m => Maybe (m DerivStrategy) -> m Cxt -> m Type -> m Dec
-standaloneDerivWithStrategyD mdsq ctxtq tyq =
+standaloneDerivWithStrategyD mdsq ctxtq tyq = standaloneDerivWithAllD mdsq Nothing ctxtq tyq
+
+standaloneDerivWithAllD :: Quote m => Maybe (m DerivStrategy) -> Maybe [m (TyVarBndr ())] -> m Cxt -> m Type -> m Dec
+standaloneDerivWithAllD mdsq ty_bndrsq ctxtq tyq =
do
- mds <- sequenceA mdsq
- ctxt <- ctxtq
- ty <- tyq
- pure $ StandaloneDerivD mds ctxt ty
+ mds <- sequenceA mdsq
+ ty_bndrs <- traverse sequenceA ty_bndrsq
+ ctxt <- ctxtq
+ ty <- tyq
+ pure $ StandaloneDerivD mds ty_bndrs ctxt ty
defaultSigD :: Quote m => Name -> m Type -> m Dec
defaultSigD n tyq =
@@ -1056,21 +1062,21 @@ withDecDoc doc dec = do
doc_loc (PatSynSigD n _) = Just $ DeclDoc n
-- For instances we just pass along the full type
- doc_loc (InstanceD _ _ t _) = Just $ InstDoc t
+ doc_loc (InstanceD _ _ _ t _) = Just $ InstDoc t
doc_loc (DataInstD _ _ t _ _ _) = Just $ InstDoc t
doc_loc (NewtypeInstD _ _ t _ _ _) = Just $ InstDoc t
doc_loc (TySynInstD (TySynEqn _ t _)) = Just $ InstDoc t
-- Declarations that can't have documentation attached to
-- ValDs that aren't a simple variable pattern
- doc_loc (ValD _ _ _) = Nothing
- doc_loc (KiSigD _ _) = Nothing
- doc_loc (PragmaD _) = Nothing
- doc_loc (RoleAnnotD _ _) = Nothing
- doc_loc (StandaloneDerivD _ _ _) = Nothing
- doc_loc (DefaultSigD _ _) = Nothing
- doc_loc (ImplicitParamBindD _ _) = Nothing
- doc_loc (DefaultD _) = Nothing
+ doc_loc (ValD _ _ _) = Nothing
+ doc_loc (KiSigD _ _) = Nothing
+ doc_loc (PragmaD _) = Nothing
+ doc_loc (RoleAnnotD _ _) = Nothing
+ doc_loc (StandaloneDerivD _ _ _ _) = Nothing
+ doc_loc (DefaultSigD _ _) = Nothing
+ doc_loc (ImplicitParamBindD _ _) = Nothing
+ doc_loc (DefaultD _) = Nothing
-- | Variant of 'withDecDoc' that applies the same documentation to
-- multiple declarations. Useful for documenting quoted declarations.
=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -97,10 +97,9 @@ pprPatSynType :: PatSynType -> Doc
pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))
| null exTys, null provs = ppr (ForallT uniTys reqs ty'')
| null uniTys, null reqs = noreqs <+> ppr ty'
- | null reqs = pprForallBndrs uniTys <+> noreqs <+> ppr ty'
+ | null reqs = ppr_invis_forall_bndrs uniTys <+> noreqs <+> ppr ty'
| otherwise = ppr ty
where noreqs = text "() =>"
- pprForallBndrs tvs = text "forall" <+> hsep (map ppr tvs) <+> text "."
pprPatSynType ty = ppr ty
------------------------------
@@ -404,9 +403,13 @@ ppr_dec _ (TypeDataD t xs ksig cs)
ppr_dec _ (ClassD ctxt c xs fds ds)
= text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
$$ where_clause ds
-ppr_dec _ (InstanceD o ctxt i ds) =
- text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i
- $$ where_clause ds
+ppr_dec _ (InstanceD o tvs ctxt i ds)
+ = text "instance"
+ <+> maybe empty ppr_overlap o
+ <+> maybe empty ppr_invis_forall_bndrs tvs
+ <+> pprCxt ctxt
+ <+> ppr i
+ $$ where_clause ds
ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t
ppr_dec _ (KiSigD f k) = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k
ppr_dec _ (ForeignD f) = ppr f
@@ -452,10 +455,11 @@ ppr_dec _ (ClosedTypeFamilyD tfhead eqns)
= ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs
ppr_dec _ (RoleAnnotD name roles)
= hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
-ppr_dec _ (StandaloneDerivD ds cxt ty)
+ppr_dec _ (StandaloneDerivD ds tvs cxt ty)
= hsep [ text "deriving"
, maybe empty ppr_deriv_strategy ds
, text "instance"
+ , maybe empty ppr_invis_forall_bndrs tvs
, pprCxt cxt
, ppr ty ]
ppr_dec _ (DefaultSigD n ty)
@@ -473,6 +477,12 @@ ppr_dec _ (PatSynSigD name ty)
ppr_dec _ (ImplicitParamBindD n e)
= hsep [text ('?' : n), text "=", ppr e]
+ppr_invis_forall_bndrs :: Ppr a => [a] -> Doc
+ppr_invis_forall_bndrs bndrs =
+ hsep [ text "forall"
+ , fsep (map ppr bndrs)
+ , char '.' ]
+
ppr_deriv_strategy :: DerivStrategy -> Doc
ppr_deriv_strategy ds =
case ds of
@@ -565,7 +575,7 @@ ppr_tf_head (TypeFamilyHead tc tvs res inj)
| otherwise = empty
ppr_bndrs :: PprFlag flag => Maybe [TyVarBndr flag] -> Doc
-ppr_bndrs (Just bndrs) = text "forall" <+> sep (map ppr bndrs) <> text "."
+ppr_bndrs (Just bndrs) = ppr_invis_forall_bndrs bndrs
ppr_bndrs Nothing = empty
------------------------------
@@ -623,17 +633,12 @@ instance Ppr Pragma where
= text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"
ppr (RuleP n ty_bndrs tm_bndrs lhs rhs phases)
= sep [ text "{-# RULES" <+> pprString n <+> ppr phases
- , nest 4 $ ppr_ty_forall ty_bndrs <+> ppr_tm_forall ty_bndrs
- <+> ppr lhs
+ , nest 4 $ maybe empty ppr_invis_forall_bndrs ty_bndrs
+ <+> ppr_tm_forall ty_bndrs
+ <+> ppr lhs
, nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]
- where ppr_ty_forall Nothing = empty
- ppr_ty_forall (Just bndrs) = text "forall"
- <+> fsep (map ppr bndrs)
- <+> char '.'
- ppr_tm_forall Nothing | null tm_bndrs = empty
- ppr_tm_forall _ = text "forall"
- <+> fsep (map ppr tm_bndrs)
- <+> char '.'
+ where ppr_tm_forall Nothing | null tm_bndrs = empty
+ ppr_tm_forall _ = ppr_invis_forall_bndrs tm_bndrs
ppr (AnnP tgt expr)
= text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
where target1 ModuleAnnotation = text "module"
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -2409,8 +2409,8 @@ data Dec
| TySynD Name [TyVarBndr ()] Type -- ^ @{ type T x = (x,x) }@
| ClassD Cxt Name [TyVarBndr ()]
[FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@
- | InstanceD (Maybe Overlap) Cxt Type [Dec]
- -- ^ @{ instance {\-\# OVERLAPS \#-\}
+ | InstanceD (Maybe Overlap) (Maybe [TyVarBndr ()]) Cxt Type [Dec]
+ -- ^ @{ instance {\-\# OVERLAPS \#-\} forall w .
-- Show w => Show [w] where ds }@
| SigD Name Type -- ^ @{ length :: [a] -> Int }@
| KiSigD Name Kind -- ^ @{ type TypeRep :: k -> Type }@
@@ -2451,8 +2451,8 @@ data Dec
-- ^ @{ type family F a b = (r :: *) | r -> a where ... }@
| RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@
- | StandaloneDerivD (Maybe DerivStrategy) Cxt Type
- -- ^ @{ deriving stock instance Ord a => Ord (Foo a) }@
+ | StandaloneDerivD (Maybe DerivStrategy) (Maybe [TyVarBndr ()]) Cxt Type
+ -- ^ @{ deriving stock instance forall a. Ord a => Ord (Foo a) }@
| DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@
-- | Pattern Synonyms
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -2,12 +2,22 @@
## 2.20.0.0
- * The `Ppr.pprInfixT` function has gained a `Precedence` argument.
+ * The `Ppr.pprInfixT` function has gained a `Precedence` argument.
+
* The values of named precedence levels like `Ppr.appPrec` have changed.
* Add `TypeDataD` constructor to the `Dec` type for `type data`
declarations (GHC proposal #106).
+ * The constructors `InstanceD` and `StandaloneDerivD` now take one extra
+ argument, of type `Maybe (TyVarBndr ())`, in order to handle
+ instances with user-written quantification, such as:
+
+ ```
+ instance forall k (a :: k). C a
+ deriving instance forall k (a :: k). D a
+ ```
+
## 2.19.0.0
* Add `DefaultD` constructor to support Haskell `default` declarations.
=====================================
testsuite/tests/th/T21794.hs
=====================================
@@ -0,0 +1,43 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module T21794 where
+
+import Data.Kind
+$([d|
+ data P = L | R
+ data T (a :: P) where
+ A :: T a
+ B :: T R
+
+ type TConstraint = forall a . T a -> Constraint
+
+ type ForAllA1 :: TConstraint -> Constraint
+ class (forall a . constr @a A) => ForAllA1 constr
+ instance forall (constr :: TConstraint) . (forall a . constr @a A) => ForAllA1 constr
+
+ type ForAllA2 :: TConstraint -> Constraint
+ class (forall a . constr @a A) => ForAllA2 constr
+ deriving anyclass instance forall (constr :: TConstraint) . (forall a . constr @a A) => ForAllA2 constr
+
+ |])
+
+
+$([d|
+ type C :: forall {k} {l}. k -> l -> Type
+ class C a b
+
+ instance forall k (a :: k) (b :: Type). C a k
+ |])
\ No newline at end of file
=====================================
testsuite/tests/th/T21794.stderr
=====================================
@@ -0,0 +1,36 @@
+T21794.hs:(18,2)-(34,6): Splicing declarations
+ [d| type ForAllA1 :: TConstraint -> Constraint
+ type ForAllA2 :: TConstraint -> Constraint
+
+ data P = L | R
+ data T (a :: P)
+ where
+ A :: T a
+ B :: T R
+ type TConstraint = forall a. T a -> Constraint
+ class (forall a. constr @a A) => ForAllA1 constr
+ class (forall a. constr @a A) => ForAllA2 constr
+
+ instance forall (constr :: TConstraint). (forall a. constr @a A) =>
+ ForAllA1 constr
+
+ deriving anyclass instance forall (constr :: TConstraint). (forall a.
+ constr @a A) =>
+ ForAllA2 constr |]
+ ======>
+ data P = L | R
+ data T (a :: P)
+ where
+ A :: T a
+ B :: T 'R
+ type TConstraint = forall a. T a -> Constraint
+ type ForAllA1 :: TConstraint -> Constraint
+ class (forall a. constr @a 'A) => ForAllA1 constr
+ instance forall (constr :: TConstraint). (forall a.
+ constr @a 'A) =>
+ ForAllA1 constr
+ type ForAllA2 :: TConstraint -> Constraint
+ class (forall a. constr @a 'A) => ForAllA2 constr
+ deriving anyclass instance forall (constr :: TConstraint). (forall a.
+ constr @a 'A) =>
+ ForAllA2 constr
=====================================
testsuite/tests/th/all.T
=====================================
@@ -556,4 +556,5 @@ test('T21920', normal, compile_and_run, [''])
test('T21723', normal, compile_and_run, [''])
test('T21942', normal, compile_and_run, [''])
test('T22784', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T21794', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('TH_fun_par', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/876c1918d584a5ccc2793a7b9154577149454845
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/876c1918d584a5ccc2793a7b9154577149454845
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230127/60c1b4ea/attachment-0001.html>
More information about the ghc-commits
mailing list