summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2017-12-02 18:48:48 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2017-12-02 18:48:48 +0200
commit9a86345be9987b9610068c38a5e430393a5f7a81 (patch)
tree9c3fc871b24504a2a06ea39956c3972d5bc44eb6
parentcf80efddf36b57e9791090c6b366ce94bc443c69 (diff)
downloadhaskell-wip/T14529.tar.gz
Make LHsQTyVars actually Located, and locate HsForAllTy.hst_bndrswip/T14529
So that AnnDot and AnnForAll can attach to the right places (API Annotations)
Diffstat
-rw-r--r--compiler/deSugar/DsMeta.hs12
-rw-r--r--compiler/hsSyn/Convert.hs14
-rw-r--r--compiler/hsSyn/HsDecls.hs4
-rw-r--r--compiler/hsSyn/HsTypes.hs56
-rw-r--r--compiler/hsSyn/HsUtils.hs2
-rw-r--r--compiler/parser/Parser.y23
-rw-r--r--compiler/parser/RdrHsSyn.hs26
-rw-r--r--compiler/rename/RnSource.hs6
-rw-r--r--compiler/rename/RnTypes.hs20
-rw-r--r--compiler/typecheck/TcHsType.hs6
-rw-r--r--compiler/typecheck/TcRnDriver.hs5
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs6
-rw-r--r--testsuite/tests/ghc-api/annotations/T10278.stdout28
-rw-r--r--testsuite/tests/ghc-api/annotations/T10399.stdout10
-rw-r--r--testsuite/tests/ghc-api/annotations/T11018.stdout8
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]),
View Lorry Controller Status