summaryrefslogtreecommitdiff
path: root/compiler/GHC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC')
-rw-r--r--compiler/GHC/Builtin/Names/TH.hs20
-rw-r--r--compiler/GHC/Hs/Type.hs18
-rw-r--r--compiler/GHC/HsToCore/Quote.hs44
-rw-r--r--compiler/GHC/Rename/Module.hs3
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs9
-rw-r--r--compiler/GHC/ThToHs.hs21
-rw-r--r--compiler/GHC/Types/Var.hs4
7 files changed, 81 insertions, 38 deletions
diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs
index bea3b9715f..89563c904b 100644
--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/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
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 313b8e8fe2..cee953df01 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/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@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
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 63094c21dd..70b5d78cd9 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/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 $
+ = withOuterForallBinders tv_outer $ \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
@@ -661,22 +661,39 @@ 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
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 { dec <- repDerivStrategy strat $ \strat' ->
+ withOuterForallBinders tv_outer $ \tvs ->
do { 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)
+
+-- | Utility function for 'repClsInstD' and 'repStandaloneDerivD':
+-- bind some type variables from an outer forall, and pass them to the thing inside.
+withOuterForallBinders :: HsOuterTyVarBndrs Specificity GhcRn
+ -> ( Core (Maybe [M (TH.TyVarBndr ())]) -> MetaM (Core (M r)) )
+ -> MetaM (Core (M r))
+withOuterForallBinders tv_outer thing_inside =
+ addHsTyVarBinds FreshNamesOnly tv_bndrs $ \tvs' ->
+ do { elt_ty <- wrapName tyVarBndrUnitTyConName
+ ; let !tvs'' = case tv_outer of
+ HsOuterImplicit {} -> coreNothing' (mkListTy elt_ty)
+ HsOuterExplicit {} -> coreJust' (mkListTy elt_ty) tvs'
+ ; thing_inside tvs'' }
+ where
+ tv_bndrs :: [LHsTyVarBndr () GhcRn]
+ tv_bndrs = fmap (fmap $ setHsTyVarBndrFlag ()) -- set visibility flag to ()
+ $ hsOuterTyVarBndrs tv_outer
repTyFamInstD :: TyFamInstDecl GhcRn -> MetaM (Core (M TH.Dec))
repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })
@@ -2566,9 +2583,10 @@ repTySyn (MkC nm) (MkC tvs) (MkC rhs)
= rep2 tySynDName [nm, tvs, rhs]
repInst :: Core (Maybe TH.Overlap) ->
+ Core (Maybe [M (TH.TyVarBndr ())]) ->
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 +2643,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 ())])
+ -> 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))
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index fc6846e566..50792c1c95 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/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
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index 239a55ee6e..125accd0ec 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/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
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 498a17694f..bd0acf382b 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/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
diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs
index e95abc0855..b5ab76a86e 100644
--- a/compiler/GHC/Types/Var.hs
+++ b/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
View Lorry Controller Status