diff options
-rw-r--r-- | compiler/deSugar/DsMeta.hs | 12 | ||||
-rw-r--r-- | compiler/hsSyn/Convert.hs | 14 | ||||
-rw-r--r-- | compiler/hsSyn/HsDecls.hs | 4 | ||||
-rw-r--r-- | compiler/hsSyn/HsTypes.hs | 56 | ||||
-rw-r--r-- | compiler/hsSyn/HsUtils.hs | 2 | ||||
-rw-r--r-- | compiler/parser/Parser.y | 23 | ||||
-rw-r--r-- | compiler/parser/RdrHsSyn.hs | 26 | ||||
-rw-r--r-- | compiler/rename/RnSource.hs | 6 | ||||
-rw-r--r-- | compiler/rename/RnTypes.hs | 20 | ||||
-rw-r--r-- | compiler/typecheck/TcHsType.hs | 6 | ||||
-rw-r--r-- | compiler/typecheck/TcRnDriver.hs | 5 | ||||
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/T10278.stdout | 28 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/T10399.stdout | 10 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/annotations/T11018.stdout | 8 |
15 files changed, 123 insertions, 103 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index f77d23ec06..fe6a44e422 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -193,7 +193,7 @@ hsSigTvBinders binds get_scoped_tvs (L _ (TypeSig _ sig)) | HsIB { hsib_vars = implicit_vars , hsib_body = hs_ty } <- hswc_body sig - , (explicit_vars, _) <- splitLHsForAllTy hs_ty + , (L _ explicit_vars, _) <- splitLHsForAllTy hs_ty = implicit_vars ++ map hsLTyVarName explicit_vars get_scoped_tvs _ = [] @@ -348,8 +348,8 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info, fdInjectivityAnn = injectivity })) = do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences] ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn - mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs - , hsq_dependent = emptyNameSet } + mkHsQTvs tvs = noLoc HsQTvs { hsq_implicit = [], hsq_explicit = tvs + , hsq_dependent = emptyNameSet } resTyVar = case resultSig of TyVarSig bndr -> mkHsQTvs [bndr] _ -> mkHsQTvs [] @@ -504,7 +504,7 @@ repTyFamEqn (HsIB { hsib_vars = var_names = do { let hs_tvs = HsQTvs { hsq_implicit = var_names , hsq_explicit = [] , hsq_dependent = emptyNameSet } -- Yuk - ; addTyClTyVarBinds hs_tvs $ \ _ -> + ; addTyClTyVarBinds (noLoc hs_tvs) $ \ _ -> do { tys1 <- repLTys tys ; tys2 <- coreList typeQTyConName tys1 ; rhs1 <- repLTy rhs @@ -520,7 +520,7 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn = ; let hs_tvs = HsQTvs { hsq_implicit = var_names , hsq_explicit = [] , hsq_dependent = emptyNameSet } -- Yuk - ; addTyClTyVarBinds hs_tvs $ \ bndrs -> + ; addTyClTyVarBinds (noLoc hs_tvs) $ \ bndrs -> do { tys1 <- repList typeQTyConName repLTy tys ; repDataDefn tc bndrs (Just tys1) defn } } @@ -880,7 +880,7 @@ addTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added -- gensym a list of type variables and enter them into the meta environment; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument -addTyVarBinds (HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) +addTyVarBinds (L _ HsQTvs { hsq_implicit = imp_tvs, hsq_explicit = exp_tvs }) thing_inside = addSimpleTyVarBinds imp_tvs $ addHsTyVarBinds exp_tvs $ diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 57e85e10cc..942ed4f121 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -519,7 +519,7 @@ cvtConstr (ForallC tvs ctxt con) add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt }) = con { con_forall = not (null all_tvs) - , con_qvars = mkHsQTvs all_tvs + , con_qvars = noLoc $ mkHsQTvs all_tvs , con_mb_cxt = add_cxt cxt' cxt } where all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars @@ -536,14 +536,14 @@ cvtConstr (GadtC c strtys ty) ; args <- mapM cvt_arg strtys ; L _ ty' <- cvtType ty ; c_ty <- mk_arr_apps args ty' - ; returnL $ mkGadtDecl c' c_ty} + ; returnL $ snd $ mkGadtDecl c' c_ty} cvtConstr (RecGadtC c varstrtys ty) = do { c' <- mapM cNameL c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty') - ; returnL $ mkGadtDecl c' rec_ty } + ; returnL $ snd $ mkGadtDecl c' rec_ty } cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack @@ -1151,7 +1151,7 @@ cvtOpAppP x op y -- Types and type variables cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs) -cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } +cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; returnL (mkHsQTvs tvs') } cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs) cvt_tv (TH.PlainTV nm) @@ -1440,7 +1440,7 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty)) | null reqs = do { l <- getL ; univs' <- hsQTvExplicit <$> cvtTvs univs ; ty' <- cvtType (ForallT exis provs ty) - ; let forTy = HsForAllTy { hst_bndrs = univs' + ; let forTy = HsForAllTy { hst_bndrs = L l univs' , hst_body = L l cxtTy } cxtTy = HsQualTy { hst_ctxt = L l [] , hst_body = ty' } @@ -1498,9 +1498,9 @@ mkHsForAllTy :: [TH.TyVarBndr] -- ^ The converted rho type -> LHsType name -- ^ The complete type, quantified with a forall if necessary -mkHsForAllTy tvs loc tvs' rho_ty +mkHsForAllTy tvs loc tvs'@(L l _) rho_ty | null tvs = rho_ty - | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs' + | otherwise = L loc $ HsForAllTy { hst_bndrs = L l $ hsQTvExplicit tvs' , hst_body = rho_ty } -- | If passed an empty 'TH.Cxt', this simply returns the third argument diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index b059b9ad2b..1d50656eea 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -689,7 +689,7 @@ pp_vanilla_decl_head :: (SourceTextX pass, OutputableBndrId pass) -> LexicalFixity -> HsContext pass -> SDoc -pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context +pp_vanilla_decl_head thing (L _ HsQTvs { hsq_explicit = tyvars }) fixity context = hsep [pprHsContext context, pp_tyvars tyvars] where pp_tyvars (varl:varsr) @@ -1290,7 +1290,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con <+> pprConDeclFields (unLoc fields) cxt = fromMaybe (noLoc []) mcxt -pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars +pprConDecl (ConDeclGADT { con_names = cons, con_qvars = L _ qvars , con_mb_cxt = mcxt, con_args = args , con_res_ty = res_ty, con_doc = doc }) = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 10e2d00c0e..64f79c1047 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -19,7 +19,7 @@ HsTypes: Abstract syntax: user-defined types module HsTypes ( HsType(..), LHsType, HsKind, LHsKind, HsTyVarBndr(..), LHsTyVarBndr, - LHsQTyVars(..), + LHsQTyVars,HsQTyVars(..), HsImplicitBndrs(..), HsWildCardBndrs(..), LHsSigType, LHsSigWcType, LHsWcType, @@ -49,7 +49,7 @@ module HsTypes ( mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, - mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs, + mkHsQTvs, hsQTvExplicit, emptyHsQTvs, isEmptyLHsQTvs, isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy, hsScopedTvs, hsWcScopedTvs, dropWildCards, hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, @@ -254,7 +254,10 @@ type LHsTyVarBndr pass = Located (HsTyVarBndr pass) -- See Note [HsType binders] -- | Located Haskell Quantified Type Variables -data LHsQTyVars pass -- See Note [HsType binders] +type LHsQTyVars pass = Located (HsQTyVars pass) + +-- | Haskell Quantified Type Variables +data HsQTyVars pass -- See Note [HsType binders] = HsQTvs { hsq_implicit :: PostRn pass [Name] -- Implicit (dependent) variables @@ -269,21 +272,22 @@ data LHsQTyVars pass -- See Note [HsType binders] -- See Note [Dependent LHsQTyVars] in TcHsType } -deriving instance (DataId pass) => Data (LHsQTyVars pass) +deriving instance (DataId pass) => Data (HsQTyVars pass) -mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs +mkHsQTvs :: [LHsTyVarBndr GhcPs] -> HsQTyVars GhcPs mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs , hsq_dependent = PlaceHolder } +-- AZ: consider returning Located [LHsTyVarBndr pass] hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] -hsQTvExplicit = hsq_explicit +hsQTvExplicit = hsq_explicit . unLoc -emptyLHsQTvs :: LHsQTyVars GhcRn -emptyLHsQTvs = HsQTvs [] [] emptyNameSet +emptyHsQTvs :: HsQTyVars GhcRn +emptyHsQTvs = HsQTvs [] [] emptyNameSet isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool -isEmptyLHsQTvs (HsQTvs [] [] _) = True -isEmptyLHsQTvs _ = False +isEmptyLHsQTvs (L _ (HsQTvs [] [] _)) = True +isEmptyLHsQTvs _ = False ------------------------------------------------ -- HsImplicitBndrs @@ -428,7 +432,7 @@ hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit -- | Haskell Type data HsType pass = HsForAllTy -- See Note [HsType binders] - { hst_bndrs :: [LHsTyVarBndr pass] + { hst_bndrs :: Located [LHsTyVarBndr pass] -- Explicit, user-supplied 'forall a b c' , hst_body :: LHsType pass -- body type } @@ -819,7 +823,7 @@ hsWcScopedTvs sig_ty | HsWC { hswc_wcs = nwcs, hswc_body = sig_ty1 } <- sig_ty , HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty1 = case sig_ty2 of - L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++ + L _ (HsForAllTy { hst_bndrs = L _ tvs }) -> vars ++ nwcs ++ map hsLTyVarName tvs -- include kind variables only if the type is headed by forall -- (this is consistent with GHC 7 behaviour) @@ -829,7 +833,7 @@ hsScopedTvs :: LHsSigType GhcRn -> [Name] -- Same as hsWcScopedTvs, but for a LHsSigType hsScopedTvs sig_ty | HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty - , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2 + , L _ (HsForAllTy { hst_bndrs = L _ tvs }) <- sig_ty2 = vars ++ map hsLTyVarName tvs | otherwise = [] @@ -861,7 +865,7 @@ hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] -- All variables -hsAllLTyVarNames (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs }) +hsAllLTyVarNames (L _ (HsQTvs { hsq_implicit = kvs, hsq_explicit = tvs })) = kvs ++ map hsLTyVarName tvs hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass) @@ -880,7 +884,8 @@ hsLTyVarBndrToType = fmap cvt -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. hsLTyVarBndrsToTypes :: LHsQTyVars pass -> [LHsType pass] -hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs +hsLTyVarBndrsToTypes (L _ (HsQTvs { hsq_explicit = tvbs })) + = map hsLTyVarBndrToType tvbs --------------------- wildCardName :: HsWildCardInfo GhcRn -> Name @@ -1023,22 +1028,23 @@ splitLHsPatSynTy :: LHsType pass , LHsType pass) -- body type splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) where - (univs, ty1) = splitLHsForAllTy ty - (reqs, ty2) = splitLHsQualTy ty1 - (exis, ty3) = splitLHsForAllTy ty2 - (provs, ty4) = splitLHsQualTy ty3 + (L _ univs, ty1) = splitLHsForAllTy ty + ( reqs, ty2) = splitLHsQualTy ty1 + (L _ exis, ty3) = splitLHsForAllTy ty2 + ( provs, ty4) = splitLHsQualTy ty3 splitLHsSigmaTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) splitLHsSigmaTy ty - | (tvs, ty1) <- splitLHsForAllTy ty + | (L _ tvs, ty1) <- splitLHsForAllTy ty , (ctxt, ty2) <- splitLHsQualTy ty1 = (tvs, ctxt, ty2) -splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) -splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) +splitLHsForAllTy :: LHsType pass -> (Located [LHsTyVarBndr pass], LHsType pass) +splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = ltvs, hst_body = body })) + = (ltvs, body) splitLHsForAllTy (L _ (HsParTy t)) = splitLHsForAllTy t -splitLHsForAllTy body = ([], body) +splitLHsForAllTy body = (noLoc [], body) splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) @@ -1156,7 +1162,7 @@ instance Outputable HsTyLit where ppr = ppr_tylit instance (SourceTextX pass, OutputableBndrId pass) - => Outputable (LHsQTyVars pass) where + => Outputable (HsQTyVars pass) where ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs instance (SourceTextX pass, OutputableBndrId pass) @@ -1266,7 +1272,7 @@ ppr_mono_lty ty = ppr_mono_ty (unLoc ty) ppr_mono_ty :: (SourceTextX pass, OutputableBndrId pass) => HsType pass -> SDoc -ppr_mono_ty (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) +ppr_mono_ty (HsForAllTy { hst_bndrs = L _ tvs, hst_body = ty }) = sep [pprHsForAllTvs tvs, ppr_mono_lty ty] ppr_mono_ty (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty }) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 67c0c3bc23..15ec634c2f 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -635,7 +635,7 @@ typeToLHsType ty go (FunTy arg res) = nlHsFunTy (go arg) (go res) go ty@(ForAllTy {}) | (tvs, tau) <- tcSplitForAllTys ty - = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs + = noLoc (HsForAllTy { hst_bndrs = noLoc $ map go_tv tvs , hst_body = go tau }) go (TyVarTy tv) = nlHsTyVar (getRdrName tv) go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 69c8fdefd0..3af5d1a9d9 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1737,10 +1737,11 @@ unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) } -- A ctype is a for-all type ctype :: { LHsType GhcPs } : 'forall' tv_bndrs '.' ctype {% hintExplicitForall (getLoc $1) >> - ams (sLL $1 $> $ - HsForAllTy { hst_bndrs = $2 - , hst_body = $4 }) - [mu AnnForall $1, mj AnnDot $3] } + let { L l tvs = sLL $1 $3 $ $2 } + in do { ams (L l ()) [mu AnnForall $1, mj AnnDot $3] + ; return (sLL $1 $> $ + HsForAllTy { hst_bndrs = L l tvs + , hst_body = $4 }) } } | context '=>' ctype {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> return (sLL $1 $> $ HsQualTy { hst_ctxt = $1 @@ -1762,10 +1763,11 @@ ctype :: { LHsType GhcPs } ctypedoc :: { LHsType GhcPs } : 'forall' tv_bndrs '.' ctypedoc {% hintExplicitForall (getLoc $1) >> - ams (sLL $1 $> $ - HsForAllTy { hst_bndrs = $2 - , hst_body = $4 }) - [mu AnnForall $1,mj AnnDot $3] } + let { L l tvs = sLL $1 $3 $ $2 } + in do { ams (L l ()) [mu AnnForall $1, mj AnnDot $3] + ; return (sLL $1 $> $ + HsForAllTy { hst_bndrs = L l tvs + , hst_body = $4 }) } } | context '=>' ctypedoc {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2) >> return (sLL $1 $> $ HsQualTy { hst_ctxt = $1 @@ -2064,8 +2066,9 @@ gadt_constr :: { LConDecl GhcPs } -- see Note [Difference in parsing GADT and data constructors] -- Returns a list because of: C,D :: ty : con_list '::' sigtype - {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) $3)) - [mu AnnDcolon $2] } + {% let { (anns,gadt) = mkGadtDecl (unLoc $1) $3 } + in ams (sLL $1 $> gadt) + ((mu AnnDcolon $2):anns) } {- Note [Difference in parsing GADT and data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 1c03344eb2..534330a003 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -567,19 +567,21 @@ mkConDeclH98 name mb_forall cxt args mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -- Always a HsForAllTy - -> ConDecl GhcPs + -> ([AddAnn],ConDecl GhcPs) mkGadtDecl names ty - = ConDeclGADT { con_names = names - , con_forall = isLHsForAllTy ty - , con_qvars = mkHsQTvs tvs - , con_mb_cxt = mcxt - , con_args = args - , con_res_ty = res_ty - , con_doc = Nothing } + = (anns, ConDeclGADT { con_names = names + , con_forall = isLHsForAllTy ty + , con_qvars = L tvloc $ mkHsQTvs tvs + , con_mb_cxt = mcxt + , con_args = args + , con_res_ty = res_ty + , con_doc = Nothing }) where - (tvs, rho) = splitLHsForAllTy ty + (L tvloc tvs, rho) = splitLHsForAllTy ty (mcxt, tau) = split_rho rho + anns = getHsParTyAsAnns ty ++ getHsParTyAsAnns rho ++ getHsParTyAsAnns tau + split_rho (L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) = (Just cxt, tau) split_rho (L _ (HsParTy ty)) = split_rho ty @@ -592,6 +594,10 @@ mkGadtDecl names ty split_tau (L _ (HsParTy ty)) = split_tau ty split_tau tau = (PrefixCon [], tau) +getHsParTyAsAnns :: LHsType GhcPs -> [AddAnn] +getHsParTyAsAnns (L l (HsParTy ty)) = mkParensApiAnn l ++ getHsParTyAsAnns ty +getHsParTyAsAnns _ = [] + setRdrNameSpace :: RdrName -> NameSpace -> RdrName -- ^ This rather gruesome function is used mainly by the parser. -- When parsing: @@ -713,7 +719,7 @@ checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs] -- Convert.hs checkTyVars pp_what equals_or_where tc tparms = do { tvs <- mapM chk tparms - ; return (mkHsQTvs tvs) } + ; return (noLoc $ mkHsQTvs tvs) } where chk (L _ (HsParTy ty)) = chk ty diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 5b38f2879c..b3fb47307b 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -2025,7 +2025,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs rnConDecl decl@(ConDeclGADT { con_names = names , con_forall = explicit_forall - , con_qvars = qtvs + , con_qvars = L ltvs qtvs , con_mb_cxt = mcxt , con_args = args , con_res_ty = res_ty @@ -2034,7 +2034,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names ; new_names <- mapM lookupLocatedTopBndrRn names ; mb_doc' <- rnMbLHsDoc mb_doc - ; let explicit_tkvs = hsQTvExplicit qtvs + ; let explicit_tkvs = hsQTvExplicit (L ltvs qtvs) theta = hsConDeclTheta mcxt arg_tys = hsConDeclArgTys args ; free_tkvs <- extractHsTysRdrTyVarsDups (res_ty : theta ++ arg_tys) @@ -2065,7 +2065,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) ; return (decl { con_names = new_names - , con_qvars = new_qtvs, con_mb_cxt = new_cxt + , con_qvars = L ltvs new_qtvs, con_mb_cxt = new_cxt , con_args = args', con_res_ty = res_ty' , con_doc = mb_doc' }, all_fvs) } } diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 727744d54d..40f7fda266 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -160,10 +160,11 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -- A lot of faff just to allow the extra-constraints wildcard to appear - rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body }) + rn_ty env hs_ty@(HsForAllTy { hst_bndrs = L ltv tvs, hst_body = hs_body }) = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' -> do { (hs_body', fvs) <- rn_lty env hs_body - ; return (HsForAllTy { hst_bndrs = tvs', hst_body = hs_body' }, fvs) } + ; return (HsForAllTy { hst_bndrs = L ltv tvs', hst_body = hs_body' } + , fvs) } rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty }) | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt @@ -509,12 +510,12 @@ rnLHsTyKi env (L loc ty) rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) +rnHsTyKi env ty@(HsForAllTy { hst_bndrs = L ltv tyvars, hst_body = tau }) = do { checkTypeInType env ty ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty) Nothing tyvars $ \ tyvars' -> do { (tau', fvs) <- rnLHsTyKi env tau - ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' } + ; return ( HsForAllTy { hst_bndrs = L ltv tyvars', hst_body = tau' } , fvs) } } rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) @@ -932,9 +933,10 @@ bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs -> do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs) ; dep_bndr_nms <- mapM (lookupLocalOccRn . unLoc) dep_bndrs - ; thing_inside (HsQTvs { hsq_implicit = implicit_kv_nms - , hsq_explicit = rn_bndrs - , hsq_dependent = mkNameSet dep_bndr_nms }) + ; thing_inside (noLoc + $ HsQTvs { hsq_implicit = implicit_kv_nms + , hsq_explicit = rn_bndrs + , hsq_dependent = mkNameSet dep_bndr_nms }) all_bound_on_lhs } } where @@ -1107,7 +1109,7 @@ collectAnonWildCards lty = go lty HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds HsExplicitListTy _ _ tys -> gos tys HsExplicitTupleTy _ tys -> gos tys - HsForAllTy { hst_bndrs = bndrs + HsForAllTy { hst_bndrs = L _ bndrs , hst_body = ty } -> collectAnonWildCardsBndrs bndrs `mappend` go ty HsQualTy { hst_ctxt = L _ ctxt @@ -1800,7 +1802,7 @@ extract_lty t_or_k (L _ ty) acc HsTyLit _ -> return acc HsKindSig ty ki -> extract_lty t_or_k ty =<< extract_lkind ki acc - HsForAllTy { hst_bndrs = tvs, hst_body = ty } + HsForAllTy { hst_bndrs = L _ tvs, hst_body = ty } -> extract_hs_tv_bndrs tvs acc =<< extract_lty t_or_k ty emptyFKTV HsQualTy { hst_ctxt = ctxt, hst_body = ty } diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index cc826b9401..82869d6d73 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -577,7 +577,7 @@ tc_hs_type mode (HsOpTy ty1 (L _ op) ty2) exp_kind = tc_fun_type mode ty1 ty2 exp_kind --------- Foralls -tc_hs_type mode (HsForAllTy { hst_bndrs = hs_tvs, hst_body = ty }) exp_kind +tc_hs_type mode (HsForAllTy { hst_bndrs = L _ hs_tvs, hst_body = ty }) exp_kind = fmap fst $ tcExplicitTKBndrs hs_tvs $ \ tvs' -> -- Do not kind-generalise here! See Note [Kind generalisation] @@ -1390,8 +1390,8 @@ kcHsTyVarBndrs :: Name -- ^ of the thing being checked -> TcM (Kind, r) -- ^ The result kind, possibly with other info -> TcM (TcTyCon, r) -- ^ A suitably-kinded TcTyCon kcHsTyVarBndrs name flav cusk all_kind_vars - (HsQTvs { hsq_implicit = kv_ns, hsq_explicit = hs_tvs - , hsq_dependent = dep_names }) thing_inside + (L _ HsQTvs { hsq_implicit = kv_ns, hsq_explicit = hs_tvs + , hsq_dependent = dep_names }) thing_inside | cusk = do { kv_kinds <- mk_kv_kinds ; lvl <- getTcLevel diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index fd63effbe6..5e1ff4359b 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -2139,8 +2139,9 @@ getGhciStepIO = do let ghciM = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv) ioM = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) - step_ty = noLoc $ HsForAllTy { hst_bndrs = [noLoc $ UserTyVar (noLoc a_tv)] - , hst_body = nlHsFunTy ghciM ioM } + step_ty = noLoc $ HsForAllTy + { hst_bndrs = noLoc [noLoc $ UserTyVar (noLoc a_tv)] + , hst_body = nlHsFunTy ghciM ioM } stepTy :: LHsSigWcType GhcRn stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty) diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 2eed581d14..263012a461 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -633,7 +633,7 @@ kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs ; return () } kcConDecl (ConDeclGADT { con_names = names - , con_qvars = qtvs, con_mb_cxt = cxt + , con_qvars = L _ qtvs, con_mb_cxt = cxt , con_args = args, con_res_ty = res_ty }) | HsQTvs { hsq_implicit = implicit_tkv_nms , hsq_explicit = explicit_tkv_nms } <- qtvs @@ -1098,7 +1098,7 @@ tcDefaultAssocDecl _ (d1:_:_) <+> ppr (feqn_tycon (unLoc d1))) tcDefaultAssocDecl fam_tc [L loc (FamEqn { feqn_tycon = lname@(L _ tc_name) - , feqn_pats = hs_tvs + , feqn_pats = L _ hs_tvs , feqn_fixity = fixity , feqn_rhs = rhs })] | HsQTvs { hsq_implicit = imp_vars, hsq_explicit = exp_vars } <- hs_tvs @@ -1721,7 +1721,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl tcConDecl rep_tycon tmpl_bndrs res_tmpl (ConDeclGADT { con_names = names - , con_qvars = qtvs + , con_qvars = L _ qtvs , con_mb_cxt = cxt, con_args = hs_args , con_res_ty = res_ty }) | HsQTvs { hsq_implicit = implicit_tkv_nms diff --git a/testsuite/tests/ghc-api/annotations/T10278.stdout b/testsuite/tests/ghc-api/annotations/T10278.stdout index 46767575b1..33d462827d 100644 --- a/testsuite/tests/ghc-api/annotations/T10278.stdout +++ b/testsuite/tests/ghc-api/annotations/T10278.stdout @@ -8,10 +8,10 @@ ((Test10278.hs:1:1,AnnWhere), [Test10278.hs:2:18-22]), ((Test10278.hs:4:1-61,AnnDcolon), [Test10278.hs:4:16-17]), ((Test10278.hs:4:1-61,AnnSemi), [Test10278.hs:5:1]), -((Test10278.hs:4:19-61,AnnDot), [Test10278.hs:4:29]), -((Test10278.hs:4:19-61,AnnForall), [Test10278.hs:4:19-24]), -((Test10278.hs:4:31-61,AnnDot), [Test10278.hs:4:42]), -((Test10278.hs:4:31-61,AnnForall), [Test10278.hs:4:31-36]), +((Test10278.hs:4:19-29,AnnDot), [Test10278.hs:4:29]), +((Test10278.hs:4:19-29,AnnForall), [Test10278.hs:4:19-24]), +((Test10278.hs:4:31-42,AnnDot), [Test10278.hs:4:42]), +((Test10278.hs:4:31-42,AnnForall), [Test10278.hs:4:31-36]), ((Test10278.hs:4:44-61,AnnRarrow), [Test10278.hs:4:48-49]), ((Test10278.hs:4:51-61,AnnRarrow), [Test10278.hs:4:56-57]), ((Test10278.hs:5:1-26,AnnEqual), [Test10278.hs:5:16]), @@ -26,10 +26,10 @@ ((Test10278.hs:(8,19)-(10,58),AnnCloseP), [Test10278.hs:10:58]), ((Test10278.hs:(8,19)-(10,58),AnnOpenP), [Test10278.hs:8:19]), ((Test10278.hs:(8,19)-(11,33),AnnRarrow), [Test10278.hs:11:23-24]), -((Test10278.hs:(8,20)-(10,57),AnnDot), [Test10278.hs:8:30]), -((Test10278.hs:(8,20)-(10,57),AnnForall), [Test10278.hs:8:20-25]), -((Test10278.hs:(8,32)-(10,57),AnnDot), [Test10278.hs:8:43]), -((Test10278.hs:(8,32)-(10,57),AnnForall), [Test10278.hs:8:32-37]), +((Test10278.hs:8:20-30,AnnDot), [Test10278.hs:8:30]), +((Test10278.hs:8:20-30,AnnForall), [Test10278.hs:8:20-25]), +((Test10278.hs:8:32-43,AnnDot), [Test10278.hs:8:43]), +((Test10278.hs:8:32-43,AnnForall), [Test10278.hs:8:32-37]), ((Test10278.hs:9:27-50,AnnRarrow), [Test10278.hs:10:31-32]), ((Test10278.hs:(9,27)-(10,57),AnnRarrow), [Test10278.hs:10:31-32]), ((Test10278.hs:9:38-50,AnnCloseP), [Test10278.hs:9:50]), @@ -49,8 +49,8 @@ ((Test10278.hs:(14,1)-(17,80),AnnWhere), [Test10278.hs:14:21-25]), ((Test10278.hs:15:5-64,AnnDcolon), [Test10278.hs:15:11-12]), ((Test10278.hs:15:5-64,AnnSemi), [Test10278.hs:16:5]), -((Test10278.hs:15:14-64,AnnDot), [Test10278.hs:15:23]), -((Test10278.hs:15:14-64,AnnForall), [Test10278.hs:15:14-19]), +((Test10278.hs:15:14-23,AnnDot), [Test10278.hs:15:23]), +((Test10278.hs:15:14-23,AnnForall), [Test10278.hs:15:14-19]), ((Test10278.hs:15:25-40,AnnCloseP), [Test10278.hs:15:40, Test10278.hs:15:40]), ((Test10278.hs:15:25-40,AnnDarrow), [Test10278.hs:15:42-43]), ((Test10278.hs:15:25-40,AnnOpenP), [Test10278.hs:15:25, Test10278.hs:15:25]), @@ -60,8 +60,8 @@ ((Test10278.hs:15:45-64,AnnRarrow), [Test10278.hs:15:48-49]), ((Test10278.hs:16:5-64,AnnDcolon), [Test10278.hs:16:11-12]), ((Test10278.hs:16:5-64,AnnSemi), [Test10278.hs:17:5]), -((Test10278.hs:16:14-64,AnnDot), [Test10278.hs:16:23]), -((Test10278.hs:16:14-64,AnnForall), [Test10278.hs:16:14-19]), +((Test10278.hs:16:14-23,AnnDot), [Test10278.hs:16:23]), +((Test10278.hs:16:14-23,AnnForall), [Test10278.hs:16:14-19]), ((Test10278.hs:16:25-40,AnnCloseP), [Test10278.hs:16:40, Test10278.hs:16:40]), ((Test10278.hs:16:25-40,AnnDarrow), [Test10278.hs:16:42-43]), ((Test10278.hs:16:25-40,AnnOpenP), [Test10278.hs:16:25, Test10278.hs:16:25]), @@ -73,8 +73,8 @@ ((Test10278.hs:17:15-20,AnnCloseP), [Test10278.hs:17:20]), ((Test10278.hs:17:15-20,AnnDarrow), [Test10278.hs:17:22-23]), ((Test10278.hs:17:15-20,AnnOpenP), [Test10278.hs:17:15]), -((Test10278.hs:17:25-80,AnnDot), [Test10278.hs:17:34]), -((Test10278.hs:17:25-80,AnnForall), [Test10278.hs:17:25-30]), +((Test10278.hs:17:25-34,AnnDot), [Test10278.hs:17:34]), +((Test10278.hs:17:25-34,AnnForall), [Test10278.hs:17:25-30]), ((Test10278.hs:17:36-51,AnnCloseP), [Test10278.hs:17:51, Test10278.hs:17:51]), ((Test10278.hs:17:36-51,AnnDarrow), [Test10278.hs:17:53-54]), ((Test10278.hs:17:36-51,AnnOpenP), [Test10278.hs:17:36, Test10278.hs:17:36]), diff --git a/testsuite/tests/ghc-api/annotations/T10399.stdout b/testsuite/tests/ghc-api/annotations/T10399.stdout index e290be4e67..5de8d6ee8c 100644 --- a/testsuite/tests/ghc-api/annotations/T10399.stdout +++ b/testsuite/tests/ghc-api/annotations/T10399.stdout @@ -34,8 +34,8 @@ ((Test10399.hs:(14,1)-(17,69),AnnWhere), [Test10399.hs:14:21-25]), ((Test10399.hs:15:5-64,AnnDcolon), [Test10399.hs:15:11-12]), ((Test10399.hs:15:5-64,AnnSemi), [Test10399.hs:16:5]), -((Test10399.hs:15:14-64,AnnDot), [Test10399.hs:15:23]), -((Test10399.hs:15:14-64,AnnForall), [Test10399.hs:15:14-19]), +((Test10399.hs:15:14-23,AnnDot), [Test10399.hs:15:23]), +((Test10399.hs:15:14-23,AnnForall), [Test10399.hs:15:14-19]), ((Test10399.hs:15:25-40,AnnCloseP), [Test10399.hs:15:40, Test10399.hs:15:40]), ((Test10399.hs:15:25-40,AnnDarrow), [Test10399.hs:15:42-43]), ((Test10399.hs:15:25-40,AnnOpenP), [Test10399.hs:15:25, Test10399.hs:15:25]), @@ -43,9 +43,11 @@ ((Test10399.hs:15:45-46,AnnBang), [Test10399.hs:15:45]), ((Test10399.hs:15:45-46,AnnRarrow), [Test10399.hs:15:48-49]), ((Test10399.hs:15:45-64,AnnRarrow), [Test10399.hs:15:48-49]), +((Test10399.hs:(16,5)-(17,69),AnnCloseP), [Test10399.hs:17:69]), ((Test10399.hs:(16,5)-(17,69),AnnDcolon), [Test10399.hs:16:12-13]), -((Test10399.hs:(16,15)-(17,69),AnnDot), [Test10399.hs:16:25]), -((Test10399.hs:(16,15)-(17,69),AnnForall), [Test10399.hs:16:15-20]), +((Test10399.hs:(16,5)-(17,69),AnnOpenP), [Test10399.hs:16:27]), +((Test10399.hs:16:15-25,AnnDot), [Test10399.hs:16:25]), +((Test10399.hs:16:15-25,AnnForall), [Test10399.hs:16:15-20]), ((Test10399.hs:(16,27)-(17,69),AnnCloseP), [Test10399.hs:17:69]), ((Test10399.hs:(16,27)-(17,69),AnnOpenP), [Test10399.hs:16:27]), ((Test10399.hs:16:28-43,AnnCloseP), [Test10399.hs:16:43, Test10399.hs:16:43]), diff --git a/testsuite/tests/ghc-api/annotations/T11018.stdout b/testsuite/tests/ghc-api/annotations/T11018.stdout index 011867e0d8..dec084de3a 100644 --- a/testsuite/tests/ghc-api/annotations/T11018.stdout +++ b/testsuite/tests/ghc-api/annotations/T11018.stdout @@ -8,8 +8,8 @@ ((Test11018.hs:1:1,AnnWhere), [Test11018.hs:4:18-22]), ((Test11018.hs:6:1-36,AnnDcolon), [Test11018.hs:6:12-13]), ((Test11018.hs:6:1-36,AnnSemi), [Test11018.hs:7:1]), -((Test11018.hs:6:15-36,AnnDot), [Test11018.hs:6:24]), -((Test11018.hs:6:15-36,AnnForall), [Test11018.hs:6:15-20]), +((Test11018.hs:6:15-24,AnnDot), [Test11018.hs:6:24]), +((Test11018.hs:6:15-24,AnnForall), [Test11018.hs:6:15-20]), ((Test11018.hs:6:26-36,AnnRarrow), [Test11018.hs:6:28-29]), ((Test11018.hs:(7,1)-(9,10),AnnEqual), [Test11018.hs:7:14]), ((Test11018.hs:(7,1)-(9,10),AnnFunId), [Test11018.hs:7:1-10]), @@ -103,8 +103,8 @@ ((Test11018.hs:27:28-30,AnnVal), [Test11018.hs:27:29]), ((Test11018.hs:31:1-26,AnnDcolonU), [Test11018.hs:31:9]), ((Test11018.hs:31:1-26,AnnSemi), [Test11018.hs:32:1]), -((Test11018.hs:31:11-26,AnnDot), [Test11018.hs:31:15]), -((Test11018.hs:31:11-26,AnnForallU), [Test11018.hs:31:11]), +((Test11018.hs:31:11-15,AnnDot), [Test11018.hs:31:15]), +((Test11018.hs:31:11-15,AnnForallU), [Test11018.hs:31:11]), ((Test11018.hs:31:17-26,AnnRarrowU), [Test11018.hs:31:19]), ((Test11018.hs:(32,1)-(34,10),AnnEqual), [Test11018.hs:32:11]), ((Test11018.hs:(32,1)-(34,10),AnnFunId), [Test11018.hs:32:1-7]), |