summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Data/BooleanFormula.hs8
-rw-r--r--compiler/GHC/Driver/Main.hs2
-rw-r--r--compiler/GHC/Hs/Binds.hs2
-rw-r--r--compiler/GHC/Hs/Decls.hs8
-rw-r--r--compiler/GHC/Hs/Dump.hs35
-rw-r--r--compiler/GHC/Hs/Expr.hs17
-rw-r--r--compiler/GHC/Hs/Extension.hs2
-rw-r--r--compiler/GHC/Hs/Pat.hs2
-rw-r--r--compiler/GHC/Hs/Type.hs18
-rw-r--r--compiler/GHC/Hs/Utils.hs101
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs2
-rw-r--r--compiler/GHC/HsToCore/Docs.hs36
-rw-r--r--compiler/GHC/HsToCore/Expr.hs6
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs2
-rw-r--r--compiler/GHC/HsToCore/Monad.hs7
-rw-r--r--compiler/GHC/HsToCore/Quote.hs4
-rw-r--r--compiler/GHC/HsToCore/Ticks.hs4
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs86
-rw-r--r--compiler/GHC/Iface/Ext/Utils.hs21
-rw-r--r--compiler/GHC/IfaceToCore.hs2
-rw-r--r--compiler/GHC/Parser.y362
-rw-r--r--compiler/GHC/Parser/Annotation.hs487
-rw-r--r--compiler/GHC/Parser/HaddockLex.x2
-rw-r--r--compiler/GHC/Parser/Lexer.x3
-rw-r--r--compiler/GHC/Parser/PostProcess.hs161
-rw-r--r--compiler/GHC/Parser/PostProcess/Haddock.hs29
-rw-r--r--compiler/GHC/Parser/Types.hs2
-rw-r--r--compiler/GHC/Rename/Bind.hs10
-rw-r--r--compiler/GHC/Rename/Env.hs40
-rw-r--r--compiler/GHC/Rename/Expr.hs20
-rw-r--r--compiler/GHC/Rename/HsType.hs10
-rw-r--r--compiler/GHC/Rename/Module.hs26
-rw-r--r--compiler/GHC/Rename/Names.hs24
-rw-r--r--compiler/GHC/Rename/Pat.hs14
-rw-r--r--compiler/GHC/Rename/Splice.hs12
-rw-r--r--compiler/GHC/Rename/Utils.hs30
-rw-r--r--compiler/GHC/Runtime/Eval.hs2
-rw-r--r--compiler/GHC/Tc/Deriv/Functor.hs20
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs28
-rw-r--r--compiler/GHC/Tc/Deriv/Generics.hs2
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs14
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Foreign.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Head.hs8
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs4
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs6
-rw-r--r--compiler/GHC/Tc/Gen/Rule.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs2
-rw-r--r--compiler/GHC/Tc/Module.hs10
-rw-r--r--compiler/GHC/Tc/TyCl.hs6
-rw-r--r--compiler/GHC/Tc/TyCl/Class.hs14
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs9
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs12
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs2
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs4
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs10
-rw-r--r--compiler/GHC/Tc/Utils/Instantiate.hs2
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs38
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs8
-rw-r--r--compiler/GHC/ThToHs.hs105
-rw-r--r--compiler/GHC/Unit/Module/Warnings.hs17
65 files changed, 1149 insertions, 799 deletions
diff --git a/compiler/GHC/Data/BooleanFormula.hs b/compiler/GHC/Data/BooleanFormula.hs
index f01aa0339d..6b4146bf75 100644
--- a/compiler/GHC/Data/BooleanFormula.hs
+++ b/compiler/GHC/Data/BooleanFormula.hs
@@ -25,7 +25,7 @@ import Data.Data
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Binary
-import GHC.Parser.Annotation ( LocatedL, noLocA )
+import GHC.Parser.Annotation ( LocatedL, noLocI )
import GHC.Types.SrcLoc
import GHC.Types.Unique
import GHC.Types.Unique.Set
@@ -259,6 +259,6 @@ instance Binary a => Binary (BooleanFormula a) where
h <- getByte bh
case h of
0 -> Var <$> get bh
- 1 -> And . fmap noLocA <$> get bh
- 2 -> Or . fmap noLocA <$> get bh
- _ -> Parens . noLocA <$> get bh
+ 1 -> And . fmap noLocI <$> get bh
+ 2 -> Or . fmap noLocI <$> get bh
+ _ -> Parens . noLocI <$> get bh
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 3321d1203f..59986a4027 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -689,7 +689,7 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do
outer_mod' = mkHomeModule home_unit mod_name
inner_mod = homeModuleNameInstantiation home_unit mod_name
src_filename = ms_hspp_file mod_summary
- real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
+ real_loc = realSrcLocSpan (mkRealSrcLoc (mkFastString src_filename) 1 1)
keep_rn' = gopt Opt_WriteHie dflags || keep_rn
massert (isHomeModule home_unit outer_mod)
tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index c7dd8fca0f..4957349408 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -84,7 +84,7 @@ data NHsValBindsLR idL
[(RecFlag, LHsBinds idL)]
[LSig GhcRn]
-type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey
+type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey [DeclTag]
type instance XXValBindsLR (GhcPass pL) pR
= NHsValBindsLR (GhcPass pL)
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 201adc5467..db50fa9ba8 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -350,7 +350,7 @@ data DataDeclRn = DataDeclRn
, tcdFVs :: NameSet }
deriving Data
-type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey)
+type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey [RealSrcSpan])
-- TODO:AZ:tidy up AnnSortKey above
type instance XClassDecl GhcRn = NameSet -- FVs
@@ -797,7 +797,7 @@ type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA
----------------- Class instances -------------
-type instance XCClsInstDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up
+type instance XCClsInstDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey [RealSrcSpan]) -- TODO:AZ:tidy up
type instance XCClsInstDecl GhcRn = NoExtField
type instance XCClsInstDecl GhcTc = NoExtField
@@ -1273,8 +1273,6 @@ type instance XCRoleAnnotDecl GhcTc = NoExtField
type instance XXRoleAnnotDecl (GhcPass _) = DataConCantHappen
-type instance Anno (Maybe Role) = SrcAnn NoEpAnns
-
instance OutputableBndr (IdP (GhcPass p))
=> Outputable (RoleAnnotDecl (GhcPass p)) where
ppr (RoleAnnotDecl _ ltycon roles)
@@ -1329,7 +1327,7 @@ type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA
type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA
type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA
-type instance Anno (Maybe Role) = SrcAnn NoEpAnns
+type instance Anno (Maybe Role) = EpAnnS NoEpAnns
type instance Anno CCallConv = SrcSpan
type instance Anno Safety = SrcSpan
type instance Anno CExportSpec = SrcSpan
diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs
index 794607bd49..97a3b19301 100644
--- a/compiler/GHC/Hs/Dump.hs
+++ b/compiler/GHC/Hs/Dump.hs
@@ -69,6 +69,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
`extQ` annotationTrailingAnn
`extQ` annotationEpaLocation
`extQ` annotationNoEpAnns
+ `extQ` annotationListItem
`extQ` addEpAnn
`extQ` lit `extQ` litr `extQ` litt
`extQ` sourceText
@@ -144,7 +145,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
_ -> parens $ text "SourceText" <+> text "blanked"
epaAnchor :: EpaLocation -> SDoc
- epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r
+ epaAnchor (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s
epaAnchor (EpaDelta d cs) = case ba of
NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs
BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"
@@ -266,6 +267,9 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc
annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns")
+ annotationListItem:: EpAnnS AnnListItem -> SDoc
+ annotationListItem = annotation'' (text "EpAnnS AnnListItem")
+
annotation' :: forall a .(Data a, Typeable a)
=> SDoc -> EpAnn a -> SDoc
annotation' tag anns = case ba of
@@ -273,10 +277,17 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns))
$$ vcat (gmapQ showAstData' anns)
+ annotation'' :: forall a .(Data a, Typeable a)
+ => SDoc -> EpAnnS a -> SDoc
+ annotation'' tag anns = case ba of
+ BlankEpAnnotations -> parens (text "blanked:" <+> tag)
+ NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns))
+ $$ vcat (gmapQ showAstData' anns)
+
-- -------------------------
- srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc
- srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")
+ srcSpanAnnA :: (EpAnnS AnnListItem) -> SDoc
+ srcSpanAnnA = locatedEpAnn'' (text "SrcSpanAnnA")
srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc
srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")
@@ -287,8 +298,8 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc
srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")
- srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc
- srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")
+ srcSpanAnnN :: EpAnnS NameAnn -> SDoc
+ srcSpanAnnN = locatedEpAnn'' (text "SrcSpanAnnN")
locatedAnn'' :: forall a. (Typeable a, Data a)
=> SDoc -> SrcSpanAnn' a -> SDoc
@@ -304,6 +315,20 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
Nothing -> text "locatedAnn:unmatched" <+> tag
<+> (parens $ text (showConstr (toConstr ss)))
+ locatedEpAnn'' :: forall a. (Typeable a, Data a)
+ => SDoc -> EpAnnS a -> SDoc
+ locatedEpAnn'' tag ss = parens $
+ case cast ss of
+ Just (anns :: EpAnnS a) ->
+ case ba of
+ BlankEpAnnotations
+ -> parens (text "blanked:" <+> tag)
+ NoBlankEpAnnotations
+ -> parens $ text (showConstr (toConstr anns))
+ $$ vcat (gmapQ showAstData' anns)
+ Nothing -> text "locatedEpAnn:unmatched" <+> tag
+ <+> (parens $ text (showConstr (toConstr ss)))
+
normalize_newlines :: String -> String
normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index be7af5002a..b9b0e726a7 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -150,7 +150,7 @@ mkSyntaxExpr = SyntaxExprRn
-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the
-- renamer).
mkRnSyntaxExpr :: Name -> SyntaxExprRn
-mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLocA name
+mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLocN name
instance Outputable SyntaxExprRn where
ppr (SyntaxExprRn expr) = ppr expr
@@ -2188,13 +2188,13 @@ type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA
type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]
= SrcSpanAnnL
-type instance Anno (HsCmdTop (GhcPass p)) = SrcAnn NoEpAnns
+type instance Anno (HsCmdTop (GhcPass p)) = EpAnnS NoEpAnns
type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL
type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p))))] = SrcSpanAnnL
type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA
type instance Anno (Match (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpanAnnA
-type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcAnn NoEpAnns
-type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcAnn NoEpAnns
+type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = EpAnnS NoEpAnns
+type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = EpAnnS NoEpAnns
type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA
type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA
@@ -2209,6 +2209,11 @@ type instance Anno FastString = SrcAnn NoEpAnns
type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns
-instance (Anno a ~ SrcSpanAnn' (EpAnn an))
- => WrapXRec (GhcPass p) a where
+instance (Anno
+ [LocatedA (StmtLR (GhcPass idL) (GhcPass idR) body)] ~ SrcAnn an,
+ IsPass idL, IsPass idR)
+ => WrapXRec (GhcPass idL) [LocatedA (StmtLR (GhcPass idL) (GhcPass idR) body)] where
+ wrapXRec = noLocI
+
+instance WrapXRec (GhcPass p) (HsType (GhcPass p)) where
wrapXRec = noLocA
diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs
index 8e73f60b85..cfc797335c 100644
--- a/compiler/GHC/Hs/Extension.hs
+++ b/compiler/GHC/Hs/Extension.hs
@@ -107,7 +107,7 @@ type instance Anno RdrName = SrcSpanAnnN
type instance Anno Name = SrcSpanAnnN
type instance Anno Id = SrcSpanAnnN
-type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a),
+type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ EpAnnS NameAnn,
IsPass p)
instance UnXRec (GhcPass p) where
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 3a40d15514..6bcecdced9 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -420,7 +420,7 @@ mkPrefixConPat :: DataCon ->
[LPat GhcTc] -> [Type] -> LPat GhcTc
-- Make a vanilla Prefix constructor pattern
mkPrefixConPat dc pats tys
- = noLocA $ ConPat { pat_con = noLocA (RealDataCon dc)
+ = noLocA $ ConPat { pat_con = noLocN (RealDataCon dc)
, pat_args = PrefixCon [] pats
, pat_con_ext = ConPatTc
{ cpt_tvs = []
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index eb3a955269..c6bbfbd774 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -155,7 +155,7 @@ getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)
-}
fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)
-fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt
+fromMaybeContext mctxt = unLoc $ fromMaybe (noLocI []) mctxt
type instance XHsForAllVis (GhcPass _) = EpAnnForallTy
-- Location of 'forall' and '->'
@@ -360,10 +360,10 @@ type instance XXTyLit (GhcPass _) = DataConCantHappen
oneDataConHsTy :: HsType GhcRn
-oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName)
+oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocN oneDataConName)
manyDataConHsTy :: HsType GhcRn
-manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocA manyDataConName)
+manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocN manyDataConName)
hsLinear :: a -> HsScaled (GhcPass p) a
hsLinear = HsScaled (HsLinearArrow (HsPct1 noHsTok noHsUniTok))
@@ -442,7 +442,7 @@ hsAllLTyVarNames (HsQTvs { hsq_ext = kvs
= kvs ++ hsLTyVarNames tvs
hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))
-hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a)
+hsLTyVarLocName (L l a) = L (l2ll l) (hsTyVarName a)
hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]
hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)
@@ -524,15 +524,15 @@ splitHsFunType ty = go ty
= let
(anns, cs, args, res) = splitHsFunType ty
anns' = anns ++ annParen2AddEpAnn an
- cs' = cs S.<> epAnnComments (ann l) S.<> epAnnComments an
+ cs' = cs S.<> s_comments l S.<> epAnnComments an
in (anns', cs', args, res)
go (L ll (HsFunTy (EpAnn _ _ cs) mult x y))
| (anns, csy, args, res) <- splitHsFunType y
- = (anns, csy S.<> epAnnComments (ann ll), HsScaled mult x':args, res)
+ = (anns, csy S.<> s_comments ll, HsScaled mult x':args, res)
where
L l t = x
- x' = L (addCommentsToSrcAnn l cs) t
+ x' = L (addCommentsToEpAnnS l cs) t
go other = ([], emptyComments, [], other)
@@ -1372,5 +1372,5 @@ type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA
type instance Anno HsIPName = SrcAnn NoEpAnns
type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA
-type instance Anno (FieldOcc (GhcPass p)) = SrcAnn NoEpAnns
-type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcAnn NoEpAnns
+type instance Anno (FieldOcc (GhcPass p)) = EpAnnS NoEpAnns
+type instance Anno (AmbiguousFieldOcc (GhcPass p)) = EpAnnS NoEpAnns
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index 008469b458..a407c7d16e 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -181,7 +181,7 @@ mkHsPar e = L (getLoc e) (gHsPar e)
mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcAnn NoEpAnns)
+ ~ EpAnnS NoEpAnns)
=> HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
@@ -195,14 +195,14 @@ mkSimpleMatch ctxt pats rhs
(pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs)
unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcAnn NoEpAnns
+ ~ EpAnnS NoEpAnns
=> SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn
-> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))
unguardedGRHSs loc rhs an
= GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds
unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcAnn NoEpAnns
+ ~ EpAnnS NoEpAnns
=> EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))
-> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]
unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)]
@@ -218,7 +218,7 @@ mkMatchGroup :: AnnoBody p body
-> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
-> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
mkMatchGroup origin matches = MG { mg_ext = origin
- , mg_alts = matches }
+ , mg_alts = matches }
mkLamCaseMatchGroup :: AnnoBody p body
=> Origin
@@ -230,10 +230,10 @@ mkLamCaseMatchGroup origin lc_variant (L l matches)
where fixCtxt (L a match) = L a match{m_ctxt = LamCaseAlt lc_variant}
mkLocatedList :: Semigroup a
- => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]
+ => [LocatedAnS a e2] -> LocatedL [LocatedAnS a e2]
mkLocatedList ms = case nonEmpty ms of
- Nothing -> noLocA []
- Just ms1 -> L (noAnnSrcSpan $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms
+ Nothing -> noLocI []
+ Just ms1 -> L (noAnnSrcSpanI $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms
mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2)
@@ -272,7 +272,7 @@ mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))
where
matches = mkMatchGroup Generated
- (noLocA [mkSimpleMatch LambdaExpr pats' body])
+ (noLocI [mkSimpleMatch LambdaExpr pats' body])
pats' = map (parenthesizePat appPrec) pats
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
@@ -282,7 +282,7 @@ mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
-- |A simple case alternative with a single pattern, no binds, no guards;
-- pre-typechecking
mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcAnn NoEpAnns,
+ ~ EpAnnS NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA)
=> LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
@@ -292,7 +292,7 @@ mkHsCaseAlt pat expr
nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc
nlHsTyApp fun_id tys
- = noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocA fun_id)))
+ = noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocN fun_id)))
nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
@@ -342,23 +342,38 @@ mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn)
mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))
-emptyRecStmt :: (Anno [GenLocated
+emptyRecStmt :: forall idL bodyR .
+ (Anno [GenLocated
(Anno (StmtLR (GhcPass idL) GhcPs bodyR))
- (StmtLR (GhcPass idL) GhcPs bodyR)]
- ~ SrcSpanAnnL)
+ (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL,
+ Anno [LocatedA (StmtLR (GhcPass idL) (GhcPass 'Parsed) bodyR)] ~ SrcSpanAnnL,
+ WrapXRec GhcPs [GenLocated
+ (Anno (StmtLR (GhcPass idL) (GhcPass 'Parsed) bodyR))
+ (StmtLR (GhcPass idL) (GhcPass 'Parsed) bodyR)],
+ IsPass idL)
=> StmtLR (GhcPass idL) GhcPs bodyR
-emptyRecStmtName :: (Anno [GenLocated
+emptyRecStmtName :: forall bodyR .
+ (Anno [GenLocated
(Anno (StmtLR GhcRn GhcRn bodyR))
- (StmtLR GhcRn GhcRn bodyR)]
- ~ SrcSpanAnnL)
+ (StmtLR GhcRn GhcRn bodyR)] ~ SrcSpanAnnL,
+ Anno [LocatedA (StmtLR GhcRn GhcRn bodyR)] ~ SrcSpanAnnL,
+ WrapXRec GhcRn [LStmtLR GhcRn GhcRn bodyR]
+ )
=> StmtLR GhcRn GhcRn bodyR
emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc))
mkRecStmt :: forall (idL :: Pass) bodyR.
- (Anno [GenLocated
+ (WrapXRec GhcPs [LocatedA (StmtLR (GhcPass idL) GhcPs bodyR)],
+ Anno [LocatedA (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL,
+ WrapXRec GhcPs [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR))
+ (StmtLR (GhcPass idL) GhcPs bodyR)],
+ IsPass idL,
+
+ Anno [GenLocated
(Anno (StmtLR (GhcPass idL) GhcPs bodyR))
(StmtLR (GhcPass idL) GhcPs bodyR)]
- ~ SrcSpanAnnL)
+ ~ SrcSpanAnnL
+ )
=> EpAnn AnnList
-> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR]
-> StmtLR (GhcPass idL) GhcPs bodyR
@@ -427,7 +442,11 @@ mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr,
xbstc_failOp = Nothing }) pat body
emptyRecStmt' :: forall idL idR body .
- (WrapXRec (GhcPass idR) [LStmtLR (GhcPass idL) (GhcPass idR) body], IsPass idR)
+ (Anno [LocatedA (StmtLR (GhcPass idL) (GhcPass idR) body)] ~ SrcSpanAnnL,
+ WrapXRec (GhcPass idR) [GenLocated (Anno (StmtLR (GhcPass idL) (GhcPass idR) body))
+ (StmtLR (GhcPass idL) (GhcPass idR) body)],
+
+ IsPass idL, IsPass idR)
=> XRecStmt (GhcPass idL) (GhcPass idR) body
-> StmtLR (GhcPass idL) (GhcPass idR) body
emptyRecStmt' tyVal =
@@ -458,7 +477,7 @@ mkLetStmt anns binds = LetStmt anns binds
-- | A useful function for building @OpApps@. The operator is always a
-- variable, and we don't know the fixity yet.
mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
-mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2
+mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocN op))) e2
mkHsString :: String -> HsLit (GhcPass p)
mkHsString s = HsString NoSourceText (mkFastString s)
@@ -485,11 +504,11 @@ mkConLikeTc con = XExpr (ConLikeTc con [] [])
nlHsVar :: IsSrcSpanAnn p a
=> IdP (GhcPass p) -> LHsExpr (GhcPass p)
-nlHsVar n = noLocA (HsVar noExtField (noLocA n))
+nlHsVar n = noLocA (HsVar noExtField (noLocN n))
nl_HsVar :: IsSrcSpanAnn p a
=> IdP (GhcPass p) -> HsExpr (GhcPass p)
-nl_HsVar n = HsVar noExtField (noLocA n)
+nl_HsVar n = HsVar noExtField (noLocN n)
-- | NB: Only for 'LHsExpr' 'Id'.
nlHsDataCon :: DataCon -> LHsExpr GhcTc
@@ -503,7 +522,7 @@ nlHsIntLit n = noLocA (HsLit noComments (HsInt noExtField (mkIntegralLit n)))
nlVarPat :: IsSrcSpanAnn p a
=> IdP (GhcPass p) -> LPat (GhcPass p)
-nlVarPat n = noLocA (VarPat noExtField (noLocA n))
+nlVarPat n = noLocA (VarPat noExtField (noLocN n))
nlLitPat :: HsLit GhcPs -> LPat GhcPs
nlLitPat l = noLocA (LitPat noExtField l)
@@ -528,8 +547,8 @@ nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
nlHsVarApps :: IsSrcSpanAnn p a
=> IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
-nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocA f))
- (map ((HsVar noExtField) . noLocA) xs))
+nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocN f))
+ (map ((HsVar noExtField) . noLocN) xs))
where
mk f a = HsApp noComments (noLocA f) (noLocA a)
@@ -541,7 +560,7 @@ nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
nlInfixConPat con l r = noLocA $ ConPat
- { pat_con = noLocA con
+ { pat_con = noLocN con
, pat_args = InfixCon (parenthesizePat opPrec l)
(parenthesizePat opPrec r)
, pat_con_ext = noAnn
@@ -550,28 +569,28 @@ nlInfixConPat con l r = noLocA $ ConPat
nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat con pats = noLocA $ ConPat
{ pat_con_ext = noAnn
- , pat_con = noLocA con
+ , pat_con = noLocN con
, pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)
}
nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
nlConPatName con pats = noLocA $ ConPat
{ pat_con_ext = noExtField
- , pat_con = noLocA con
+ , pat_con = noLocN con
, pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)
}
nlNullaryConPat :: RdrName -> LPat GhcPs
nlNullaryConPat con = noLocA $ ConPat
{ pat_con_ext = noAnn
- , pat_con = noLocA con
+ , pat_con = noLocN con
, pat_args = PrefixCon [] []
}
nlWildConPat :: DataCon -> LPat GhcPs
nlWildConPat con = noLocA $ ConPat
{ pat_con_ext = noAnn
- , pat_con = noLocA $ getRdrName con
+ , pat_con = noLocN $ getRdrName con
, pat_args = PrefixCon [] $
replicate (dataConSourceArity con)
nlWildPat
@@ -587,7 +606,7 @@ nlWildPatName = noLocA (WildPat noExtField )
nlHsDo :: HsDoFlavour -> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
-nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))
+nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocI stmts))
nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2)
@@ -599,7 +618,7 @@ nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
-- AZ:Is this used?
-nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match])))
+nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocI [match])))
nlHsPar e = noLocA (gHsPar e)
-- nlHsIf should generate if-expressions which are NOT subject to
@@ -608,7 +627,7 @@ nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf cond true false = noLocA (HsIf noAnn cond true false)
nlHsCase expr matches
- = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocA matches)))
+ = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocI matches)))
nlList exprs = noLocA (ExplicitList noAnn exprs)
nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
@@ -618,7 +637,7 @@ nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t))
-nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x))
+nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocN x))
nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) (parenthesizeHsType funPrec a) b)
nlHsParTy t = noLocA (HsParTy noAnn t)
@@ -629,7 +648,7 @@ nlHsTyConApp :: IsSrcSpanAnn p a
nlHsTyConApp prom fixity tycon tys
| Infix <- fixity
, HsValArg ty1 : HsValArg ty2 : rest <- tys
- = foldl' mk_app (noLocA $ HsOpTy noAnn prom ty1 (noLocA tycon) ty2) rest
+ = foldl' mk_app (noLocA $ HsOpTy noAnn prom ty1 (noLocN tycon) ty2) rest
| otherwise
= foldl' mk_app (nlHsTyVar prom tycon) tys
where
@@ -803,7 +822,7 @@ mkFunBind :: Origin -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-- ^ Not infix, with place holders for coercion and free vars
mkFunBind origin fn ms
= FunBind { fun_id = fn
- , fun_matches = mkMatchGroup origin (noLocA ms)
+ , fun_matches = mkMatchGroup origin (noLocI ms)
, fun_ext = noExtField
}
@@ -811,7 +830,7 @@ mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn
-- ^ In Name-land, with empty bind_fvs
mkTopFunBind origin fn ms = FunBind { fun_id = fn
- , fun_matches = mkMatchGroup origin (noLocA ms)
+ , fun_matches = mkMatchGroup origin (noLocI ms)
, fun_ext = emptyNameSet -- NB: closed
-- binding
}
@@ -867,8 +886,8 @@ spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))
mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
-> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind loc fun pats expr
- = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun)
- [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr
+ = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpanN loc) fun)
+ [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpanN loc) fun)) pats expr
emptyLocalBinds]
-- | Make a prefix, non-strict function 'HsMatchContext'
@@ -1440,7 +1459,7 @@ hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a)
=> [LForeignDecl (GhcPass p)] -> [LIdP (GhcPass p)]
-- ^ See Note [SrcSpan for binders]
hsForeignDeclsBinders foreign_decls
- = [ L (noAnnSrcSpan (locA decl_loc)) n
+ = [ L (noAnnSrcSpanN (locA decl_loc)) n
| L decl_loc (ForeignImport { fd_name = L _ n })
<- foreign_decls]
@@ -1740,6 +1759,6 @@ lPatImplicits = hs_lpat
, let pat_explicit =
maybe True ((i<) . unRecFieldsDotDot . unLoc)
(rec_dotdot fs)]
- err_loc = maybe (getLocA n) getLoc (rec_dotdot fs)
+ err_loc = maybe (getLocN n) getLoc (rec_dotdot fs)
details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2
diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs
index cc757a94e3..6f4796290e 100644
--- a/compiler/GHC/HsToCore/Arrows.hs
+++ b/compiler/GHC/HsToCore/Arrows.hs
@@ -810,7 +810,7 @@ dsCases ids local_vars stack_id stack_ty res_ty
-- implemented as `arr \case {}`.
Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>
dsExpr (HsLamCase EpAnnNotUsed LamCase
- (MG { mg_alts = noLocA []
+ (MG { mg_alts = noLocI []
, mg_ext = MatchGroupTc [Scaled ManyTy void_ty] res_ty Generated
}))
diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs
index f162dadaf5..f142817730 100644
--- a/compiler/GHC/HsToCore/Docs.hs
+++ b/compiler/GHC/HsToCore/Docs.hs
@@ -249,9 +249,12 @@ mkMaps env instances decls =
-> ( [(Name, [HsDoc GhcRn])]
, [(Name, IntMap (HsDoc GhcRn))]
)
- mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) =
+ mappings (L (EpAnnS anc _ _ ) decl, doc) =
(dm, am)
where
+ l = case anc of
+ EpaSpan (RealSrcSpan s _) -> Just s
+ _ -> Nothing
args = declTypeDocs decl
subs :: [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
@@ -263,14 +266,14 @@ mkMaps env instances decls =
ns = names l decl
dm = [(n, d) | (n, d) <- zip ns (repeat doc) ++ zip subNs subDocs, not $ all (isEmptyDocString . hsDocString) d]
am = [(n, args) | n <- ns] ++ zip subNs subArgs
- mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], [])
instanceMap :: Map RealSrcSpan Name
instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]
- names :: RealSrcSpan -> HsDecl GhcRn -> [Name]
+ names :: Maybe RealSrcSpan -> HsDecl GhcRn -> [Name]
names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap
- names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
+ names (Just l) (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].
+ names Nothing (DerivD {}) = []
names _ decl = getMainDeclBinder env decl
{-
@@ -327,12 +330,12 @@ getInstLoc = \case
-- type instance Foo Int = Bool
-- ^^^
DataFamInstD _ (DataFamInstDecl
- { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l
+ { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locN l
-- Since CoAxioms' Names refer to the whole line for type family instances
-- in particular, we need to dig a bit deeper to pull out the entire
-- equation. This does not happen for data family instances, for some reason.
TyFamInstD _ (TyFamInstDecl
- { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l
+ { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locN l
-- | Get all subordinate declarations inside a declaration, and their docs.
-- A subordinate declaration is something like the associate type or data
@@ -347,10 +350,10 @@ subordinates env instMap decl = case decl of
DataFamInstDecl { dfid_eqn =
FamEqn { feqn_tycon = L l _
, feqn_rhs = defn }} <- unLoc <$> cid_datafam_insts d
- [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn
+ [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locN l) instMap] ] ++ dataSubs defn
ty_fams = do
TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts d
- [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ]
+ [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locN l) instMap] ]
in data_fams ++ ty_fams
InstD _ (DataFamInstD _ (DataFamInstDecl d))
@@ -503,18 +506,19 @@ ungroup group_ =
-- | Collect docs and attach them to the right declarations.
--
-- A declaration may have multiple doc strings attached to it.
-collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDoc p])]
+-- collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDoc p])]
+collectDocs :: [LHsDecl GhcRn] -> [(LHsDecl GhcRn, [HsDoc GhcRn])]
-- ^ This is an example.
collectDocs = go [] Nothing
where
go docs mprev decls = case (decls, mprev) of
- ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing) -> go (unLoc s:docs) Nothing ds
- ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [unLoc s] Nothing ds
- ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev) -> go (unLoc s:docs) mprev ds
- (d : ds, Nothing) -> go docs (Just d) ds
- (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds
- ([] , Nothing) -> []
- ([] , Just prev) -> finished prev docs []
+ ((L _ (DocD _ (DocCommentNext s))) : ds, Nothing) -> go (unLoc s:docs) Nothing ds
+ ((L _ (DocD _ (DocCommentNext s))) : ds, Just prev) -> finished prev docs $ go [unLoc s] Nothing ds
+ ((L _ (DocD _ (DocCommentPrev s))) : ds, mprev) -> go (unLoc s:docs) mprev ds
+ (d : ds, Nothing) -> go docs (Just d) ds
+ (d : ds, Just prev) -> finished prev docs $ go [] (Just d) ds
+ ([] , Nothing) -> []
+ ([] , Just prev) -> finished prev docs []
finished decl docs rest = (decl, reverse docs) : rest
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 6a0bee9089..00e4784360 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -711,7 +711,7 @@ dsDo ctx stmts
; rhss' <- sequence rhss
- ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)
+ ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocI stmts)
; let match_args (pat, fail_op) (vs,body)
= putSrcSpanDs (getLocA pat) $
@@ -756,14 +756,14 @@ dsDo ctx stmts
rets = map noLocA rec_rets
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
mfix_arg = noLocA $ HsLam noExtField
- (MG { mg_alts = noLocA [mkSimpleMatch
+ (MG { mg_alts = noLocI [mkSimpleMatch
LambdaExpr
[mfix_pat] body]
, mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated
})
mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
body = noLocA $ HsDo body_ty
- ctx (noLocA (rec_stmts ++ [ret_stmt]))
+ ctx (noLocI (rec_stmts ++ [ret_stmt]))
ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
ret_stmt = noLocA $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo,
diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs
index 1c21f2a5e6..7d49b35f8d 100644
--- a/compiler/GHC/HsToCore/Match/Literal.hs
+++ b/compiler/GHC/HsToCore/Match/Literal.hs
@@ -575,7 +575,7 @@ tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty
_ -> Nothing
tidyNPat over_lit mb_neg eq outer_ty
- = NPat outer_ty (noLocA over_lit) mb_neg eq
+ = NPat outer_ty (noLocI over_lit) mb_neg eq
{-
************************************************************************
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 1edcde6924..9f85713798 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -22,7 +22,7 @@ module GHC.HsToCore.Monad (
duplicateLocalDs, newSysLocalDs,
newSysLocalsDs, newUniqueId,
newFailLocalDs, newPredVarDs,
- getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
+ getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA, putSrcSpanDsI,
mkNamePprCtxDs,
newUnique,
UniqSupply, newUniqueSupply,
@@ -429,9 +429,12 @@ putSrcSpanDs (UnhelpfulSpan {}) thing_inside
putSrcSpanDs (RealSrcSpan real_span _) thing_inside
= updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
-putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a
+putSrcSpanDsA :: EpAnnS ann -> DsM a -> DsM a
putSrcSpanDsA loc = putSrcSpanDs (locA loc)
+putSrcSpanDsI :: SrcSpanAnn' ann -> DsM a -> DsM a
+putSrcSpanDsI loc = putSrcSpanDs (locI loc)
+
-- | Emit a diagnostic for the current source location. In case the diagnostic is a warning,
-- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags.
-- See Note [Discarding Messages] in 'GHC.Types.Error'.
diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs
index 75a7121548..c5420f37cc 100644
--- a/compiler/GHC/HsToCore/Quote.hs
+++ b/compiler/GHC/HsToCore/Quote.hs
@@ -1463,7 +1463,7 @@ repMaybeLTy m = do
k_ty <- wrapName kindTyConName
repMaybeT k_ty repLTy m
-repRole :: LocatedAn NoEpAnns (Maybe Role) -> MetaM (Core TH.Role)
+repRole :: LocatedAnS NoEpAnns (Maybe Role) -> MetaM (Core TH.Role)
repRole (L _ (Just Nominal)) = rep2_nw nominalRName []
repRole (L _ (Just Representational)) = rep2_nw representationalRName []
repRole (L _ (Just Phantom)) = rep2_nw phantomRName []
@@ -1510,7 +1510,7 @@ repE (HsVar _ (L _ x)) =
repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar
repE (HsOverLabel _ _ s) = repOverLabel s
-repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocA x))
+repE (HsRecSel _ (FieldOcc x _)) = repE (HsVar noExtField (noLocN x))
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
index 8c0227df80..2fe1787420 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ b/compiler/GHC/HsToCore/Ticks.hs
@@ -723,7 +723,7 @@ addTickStmt isGuard stmt@(RecStmt {})
; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
- ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
+ ; return (stmt { recS_stmts = noLocI stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)
@@ -937,7 +937,7 @@ addTickCmdStmt stmt@(RecStmt {})
; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
- ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'
+ ; return (stmt { recS_stmts = noLocI stmts', recS_ret_fn = ret'
, recS_mfix_fn = mfix', recS_bind_fn = bind' }) }
addTickCmdStmt ApplicativeStmt{} =
panic "ToDo: addTickCmdStmt ApplicativeLastStmt"
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index 24a68e63c4..199f4c9efe 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -398,14 +398,14 @@ processGrp grp = concatM
, toHie $ hs_docs grp
]
-getRealSpanA :: SrcSpanAnn' ann -> Maybe Span
+getRealSpanA :: EpAnnS ann -> Maybe Span
getRealSpanA la = getRealSpan (locA la)
getRealSpan :: SrcSpan -> Maybe Span
getRealSpan (RealSrcSpan sp _) = Just sp
getRealSpan _ = Nothing
-grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns)
+grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnnS NoEpAnns)
=> GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan
grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLocA xs)
@@ -555,7 +555,7 @@ instance HasLoc (LocatedA a) where
loc (L la _) = locA la
instance HasLoc (LocatedN a) where
- loc (L la _) = locA la
+ loc (L la _) = locN la
instance HasLoc a => HasLoc [a] where
loc [] = noSrcSpan
@@ -610,15 +610,15 @@ instance (ToHie a) => ToHie (Maybe a) where
toHie = maybe (pure []) toHie
instance ToHie (IEContext (LocatedA ModuleName)) where
- toHie (IEC c (L (SrcSpanAnn _ (RealSrcSpan span _)) mname)) = do
+ toHie (IEC c (L (EpAnnS (EpaSpan (RealSrcSpan span _)) _ _) mname)) = do
org <- ask
pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []]
where details = mempty{identInfo = S.singleton (IEThing c)}
idents = M.singleton (Left mname) details
- toHie _ = pure []
+ toHie (IEC _ (L (EpAnnS _ _ _) _)) = pure []
instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where
- toHie (C c (L l a)) = toHie (C c (L (locA l) a))
+ toHie (C c (L l a)) = toHie (C c (L (locN l) a))
instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where
toHie (C c (L l a)) = toHie (C c (L (locA l) a))
@@ -839,7 +839,7 @@ type AnnoBody p body
, Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]
~ SrcSpanAnnL
, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcAnn NoEpAnns
+ ~ EpAnnS NoEpAnns
, Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA
, Data (body (GhcPass p))
@@ -897,7 +897,7 @@ instance ( HiePass p
toHie mg = case mg of
MG{ mg_alts = (L span alts) } ->
local (setOrigin origin) $ concatM
- [ locOnly (locA span)
+ [ locOnly (locI span)
, toHie alts
]
where origin = case hiePass @p of
@@ -1091,7 +1091,7 @@ instance ( ToHie (LocatedA (body (GhcPass p)))
instance ( ToHie (LocatedA (body (GhcPass p)))
, HiePass p
, AnnoBody p body
- ) => ToHie (LocatedAn NoEpAnns (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where
+ ) => ToHie (LocatedAnS NoEpAnns (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where
toHie (L span g) = concatM $ makeNodeA g span : case g of
GRHS _ guards body ->
[ toHie $ listScopes (mkLScopeA body) guards
@@ -1106,7 +1106,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
]
HsUnboundVar _ _ -> [] -- there is an unbound name here, but that causes trouble
HsRecSel _ fld ->
- [ toHie $ RFC RecFieldOcc Nothing (L (l2l mspan:: SrcAnn NoEpAnns) fld)
+ [ toHie $ RFC RecFieldOcc Nothing (L (l2l mspan:: EpAnnS NoEpAnns) fld)
]
HsOverLabel {} -> []
HsIPVar _ _ -> []
@@ -1168,7 +1168,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where
, toHie expr
]
HsDo _ _ (L ispan stmts) ->
- [ locOnly (locA ispan)
+ [ locOnly (locI ispan)
, toHie $ listScopes NoScope stmts
]
ExplicitList _ exprs ->
@@ -1374,14 +1374,14 @@ instance ( ToHie (RFContext label)
, toHie expr
]
-instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (FieldOcc (GhcPass p)))) where
+instance HiePass p => ToHie (RFContext (LocatedAnS NoEpAnns (FieldOcc (GhcPass p)))) where
toHie (RFC c rhs (L nspan f)) = concatM $ case f of
FieldOcc fld _ ->
case hiePass @p of
HieRn -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]
HieTc -> [toHie $ C (RecField c rhs) (L (locA nspan) fld)]
-instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (AmbiguousFieldOcc (GhcPass p)))) where
+instance HiePass p => ToHie (RFContext (LocatedAnS NoEpAnns (AmbiguousFieldOcc (GhcPass p)))) where
toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of
Unambiguous fld _ ->
case hiePass @p of
@@ -1411,7 +1411,7 @@ instance ToHie (HsConDeclGADTDetails GhcRn) where
toHie (PrefixConGADT args) = toHie args
toHie (RecConGADT rec _) = toHie rec
-instance HiePass p => ToHie (LocatedAn NoEpAnns (HsCmdTop (GhcPass p))) where
+instance HiePass p => ToHie (LocatedAnS NoEpAnns (HsCmdTop (GhcPass p))) where
toHie (L span top) = concatM $ makeNodeA top span : case top of
HsCmdTop _ cmd ->
[ toHie cmd
@@ -1454,7 +1454,7 @@ instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where
, toHie cmd'
]
HsCmdDo _ (L ispan stmts) ->
- [ locOnly (locA ispan)
+ [ locOnly (locI ispan)
, toHie $ listScopes NoScope stmts
]
XCmd _ -> []
@@ -1487,11 +1487,11 @@ instance ToHie (LocatedA (TyClDecl GhcRn)) where
, toHie defn
]
where
- quant_scope = mkLScopeA $ fromMaybe (noLocA []) $ dd_ctxt defn
+ quant_scope = mkLScopeI $ fromMaybe (noLocI []) $ dd_ctxt defn
rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc
sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn
con_sc = foldr combineScopes NoScope $ mkLScopeA <$> dd_cons defn
- deriv_sc = foldr combineScopes NoScope $ mkLScopeA <$> dd_derivs defn
+ deriv_sc = foldr combineScopes NoScope $ mkLScopeI <$> dd_derivs defn
ClassDecl { tcdCtxt = context
, tcdLName = name
, tcdTyVars = vars
@@ -1512,7 +1512,7 @@ instance ToHie (LocatedA (TyClDecl GhcRn)) where
, toHie deftyps
]
where
- context_scope = mkLScopeA $ fromMaybe (noLocA []) context
+ context_scope = mkLScopeI $ fromMaybe (noLocI []) context
rhs_scope = foldl1' combineScopes $ map mkScope
[ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]
@@ -1527,8 +1527,8 @@ instance ToHie (LocatedA (FamilyDecl GhcRn)) where
]
where
rhsSpan = sigSpan `combineScopes` injSpan
- sigSpan = mkScope $ getLocA sig
- injSpan = maybe NoScope (mkScope . getLocA) inj
+ sigSpan = mkScope $ getLocI sig
+ injSpan = maybe NoScope (mkScope . getLocI) inj
instance ToHie (FamilyInfo GhcRn) where
toHie (ClosedTypeFamily (Just eqns)) = concatM $
@@ -1539,8 +1539,8 @@ instance ToHie (FamilyInfo GhcRn) where
go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib
toHie _ = pure []
-instance ToHie (RScoped (LocatedAn NoEpAnns (FamilyResultSig GhcRn))) where
- toHie (RS sc (L span sig)) = concatM $ makeNodeA sig span : case sig of
+instance ToHie (RScoped (LocatedAn NoEpAnns (FamilyResultSig GhcRn))) where
+ toHie (RS sc (L span sig)) = concatM $ makeNodeI sig span : case sig of
NoSig _ ->
[]
KindSig _ k ->
@@ -1577,7 +1577,7 @@ instance (ToHie rhs, HasLoc rhs)
rhsScope = mkScope (loc rhs)
instance ToHie (LocatedAn NoEpAnns (InjectivityAnn GhcRn)) where
- toHie (L span ann) = concatM $ makeNodeA ann span : case ann of
+ toHie (L span ann) = concatM $ makeNodeI ann span : case ann of
InjectivityAnn _ lhs rhs ->
[ toHie $ C Use lhs
, toHie $ map (C Use) rhs
@@ -1598,26 +1598,26 @@ instance ToHie (Located [LocatedAn NoEpAnns (HsDerivingClause GhcRn)]) where
]
instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where
- toHie (L span cl) = concatM $ makeNodeA cl span : case cl of
+ toHie (L span cl) = concatM $ makeNodeI cl span : case cl of
HsDerivingClause _ strat dct ->
- [ toHie (RS (mkLScopeA dct) <$> strat)
+ [ toHie (RS (mkLScopeI dct) <$> strat)
, toHie dct
]
instance ToHie (LocatedC (DerivClauseTys GhcRn)) where
- toHie (L span dct) = concatM $ makeNodeA dct span : case dct of
+ toHie (L span dct) = concatM $ makeNodeI dct span : case dct of
DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ]
DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ]
instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where
- toHie (RS sc (L span strat)) = concatM $ makeNodeA strat span : case strat of
+ toHie (RS sc (L span strat)) = concatM $ makeNodeI strat span : case strat of
StockStrategy _ -> []
AnyclassStrategy _ -> []
NewtypeStrategy _ -> []
ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ]
instance ToHie (LocatedP OverlapMode) where
- toHie (L span _) = locOnly (locA span)
+ toHie (L span _) = locOnly (locI span)
instance ToHie a => ToHie (HsScaled GhcRn a) where
toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t]
@@ -1641,10 +1641,10 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where
]
where
rhsScope = combineScopes argsScope tyScope
- ctxScope = maybe NoScope mkLScopeA ctx
+ ctxScope = maybe NoScope mkLScopeI ctx
argsScope = case args of
PrefixConGADT xs -> scaled_args_scope xs
- RecConGADT x _ -> mkLScopeA x
+ RecConGADT x _ -> mkLScopeI x
tyScope = mkLScopeA typ
resScope = ResolvedScopes [ctxScope, rhsScope]
ConDeclH98 { con_name = name, con_ex_tvs = qvars
@@ -1658,17 +1658,17 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where
]
where
rhsScope = combineScopes ctxScope argsScope
- ctxScope = maybe NoScope mkLScopeA ctx
+ ctxScope = maybe NoScope mkLScopeI ctx
argsScope = case dets of
PrefixCon _ xs -> scaled_args_scope xs
InfixCon a b -> scaled_args_scope [a, b]
- RecCon x -> mkLScopeA x
+ RecCon x -> mkLScopeI x
where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope
scaled_args_scope = foldr combineScopes NoScope . map (mkLScopeA . hsScaledThing)
instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where
toHie (L span decls) = concatM $
- [ locOnly (locA span)
+ [ locOnly (locI span)
, toHie decls
]
@@ -1733,7 +1733,7 @@ instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where
]
SCCFunSig _ name mtxt ->
[ toHie $ (C Use) name
- , maybe (pure []) (locOnly . getLocA) mtxt
+ , maybe (pure []) (locOnly . getLocI) mtxt
]
CompleteMatchSig _ (L ispan names) typ ->
[ locOnly ispan
@@ -1860,7 +1860,7 @@ instance ToHie (TScoped (LHsQTyVars GhcRn)) where
instance ToHie (LocatedC [LocatedA (HsType GhcRn)]) where
toHie (L span tys) = concatM $
- [ locOnly (locA span)
+ [ locOnly (locI span)
, toHie tys
]
@@ -1909,7 +1909,7 @@ instance ToHie PendingTcSplice where
toHie (PendingTcSplice _ e) = toHie e
instance ToHie (LBooleanFormula (LocatedN Name)) where
- toHie (L span form) = concatM $ makeNode form (locA span) : case form of
+ toHie (L span form) = concatM $ makeNode form (locI span) : case form of
Var a ->
[ toHie $ C Use a
]
@@ -1923,8 +1923,8 @@ instance ToHie (LBooleanFormula (LocatedN Name)) where
[ toHie f
]
-instance ToHie (LocatedAn NoEpAnns HsIPName) where
- toHie (L span e) = makeNodeA e span
+instance ToHie (LocatedAn NoEpAnns HsIPName) where
+ toHie (L span e) = makeNodeI e span
instance HiePass p => ToHie (LocatedA (HsUntypedSplice (GhcPass p))) where
toHie (L span sp) = concatM $ makeNodeA sp span : case sp of
@@ -1932,7 +1932,7 @@ instance HiePass p => ToHie (LocatedA (HsUntypedSplice (GhcPass p))) where
[ toHie expr
]
HsQuasiQuote _ _ ispanFs ->
- [ locOnly (getLocA ispanFs)
+ [ locOnly (getLocI ispanFs)
]
instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where
@@ -2062,19 +2062,19 @@ instance ToHie (LocatedA (RuleDecls GhcRn)) where
instance ToHie (LocatedA (RuleDecl GhcRn)) where
toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM
[ makeNodeA r span
- , locOnly $ getLocA rname
+ , locOnly $ getLocI rname
, toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs
, toHie $ map (RS $ mkScope (locA span)) bndrs
, toHie exprA
, toHie exprB
]
where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc
- bndrs_sc = maybe NoScope mkLScopeA (listToMaybe bndrs)
+ bndrs_sc = maybe NoScope mkLScopeI (listToMaybe bndrs)
exprA_sc = mkLScopeA exprA
exprB_sc = mkLScopeA exprB
instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where
- toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of
+ toHie (RS sc (L span bndr)) = concatM $ makeNodeI bndr span : case bndr of
RuleBndr _ var ->
[ toHie $ C (ValBind RegularBind sc Nothing) var
]
@@ -2092,7 +2092,7 @@ instance ToHie (LocatedA (ImportDecl GhcRn)) where
]
where
goIE (hiding, (L sp liens)) = concatM $
- [ locOnly (locA sp)
+ [ locOnly (locI sp)
, toHie $ map (IEC c) liens
]
where
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
index 105e13acd9..a0e5571193 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ b/compiler/GHC/Iface/Ext/Utils.hs
@@ -527,7 +527,7 @@ locOnly (RealSrcSpan span _) = do
pure [Node e span []]
locOnly _ = pure []
-mkScopeA :: SrcSpanAnn' ann -> Scope
+mkScopeA :: EpAnnS ann -> Scope
mkScopeA l = mkScope (locA l)
mkScope :: SrcSpan -> Scope
@@ -537,11 +537,14 @@ mkScope _ = NoScope
mkLScope :: Located a -> Scope
mkLScope = mkScope . getLoc
-mkLScopeA :: GenLocated (SrcSpanAnn' a) e -> Scope
+mkLScopeA :: LocatedAnS a e -> Scope
mkLScopeA = mkScope . locA . getLoc
+mkLScopeI :: GenLocated (SrcAnn a) e -> Scope
+mkLScopeI = mkScope . locI . getLoc
+
mkLScopeN :: LocatedN a -> Scope
-mkLScopeN = mkScope . getLocA
+mkLScopeN = mkScope . getLocN
combineScopes :: Scope -> Scope -> Scope
combineScopes ModuleScope _ = ModuleScope
@@ -557,11 +560,19 @@ mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni
{-# INLINEABLE makeNodeA #-}
makeNodeA
:: (Monad m, Data a)
- => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
- -> SrcSpanAnn' ann -- ^ return an empty list if this is unhelpful
+ => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
+ -> EpAnnS ann -- ^ return an empty list if this is unhelpful
-> ReaderT NodeOrigin m [HieAST b]
makeNodeA x spn = makeNode x (locA spn)
+{-# INLINEABLE makeNodeI #-}
+makeNodeI
+ :: (Monad m, Data a)
+ => a -- ^ helps fill in 'nodeAnnotations' (with 'Data')
+ -> SrcAnn ann -- ^ return an empty list if this is unhelpful
+ -> ReaderT NodeOrigin m [HieAST b]
+makeNodeI x spn = makeNode x (locI spn)
+
{-# INLINEABLE makeNode #-}
makeNode
:: (Monad m, Data a)
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 2a81b9c2a0..47b9246ad1 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -291,7 +291,7 @@ mergeIfaceDecl d1 d2
(mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])
in d1 { ifBody = (ifBody d1) {
ifSigs = ops,
- ifMinDef = BF.mkOr [noLocA bf1, noLocA bf2]
+ ifMinDef = BF.mkOr [noLocI bf1, noLocI bf2]
}
} `withRolesFrom` d2
-- It doesn't matter; we'll check for consistency later when
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index d95d9d1512..a7a2880c15 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -886,7 +886,7 @@ unitdecl :: { LHsUnitDecl PackageName }
signature :: { Located (HsModule GhcPs) }
: 'signature' modid maybemodwarning maybeexports 'where' body
{% fileSrcSpan >>= \ loc ->
- acs (\cs-> (L loc (HsModule (XModulePs
+ acs (\cs -> (L loc (HsModule (XModulePs
(EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6) Nothing) cs)
(thdOf3 $6) $3 Nothing)
(Just $2) $4 (fst $ sndOf3 $6)
@@ -918,10 +918,10 @@ implicit_top :: { () }
maybemodwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) }
: '{-# DEPRECATED' strings '#-}'
- {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
+ {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))
(AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }
| '{-# WARNING' warning_category strings '#-}'
- {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))
+ {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))
(AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}
| {- empty -} { Nothing }
@@ -1362,18 +1362,18 @@ overlap_pragma :: { Maybe (LocatedP OverlapMode) }
| {- empty -} { Nothing }
deriv_strategy_no_via :: { LDerivStrategy GhcPs }
- : 'stock' {% acsA (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }
- | 'anyclass' {% acsA (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }
- | 'newtype' {% acsA (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }
+ : 'stock' {% acsI (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }
+ | 'anyclass' {% acsI (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }
+ | 'newtype' {% acsI (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }
deriv_strategy_via :: { LDerivStrategy GhcPs }
- : 'via' sigktype {% acsA (\cs -> sLLlA $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glR $1) [mj AnnVia $1] cs)
+ : 'via' sigktype {% acsI (\cs -> sLLlA $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glR $1) [mj AnnVia $1] cs)
$2))) }
deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
- : 'stock' {% fmap Just $ acsA (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }
- | 'anyclass' {% fmap Just $ acsA (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }
- | 'newtype' {% fmap Just $ acsA (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }
+ : 'stock' {% fmap Just $ acsI (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }
+ | 'anyclass' {% fmap Just $ acsI (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }
+ | 'newtype' {% fmap Just $ acsI (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }
| deriv_strategy_via { Just $1 }
| {- empty -} { Nothing }
@@ -1381,12 +1381,12 @@ deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }
opt_injective_info :: { Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)) }
: {- empty -} { noLoc ([], Nothing) }
- | '|' injectivity_cond { sLL $1 (reLoc $>) ([mj AnnVbar $1]
+ | '|' injectivity_cond { sLL $1 (reLocI $>) ([mj AnnVbar $1]
, Just ($2)) }
injectivity_cond :: { LInjectivityAnn GhcPs }
: tyvarid '->' inj_varids
- {% acsA (\cs -> sLL (reLocN $1) $> (InjectivityAnn (EpAnn (glNR $1) [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) }
+ {% acsI (\cs -> sLL (reLocN $1) $> (InjectivityAnn (EpAnn (glNR $1) [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) }
inj_varids :: { Located [LocatedN RdrName] }
: inj_varids tyvarid { sLL $1 (reLocN $>) ($2 : unLoc $1) }
@@ -1423,7 +1423,7 @@ ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }
(h:t) -> do
h' <- addTrailingSemiA h (gl $2)
return (sLL $1 $> (h':t)) }
- | ty_fam_inst_eqn { sLLAA $1 $> [$1] }
+ | ty_fam_inst_eqn { sL1 (reLoc $1) $ [$1] }
| {- empty -} { noLoc [] }
ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }
@@ -1527,24 +1527,24 @@ opt_kind_sig :: { Located ([AddEpAnn], Maybe (LHsKind GhcPs)) }
| '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], Just $2) }
opt_datafam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }
- : { noLoc ([] , noLocA (NoSig noExtField) )}
- | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLa $1 (reLoc $>) (KindSig noExtField $2))}
+ : { noLoc ([] , noLocI (NoSig noExtField) )}
+ | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLi $1 (reLoc $>) (KindSig noExtField $2))}
opt_tyfam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }
- : { noLoc ([] , noLocA (NoSig noExtField) )}
- | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLa $1 (reLoc $>) (KindSig noExtField $2))}
+ : { noLoc ([] , noLocI (NoSig noExtField) )}
+ | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLi $1 (reLoc $>) (KindSig noExtField $2))}
| '=' tv_bndr {% do { tvb <- fromSpecTyVarBndr $2
- ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLLa $1 (reLoc $>) (TyVarSig noExtField tvb))} }
+ ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLLi $1 (reLoc $>) (TyVarSig noExtField tvb))} }
opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs
, Maybe (LInjectivityAnn GhcPs)))}
- : { noLoc ([], (noLocA (NoSig noExtField), Nothing)) }
+ : { noLoc ([], (noLocI (NoSig noExtField), Nothing)) }
| '::' kind { sLL $1 (reLoc $>) ( [mu AnnDcolon $1]
- , (sL1a (reLoc $>) (KindSig noExtField $2), Nothing)) }
+ , (sL1i (reLoc $>) (KindSig noExtField $2), Nothing)) }
| '=' tv_bndr_no_braces '|' injectivity_cond
{% do { tvb <- fromSpecTyVarBndr $2
- ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1, mj AnnVbar $3]
- , (sLLa $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} }
+ ; return $ sLL $1 (reLocI $>) ([mj AnnEqual $1, mj AnnVbar $3]
+ , (sLLi $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} }
-- tycl_hdr parses the header of a class or data type decl,
-- which takes the form
@@ -1554,7 +1554,7 @@ opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs
-- T Int [a] -- for associated types
-- Rather a lot of inlining here, else we get reduce/reduce errors
tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }
- : context '=>' type {% acs (\cs -> (sLLAA $1 $> (Just (addTrailingDarrowC $1 $2 cs), $3))) }
+ : context '=>' type {% acs (\cs -> (sLL (reLocI $1) (reLoc $>) (Just (addTrailingDarrowC $1 $2 cs), $3))) }
| type { sL1A $1 (Nothing, $1) }
datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) }
@@ -1571,7 +1571,7 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs
; cs <- getCommentsFor loc
; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4))
} }
- | context '=>' type {% acs (\cs -> (sLLAA $1 $>(Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }
+ | context '=>' type {% acs (\cs -> (sLL (reLocI $1) (reLoc $>) (Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }
| type { sL1A $1 (Nothing, mkHsOuterImplicit, $1) }
@@ -1603,7 +1603,7 @@ stand_alone_deriving :: { LDerivDecl GhcPs }
role_annot :: { LRoleAnnotDecl GhcPs }
role_annot : 'type' 'role' oqtycon maybe_roles
- {% mkRoleAnnotDecl (comb3N $1 $4 $3) $3 (reverse (unLoc $4))
+ {% mkRoleAnnotDecl (comb3A $1 $4 $3) $3 (reverse (unLoc $4))
[mj AnnType $1,mj AnnRole $2] }
-- Reversed!
@@ -1638,7 +1638,7 @@ pattern_synonym_decl :: { LHsDecl GhcPs }
| 'pattern' pattern_synonym_lhs '<-' pat where_decls
{% do { let (name, args, as) = $2
; mg <- mkPatSynMatchGroup name $5
- ; acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $
+ ; acsA (\cs -> sLL $1 (reLocI $>) . ValD noExtField $
mkPatSynBind name args $4 (ExplicitBidirectional mg)
(EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs))
}}
@@ -1659,9 +1659,9 @@ cvars1 :: { [RecordPatSynField GhcPs] }
where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) }
: 'where' '{' decls '}' {% amsrl (sLL $1 $> (snd $ unLoc $3))
- (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) [mj AnnWhere $1] (fst $ unLoc $3)) }
+ (AnnList (glRM $3) (Just $ moc $2) (Just $ mcc $4) [mj AnnWhere $1] (fst $ unLoc $3)) }
| 'where' vocurly decls close {% amsrl (sLL $1 $3 (snd $ unLoc $3))
- (AnnList (Just $ glR $3) Nothing Nothing [mj AnnWhere $1] (fst $ unLoc $3))}
+ (AnnList (glRM $3) Nothing Nothing [mj AnnWhere $1] (fst $ unLoc $3))}
pattern_synonym_sig :: { LSig GhcPs }
: 'pattern' con_list '::' sigtype
@@ -1798,9 +1798,9 @@ decls :: { Located ([TrailingAnn], OrdList (LHsDecl GhcPs)) }
| {- empty -} { noLoc ([],nilOL) }
decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) }
- : '{' decls '}' { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)
+ : '{' decls '}' { sLL $1 $> (AnnList (glRM $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)
,sL1 $2 $ snd $ unLoc $2) }
- | vocurly decls close { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2)
+ | vocurly decls close { L (gl $2) (AnnList (glRM $2) Nothing Nothing [] (fst $ unLoc $2)
,sL1 $2 $ snd $ unLoc $2) }
-- Binding groups other than those of class and instance declarations
@@ -1816,7 +1816,7 @@ binds :: { Located (HsLocalBinds GhcPs) }
$ HsIPBinds (EpAnn (glR $1) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }
| vocurly dbinds close {% acs (\cs -> (L (gl $2)
- $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }
+ $ HsIPBinds (EpAnn (glR $1) (AnnList (glRM $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }
wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) }
@@ -1850,7 +1850,7 @@ rule :: { LRuleDecl GhcPs }
runPV (unECP $6) >>= \ $6 ->
acsA (\cs -> (sLLlA $1 $> $ HsRule
{ rd_ext = (EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs, getSTRINGs $1)
- , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)
+ , rd_name = L (noAnnSrcSpanI $ gl $1) (getSTRING $1)
, rd_act = (snd $2) `orElse` AlwaysActive
, rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3
, rd_lhs = $4, rd_rhs = $6 })) }
@@ -1909,8 +1909,8 @@ rule_vars :: { [LRuleTyTmVar] }
| {- empty -} { [] }
rule_var :: { LRuleTyTmVar }
- : varid { sL1l $1 (RuleTyTmVar noAnn $1 Nothing) }
- | '(' varid '::' ctype ')' {% acsA (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) }
+ : varid { sL1ln $1 (RuleTyTmVar noAnn $1 Nothing) }
+ | '(' varid '::' ctype ')' {% acsI (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) }
{- Note [Parsing explicit foralls in Rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1963,7 +1963,7 @@ warning :: { OrdList (LWarnDecl GhcPs) }
: warning_category namelist strings
{% fmap unitOL $ acsA (\cs -> sLL $2 $>
(Warning (EpAnn (glR $2) (fst $ unLoc $3) cs) (unLoc $2)
- (WarningTxt $1 (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
+ (WarningTxt $1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }
deprecations :: { OrdList (LWarnDecl GhcPs) }
: deprecations ';' deprecation
@@ -1986,7 +1986,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) }
deprecation :: { OrdList (LWarnDecl GhcPs) }
: namelist strings
{% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)
- (DeprecatedTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) }
+ (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) }
strings :: { Located ([AddEpAnn],[Located StringLiteral]) }
: STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }
@@ -2079,7 +2079,7 @@ opt_tyconsig :: { ([AddEpAnn], Maybe (LocatedN RdrName)) }
-- See Note [forall-or-nothing rule] in GHC.Hs.Type.
sigktype :: { LHsSigType GhcPs }
: sigtype { $1 }
- | ctype '::' kind {% acsA (\cs -> sLLAA $1 $> $ mkHsImplicitSigType $
+ | ctype '::' kind {% acsA (\cs -> sLL (reLoc $1) (reLoc $>) $ mkHsImplicitSigType $
sLLa (reLoc $1) (reLoc $>) $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }
-- Like ctype, but for types that obey the forall-or-nothing rule.
@@ -2120,7 +2120,7 @@ forall_telescope :: { Located (HsForAllTelescope GhcPs) }
-- A ktype is a ctype, possibly with a kind annotation
ktype :: { LHsType GhcPs }
: ctype { $1 }
- | ctype '::' kind {% acsA (\cs -> sLLAA $1 $> $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }
+ | ctype '::' kind {% acsA (\cs -> sLL (reLoc $1) (reLoc $>) $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }
-- A ctype is a for-all type
ctype :: { LHsType GhcPs }
@@ -2128,12 +2128,12 @@ ctype :: { LHsType GhcPs }
HsForAllTy { hst_tele = unLoc $1
, hst_xforall = noExtField
, hst_body = $2 } }
- | context '=>' ctype {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $
+ | context '=>' ctype {% acsA (\cs -> (sLL (reLocI $1) (reLoc $>) $
HsQualTy { hst_ctxt = addTrailingDarrowC $1 $2 cs
, hst_xqual = NoExtField
, hst_body = $3 })) }
- | ipvar '::' ctype {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (EpAnn (glR $1) [mu AnnDcolon $2] cs) (reLocA $1) $3)) }
+ | ipvar '::' ctype {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (EpAnn (glR $1) [mu AnnDcolon $2] cs) (reLocE $1) $3)) }
| type { $1 }
----------------------
@@ -2190,7 +2190,7 @@ infixtype :: { forall b. DisambTD b => PV (LocatedA b) }
| ftype tyop infixtype { $1 >>= \ $1 ->
$3 >>= \ $3 ->
do { let (op, prom) = $2
- ; when (looksLikeMult $1 op $3) $ hintLinear (getLocA op)
+ ; when (looksLikeMult $1 op $3) $ hintLinear (getLocN op)
; mkHsOpTyPV prom $1 op $3 } }
| unpackedness infixtype { $2 >>= \ $2 ->
mkUnpackednessPV $1 $2 }
@@ -2210,10 +2210,10 @@ tyarg :: { LHsType GhcPs }
tyop :: { (LocatedN RdrName, PromotionFlag) }
: qtyconop { ($1, NotPromoted) }
| tyvarop { ($1, NotPromoted) }
- | SIMPLEQUOTE qconop {% do { op <- amsrn (sLL $1 (reLoc $>) (unLoc $2))
+ | SIMPLEQUOTE qconop {% do { op <- amsrn (sLL $1 (reLocN $>) (unLoc $2))
(NameAnnQuote (glAA $1) (gl $2) [])
; return (op, IsPromoted) } }
- | SIMPLEQUOTE varop {% do { op <- amsrn (sLL $1 (reLoc $>) (unLoc $2))
+ | SIMPLEQUOTE varop {% do { op <- amsrn (sLL $1 (reLocN $>) (unLoc $2))
(NameAnnQuote (glAA $1) (gl $2) [])
; return (op, IsPromoted) } }
@@ -2228,7 +2228,7 @@ atype :: { LHsType GhcPs }
| PREFIX_TILDE atype {% acsA (\cs -> sLLlA $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnTilde $1] cs) SrcLazy $2)) }
| PREFIX_BANG atype {% acsA (\cs -> sLLlA $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnBang $1] cs) SrcStrict $2)) }
- | '{' fielddecls '}' {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glR $1) (AnnList (Just $ listAsAnchor $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))
+ | '{' fielddecls '}' {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glR $1) (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))
; checkRecordSyntax decls }}
-- Constructor sigs only
| '(' ')' {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $2)) cs)
@@ -2422,8 +2422,8 @@ constrs1 :: { Located [LConDecl GhcPs] }
constr :: { LConDecl GhcPs }
: forall context '=>' constr_stuff
{% acsA (\cs -> let (con,details) = unLoc $4 in
- (L (comb4 $1 (reLoc $2) $3 $4) (mkConDeclH98
- (EpAnn (spanAsAnchor (comb4 $1 (reLoc $2) $3 $4))
+ (L (comb4 $1 (reLocI $2) $3 $4) (mkConDeclH98
+ (EpAnn (spanAsAnchor (comb4 $1 (reLocI $2) $3 $4))
(mu AnnDarrow $3:(fst $ unLoc $1)) cs)
con
(snd $ unLoc $1)
@@ -2470,23 +2470,23 @@ maybe_derivings :: { Located (HsDeriving GhcPs) }
-- A list of one or more deriving clauses at the end of a datatype
derivings :: { Located (HsDeriving GhcPs) }
- : derivings deriving { sLL $1 (reLoc $>) ($2 : unLoc $1) } -- AZ: order?
- | deriving { sL1 (reLoc $>) [$1] }
+ : derivings deriving { sLL $1 (reLocI $>) ($2 : unLoc $1) } -- AZ: order?
+ | deriving { sL1 (reLocI $>) [$1] }
-- The outer Located is just to allow the caller to
-- know the rightmost extremity of the 'deriving' clause
deriving :: { LHsDerivingClause GhcPs }
: 'deriving' deriv_clause_types
- {% let { full_loc = comb2A $1 $> }
- in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) Nothing $2) }
+ {% let { full_loc = comb2 $1 (reLocI $>) }
+ in acsI (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) Nothing $2) }
| 'deriving' deriv_strategy_no_via deriv_clause_types
- {% let { full_loc = comb2A $1 $> }
- in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $2) $3) }
+ {% let { full_loc = comb2 $1 (reLocI $>) }
+ in acsI (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $2) $3) }
| 'deriving' deriv_clause_types deriv_strategy_via
- {% let { full_loc = comb2 $1 (reLoc $>) }
- in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) }
+ {% let { full_loc = comb2 $1 (reLocI $>) }
+ in acsI (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) }
deriv_clause_types :: { LDerivClauseTys GhcPs }
: qtycon { let { tc = sL1 (reLocL $1) $ mkHsImplicitSigType $
@@ -2526,7 +2526,7 @@ decl_no_th :: { LHsDecl GhcPs }
: sigdecl { $1 }
| infixexp opt_sig rhs {% runPV (unECP $1) >>= \ $1 ->
- do { let { l = comb2Al $1 $> }
+ do { let { l = comb2 (reLoc $1) $> }
; r <- checkValDef l $1 $2 $3;
-- Depending upon what the pattern looks like we might get either
-- a FunBind or PatBind back from checkValDef. See Note
@@ -2568,7 +2568,7 @@ sigdecl :: { LHsDecl GhcPs }
infixexp '::' sigtype
{% do { $1 <- runPV (unECP $1)
; v <- checkValSigLhs $1
- ; acsA (\cs -> (sLLAl $1 (reLoc $>) $ SigD noExtField $
+ ; acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $ SigD noExtField $
TypeSig (EpAnn (glAR $1) (AnnSig (mu AnnDcolon $2) []) cs) [v] (mkHsWildCardBndrs $3)))} }
| var ',' sig_vars '::' sigtype
@@ -2613,7 +2613,7 @@ sigdecl :: { LHsDecl GhcPs }
| '{-# SCC' qvar STRING '#-}'
{% do { scc <- getSCC $3
; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing
- ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $4] cs), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }}
+ ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $4] cs), (getSCC_PRAGs $1)) $2 (Just ( sL1i $3 str_lit))))) }}
| '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
{% acsA (\cs ->
@@ -2653,38 +2653,38 @@ quasiquote :: { Located (HsUntypedSplice GhcPs) }
: TH_QUASIQUOTE { let { loc = getLoc $1
; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkUnqual varName quoter }
- in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) }
+ in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpanI (mkSrcSpanPs quoteSpan)) quote)) }
| TH_QQUASIQUOTE { let { loc = getLoc $1
; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1
; quoterId = mkQual varName (qual, quoter) }
- in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) }
+ in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpanI (mkSrcSpanPs quoteSpan)) quote)) }
exp :: { ECP }
: infixexp '::' ctype
{ ECP $
unECP $1 >>= \ $1 ->
rejectPragmaPV $1 >>
- mkHsTySigPV (noAnnSrcSpan $ comb2Al $1 (reLoc $>)) $1 $3
+ mkHsTySigPV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 $3
[(mu AnnDcolon $2)] }
| infixexp '-<' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annlarrowtail $2) cs) $1 $3
+ acsA (\cs -> sLL (reLoc $1) (reLoc $>) $ HsCmdArrApp (EpAnn (glAR $1) (mu Annlarrowtail $2) cs) $1 $3
HsFirstOrderApp True) }
| infixexp '>-' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annrarrowtail $2) cs) $3 $1
+ acsA (\cs -> sLL (reLoc $1) (reLoc $>) $ HsCmdArrApp (EpAnn (glAR $1) (mu Annrarrowtail $2) cs) $3 $1
HsFirstOrderApp False) }
| infixexp '-<<' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnLarrowtail $2) cs) $1 $3
+ acsA (\cs -> sLL (reLoc $1) (reLoc $>) $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnLarrowtail $2) cs) $1 $3
HsHigherOrderApp True) }
| infixexp '>>-' exp {% runPV (unECP $1) >>= \ $1 ->
runPV (unECP $3) >>= \ $3 ->
fmap ecpFromCmd $
- acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnRarrowtail $2) cs) $3 $1
+ acsA (\cs -> sLL (reLoc $1) (reLoc $>) $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnRarrowtail $2) cs) $3 $1
HsHigherOrderApp False) }
-- See Note [%shift: exp -> infixexp]
| infixexp %shift { $1 }
@@ -2824,8 +2824,8 @@ aexp :: { ECP }
{ ECP $
unECP $4 >>= \ $4 ->
mkHsLamPV (comb2 $1 (reLoc $>)) (\cs -> mkMatchGroup FromSource
- (reLocA $ sLLlA $1 $>
- [reLocA $ sLLlA $1 $>
+ (reLocE $ sLL $1 (reLoc $>)
+ [reLocA $ sLL $1 (reLoc $>)
$ Match { m_ext = EpAnn (glR $1) [mj AnnLam $1] cs
, m_ctxt = LambdaExpr
, m_pats = $2
@@ -2835,10 +2835,10 @@ aexp :: { ECP }
mkHsLetPV (comb2A $1 $>) (hsTok $1) (unLoc $2) (hsTok $3) $4 }
| '\\' 'lcase' altslist(pats1)
{ ECP $ $3 >>= \ $3 ->
- mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCase $3 [mj AnnLam $1,mj AnnCase $2] }
+ mkHsLamCasePV (comb2 $1 (reLocI $>)) LamCase $3 [mj AnnLam $1,mj AnnCase $2] }
| '\\' 'lcases' altslist(apats)
{ ECP $ $3 >>= \ $3 ->
- mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCases $3 [mj AnnLam $1,mj AnnCases $2] }
+ mkHsLamCasePV (comb2 $1 (reLocI $>)) LamCases $3 [mj AnnLam $1,mj AnnCases $2] }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
return $ ECP $
@@ -2859,24 +2859,24 @@ aexp :: { ECP }
| 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->
return $ ECP $
$4 >>= \ $4 ->
- mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4
+ mkHsCasePV (comb3 $1 $3 (reLocI $4)) $2 $4
(EpAnnHsCase (glAA $1) (glAA $3) []) }
-- QualifiedDo.
| DO stmtlist {% do
hintQualifiedDo $1
return $ ECP $
$2 >>= \ $2 ->
- mkHsDoPV (comb2A $1 $2)
+ mkHsDoPV (comb2 $1 (reLocI $2))
(fmap mkModuleNameFS (getDO $1))
$2
- (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnDo $1] []) }
+ (AnnList (Just $ glIR $2) Nothing Nothing [mj AnnDo $1] []) }
| MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->
fmap ecpFromExp $
- acsA (\cs -> L (comb2A $1 $2)
+ acsA (\cs -> L (comb2 $1 (reLocI $2))
(mkHsDoAnns (MDoExpr $
fmap mkModuleNameFS (getMDO $1))
$2
- (EpAnn (glR $1) (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) }
+ (EpAnn (glR $1) (AnnList (Just $ glIR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) }
| 'proc' aexp '->' exp
{% (checkPattern <=< runPV) (unECP $2) >>= \ p ->
runPV (unECP $4) >>= \ $4@cmd ->
@@ -2898,8 +2898,8 @@ aexp1 :: { ECP }
| aexp1 TIGHT_INFIX_PROJ field
{% runPV (unECP $1) >>= \ $1 ->
fmap ecpFromExp $ acsa (\cs ->
- let fl = sLLa $2 (reLoc $>) (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in
- mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 fl (EpAnn (glAR $1) NoEpAnns cs)) }
+ let fl = sLLi $2 (reLocN $>) (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in
+ mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) (reLocN $>)) $1 fl (EpAnn (glAR $1) NoEpAnns cs)) }
| aexp2 { $1 }
@@ -2977,15 +2977,15 @@ aexp2 :: { ECP }
-- arrow notation extension
| '(|' aexp cmdargs '|)' {% runPV (unECP $2) >>= \ $2 ->
fmap ecpFromCmd $
- acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix
+ acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glR $1) (AnnList (glRM $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix
Nothing (reverse $3)) }
projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) }
projection
-- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer
: projection TIGHT_INFIX_PROJ field
- {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $2 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) }
- | PREFIX_PROJ field {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $1 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }
+ {% acs (\cs -> sLL $1 (reLocN $>) ((sLLi $2 (reLocN $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) }
+ | PREFIX_PROJ field {% acs (\cs -> sLL $1 (reLocN $>) ((sLLi $1 (reLocN $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }
splice_exp :: { LHsExpr GhcPs }
: splice_untyped { fmap (HsUntypedSplice noAnn) (reLocA $1) }
@@ -3045,12 +3045,12 @@ texp :: { ECP }
runPV (rejectPragmaPV $1) >>
runPV $2 >>= \ $2 ->
return $ ecpFromExp $
- reLocA $ sLL (reLoc $1) (reLocN $>) $ SectionL noAnn $1 (n2l $2) }
+ reLocA $ sLL (reLoc $1) (reLocN $>) $ SectionL noAnn $1 (la2la $2) }
| qopm infixexp { ECP $
superInfixOp $
unECP $2 >>= \ $2 ->
$1 >>= \ $1 ->
- pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }
+ pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (la2la $1) $2 }
-- View patterns get parenthesized above
| exp '->' texp { ECP $
@@ -3243,12 +3243,12 @@ guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }
altslist(PATS) :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) }
: '{' alts(PATS) '}' { $2 >>= \ $2 -> amsrl
(sLL $1 $> (reverse (snd $ unLoc $2)))
- (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }
+ (AnnList (glRM $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }
| vocurly alts(PATS) close { $2 >>= \ $2 -> amsrl
(L (getLoc $2) (reverse (snd $ unLoc $2)))
- (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) }
+ (AnnList (glRM $2) Nothing Nothing (fst $ unLoc $2) []) }
| '{' '}' { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) }
- | vocurly close { return $ noLocA [] }
+ | vocurly close { return $ noLocI [] }
alts(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }
: alts1(PATS) { $1 >>= \ $1 -> return $
@@ -3343,9 +3343,9 @@ apats :: { [LPat GhcPs] }
stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) }
: '{' stmts '}' { $2 >>= \ $2 ->
- amsrl (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }
+ amsrl (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }
| vocurly stmts close { $2 >>= \ $2 -> amsrl
- (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }
+ (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }
-- do { ;; s ; s ; ; s ;; }
-- The last Stmt should be an expression, but that's hard to enforce
@@ -3387,7 +3387,7 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }
stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }
: qual { $1 }
| 'rec' stmtlist { $2 >>= \ $2 ->
- acsA (\cs -> (sLL $1 (reLoc $>) $ mkRecStmt
+ acsA (\cs -> (sLL $1 (reLocI $>) $ mkRecStmt
(EpAnn (glR $1) (hsDoAnn $1 $2 AnnRec) cs)
$2)) }
@@ -3419,13 +3419,13 @@ fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }
fbind :: { forall b. DisambECP b => PV (Fbind b) }
: qvar '=' texp { unECP $3 >>= \ $3 ->
- fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsFieldBind (EpAnn (glNR $1) [mj AnnEqual $2] cs) (sL1l $1 $ mkFieldOcc $1) $3 False) }
+ fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsFieldBind (EpAnn (glNR $1) [mj AnnEqual $2] cs) (reLocA $ sL1 (reLoc $1) $ mkFieldOcc $1) $3 False) }
-- RHS is a 'texp', allowing view patterns (#6038)
-- and, incidentally, sections. Eg
-- f (R { x = show -> s }) = ...
| qvar { placeHolderPunRhs >>= \rhs ->
- fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsFieldBind (EpAnn (glNR $1) [] cs) (sL1l $1 $ mkFieldOcc $1) rhs True) }
+ fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsFieldBind (EpAnn (glNR $1) [] cs) (reLocA $ sL1 (reLoc $1) $ mkFieldOcc $1) rhs True) }
-- In the punning case, use a place-holder
-- The renamer fills in the final value
@@ -3433,15 +3433,15 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) }
-- AZ: need to pull out the let block into a helper
| field TIGHT_INFIX_PROJ fieldToUpdate '=' texp
{ do
- let top = sL1 (la2la $1) $ DotFieldOcc noAnn $1
+ let top = sL1 (n2l $1) $ DotFieldOcc noAnn $1
((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)
- lf' = comb2 $2 (reLoc $ L lf ())
- fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t
+ lf' = comb2 $2 (reLocI $ L lf ())
+ fields = top : L (noAnnSrcSpanI lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t
final = last fields
- l = comb2 (reLoc $1) $3
+ l = comb2 (reLocN $1) $3
isPun = False
$5 <- unECP $5
- fmap Right $ mkHsProjUpdatePV (comb2 (reLoc $1) (reLoc $5)) (L l fields) $5 isPun
+ fmap Right $ mkHsProjUpdatePV (comb2 (reLocN $1) (reLoc $5)) (L l fields) $5 isPun
[mj AnnEqual $4]
}
@@ -3449,24 +3449,24 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) }
-- AZ: need to pull out the let block into a helper
| field TIGHT_INFIX_PROJ fieldToUpdate
{ do
- let top = sL1 (la2la $1) $ DotFieldOcc noAnn $1
+ let top = sL1 (n2l $1) $ DotFieldOcc noAnn $1
((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)
- lf' = comb2 $2 (reLoc $ L lf ())
- fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t
+ lf' = comb2 $2 (reLocI $ L lf ())
+ fields = top : L (noAnnSrcSpanI lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t
final = last fields
- l = comb2 (reLoc $1) $3
+ l = comb2 (reLocN $1) $3
isPun = True
- var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final))
+ var <- mkHsVarPV (L (noAnnSrcSpanN $ getLocI final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final))
fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []
}
fieldToUpdate :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] }
fieldToUpdate
-- See Note [Whitespace-sensitive operator parsing] in Lexer.x
- : fieldToUpdate TIGHT_INFIX_PROJ field {% getCommentsFor (getLocA $3) >>= \cs ->
- return (sLL $1 (reLoc $>) ((sLLa $2 (reLoc $>) (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }
- | field {% getCommentsFor (getLocA $1) >>= \cs ->
- return (sL1 (reLoc $1) [sL1a (reLoc $1) (DotFieldOcc (EpAnn (glNR $1) (AnnFieldLabel Nothing) cs) $1)]) }
+ : fieldToUpdate TIGHT_INFIX_PROJ field {% getCommentsFor (getLocN $3) >>= \cs ->
+ return (sLL $1 (reLocN $>) ((sLLi $2 (reLocN $>) (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }
+ | field {% getCommentsFor (getLocN $1) >>= \cs ->
+ return (sL1 (reLocN $1) [sL1i (reLocN $1) (DotFieldOcc (EpAnn (glNR $1) (AnnFieldLabel Nothing) cs) $1)]) }
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
@@ -3487,7 +3487,7 @@ dbinds :: { Located [LIPBind GhcPs] } -- reversed
dbind :: { LIPBind GhcPs }
dbind : ipvar '=' exp {% runPV (unECP $3) >>= \ $3 ->
- acsA (\cs -> sLLlA $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (reLocA $1) $3)) }
+ acsA (\cs -> sLLlA $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (reLocE $1) $3)) }
ipvar :: { Located HsIPName }
: IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) }
@@ -3503,17 +3503,17 @@ overloaded_label :: { Located (SourceText, FastString) }
name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) }
: name_boolformula { $1 }
- | {- empty -} { noLocA mkTrue }
+ | {- empty -} { noLocI mkTrue }
name_boolformula :: { LBooleanFormula (LocatedN RdrName) }
: name_boolformula_and { $1 }
| name_boolformula_and '|' name_boolformula
{% do { h <- addTrailingVbarL $1 (gl $2)
- ; return (reLocA $ sLLAA $1 $> (Or [h,$3])) } }
+ ; return (reLocE $ sLLAA $1 $> (Or [h,$3])) } }
name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) }
: name_boolformula_and_list
- { reLocA $ sLLAA (head $1) (last $1) (And ($1)) }
+ { reLocE $ sLLAA (head $1) (last $1) (And ($1)) }
name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }
: name_boolformula_atom { [$1] }
@@ -3524,7 +3524,7 @@ name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }
name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }
: '(' name_boolformula ')' {% amsrl (sLL $1 $> (Parens $2))
(AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) }
- | name_var { reLocA $ sL1N $1 (Var $1) }
+ | name_var { reLocE $ sL1N $1 (Var $1) }
namelist :: { Located [LocatedN RdrName] }
namelist : name_var { sL1N $1 [$1] }
@@ -4011,26 +4011,22 @@ comb2 :: Located a -> Located b -> SrcSpan
comb2 a b = a `seq` b `seq` combineLocs a b
-- Utilities for combining source spans
-comb2A :: Located a -> LocatedAn t b -> SrcSpan
+comb2A :: (Monoid t) => Located a -> LocatedAnS t b -> SrcSpan
comb2A a b = a `seq` b `seq` combineLocs a (reLoc b)
comb2N :: Located a -> LocatedN b -> SrcSpan
comb2N a b = a `seq` b `seq` combineLocs a (reLocN b)
comb2Al :: LocatedAn t a -> Located b -> SrcSpan
-comb2Al a b = a `seq` b `seq` combineLocs (reLoc a) b
+comb2Al a b = a `seq` b `seq` combineLocs (reLocI a) b
comb3 :: Located a -> Located b -> Located c -> SrcSpan
comb3 a b c = a `seq` b `seq` c `seq`
combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))
-comb3A :: Located a -> Located b -> LocatedAn t c -> SrcSpan
+comb3A :: Located a -> Located b -> LocatedN c -> SrcSpan
comb3A a b c = a `seq` b `seq` c `seq`
- combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))
-
-comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan
-comb3N a b c = a `seq` b `seq` c `seq`
- combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))
+ combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocN c))
comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan
comb4 a b c d = a `seq` b `seq` c `seq` d `seq`
@@ -4059,49 +4055,75 @@ sL1 :: GenLocated l a -> b -> GenLocated l b
sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sL1A #-}
-sL1A :: LocatedAn t a -> b -> Located b
+-- sL1A :: LocatedAn t a -> b -> Located b
+sL1A :: LocatedAnS t a -> b -> Located b
sL1A x = sL (getLocA x) -- #define sL1 sL (getLoc $1)
{-# INLINE sL1N #-}
sL1N :: LocatedN a -> b -> Located b
-sL1N x = sL (getLocA x) -- #define sL1 sL (getLoc $1)
+sL1N x = sL (getLocN x) -- #define sL1 sL (getLoc $1)
{-# INLINE sL1a #-}
-sL1a :: Located a -> b -> LocatedAn t b
+-- sL1a :: Located a -> b -> LocatedAn t b
+sL1a :: (Monoid t) => Located a -> b -> LocatedAnS t b
sL1a x = sL (noAnnSrcSpan $ getLoc x) -- #define sL1 sL (getLoc $1)
+{-# INLINE sL1i #-}
+sL1i :: Located a -> b -> LocatedAn t b
+sL1i x = sL (noAnnSrcSpanI $ getLoc x) -- #define sL1 sL (getLoc $1)
+
+
{-# INLINE sL1l #-}
sL1l :: LocatedAn t a -> b -> LocatedAn u b
-sL1l x = sL (l2l $ getLoc x) -- #define sL1 sL (getLoc $1)
+sL1l x = sL (l2li $ getLoc x) -- #define sL1 sL (getLoc $1)
+
+{-# INLINE sL1ln #-}
+sL1ln :: LocatedN a -> b -> LocatedAn u b
+sL1ln x = sL (noAnnSrcSpanI $ getLocN x) -- #define sL1 sL (getLoc $1)
{-# INLINE sL1n #-}
sL1n :: Located a -> b -> LocatedN b
-sL1n x = L (noAnnSrcSpan $ getLoc x) -- #define sL1 sL (getLoc $1)
+sL1n x = L (noAnnSrcSpanN $ getLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sLL #-}
sLL :: Located a -> Located b -> c -> Located c
sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
{-# INLINE sLLa #-}
-sLLa :: Located a -> Located b -> c -> LocatedAn t c
+-- sLLa :: Located a -> Located b -> c -> LocatedAn t c
+sLLa :: (Monoid t) => Located a -> Located b -> c -> LocatedAnS t c
sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>)
+{-# INLINE sLLi #-}
+sLLi :: Located a -> Located b -> c -> LocatedAn t c
+sLLi x y = sL (noAnnSrcSpanI $ comb2 x y) -- #define LL sL (comb2 $1 $>)
+
{-# INLINE sLLlA #-}
-sLLlA :: Located a -> LocatedAn t b -> c -> Located c
+-- sLLlA :: Located a -> LocatedAn t b -> c -> Located c
+sLLlA :: (Monoid t) => Located a -> LocatedAnS t b -> c -> Located c
sLLlA x y = sL (comb2A x y) -- #define LL sL (comb2 $1 $>)
{-# INLINE sLLAl #-}
-sLLAl :: LocatedAn t a -> Located b -> c -> Located c
-sLLAl x y = sL (comb2A y x) -- #define LL sL (comb2 $1 $>)
+sLLAl :: (Monoid t) => LocatedAnS t a -> Located b -> c -> Located c
+sLLAl x y = sL (comb2 y (reLoc x)) -- #define LL sL (comb2 $1 $>)
+
+{-# INLINE sLLIl #-}
+sLLIl :: LocatedAn t a -> Located b -> c -> Located c
+sLLIl x y = sL (comb2 y (reLocI x)) -- #define LL sL (comb2 $1 $>)
{-# INLINE sLLAsl #-}
-sLLAsl :: [LocatedAn t a] -> Located b -> c -> Located c
+sLLAsl :: (Monoid t) => [LocatedAnS t a] -> Located b -> c -> Located c
sLLAsl [] = sL1
sLLAsl (x:_) = sLLAl x
+{-# INLINE sLLIsl #-}
+sLLIsl :: [LocatedAn t a] -> Located b -> c -> Located c
+sLLIsl [] = sL1
+sLLIsl (x:_) = sLLIl x
+
{-# INLINE sLLAA #-}
sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c
-sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL sL (comb2 $1 $>)
+sLLAA x y = sL (comb2 (reLocI y) (reLocI x)) -- #define LL sL (comb2 $1 $>)
{- Note [Adding location info]
@@ -4161,7 +4183,7 @@ looksLikeMult ty1 l_op ty2
| Unqual op_name <- unLoc l_op
, occNameFS op_name == fsLit "%"
, Strict.Just ty1_pos <- getBufSpan (getLocA ty1)
- , Strict.Just pct_pos <- getBufSpan (getLocA l_op)
+ , Strict.Just pct_pos <- getBufSpan (getLocN l_op)
, Strict.Just ty2_pos <- getBufSpan (getLocA ty2)
, bufSpanEnd ty1_pos /= bufSpanStart pct_pos
, bufSpanEnd pct_pos == bufSpanStart ty2_pos
@@ -4253,32 +4275,42 @@ toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax
gl :: GenLocated l a -> l
gl = getLoc
-glA :: LocatedAn t a -> SrcSpan
+glA :: LocatedAnS t a -> SrcSpan
glA = getLocA
+glI :: LocatedAn t a -> SrcSpan
+glI = getLocI
+
glN :: LocatedN a -> SrcSpan
-glN = getLocA
+glN = getLocN
glR :: Located a -> Anchor
-glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor
+glR la = spanAsAnchor$ getLoc la
+
+glRM :: Located a -> Maybe Anchor
+glRM (L (RealSrcSpan la mb) _) = Just $ EpaSpan (RealSrcSpan la mb)
+glRM _ = Nothing
glAA :: Located a -> EpaLocation
glAA = srcSpan2e . getLoc
glRR :: Located a -> RealSrcSpan
-glRR = realSrcSpan . getLoc
+glRR = realSrcSpan "glRR" . getLoc
-glAR :: LocatedAn t a -> Anchor
-glAR la = Anchor (realSrcSpan $ getLocA la) UnchangedAnchor
+glAR :: LocatedAnS t a -> Anchor
+glAR la = spanAsAnchor $ getLocA la
+
+glIR :: LocatedAn t a -> Anchor
+glIR la = spanAsAnchor $ getLocI la
glNR :: LocatedN a -> Anchor
-glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor
+glNR ln = spanAsAnchor $ getLocN ln
glNRR :: LocatedN a -> EpaLocation
-glNRR = srcSpan2e . getLocA
+glNRR = srcSpan2e . getLocN
anc :: RealSrcSpan -> Anchor
-anc r = Anchor r UnchangedAnchor
+anc r = EpaSpan (RealSrcSpan r Strict.Nothing)
acs :: MonadP m => (EpAnnComments -> Located a) -> m (Located a)
acs a = do
@@ -4298,16 +4330,20 @@ acsFinal a = do
Strict.Just (pos `Strict.And` gap) -> Just (pos,gap)
return (a (cs Semi.<> csf) ce)
-
-acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)
+-- acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)
+acsa :: (Monoid t, MonadP m) => (EpAnnComments -> LocatedAnS t a) -> m (LocatedAnS t a)
acsa a = do
let (L l _) = a emptyComments
cs <- getCommentsFor (locA l)
return (a cs)
-acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)
+-- acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)
+acsA :: (Monoid t, MonadP m) => (EpAnnComments -> Located a) -> m (LocatedAnS t a)
acsA a = reLocA <$> acs a
+acsI :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)
+acsI a = reLocE <$> acs a
+
acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP
acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a
; return (ecpFromExp $ expr) }
@@ -4340,8 +4376,7 @@ amsrp a@(L l _) bs = do
amsrn :: MonadP m => Located a -> NameAnn -> m (LocatedN a)
amsrn (L l a) an = do
cs <- getCommentsFor l
- let ann = (EpAnn (spanAsAnchor l) an cs)
- return (L (SrcSpanAnn ann l) a)
+ return (L (EpAnnS (spanAsAnchor l) an cs) a)
-- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose
mo,mc :: Located Token -> AddEpAnn
@@ -4364,17 +4399,21 @@ mos,mcs :: Located Token -> AddEpAnn
mos ll = mj AnnOpenS ll
mcs ll = mj AnnCloseS ll
-pvA :: MonadP m => m (Located a) -> m (LocatedAn t a)
+pvA :: (Monoid t) => MonadP m => m (Located a) -> m (LocatedAnS t a)
pvA a = do { av <- a
; return (reLocA av) }
+pvI :: MonadP m => m (Located a) -> m (LocatedAn t a)
+pvI a = do { av <- a
+ ; return (reLocE av) }
+
pvN :: MonadP m => m (Located a) -> m (LocatedN a)
pvN a = do { (L l av) <- a
- ; return (L (noAnnSrcSpan l) av) }
+ ; return (L (noAnnSrcSpanN l) av) }
pvL :: MonadP m => m (LocatedAn t a) -> m (Located a)
pvL a = do { av <- a
- ; return (reLoc av) }
+ ; return (reLocI av) }
-- | Parse a Haskell module with Haddock comments.
-- This is done in two steps:
@@ -4388,16 +4427,19 @@ pvL a = do { av <- a
parseModule :: P (Located (HsModule GhcPs))
parseModule = parseModuleNoHaddock >>= addHaddockToModule
-commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)
-commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc
+commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> (EpAnnS ann)
+commentsA loc cs = (EpAnnS (spanAsAnchor loc) mempty cs)
+
+commentsI :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)
+commentsI loc cs = SrcSpanAnn (EpAnn (spanAsAnchor loc) mempty cs) loc
-- | Instead of getting the *enclosed* comments, this includes the
-- *preceding* ones. It is used at the top level to get comments
-- between top level declarations.
-commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a)
+commentsPA :: (Monoid ann) => LocatedAnS ann a -> P (LocatedAnS ann a)
commentsPA la@(L l a) = do
cs <- getPriorCommentsFor (getLocA la)
- return (L (addCommentsToSrcAnn l cs) a)
+ return (L (addCommentsToEpAnnS l cs) a)
rs :: SrcSpan -> RealSrcSpan
rs (RealSrcSpan l _) = l
@@ -4405,12 +4447,21 @@ rs _ = panic "Parser should only have RealSrcSpan"
hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList
hsDoAnn (L l _) (L ll _) kw
- = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []
+ = case locI ll of
+ RealSrcSpan lll _ -> AnnList (Just$ realSpanAsAnchor lll) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []
+ _ -> AnnList Nothing Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []
-listAsAnchor :: [LocatedAn t a] -> Anchor
+listAsAnchor :: [LocatedAnS t a] -> Anchor
listAsAnchor [] = spanAsAnchor noSrcSpan
listAsAnchor (L l _:_) = spanAsAnchor (locA l)
+listAsAnchorM :: [LocatedAnS t a] -> Maybe Anchor
+listAsAnchorM [] = Nothing
+listAsAnchorM (L l _:_) =
+ case locA l of
+ RealSrcSpan ll _ -> Just $ realSpanAsAnchor ll
+ _ -> Nothing
+
hsTok :: Located Token -> LHsToken tok GhcPs
hsTok (L l _) = L (mkTokenLocation l) HsTok
@@ -4438,15 +4489,15 @@ addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)
addTrailingCommaA la span = addTrailingAnnA la span AddCommaAnn
addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (EpaLocation -> TrailingAnn) -> m (LocatedA a)
-addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do
+addTrailingAnnA (L anns a) ss ta = do
-- cs <- getCommentsFor l
let cs = emptyComments
-- AZ:TODO: generalise updating comments into an annotation
let
anns' = if isZeroWidthSpan ss
then anns
- else addTrailingAnnToA l (ta (srcSpan2e ss)) cs anns
- return (L (SrcSpanAnn anns' l) a)
+ else addTrailingAnnToA (ta (srcSpan2e ss)) cs anns
+ return (L anns' a)
-- -------------------------------------
@@ -4466,14 +4517,15 @@ addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do
-- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation
addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a)
-addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do
+addTrailingCommaN (L anns a) span = do
+ let l = locN anns
-- cs <- getCommentsFor l
let cs = emptyComments
-- AZ:TODO: generalise updating comments into an annotation
let anns' = if isZeroWidthSpan span
then anns
else addTrailingCommaToN l anns (srcSpan2e span)
- return (L (SrcSpanAnn anns' l) a)
+ return (L anns' a)
addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral
addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (epaLocationRealSrcSpan span) })
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index f4e1a06198..51cf2deac7 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -14,12 +14,17 @@ module GHC.Parser.Annotation (
-- * In-tree Exact Print Annotations
AddEpAnn(..),
EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn,
+ epaLocationFromEpAnnS,
TokenLocation(..),
getTokenSrcSpan,
DeltaPos(..), deltaPos, getDeltaLine,
- EpAnn(..), Anchor(..), AnchorOperation(..),
+ EpAnn(..), Anchor, AnchorOperation(..),
+ anchor, anchor_op,
+ EpAnnS(..),
spanAsAnchor, realSpanAsAnchor,
+ spanFromAnchor,
+ noSpanAnchor,
noAnn,
-- ** Comments in Annotations
@@ -32,6 +37,7 @@ module GHC.Parser.Annotation (
LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,
SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN,
SrcSpanAnn'(..), SrcAnn,
+ LocatedAnS,
-- ** Annotation data types used in 'GenLocated'
@@ -41,7 +47,7 @@ module GHC.Parser.Annotation (
AnnContext(..),
NameAnn(..), NameAdornment(..),
NoEpAnns(..),
- AnnSortKey(..),
+ AnnSortKey(..), DeclTag(..),
-- ** Trailing annotations in lists
TrailingAnn(..), trailingAnnToAddEpAnn,
@@ -49,15 +55,18 @@ module GHC.Parser.Annotation (
-- ** Utilities for converting between different 'GenLocated' when
-- ** we do not care about the annotations.
- la2na, na2la, n2l, l2n, l2l, la2la,
- reLoc, reLocA, reLocL, reLocC, reLocN,
+ la2na, l2l, l2li, l2ll, nn2la, nn2li, l2ln,
+ n2l, l2n, la2la, la2li,
+ reLoc, reLocI, reLocA, reLocE, reLocL, reLocC, reLocN,
+ locN, locA,
srcSpan2e, la2e, realSrcSpan,
-- ** Building up annotations
extraToAnnList, reAnn,
reAnnL, reAnnC,
- addAnns, addAnnsA, widenSpan, widenAnchor, widenAnchorR, widenLocatedAn,
+ addAnns, addAnnsA, widenSpan, widenAnchor, widenAnchorS, widenLocatedAn,
+ widenEpAnnS,
-- ** Querying annotations
getLocAnn,
@@ -66,22 +75,27 @@ module GHC.Parser.Annotation (
epAnnComments,
-- ** Working with locations of annotations
- sortLocatedA,
- mapLocA,
- combineLocsA,
- combineSrcSpansA,
- addCLocA, addCLocAA,
+ sortLocatedA, sortLocatedI,
+ mapLocA, mapLocI,
+ combineLocsA, combineLocsI,
+ combineSrcSpansA, combineSrcSpansI,
+ addCLocA, addCLocAA, addCLocI, addCLocII,
-- ** Constructing 'GenLocated' annotation types when we do not care
-- about annotations.
noLocA, getLocA,
- noSrcSpanA,
- noAnnSrcSpan,
+ noLocN, getLocN,
+ noLocI, getLocI,
+ noSrcSpanA, noSrcSpanN, noSrcSpanI,
+ noAnnSrcSpan, noAnnSrcSpanN, noAnnSrcSpanI,
-- ** Working with comments in annotations
- noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn,
+ noComments, comment, addCommentsToSrcAnn,
+ setCommentsSrcAnn, setCommentsEpAnnS,
+ addCommentsToEpAnnS,
addCommentsToEpAnn, setCommentsEpAnn,
- transferAnnsA, commentsOnlyA, removeCommentsA,
+ transferAnnsA, commentsOnlyA, commentsOnlyI,
+ removeCommentsA, removeCommentsI,
placeholderRealSpan,
) where
@@ -368,12 +382,6 @@ data EpaCommentTok =
| EpaDocOptions String -- ^ doc options (prune, ignore-exports, etc)
| EpaLineComment String -- ^ comment starting by "--"
| EpaBlockComment String -- ^ comment in {- -}
- | EpaEofComment -- ^ empty comment, capturing
- -- location of EOF
-
- -- See #19697 for a discussion of EpaEofComment's use and how it
- -- should be removed in favour of capturing it in the location for
- -- 'Located HsModule' in the parser.
deriving (Eq, Data, Show)
-- Note: these are based on the Token versions, but the Token type is
@@ -404,9 +412,9 @@ data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)
-- in the @'EpaDelta'@ variant captures any comments between the prior
-- output and the thing being marked here, since we cannot otherwise
-- sort the relative order.
-data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan)
+data EpaLocation = EpaSpan !SrcSpan
| EpaDelta !DeltaPos ![LEpaComment]
- deriving (Data,Eq)
+ deriving (Data,Eq,Show)
-- | Tokens embedded in the AST have an EpaLocation, unless they come from
-- generated code (e.g. by TH).
@@ -416,7 +424,7 @@ data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation
getTokenSrcSpan :: TokenLocation -> SrcSpan
getTokenSrcSpan NoTokenLoc = noSrcSpan
getTokenSrcSpan (TokenLoc EpaDelta{}) = noSrcSpan
-getTokenSrcSpan (TokenLoc (EpaSpan rspan mbufpos)) = RealSrcSpan rspan mbufpos
+getTokenSrcSpan (TokenLoc (EpaSpan span)) = span
instance Outputable a => Outputable (GenLocated TokenLocation a) where
ppr (L _ x) = ppr x
@@ -453,15 +461,19 @@ getDeltaLine (DifferentLine r _) = r
-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the
-- partial function is safe.
epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan
-epaLocationRealSrcSpan (EpaSpan r _) = r
-epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan"
+epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r
+epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan"
epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation
-epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) Strict.Nothing
-epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) Strict.Nothing
+epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = spanAsAnchor l
+epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = anc
+
+epaLocationFromEpAnnS :: EpAnnS ann -> EpaLocation
+epaLocationFromEpAnnS (EpAnnS anc _ _) = anc
+
instance Outputable EpaLocation where
- ppr (EpaSpan r _) = text "EpaSpan" <+> ppr r
+ ppr (EpaSpan ss) = text "EpaSpan" <+> ppr ss
ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs
instance Outputable AddEpAnn where
@@ -523,12 +535,35 @@ data EpAnn ann
-- the element relative to its container. If it is moved, that
-- relationship is tracked in the 'anchor_op' instead.
-data Anchor = Anchor { anchor :: RealSrcSpan
- -- ^ Base location for the start of
- -- the syntactic element holding
- -- the annotations.
- , anchor_op :: AnchorOperation }
- deriving (Data, Eq, Show)
+-- AZ: This is a temporary type until we get rid of EpAnnNotUsed, at
+-- which time it replaces EpAnn
+data EpAnnS ann
+ = EpAnnS { s_entry :: !Anchor
+ -- ^ Base location for the start of the syntactic element
+ -- holding the annotations.
+ , s_anns :: !ann -- ^ Annotations added by the Parser
+ , s_comments :: !EpAnnComments
+ -- ^ Comments enclosed in the SrcSpan of the element
+ -- this `EpAnn` is attached to
+ } deriving (Data, Eq, Functor)
+
+-- data Anchor = Anchor { anchor :: !RealSrcSpan
+-- -- ^ Base location for the start of
+-- -- the syntactic element holding
+-- -- the annotations.
+-- , anchor_op :: !AnchorOperation }
+-- deriving (Data, Eq, Show)
+
+type Anchor = EpaLocation -- Transitional
+
+anchor :: Anchor -> RealSrcSpan
+anchor (EpaSpan (RealSrcSpan r _)) = r
+anchor _ = panic "anchor"
+-- anchor (EpaDelta _ _) = placeholderRealSpan
+
+anchor_op :: Anchor -> AnchorOperation
+anchor_op (EpaSpan _) = UnchangedAnchor
+anchor_op (EpaDelta dp _) = MovedAnchor dp
-- | If tools modify the parsed source, the 'MovedAnchor' variant can
-- directly provide the spacing for this item relative to the previous
@@ -541,10 +576,17 @@ data AnchorOperation = UnchangedAnchor
spanAsAnchor :: SrcSpan -> Anchor
-spanAsAnchor s = Anchor (realSrcSpan s) UnchangedAnchor
+spanAsAnchor ss = EpaSpan ss
realSpanAsAnchor :: RealSrcSpan -> Anchor
-realSpanAsAnchor s = Anchor s UnchangedAnchor
+realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing)
+
+spanFromAnchor :: Anchor -> SrcSpan
+spanFromAnchor (EpaSpan ss) = ss
+spanFromAnchor (EpaDelta _ _) = UnhelpfulSpan (UnhelpfulOther (fsLit "spanFromAnchor"))
+
+noSpanAnchor :: Anchor
+noSpanAnchor = EpaDelta (SameLine 0) []
-- ---------------------------------------------------------------------
@@ -577,7 +619,7 @@ emptyComments = EpaComments []
-- Important that the fields are strict as these live inside L nodes which
-- are live for a long time.
-data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locA :: !SrcSpan }
+data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locI :: !SrcSpan }
deriving (Data, Eq)
-- See Note [XRec and Anno in the AST]
@@ -591,8 +633,8 @@ type LocatedL = GenLocated SrcSpanAnnL
type LocatedP = GenLocated SrcSpanAnnP
type LocatedC = GenLocated SrcSpanAnnC
-type SrcSpanAnnA = SrcAnn AnnListItem
-type SrcSpanAnnN = SrcAnn NameAnn
+type SrcSpanAnnA = EpAnnS AnnListItem
+type SrcSpanAnnN = EpAnnS NameAnn
type SrcSpanAnnL = SrcAnn AnnList
type SrcSpanAnnP = SrcAnn AnnPragma
@@ -602,6 +644,8 @@ type SrcSpanAnnC = SrcAnn AnnContext
-- parameterised annotation type.
type LocatedAn an = GenLocated (SrcAnn an)
+type LocatedAnS an = GenLocated (EpAnnS an)
+
{-
Note [XRec and Anno in the AST]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -803,11 +847,28 @@ data AnnPragma
-- SrcSpan is used purely as an index into the annotations, allowing
-- transformations of the AST including the introduction of new Located
-- items or re-arranging existing ones.
-data AnnSortKey
+data AnnSortKey a
= NoAnnSortKey
- | AnnSortKey [RealSrcSpan]
+ | AnnSortKey a
deriving (Data, Eq)
+data DeclTag
+ = TyClDTag
+ | InstDTag
+ | DerivDTag
+ | ValDTag
+ | SigDTag
+ | KindSigDTag
+ | DefDTag
+ | ForDTag
+ | WarningDTag
+ | AnnDTag
+ | RuleDTag
+ | SpliceDTag
+ | DocDTag
+ | RoleAnnotDTag
+ deriving (Eq,Data,Ord,Show)
+
-- ---------------------------------------------------------------------
-- | Convert a 'TrailingAnn' to an 'AddEpAnn'
@@ -830,22 +891,16 @@ addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n)
-- | Helper function used in the parser to add a 'TrailingAnn' items
-- to an existing annotation.
-addTrailingAnnToA :: SrcSpan -> TrailingAnn -> EpAnnComments
- -> EpAnn AnnListItem -> EpAnn AnnListItem
-addTrailingAnnToA s t cs EpAnnNotUsed
- = EpAnn (spanAsAnchor s) (AnnListItem [t]) cs
-addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n)
- , comments = comments n <> cs }
- where
+addTrailingAnnToA :: TrailingAnn -> EpAnnComments
+ -> EpAnnS AnnListItem -> EpAnnS AnnListItem
+addTrailingAnnToA t cs (EpAnnS anc (AnnListItem ts) csa) =
+ EpAnnS anc (AnnListItem (ts ++ [t])) (csa <> cs)
-- See Note [list append in addTrailing*]
- addTrailing n = n { lann_trailing = lann_trailing n ++ [t] }
-- | Helper function used in the parser to add a comma location to an
-- existing annotation.
-addTrailingCommaToN :: SrcSpan -> EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn
-addTrailingCommaToN s EpAnnNotUsed l
- = EpAnn (spanAsAnchor s) (NameAnnTrailing [AddCommaAnn l]) emptyComments
-addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l }
+addTrailingCommaToN :: SrcSpan -> EpAnnS NameAnn -> EpaLocation -> EpAnnS NameAnn
+addTrailingCommaToN _ n l = n { s_anns = addTrailing (s_anns n) l }
where
-- See Note [list append in addTrailing*]
addTrailing :: NameAnn -> EpaLocation -> NameAnn
@@ -876,64 +931,103 @@ knowing that in most cases the original list is empty.
-- |Helper function (temporary) during transition of names
-- Discards any annotations
l2n :: LocatedAn a1 a2 -> LocatedN a2
-l2n (L la a) = L (noAnnSrcSpan (locA la)) a
+l2n (L la a) = L (noAnnSrcSpanN (locI la)) a
-n2l :: LocatedN a -> LocatedA a
-n2l (L la a) = L (na2la la) a
+n2l :: LocatedAnS ann1 a -> LocatedAn ann a
+n2l (L la a) = L (nn2la la) a
+
+la2la :: (Monoid ann) => LocatedAnS ann1 a -> LocatedAnS ann a
+la2la (L (EpAnnS anc _ cs) a) = L (EpAnnS anc mempty cs) a
-- |Helper function (temporary) during transition of names
-- Discards any annotations
la2na :: SrcSpanAnn' a -> SrcSpanAnnN
-la2na l = noAnnSrcSpan (locA l)
+la2na l = noAnnSrcSpanN (locI l)
-- |Helper function (temporary) during transition of names
-- Discards any annotations
-la2la :: LocatedAn ann1 a2 -> LocatedAn ann2 a2
-la2la (L la a) = L (noAnnSrcSpan (locA la)) a
+la2li :: LocatedAn ann1 a2 -> LocatedAn ann2 a2
+la2li (L la a) = L (noAnnSrcSpanI (locI la)) a
-l2l :: SrcSpanAnn' a -> SrcAnn ann
+-- |Helper function (temporary) during transition of names
+-- Discards any annotations
+l2l :: (Monoid ann) => EpAnnS a -> EpAnnS ann
l2l l = noAnnSrcSpan (locA l)
-- |Helper function (temporary) during transition of names
-- Discards any annotations
-na2la :: SrcSpanAnn' a -> SrcAnn ann
-na2la l = noAnnSrcSpan (locA l)
+l2li :: SrcSpanAnn' a -> SrcAnn ann
+l2li l = noAnnSrcSpanI (locI l)
+
+-- |Helper function (temporary) during transition of names
+-- Discards any annotations
+l2ln :: (Monoid ann) => SrcSpanAnn' a -> EpAnnS ann
+l2ln l = noAnnSrcSpan (locI l)
-reLoc :: LocatedAn a e -> Located e
-reLoc (L (SrcSpanAnn _ l) a) = L l a
+l2ll :: (Monoid b) => EpAnnS a -> EpAnnS b
+l2ll l = noAnnSrcSpan (locA l)
-reLocA :: Located e -> LocatedAn ann e
-reLocA (L l a) = (L (SrcSpanAnn EpAnnNotUsed l) a)
+-- |Helper function (temporary) during transition of names
+-- Discards any annotations
+nn2la :: EpAnnS a -> SrcAnn ann
+nn2la l = noAnnSrcSpanI (locN l)
+
+-- |Helper function (temporary) during transition of names
+-- Discards any annotations
+nn2li :: EpAnnS NameAnn -> EpAnnS AnnListItem
+nn2li (EpAnnS anc _ cs) = EpAnnS anc (AnnListItem []) cs
+
+-- TODO:AZ merge locN into locA
+locN :: EpAnnS ann -> SrcSpan
+locN a = spanFromAnchor $ s_entry a
+
+locA :: EpAnnS ann -> SrcSpan
+locA a = spanFromAnchor $ s_entry a
+
+reLoc :: LocatedAnS ann e -> Located e
+reLoc (L la a) = L (spanFromAnchor $ s_entry la ) a
+
+reLocI :: LocatedAn a e -> Located e
+reLocI (L (SrcSpanAnn _ l) a) = L l a
+
+reLocE :: Located e -> LocatedAn ann e
+reLocE (L l a) = (L (SrcSpanAnn EpAnnNotUsed l) a)
+
+reLocA :: (Monoid ann) => Located e -> LocatedAnS ann e
+reLocA (L l a) = (L (noAnnSrcSpan l) a)
reLocL :: LocatedN e -> LocatedA e
-reLocL (L l a) = (L (na2la l) a)
+reLocL (L l a) = (L (nn2li l) a)
reLocC :: LocatedN e -> LocatedC e
-reLocC (L l a) = (L (na2la l) a)
+reLocC (L l a) = (L (nn2la l) a)
reLocN :: LocatedN a -> Located a
-reLocN (L (SrcSpanAnn _ l) a) = L l a
+reLocN (L ln a) = L (locN ln) a
-- ---------------------------------------------------------------------
-realSrcSpan :: SrcSpan -> RealSrcSpan
-realSrcSpan (RealSrcSpan s _) = s
-realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary
+realSrcSpan :: String -> SrcSpan -> RealSrcSpan
+realSrcSpan _ (RealSrcSpan s _mb) = s
+realSrcSpan src s = mkRealSrcSpan l l
where
- l = mkRealSrcLoc (fsLit "foo") (-1) (-1)
+ l = seq s $ error $ ("realSrcSpan:from:" ++ show src)
+
+la2r :: EpAnnS a -> RealSrcSpan
+la2r l = realSrcSpan "la2r" (locA l)
srcSpan2e :: SrcSpan -> EpaLocation
-srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb
-srcSpan2e span = EpaSpan (realSrcSpan span) Strict.Nothing
+srcSpan2e ss@(RealSrcSpan _ _) = EpaSpan ss
+srcSpan2e span = EpaSpan (RealSrcSpan (realSrcSpan "srcSpan2e" span) Strict.Nothing)
la2e :: SrcSpanAnn' a -> EpaLocation
-la2e = srcSpan2e . locA
+la2e = srcSpan2e . locI
extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList
extraToAnnList (AnnList a o c e t) as = AnnList a o c (e++as) t
reAnn :: [TrailingAnn] -> EpAnnComments -> Located a -> LocatedA a
-reAnn anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem anns) cs) l) a
+reAnn anns cs (L l a) = L (EpAnnS (spanAsAnchor l) (AnnListItem anns) cs) a
reAnnC :: AnnContext -> EpAnnComments -> Located a -> LocatedC a
reAnnC anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a
@@ -942,21 +1036,46 @@ reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (SrcAnn ann) e
reAnnL anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a
getLocAnn :: Located a -> SrcSpanAnnA
-getLocAnn (L l _) = SrcSpanAnn EpAnnNotUsed l
+getLocAnn (L l _) = EpAnnS (spanAsAnchor l) (AnnListItem []) emptyComments
+
+getLocI :: GenLocated (SrcSpanAnn' a) e -> SrcSpan
+getLocI (L (SrcSpanAnn _ l) _) = l
+
+noLocI :: a -> LocatedAn an a
+noLocI = L (SrcSpanAnn EpAnnNotUsed noSrcSpan)
+
+-- noLocA :: a -> LocatedA a
+noLocA :: (Monoid ann) => a -> LocatedAnS ann a
+noLocA = L (EpAnnS (spanAsAnchor noSrcSpan) mempty emptyComments)
+
+-- AZ:TODO merge getLocN and getLocA
+getLocA :: LocatedAnS a e -> SrcSpan
+getLocA (L (EpAnnS anc _ _) _) = spanFromAnchor anc
+getLocN :: LocatedAnS an a -> SrcSpan
+getLocN (L l _) = locN l
-getLocA :: GenLocated (SrcSpanAnn' a) e -> SrcSpan
-getLocA (L (SrcSpanAnn _ l) _) = l
+noLocN :: a -> LocatedN a
+noLocN = L (noAnnSrcSpanN noSrcSpan)
-noLocA :: a -> LocatedAn an a
-noLocA = L (SrcSpanAnn EpAnnNotUsed noSrcSpan)
+noAnnSrcSpanI :: SrcSpan -> SrcAnn ann
+noAnnSrcSpanI l = SrcSpanAnn EpAnnNotUsed l
-noAnnSrcSpan :: SrcSpan -> SrcAnn ann
-noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l
+noAnnSrcSpanN :: SrcSpan -> EpAnnS NameAnn
+noAnnSrcSpanN l = EpAnnS (spanAsAnchor l) mempty emptyComments
-noSrcSpanA :: SrcAnn ann
+noAnnSrcSpan :: (Monoid ann) => SrcSpan -> EpAnnS ann
+noAnnSrcSpan l = EpAnnS (spanAsAnchor l) mempty emptyComments
+
+noSrcSpanA :: (Monoid ann) => EpAnnS ann
noSrcSpanA = noAnnSrcSpan noSrcSpan
+noSrcSpanI :: SrcAnn ann
+noSrcSpanI = noAnnSrcSpanI noSrcSpan
+
+noSrcSpanN :: EpAnnS NameAnn
+noSrcSpanN = noAnnSrcSpanN noSrcSpan
+
-- | Short form for 'EpAnnNotUsed'
noAnn :: EpAnn a
noAnn = EpAnnNotUsed
@@ -967,18 +1086,12 @@ addAnns (EpAnn l as1 cs) as2 cs2
= EpAnn (widenAnchor l (as1 ++ as2)) (as1 ++ as2) (cs <> cs2)
addAnns EpAnnNotUsed [] (EpaComments []) = EpAnnNotUsed
addAnns EpAnnNotUsed [] (EpaCommentsBalanced [] []) = EpAnnNotUsed
-addAnns EpAnnNotUsed as cs = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) as cs
+addAnns EpAnnNotUsed as cs = EpAnn (widenAnchor noSpanAnchor as) as cs
-- AZ:TODO use widenSpan here too
addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA
-addAnnsA (SrcSpanAnn (EpAnn l as1 cs) loc) as2 cs2
- = SrcSpanAnn (EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2)) loc
-addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaComments [])
- = SrcSpanAnn EpAnnNotUsed loc
-addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaCommentsBalanced [] [])
- = SrcSpanAnn EpAnnNotUsed loc
-addAnnsA (SrcSpanAnn EpAnnNotUsed loc) as cs
- = SrcSpanAnn (EpAnn (spanAsAnchor loc) (AnnListItem as) cs) loc
+addAnnsA (EpAnnS l as1 cs) as2 cs2
+ = (EpAnnS l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2))
-- | The annotations need to all come after the anchor. Make sure
-- this is the case.
@@ -986,7 +1099,7 @@ widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan
widenSpan s as = foldl combineSrcSpans s (go as)
where
go [] = []
- go (AddEpAnn _ (EpaSpan s mb):rest) = RealSrcSpan s mb : go rest
+ go (AddEpAnn _ (EpaSpan ss):rest) = ss : go rest
go (AddEpAnn _ (EpaDelta _ _):rest) = go rest
-- | The annotations need to all come after the anchor. Make sure
@@ -995,18 +1108,51 @@ widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan
widenRealSpan s as = foldl combineRealSrcSpans s (go as)
where
go [] = []
- go (AddEpAnn _ (EpaSpan s _):rest) = s : go rest
- go (AddEpAnn _ (EpaDelta _ _):rest) = go rest
+ go (AddEpAnn _ (EpaSpan (RealSrcSpan s _)):rest) = s : go rest
+ go (AddEpAnn _ _ :rest) = go rest
-widenAnchor :: Anchor -> [AddEpAnn] -> Anchor
-widenAnchor (Anchor s op) as = Anchor (widenRealSpan s as) op
+realSpanFromAnns :: [AddEpAnn] -> Strict.Maybe RealSrcSpan
+realSpanFromAnns as = go Strict.Nothing as
+ where
+ combine Strict.Nothing r = Strict.Just r
+ combine (Strict.Just l) r = Strict.Just $ combineRealSrcSpans l r
-widenAnchorR :: Anchor -> RealSrcSpan -> Anchor
-widenAnchorR (Anchor s op) r = Anchor (combineRealSrcSpans s r) op
+ go acc [] = acc
+ go acc (AddEpAnn _ (EpaSpan (RealSrcSpan s _b)):rest) = go (combine acc s) rest
+ go acc (AddEpAnn _ _ :rest) = go acc rest
+
+bufSpanFromAnns :: [AddEpAnn] -> Strict.Maybe BufSpan
+bufSpanFromAnns as = go Strict.Nothing as
+ where
+ combine Strict.Nothing r = Strict.Just r
+ combine (Strict.Just l) r = Strict.Just $ combineBufSpans l r
+
+ go acc [] = acc
+ go acc (AddEpAnn _ (EpaSpan (RealSrcSpan _ (Strict.Just mb))):rest) = go (combine acc mb) rest
+ go acc (AddEpAnn _ _:rest) = go acc rest
+
+
+widenAnchor :: Anchor -> [AddEpAnn] -> Anchor
+widenAnchor (EpaSpan (RealSrcSpan s mb)) as
+ = EpaSpan (RealSrcSpan (widenRealSpan s as) (liftA2 combineBufSpans mb (bufSpanFromAnns as)))
+widenAnchor (EpaSpan us) _ = EpaSpan us
+widenAnchor a@(EpaDelta _ _) as = case (realSpanFromAnns as) of
+ Strict.Nothing -> a
+ Strict.Just r -> EpaSpan (RealSrcSpan r Strict.Nothing)
+
+widenAnchorS :: Anchor -> SrcSpan -> Anchor
+widenAnchorS (EpaSpan (RealSrcSpan s mbe)) (RealSrcSpan r mbr)
+ = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr))
+widenAnchorS (EpaSpan us) _ = EpaSpan us
+widenAnchorS (EpaDelta _ _) (RealSrcSpan r mb) = EpaSpan (RealSrcSpan r mb)
+widenAnchorS anc _ = anc
widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an
widenLocatedAn (SrcSpanAnn a l) as = SrcSpanAnn a (widenSpan l as)
+widenEpAnnS :: EpAnnS an -> [AddEpAnn] -> EpAnnS an
+widenEpAnnS (EpAnnS anc an cs) as = EpAnnS (widenAnchor anc as) an cs
+
epAnnAnnsL :: EpAnn a -> [a]
epAnnAnnsL EpAnnNotUsed = []
epAnnAnnsL (EpAnn _ anns _) = [anns]
@@ -1027,32 +1173,53 @@ epAnnComments EpAnnNotUsed = EpaComments []
epAnnComments (EpAnn _ _ cs) = cs
-- ---------------------------------------------------------------------
--- sortLocatedA :: [LocatedA a] -> [LocatedA a]
-sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]
+sortLocatedA :: [LocatedAnS a e] -> [LocatedAnS a e]
sortLocatedA = sortBy (leftmost_smallest `on` getLocA)
-mapLocA :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b
+sortLocatedI :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]
+sortLocatedI = sortBy (leftmost_smallest `on` getLocI)
+
+mapLocA :: (Monoid ann) => (a -> b) -> GenLocated SrcSpan a -> LocatedAnS ann b
mapLocA f (L l a) = L (noAnnSrcSpan l) (f a)
+mapLocI :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b
+mapLocI f (L l a) = L (noAnnSrcSpanI l) (f a)
+
-- AZ:TODO: move this somewhere sane
-combineLocsA :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a
+combineLocsA :: Semigroup a => LocatedAnS a e1 -> LocatedAnS a e2 -> EpAnnS a
combineLocsA (L a _) (L b _) = combineSrcSpansA a b
-combineSrcSpansA :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
-combineSrcSpansA (SrcSpanAnn aa la) (SrcSpanAnn ab lb)
+combineLocsI :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a
+combineLocsI (L a _) (L b _) = combineSrcSpansI a b
+
+
+combineSrcSpansA :: Semigroup a => EpAnnS a -> EpAnnS a -> EpAnnS a
+combineSrcSpansA aa ab = aa <> ab
+
+combineSrcSpansI :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
+combineSrcSpansI (SrcSpanAnn aa la) (SrcSpanAnn ab lb)
= case SrcSpanAnn (aa <> ab) (combineSrcSpans la lb) of
SrcSpanAnn EpAnnNotUsed l -> SrcSpanAnn EpAnnNotUsed l
SrcSpanAnn (EpAnn anc an cs) l ->
- SrcSpanAnn (EpAnn (widenAnchorR anc (realSrcSpan l)) an cs) l
+ SrcSpanAnn (EpAnn (widenAnchorS anc l) an cs) l
+
-- | Combine locations from two 'Located' things and add them to a third thing
-addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3
+addCLocA :: (Monoid ann)
+ => LocatedAnS a e1 -> GenLocated SrcSpan e2 -> e3 -> LocatedAnS ann e3
addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (getLoc b)) c
-addCLocAA :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3
+-- | Combine locations from two 'Located' things and add them to a third thing
+addCLocI :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3
+addCLocI a b c = L (noAnnSrcSpanI $ combineSrcSpans (locI $ getLoc a) (getLoc b)) c
+
+addCLocAA :: LocatedAnS a1 e1 -> LocatedAnS a2 e2 -> e3 -> LocatedAnS AnnListItem e3
addCLocAA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (locA $ getLoc b)) c
+addCLocII :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3
+addCLocII a b c = L (noAnnSrcSpanI $ combineSrcSpans (locI $ getLoc a) (locI $ getLoc b)) c
+
-- ---------------------------------------------------------------------
-- Utilities for manipulating EpAnnComments
-- ---------------------------------------------------------------------
@@ -1079,14 +1246,14 @@ data NoEpAnns = NoEpAnns
deriving (Data,Eq,Ord)
noComments ::EpAnnCO
-noComments = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) NoEpAnns emptyComments
+noComments = EpAnn noSpanAnchor NoEpAnns emptyComments
-- TODO:AZ get rid of this
placeholderRealSpan :: RealSrcSpan
placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1))
comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO
-comment loc cs = EpAnn (Anchor loc UnchangedAnchor) NoEpAnns cs
+comment loc cs = EpAnn (EpaSpan (RealSrcSpan loc Strict.Nothing)) NoEpAnns cs
-- ---------------------------------------------------------------------
-- Utilities for managing comments in an `EpAnn a` structure.
@@ -1096,24 +1263,35 @@ comment loc cs = EpAnn (Anchor loc UnchangedAnchor) NoEpAnns cs
-- AST prior to exact printing the changed one.
addCommentsToSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann
addCommentsToSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs
- = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc
+ = SrcSpanAnn (EpAnn (spanAsAnchor loc) mempty cs) loc
addCommentsToSrcAnn (SrcSpanAnn (EpAnn a an cs) loc) cs'
= SrcSpanAnn (EpAnn a an (cs <> cs')) loc
+-- | Add additional comments to a 'SrcAnn', used for manipulating the
+-- AST prior to exact printing the changed one.
+addCommentsToEpAnnS :: (Monoid ann) => EpAnnS ann -> EpAnnComments -> EpAnnS ann
+addCommentsToEpAnnS (EpAnnS a an cs) cs' = (EpAnnS a an (cs <> cs'))
+
-- | Replace any existing comments on a 'SrcAnn', used for manipulating the
-- AST prior to exact printing the changed one.
setCommentsSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann
setCommentsSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs
- = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc
+ = SrcSpanAnn (EpAnn (spanAsAnchor loc) mempty cs) loc
setCommentsSrcAnn (SrcSpanAnn (EpAnn a an _) loc) cs
= SrcSpanAnn (EpAnn a an cs) loc
+-- | Replace any existing comments on a 'SrcAnn', used for manipulating the
+-- AST prior to exact printing the changed one.
+setCommentsEpAnnS :: EpAnnS ann -> EpAnnComments -> EpAnnS ann
+setCommentsEpAnnS (EpAnnS a an _) cs = (EpAnnS a an cs)
+
+
-- | Add additional comments, used for manipulating the
-- AST prior to exact printing the changed one.
addCommentsToEpAnn :: (Monoid a)
=> SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a
addCommentsToEpAnn loc EpAnnNotUsed cs
- = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs
+ = EpAnn (spanAsAnchor loc) mempty cs
addCommentsToEpAnn _ (EpAnn a an ocs) ncs = EpAnn a an (ocs <> ncs)
-- | Replace any existing comments, used for manipulating the
@@ -1121,32 +1299,34 @@ addCommentsToEpAnn _ (EpAnn a an ocs) ncs = EpAnn a an (ocs <> ncs)
setCommentsEpAnn :: (Monoid a)
=> SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a
setCommentsEpAnn loc EpAnnNotUsed cs
- = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs
+ = EpAnn (spanAsAnchor loc) mempty cs
setCommentsEpAnn _ (EpAnn a an _) cs = EpAnn a an cs
-- | Transfer comments and trailing items from the annotations in the
-- first 'SrcSpanAnnA' argument to those in the second.
transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
-transferAnnsA from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to)
-transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to
- = ((SrcSpanAnn (EpAnn a mempty emptyComments) l), to')
- where
- to' = case to of
- (SrcSpanAnn EpAnnNotUsed loc)
- -> SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) an cs) loc
- (SrcSpanAnn (EpAnn a an' cs') loc)
- -> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc
+transferAnnsA (EpAnnS a an cs) (EpAnnS a' an' cs')
+ = (EpAnnS a mempty emptyComments, EpAnnS a' (an' <> an) (cs' <> cs))
+
+-- | Remove the exact print annotations payload, leaving only the
+-- anchor and comments.
+commentsOnlyA :: Monoid ann => EpAnnS ann -> EpAnnS ann
+commentsOnlyA (EpAnnS a _ cs) = (EpAnnS a mempty cs)
-- | Remove the exact print annotations payload, leaving only the
-- anchor and comments.
-commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann
-commentsOnlyA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc
-commentsOnlyA (SrcSpanAnn (EpAnn a _ cs) loc) = (SrcSpanAnn (EpAnn a mempty cs) loc)
+commentsOnlyI :: Monoid ann => SrcAnn ann -> SrcAnn ann
+commentsOnlyI (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc
+commentsOnlyI (SrcSpanAnn (EpAnn a _ cs) loc) = (SrcSpanAnn (EpAnn a mempty cs) loc)
+
+-- | Remove the comments, leaving the exact print annotations payload
+removeCommentsA :: EpAnnS ann -> EpAnnS ann
+removeCommentsA (EpAnnS a an _) = (EpAnnS a an emptyComments)
-- | Remove the comments, leaving the exact print annotations payload
-removeCommentsA :: SrcAnn ann -> SrcAnn ann
-removeCommentsA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc
-removeCommentsA (SrcSpanAnn (EpAnn a an _) loc)
+removeCommentsI :: SrcAnn ann -> SrcAnn ann
+removeCommentsI (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc
+removeCommentsI (SrcSpanAnn (EpAnn a an _) loc)
= (SrcSpanAnn (EpAnn a an emptyComments) loc)
-- ---------------------------------------------------------------------
@@ -1167,11 +1347,22 @@ instance (Semigroup a) => Semigroup (EpAnn a) where
-- annotations must follow it. So we combine them which yields the
-- largest span
-instance Ord Anchor where
- compare (Anchor s1 _) (Anchor s2 _) = compare s1 s2
+instance (Semigroup a) => Semigroup (EpAnnS a) where
+ (EpAnnS l1 a1 b1) <> (EpAnnS l2 a2 b2) = EpAnnS (l1 <> l2) (a1 <> a2) (b1 <> b2)
+ -- The critical part about the anchor is its left edge, and all
+ -- annotations must follow it. So we combine them which yields the
+ -- largest span
+
+
+-- instance Ord Anchor where
+-- compare (Anchor s1 _) (Anchor s2 _) = compare s1 s2
instance Semigroup Anchor where
- Anchor r1 o1 <> Anchor r2 _ = Anchor (combineRealSrcSpans r1 r2) o1
+ EpaSpan s1 <> EpaSpan s2 = EpaSpan (combineSrcSpans s1 s2)
+ EpaSpan s1 <> _ = EpaSpan s1
+ _ <> EpaSpan s2 = EpaSpan s2
+ EpaDelta dp1 cs1 <> EpaDelta _dp2 cs2 = EpaDelta dp1 (cs1<>cs2)
+
instance Semigroup EpAnnComments where
EpaComments cs1 <> EpaComments cs2 = EpaComments (cs1 ++ cs2)
@@ -1186,6 +1377,10 @@ instance (Monoid a) => Monoid (EpAnn a) where
instance Semigroup NoEpAnns where
_ <> _ = NoEpAnns
+instance Monoid NoEpAnns where
+ mempty = NoEpAnns
+
+
instance Semigroup AnnListItem where
(AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2)
@@ -1212,12 +1407,12 @@ instance Monoid NameAnn where
mempty = NameAnnTrailing []
-instance Semigroup AnnSortKey where
+instance (Semigroup a) => Semigroup (AnnSortKey a) where
NoAnnSortKey <> x = x
x <> NoAnnSortKey = x
AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2)
-instance Monoid AnnSortKey where
+instance (Semigroup a) => Monoid (AnnSortKey a) where
mempty = NoAnnSortKey
instance (Outputable a) => Outputable (EpAnn a) where
@@ -1227,9 +1422,6 @@ instance (Outputable a) => Outputable (EpAnn a) where
instance Outputable NoEpAnns where
ppr NoEpAnns = text "NoEpAnns"
-instance Outputable Anchor where
- ppr (Anchor a o) = text "Anchor" <+> ppr a <+> ppr o
-
instance Outputable AnchorOperation where
ppr UnchangedAnchor = text "UnchangedAnchor"
ppr (MovedAnchor d) = text "MovedAnchor" <+> ppr d
@@ -1246,12 +1438,15 @@ instance Outputable EpAnnComments where
ppr (EpaCommentsBalanced cs ts) = text "EpaCommentsBalanced" <+> ppr cs <+> ppr ts
instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where
+ getName (L l a) = getName (L (locI l) a)
+
+instance (NamedThing (Located a)) => NamedThing (LocatedAnS an a) where
getName (L l a) = getName (L (locA l) a)
instance Outputable AnnContext where
ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c
-instance Outputable AnnSortKey where
+instance (Outputable a) => Outputable (AnnSortKey a) where
ppr NoAnnSortKey = text "NoAnnSortKey"
ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls
@@ -1265,11 +1460,23 @@ instance (Outputable a, Outputable e)
=> Outputable (GenLocated (SrcSpanAnn' a) e) where
ppr = pprLocated
+instance (Outputable a) => Outputable (EpAnnS a) where
+ ppr (EpAnnS anc an cs) = text "EpAnnS" <+> ppr anc <+> ppr an <+> ppr cs
+
+instance (Outputable a, Outputable e)
+ => Outputable (LocatedAnS a e) where
+ ppr = pprLocated
+
instance (Outputable a, OutputableBndr e)
=> OutputableBndr (GenLocated (SrcSpanAnn' a) e) where
pprInfixOcc = pprInfixOcc . unLoc
pprPrefixOcc = pprPrefixOcc . unLoc
+instance (Outputable a, OutputableBndr e)
+ => OutputableBndr (LocatedAnS a e) where
+ pprInfixOcc = pprInfixOcc . unLoc
+ pprPrefixOcc = pprPrefixOcc . unLoc
+
instance Outputable AnnListItem where
ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts
diff --git a/compiler/GHC/Parser/HaddockLex.x b/compiler/GHC/Parser/HaddockLex.x
index 52e67894b5..df281db933 100644
--- a/compiler/GHC/Parser/HaddockLex.x
+++ b/compiler/GHC/Parser/HaddockLex.x
@@ -187,7 +187,7 @@ validateIdentWith identParser mloc str0 =
pstate = initParserState pflags buffer realSrcLc
in case unP identParser pstate of
POk _ name -> Just $ case mloc of
- RealSrcSpan _ _ -> reLoc name
+ RealSrcSpan _ _ -> reLocN name
UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason
_ -> Nothing
}
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index 380a30ca78..fd0aab174a 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -3643,7 +3643,8 @@ warn_unknown_prag prags span buf len buf2 = do
-- 'AddEpAnn' values for the opening and closing bordering on the start
-- and end of the span
mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)
-mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo Strict.Nothing),AddEpAnn AnnCloseP (EpaSpan lc Strict.Nothing))
+mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan (RealSrcSpan lo Strict.Nothing)),
+ AddEpAnn AnnCloseP (EpaSpan (RealSrcSpan lc Strict.Nothing)))
where
f = srcSpanFile ss
sl = srcSpanStartLine ss
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 0b7053dcbb..470cd630a8 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -286,7 +286,7 @@ mkStandaloneKindSig loc lhs rhs anns =
check_lhs_name v@(unLoc->name) =
if isUnqual name && isTcOcc (rdrNameOcc name)
then return v
- else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $
+ else addFatalError $ mkPlainErrorMsgEnvelope (getLocN v) $
(PsErrUnexpectedQualifiedConstructor (unLoc v))
check_singular_lhs vs =
case vs of
@@ -337,21 +337,6 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
, feqn_fixity = fixity
, feqn_rhs = defn })))) }
--- mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
--- ksig data_cons (L _ maybe_deriv) anns
--- = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
--- ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan
--- ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments
--- ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
--- ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl
--- (FamEqn { feqn_ext = anns'
--- , feqn_tycon = tc
--- , feqn_bndrs = bndrs
--- , feqn_pats = tparams
--- , feqn_fixity = fixity
--- , feqn_rhs = defn })))) }
-
-
mkTyFamInst :: SrcSpan
-> TyFamInstEqn GhcPs
@@ -404,15 +389,15 @@ mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)
mkSpliceDecl lexpr@(L loc expr)
| HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr = do
cs <- getCommentsFor (locA loc)
- return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice)
+ return $ L (addCommentsToEpAnnS loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice)
| HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr = do
cs <- getCommentsFor (locA loc)
- return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice)
+ return $ L (addCommentsToEpAnnS loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice)
| otherwise = do
cs <- getCommentsFor (locA loc)
- return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField
+ return $ L (addCommentsToEpAnnS loc cs) $ SpliceD noExtField (SpliceDecl noExtField
(L loc (HsUntypedSpliceExpr noAnn lexpr))
BareSplice)
@@ -471,27 +456,30 @@ annBinds a cs (HsIPBinds an bs) = (HsIPBinds (add_where a an cs) bs, Nothing)
annBinds _ cs (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs)
add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList
-add_where an@(AddEpAnn _ (EpaSpan rs _)) (EpAnn a (AnnList anc o c r t) cs) cs2
- | valid_anchor (anchor a)
+add_where an@(AddEpAnn _ (EpaSpan (RealSrcSpan rs _))) (EpAnn a (AnnList anc o c r t) cs) cs2
+ | valid_anchor a
= EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2)
| otherwise
= EpAnn (patch_anchor rs a)
(AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2)
-add_where an@(AddEpAnn _ (EpaSpan rs _)) EpAnnNotUsed cs
- = EpAnn (Anchor rs UnchangedAnchor)
- (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs
-add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where"
+add_where an@(AddEpAnn _ (EpaSpan (RealSrcSpan rs mb))) EpAnnNotUsed cs
+ = EpAnn (EpaSpan (RealSrcSpan rs mb))
+ (AnnList (Just $ EpaSpan (RealSrcSpan rs mb)) Nothing Nothing [an] []) cs
+add_where (AddEpAnn _ _) _ _ = panic "add_where"
-- EpaDelta should only be used for transformations
-valid_anchor :: RealSrcSpan -> Bool
-valid_anchor r = srcSpanStartLine r >= 0
+valid_anchor :: Anchor -> Bool
+valid_anchor (EpaSpan _) = True
+valid_anchor (EpaDelta _ _) = False
-- If the decl list for where binds is empty, the anchor ends up
-- invalid. In this case, use the parent one
patch_anchor :: RealSrcSpan -> Anchor -> Anchor
-patch_anchor r1 (Anchor r0 op) = Anchor r op
+patch_anchor r (EpaDelta _ _) = EpaSpan (RealSrcSpan r Strict.Nothing)
+patch_anchor r1 (EpaSpan (RealSrcSpan r0 mb)) = EpaSpan (RealSrcSpan r mb)
where
r = if srcSpanStartLine r0 < 0 then r1 else r0
+patch_anchor _ (EpaSpan ss) = EpaSpan ss
fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList
fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed
@@ -500,10 +488,11 @@ fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)
-- | The 'Anchor' for a stmtlist is based on either the location or
-- the first semicolon annotion.
-stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Anchor
-stmtsAnchor (L l ((ConsOL (AddEpAnn _ (EpaSpan r _)) _), _))
- = widenAnchorR (Anchor (realSrcSpan l) UnchangedAnchor) r
-stmtsAnchor (L l _) = Anchor (realSrcSpan l) UnchangedAnchor
+stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe Anchor
+stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (AddEpAnn _ (EpaSpan (RealSrcSpan r rb))) _), _))
+ = Just $ widenAnchorS (EpaSpan (RealSrcSpan l mb)) (RealSrcSpan r rb)
+stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan (RealSrcSpan l mb)
+stmtsAnchor _ = Nothing
stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan
stmtsLoc (L l ((ConsOL aa _), _))
@@ -675,7 +664,7 @@ tyConToDataCon (L loc tc)
= return (L loc (setRdrNameSpace tc srcDataName))
| otherwise
- = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc)
+ = Left $ mkPlainErrorMsgEnvelope (locN loc) $ (PsErrNotADataCon tc)
where
occ = rdrNameOcc tc
@@ -684,7 +673,7 @@ mkPatSynMatchGroup :: LocatedN RdrName
-> P (MatchGroup GhcPs (LHsExpr GhcPs))
mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
do { matches <- mapM fromDecl (fromOL decls)
- ; when (null matches) (wrongNumberErr (locA loc))
+ ; when (null matches) (wrongNumberErr (locN loc))
; return $ mkMatchGroup FromSource (L ld matches) }
where
fromDecl (L loc decl@(ValD _ (PatBind _
@@ -772,7 +761,7 @@ mkGadtDecl loc names dcol ty = do
return noHsUniTok
return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf) arr, res_ty
- , [], epAnnComments (ann ll))
+ , [], s_comments ll)
_ -> do
let (anns, cs, arg_types, res_type) = splitHsFunType body_ty
return (PrefixConGADT arg_types, res_type, anns, cs)
@@ -900,7 +889,7 @@ checkTyVars pp_what equals_or_where tc tparms
-> P (LHsTyVarBndr () GhcPs)
chkParens ops cps cs (L l (HsParTy an ty))
= let
- (o,c) = mkParensEpAnn (realSrcSpan $ locA l)
+ (o,c) = mkParensEpAnn (realSrcSpan "checkTyVars" $ locA l)
in
chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) ty
chkParens ops cps cs ty = chk ops cps cs ty
@@ -912,14 +901,14 @@ checkTyVars pp_what equals_or_where tc tparms
= let
an = (reverse ops) ++ cps
in
- return (L (widenLocatedAn (l Semi.<> annt) an)
+ return (L (widenEpAnnS (l Semi.<> annt) an)
(KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k))
chk ops cps cs (L l (HsTyVar ann _ (L ltv tv)))
| isRdrTyVar tv
= let
an = (reverse ops) ++ cps
in
- return (L (widenLocatedAn l an)
+ return (L (widenEpAnnS l an)
(UserTyVar (addAnns ann an cs) () (L ltv tv)))
chk _ _ _ t@(L loc _)
= addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
@@ -935,7 +924,7 @@ checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()
checkDatatypeContext Nothing = return ()
checkDatatypeContext (Just c)
= do allowed <- getBit DatatypeContextsBit
- unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $
+ unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocI c) $
(PsErrIllegalDataTypeContext c)
type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar
@@ -952,10 +941,11 @@ mkRuleBndrs = fmap (fmap cvt_one)
-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
mkRuleTyVarBndrs = fmap cvt_one
+ -- where cvt_one (L l (RuleTyTmVar ann v Nothing))
where cvt_one (L l (RuleTyTmVar ann v Nothing))
- = L (l2l l) (UserTyVar ann () (fmap tm_to_ty v))
+ = L (l2ln l) (UserTyVar ann () (fmap tm_to_ty v))
cvt_one (L l (RuleTyTmVar ann v (Just sig)))
- = L (l2l l) (KindedTyVar ann () (fmap tm_to_ty v) sig)
+ = L (l2ln l) (KindedTyVar ann () (fmap tm_to_ty v) sig)
-- takes something in namespace 'varName' to something in namespace 'tvName'
tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)
tm_to_ty _ = panic "mkRuleTyVarBndrs"
@@ -1018,11 +1008,11 @@ checkTyClHdr is_cls ty
| isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps)
go l (HsParTy _ ty) acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
where
- (o,c) = mkParensEpAnn (realSrcSpan l)
+ (o,c) = mkParensEpAnn (realSrcSpan "checkTyClHdr" l)
go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix
go _ (HsAppKindTy _ ty at ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
- = return (L (noAnnSrcSpan l) (nameRdrName tup_name)
+ = return (L (noAnnSrcSpanN l) (nameRdrName tup_name)
, map HsValArg ts, fix, (reverse ops)++cps)
where
arity = length ts
@@ -1036,17 +1026,13 @@ checkTyClHdr is_cls ty
-- Combine the annotations from the HsParTy and HsStarTy into a
-- new one for the LocatedN RdrName
newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN
- newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =
- let
- lr = combineRealSrcSpans (realSrcSpan l) (anchor as)
- an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c []) cs)
- in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
newAnns _ EpAnnNotUsed = panic "missing AnnParen"
- newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =
+ newAnns (EpAnnS ap (AnnListItem ta) csp) (EpAnn as (AnnParen _ o c) cs) =
let
- lr = combineRealSrcSpans (anchor ap) (anchor as)
- an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs))
- in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
+ lr = ap Semi.<> as
+ in (EpAnnS lr
+ (NameAnn NameParens o ap c ta)
+ (csp Semi.<> cs))
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
@@ -1091,9 +1077,10 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()
-- (((Eq a))) --> [Eq a]
-- @
checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)
-checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) =
+checkContext orig_t@(L a _orig_t) =
check ([],[],emptyComments) orig_t
where
+ l = spanFromAnchor $ s_entry a
check :: ([EpaLocation],[EpaLocation],EpAnnComments)
-> LHsType GhcPs -> P (LHsContext GhcPs)
check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts))
@@ -1195,7 +1182,7 @@ checkAPat loc e0 = do
-- Overloaded numeric patterns (e.g. f 0 x = x)
-- Negation is recorded separately, so that the literal is zero or +ve
-- NB. Negative *primitive* literals are already handled by the lexer
- PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn)
+ PatBuilderOverLit pos_lit -> return (mkNPat (L (nn2la loc) pos_lit) Nothing noAnn)
-- n+k patterns
PatBuilderOpApp
@@ -1204,12 +1191,12 @@ checkAPat loc e0 = do
(L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))
(EpAnn anc _ cs)
| nPlusKPatterns && (plus == plus_RDR)
- -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit)
- (EpAnn anc (epaLocationFromSrcAnn l) cs))
+ -> return (mkNPlusKPat (L nloc n) (L (nn2la lloc) lit)
+ (EpAnn anc (epaLocationFromEpAnnS l) cs))
-- Improve error messages for the @-operator when the user meant an @-pattern
PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do
- addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos
+ addError $ mkPlainErrorMsgEnvelope (getLocN op) PsErrAtInPatPos
return (WildPat noExtField)
PatBuilderOpApp l (L cl c) r anns
@@ -1234,7 +1221,7 @@ placeHolderPunRhs :: DisambECP b => PV (LocatedA b)
-- The RHS of a punned record field will be filled in by the renamer
-- It's better not to make it an error, in case we want to print it when
-- debugging
-placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR)
+placeHolderPunRhs = mkHsVarPV (noLocN pun_RDR)
plus_RDR, pun_RDR :: RdrName
plus_RDR = mkUnqual varName (fsLit "+") -- Hack
@@ -1288,7 +1275,7 @@ checkFunBind strictness locF ann fun is_infix pats (L _ grhss)
= do ps <- runPV_details extraDetails (mapM checkLPat pats)
let match_span = noAnnSrcSpan $ locF
cs <- getCommentsFor locF
- return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)
+ return (makeFunBind fun (L (noAnnSrcSpanI $ locA match_span)
[L match_span (Match { m_ext = EpAnn (spanAsAnchor locF) ann cs
, m_ctxt = FunRhs
{ mc_fun = fun
@@ -1319,7 +1306,7 @@ checkPatBind :: SrcSpan
-> P (HsBind GhcPs)
checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v))))
(L _match_span grhss)
- = return (makeFunBind v (L (noAnnSrcSpan loc)
+ = return (makeFunBind v (L (noAnnSrcSpanI loc)
[L (noAnnSrcSpan loc) (m (EpAnn (spanAsAnchor loc) (ans++annsIn) cs) v)]))
where
m a v = Match { m_ext = a
@@ -1369,7 +1356,7 @@ isFunLhs e = go e [] [] []
go (L _ (PatBuilderApp f e)) es ops cps = go f (e:es) ops cps
go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps
= let
- (o,c) = mkParensEpAnn (realSrcSpan $ locA l)
+ (o,c) = mkParensEpAnn (realSrcSpan "checkDoAndIfThenElse" $ locA l)
in
go e es (o:ops) (c:cps)
go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ops cps
@@ -1464,8 +1451,8 @@ class DisambInfixOp b where
mkHsInfixHolePV :: SrcSpan -> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located b)
instance DisambInfixOp (HsExpr GhcPs) where
- mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)
- mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)
+ mkHsVarOpPV v = return $ L (l2l $ getLoc v) (HsVar noExtField v)
+ mkHsConOpPV v = return $ L (l2l $ getLoc v) (HsVar noExtField v)
mkHsInfixHolePV l ann = do
cs <- getCommentsFor l
return $ L l (hsHoleExpr (ann cs))
@@ -1476,7 +1463,7 @@ instance DisambInfixOp RdrName where
mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole
type AnnoBody b
- = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcAnn NoEpAnns
+ = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnnS NoEpAnns
, Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL
, Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA
, Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA
@@ -1555,7 +1542,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
-- | Disambiguate a monomorphic literal
mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)
-- | Disambiguate an overloaded literal
- mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b)
+ mkHsOverLitPV :: LocatedA (HsOverLit GhcPs) -> PV (LocatedA b)
-- | Disambiguate a wildcard
mkHsWildCardPV :: SrcSpan -> PV (Located b)
-- | Disambiguate "a :: t" (type annotation)
@@ -1654,7 +1641,7 @@ instance DisambECP (HsCmd GhcPs) where
type InfixOp (HsCmd GhcPs) = HsExpr GhcPs
superInfixOp m = m
mkHsOpAppPV l c1 op c2 = do
- let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c
+ let cmdArg (L l c) = L (l2l l) $ HsCmdTop noExtField (L l c)
cs <- getCommentsFor l
return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2]
mkHsCasePV l c (L lm m) anns = do
@@ -1671,7 +1658,7 @@ instance DisambECP (HsCmd GhcPs) where
cs <- getCommentsFor (locA l)
checkCmdBlockArguments c
checkExpBlockArguments e
- return $ L l (HsCmdApp (comment (realSrcSpan $ locA l) cs) c e)
+ return $ L l (HsCmdApp (comment (realSrcSpan "mkHsAppPV" $ locA l) cs) c e)
mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t)
mkHsIfPV l c semi1 a semi2 b anns = do
checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b
@@ -1684,7 +1671,7 @@ instance DisambECP (HsCmd GhcPs) where
mkHsParPV l lpar c rpar = do
cs <- getCommentsFor l
return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar)
- mkHsVarPV (L l v) = cmdFail (locA l) (ppr v)
+ mkHsVarPV (L l v) = cmdFail (locN l) (ppr v)
mkHsLitPV (L l a) = cmdFail l (ppr a)
mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a)
mkHsWildCardPV l = cmdFail l (text "_")
@@ -1757,7 +1744,7 @@ instance DisambECP (HsExpr GhcPs) where
cs <- getCommentsFor (locA l)
checkExpBlockArguments e1
checkExpBlockArguments e2
- return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2)
+ return $ L l (HsApp (comment (realSrcSpan "mkHsAppPV" $ locA l) cs) e1 e2)
mkHsAppTypePV l e at t = do
checkExpBlockArguments e
return $ L l (HsAppType noExtField e at (mkHsWildCardBndrs t))
@@ -1771,13 +1758,13 @@ instance DisambECP (HsExpr GhcPs) where
mkHsParPV l lpar e rpar = do
cs <- getCommentsFor l
return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar)
- mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v)
+ mkHsVarPV v@(L l _) = return $ L (l2l l) (HsVar noExtField v)
mkHsLitPV (L l a) = do
cs <- getCommentsFor l
- return $ L l (HsLit (comment (realSrcSpan l) cs) a)
+ return $ L l (HsLit (comment (realSrcSpan "mkHsLitPV" l) cs) a)
mkHsOverLitPV (L l a) = do
cs <- getCommentsFor (locA l)
- return $ L l (HsOverLit (comment (realSrcSpan (locA l)) cs) a)
+ return $ L l (HsOverLit (comment (realSrcSpan "mkHsOverLitPV" (locA l)) cs) a)
mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn)
mkHsTySigPV l a sig anns = do
cs <- getCommentsFor (locA l)
@@ -1797,7 +1784,7 @@ instance DisambECP (HsExpr GhcPs) where
return $ L (noAnnSrcSpan l) (NegApp (EpAnn (spanAsAnchor l) anns cs) a noSyntaxExpr)
mkHsSectionR_PV l op e = do
cs <- getCommentsFor l
- return $ L l (SectionR (comment (realSrcSpan l) cs) op e)
+ return $ L l (SectionR (comment (realSrcSpan "mkHsSectionR" l) cs) op e)
mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b)
>> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))
mkHsAsPatPV l v _ e = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)
@@ -1842,7 +1829,7 @@ instance DisambECP (PatBuilder GhcPs) where
mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)
- mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)
+ mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)
mkHsLitPV lit@(L l a) = do
checkUnboxedLitPat lit
return $ L l (PatBuilderPat (LitPat noExtField a))
@@ -1867,7 +1854,7 @@ instance DisambECP (PatBuilder GhcPs) where
checkRecordSyntax (L (noAnnSrcSpan l) r)
mkHsNegAppPV l (L lp p) anns = do
lit <- case p of
- PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit)
+ PatBuilderOverLit pos_lit -> return (L (nn2la lp) pos_lit)
_ -> patFail l $ PsErrInPat p PEIP_NegApp
cs <- getCommentsFor l
let an = EpAnn (spanAsAnchor l) anns cs
@@ -2041,7 +2028,7 @@ tyToDataConBuilder t =
checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV ()
checkNotPromotedDataCon NotPromoted _ = return ()
checkNotPromotedDataCon IsPromoted (L l name) =
- addError $ mkPlainErrorMsgEnvelope (locA l) $
+ addError $ mkPlainErrorMsgEnvelope (locN l) $
PsErrIllegalPromotionQuoteDataCon name
{- Note [Ambiguous syntactic categories]
@@ -2566,15 +2553,15 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
-- The idea here is to convert the label to a singleton [FastString].
let f = occNameFS . rdrNameOcc $ rdr
fl = DotFieldOcc noAnn (L loc (FieldLabelString f))
- lf = locA loc
- in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns
+ lf = locN loc
+ in mkRdrProjUpdate l (L lf [L (nn2la loc) fl]) (punnedVar f) pun anns
where
-- If punning, compute HsVar "f" otherwise just arg. This
-- has the effect that sentinel HsVar "pun-rhs" is replaced
-- by HsVar "f" here, before the update is written to a
-- setField expressions.
punnedVar :: FastString -> LHsExpr GhcPs
- punnedVar f = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f
+ punnedVar f = if not pun then arg else noLocA . HsVar noExtField . noLocN . mkRdrUnqual . mkVarOccFS $ f
mkRdrRecordCon
:: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs
@@ -2841,7 +2828,7 @@ mkTypeImpExp :: LocatedN RdrName -- TcCls or Var name space
-> P (LocatedN RdrName)
mkTypeImpExp name =
do allowed <- getBit ExplicitNamespacesBit
- unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $
+ unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocN name) $
PsErrIllegalExplicitNamespace
return (fmap (`setRdrNameSpace` tcClsName) name)
@@ -2858,7 +2845,7 @@ checkImportSpec ie@(L _ specs) =
mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)
mkImpExpSubSpec [] = return ([], ImpExpList [])
mkImpExpSubSpec [L la ImpExpQcWildcard] =
- return ([AddEpAnn AnnDotdot (la2e la)], ImpExpAll)
+ return ([AddEpAnn AnnDotdot (epaLocationFromEpAnnS la)], ImpExpAll)
mkImpExpSubSpec xs =
if (any (isImpExpQcWildcard . unLoc) xs)
then return $ ([], ImpExpAllWith xs)
@@ -2890,7 +2877,7 @@ failOpFewArgs :: MonadP m => LocatedN RdrName -> m a
failOpFewArgs (L loc op) =
do { star_is_type <- getBit StarIsTypeBit
; let is_star_type = if star_is_type then StarIsType else StarIsNotType
- ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $
+ ; addFatalError $ mkPlainErrorMsgEnvelope (locN loc) $
(PsErrOpFewArgs is_star_type op) }
-----------------------------------------------------------------------------
@@ -3112,7 +3099,7 @@ mkSumOrTuplePat l Boxed a@Sum{} _ =
mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs
mkLHsOpTy prom x op y =
- let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y
+ let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocN op) `combineSrcSpansA` getLoc y
in L loc (mkHsOpTy prom x op y)
mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs
@@ -3127,14 +3114,14 @@ mkMultTy pct t arr = HsExplicitMult pct t arr
mkTokenLocation :: SrcSpan -> TokenLocation
mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc
-mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb)
+mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan (RealSrcSpan r mb))
-- Precondition: the TokenLocation has EpaSpan, never EpaDelta.
token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation
token_location_widenR NoTokenLoc _ = NoTokenLoc
token_location_widenR tl (UnhelpfulSpan _) = tl
-token_location_widenR (TokenLoc (EpaSpan r1 mb1)) (RealSrcSpan r2 mb2) =
- (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2) (liftA2 combineBufSpans mb1 mb2)))
+token_location_widenR (TokenLoc (EpaSpan s1)) s2 =
+ (TokenLoc (EpaSpan (combineSrcSpans s1 s2)))
token_location_widenR (TokenLoc (EpaDelta _ _)) _ =
-- Never happens because the parser does not produce EpaDelta.
panic "token_location_widenR: EpaDelta"
@@ -3173,7 +3160,7 @@ mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has ha
mkRdrProjUpdate loc (L l flds) arg isPun anns =
L loc HsFieldBind {
hfbAnn = anns
- , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds)
+ , hfbLHS = L (noAnnSrcSpanI l) (FieldLabelStrings flds)
, hfbRHS = arg
, hfbPun = isPun
}
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index 706423c099..b9449c4a7e 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -311,9 +311,9 @@ lexLHsDocString = fmap lexHsDocString
-- Imports cannot have documentation comments anyway.
instance HasHaddock (LocatedL [LocatedA (IE GhcPs)]) where
addHaddock (L l_exports exports) =
- extendHdkA (locA l_exports) $ do
+ extendHdkA (locI l_exports) $ do
exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports
- registerLocHdkA (srcLocSpan (srcSpanEnd (locA l_exports))) -- Do not consume comments after the closing parenthesis
+ registerLocHdkA (srcLocSpan (srcSpanEnd (locI l_exports))) -- Do not consume comments after the closing parenthesis
pure $ L l_exports exports'
-- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'.
@@ -615,7 +615,7 @@ instance HasHaddock (Located [LocatedAn NoEpAnns (HsDerivingClause GhcPs)]) wher
-- Not used for standalone deriving.
instance HasHaddock (LocatedAn NoEpAnns (HsDerivingClause GhcPs)) where
addHaddock lderiv =
- extendHdkA (getLocA lderiv) $
+ extendHdkA (getLocI lderiv) $
for @(LocatedAn NoEpAnns) lderiv $ \deriv ->
case deriv of
HsDerivingClause { deriv_clause_ext, deriv_clause_strategy, deriv_clause_tys } -> do
@@ -629,8 +629,8 @@ instance HasHaddock (LocatedAn NoEpAnns (HsDerivingClause GhcPs)) where
(register_strategy_before, register_strategy_after) =
case deriv_clause_strategy of
Nothing -> (pure (), pure ())
- Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA (locA l))
- Just (L l _) -> (registerLocHdkA (locA l), pure ())
+ Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA (locI l))
+ Just (L l _) -> (registerLocHdkA (locI l), pure ())
register_strategy_before
deriv_clause_tys' <- addHaddock deriv_clause_tys
register_strategy_after
@@ -651,7 +651,7 @@ instance HasHaddock (LocatedAn NoEpAnns (HsDerivingClause GhcPs)) where
-- )
instance HasHaddock (LocatedC (DerivClauseTys GhcPs)) where
addHaddock (L l_dct dct) =
- extendHdkA (locA l_dct) $
+ extendHdkA (locI l_dct) $
case dct of
DctSingle x ty -> do
ty' <- addHaddock ty
@@ -700,7 +700,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where
case con_decl of
ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do
-- discardHasInnerDocs is ok because we don't need this info for GADTs.
- con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (NE.head con_names))
+ con_doc' <- discardHasInnerDocs $ getConDoc (getLocN (NE.head con_names))
con_g_args' <-
case con_g_args of
PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts
@@ -718,7 +718,7 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where
addConTrailingDoc (srcSpanEnd $ locA l_con_decl) $
case con_args of
PrefixCon _ ts -> do
- con_doc' <- getConDoc (getLocA con_name)
+ con_doc' <- getConDoc (getLocN con_name)
ts' <- traverse addHaddockConDeclFieldTy ts
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
@@ -726,14 +726,14 @@ instance HasHaddock (LocatedA (ConDecl GhcPs)) where
con_args = PrefixCon noTypeArgs ts' }
InfixCon t1 t2 -> do
t1' <- addHaddockConDeclFieldTy t1
- con_doc' <- getConDoc (getLocA con_name)
+ con_doc' <- getConDoc (getLocN con_name)
t2' <- addHaddockConDeclFieldTy t2
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
con_doc = lexLHsDocString <$> con_doc',
con_args = InfixCon t1' t2' }
RecCon (L l_rec flds) -> do
- con_doc' <- getConDoc (getLocA con_name)
+ con_doc' <- getConDoc (getLocN con_name)
flds' <- traverse addHaddockConDeclField flds
pure $ L l_con_decl $
ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,
@@ -989,7 +989,7 @@ instance HasHaddock (LocatedA (HsType GhcPs)) where
-- (Eq a, Num a) => t
HsQualTy x lhs rhs -> do
- registerHdkA lhs
+ registerHdkI lhs
rhs' <- addHaddock rhs
pure $ L l (HsQualTy x lhs rhs')
@@ -1155,9 +1155,12 @@ registerLocHdkA l = HdkA (getBufSpan l) (pure ())
-- A small wrapper over registerLocHdkA.
--
-- See Note [Adding Haddock comments to the syntax tree].
-registerHdkA :: GenLocated (SrcSpanAnn' a) e -> HdkA ()
+registerHdkA :: LocatedAnS a e -> HdkA ()
registerHdkA a = registerLocHdkA (getLocA a)
+registerHdkI :: GenLocated (SrcSpanAnn' a) e -> HdkA ()
+registerHdkI a = registerLocHdkA (getLocI a)
+
-- Modify the action of a HdkA computation.
hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b
hoistHdkA f (HdkA l m) = HdkA l (f m)
@@ -1517,7 +1520,7 @@ flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) =
mapLL (\d -> DocD noExtField d) all_docs
]
-cmpBufSpanA :: GenLocated (SrcSpanAnn' a1) a2 -> GenLocated (SrcSpanAnn' a3) a2 -> Ordering
+cmpBufSpanA :: LocatedAnS a1 a2 -> LocatedAnS a3 a2 -> Ordering
cmpBufSpanA (L la a) (L lb b) = cmpBufSpan (L (locA la) a) (L (locA lb) b)
{- *********************************************************************
diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs
index 2e38c22f69..dae5ffdefd 100644
--- a/compiler/GHC/Parser/Types.hs
+++ b/compiler/GHC/Parser/Types.hs
@@ -62,7 +62,7 @@ data PatBuilder p
| PatBuilderOverLit (HsOverLit GhcPs)
-- These instances are here so that they are not orphans
-type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcAnn NoEpAnns
+type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = EpAnnS NoEpAnns
type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL
type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA
type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 661c271fb9..e16d544a47 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -445,7 +445,7 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })
| isTopRecNameMaker name_maker
- = do { addLocMA checkConName rdrname
+ = do { addLocMN checkConName rdrname
; name <-
lookupLocatedTopConstructorRnN rdrname -- Should be in scope already
; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }
@@ -674,7 +674,7 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls
where
add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv
add_one_sig env (L loc (FixitySig _ names fixity)) =
- foldlM add_one env [ (locA loc,locA name_loc,name,fixity)
+ foldlM add_one env [ (locA loc,locN name_loc,name,fixity)
| L name_loc name <- names ]
add_one env (loc, name_loc, name,fixity) = do
@@ -1225,8 +1225,8 @@ type AnnoBody body
, Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL
, Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
, Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA
- , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns
- , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcAnn NoEpAnns
+ , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnS NoEpAnns
+ , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ EpAnnS NoEpAnns
, Outputable (body GhcPs)
)
@@ -1362,7 +1362,7 @@ rnSrcFixityDecl sig_ctxt = rn_decl
lookup_one :: LocatedN RdrName -> RnM [LocatedN Name]
lookup_one (L name_loc rdr_name)
- = setSrcSpanA name_loc $
+ = setSrcSpanN name_loc $
-- This lookup will fail if the name is not defined in the
-- same binding group as this fixity declaration.
do names <- lookupLocalTcNames sig_ctxt what rdr_name
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 49fdde1bc6..4c632c7e20 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -199,7 +199,7 @@ newTopSrcBinder (L loc rdr_name)
if isExternalName name then
do { this_mod <- getModule
; unless (this_mod == nameModule name)
- (addErrAt (locA loc) (TcRnBindingOfExistingName rdr_name))
+ (addErrAt (locN loc) (TcRnBindingOfExistingName rdr_name))
; return name }
else -- See Note [Binders in Template Haskell] in "GHC.ThToHs"
do { this_mod <- getModule
@@ -208,7 +208,7 @@ newTopSrcBinder (L loc rdr_name)
| Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do { this_mod <- getModule
; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
- (addErrAt (locA loc) (TcRnBindingOfExistingName rdr_name))
+ (addErrAt (locN loc) (TcRnBindingOfExistingName rdr_name))
-- When reading External Core we get Orig names as binders,
-- but they should agree with the module gotten from the monad
--
@@ -231,11 +231,11 @@ newTopSrcBinder (L loc rdr_name)
-- the RdrName, not from the environment. In principle, it'd be fine to
-- have an arbitrary mixture of external core definitions in a single module,
-- (apart from module-initialisation issues, perhaps).
- ; newGlobalBinder rdr_mod rdr_occ (locA loc) }
+ ; newGlobalBinder rdr_mod rdr_occ (locN loc) }
| otherwise
= do { when (isQual rdr_name)
- (addErrAt (locA loc) (badQualBndrErr rdr_name))
+ (addErrAt (locN loc) (badQualBndrErr rdr_name))
-- Binders should not be qualified; if they are, and with a different
-- module name, we get a confusing "M.T is not in scope" error later
@@ -244,11 +244,11 @@ newTopSrcBinder (L loc rdr_name)
-- We are inside a TH bracket, so make an *Internal* name
-- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names
do { uniq <- newUnique
- ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) }
+ ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locN loc)) }
else
do { this_mod <- getModule
- ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locA loc))
- ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locA loc) }
+ ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locN loc))
+ ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locN loc) }
}
{-
@@ -1000,20 +1000,20 @@ we'll miss the fact that the qualified import is redundant.
-}
-lookupLocatedOccRn :: GenLocated (SrcSpanAnn' ann) RdrName
- -> TcRn (GenLocated (SrcSpanAnn' ann) Name)
+lookupLocatedOccRn :: LocatedN RdrName
+ -> TcRn (LocatedN Name)
lookupLocatedOccRn = wrapLocMA lookupOccRn
-lookupLocatedOccRnConstr :: GenLocated (SrcSpanAnn' ann) RdrName
- -> TcRn (GenLocated (SrcSpanAnn' ann) Name)
+lookupLocatedOccRnConstr :: LocatedN RdrName
+ -> TcRn (LocatedN Name)
lookupLocatedOccRnConstr = wrapLocMA lookupOccRnConstr
-lookupLocatedOccRnRecField :: GenLocated (SrcSpanAnn' ann) RdrName
- -> TcRn (GenLocated (SrcSpanAnn' ann) Name)
+lookupLocatedOccRnRecField :: LocatedAnS ann RdrName
+ -> TcRn (LocatedAnS ann Name)
lookupLocatedOccRnRecField = wrapLocMA lookupOccRnRecField
-lookupLocatedOccRnNone :: GenLocated (SrcSpanAnn' ann) RdrName
- -> TcRn (GenLocated (SrcSpanAnn' ann) Name)
+lookupLocatedOccRnNone :: LocatedAnS ann RdrName
+ -> TcRn (LocatedAnS ann Name)
lookupLocatedOccRnNone = wrapLocMA lookupOccRnNone
lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)
@@ -2011,7 +2011,7 @@ instance Outputable HsSigCtxt where
lookupSigOccRn :: HsSigCtxt
-> Sig GhcPs
- -> LocatedA RdrName -> RnM (LocatedA Name)
+ -> LocatedN RdrName -> RnM (LocatedN Name)
lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)
lookupSigOccRnN :: HsSigCtxt
@@ -2023,8 +2023,8 @@ lookupSigOccRnN ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)
lookupSigCtxtOccRn :: HsSigCtxt
-> SDoc -- ^ description of thing we're looking up,
-- like "type family"
- -> GenLocated (SrcSpanAnn' ann) RdrName
- -> RnM (GenLocated (SrcSpanAnn' ann) Name)
+ -> GenLocated (EpAnnS ann) RdrName
+ -> RnM (GenLocated (EpAnnS ann) Name)
lookupSigCtxtOccRn ctxt what
= wrapLocMA $ \ rdr_name ->
do { mb_name <- lookupBindGroupOcc ctxt what rdr_name
@@ -2260,11 +2260,11 @@ lookupSyntaxNames :: [Name] -- Standard names
lookupSyntaxNames std_names
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if not rebindable_on then
- return (map (HsVar noExtField . noLocA) std_names, emptyFVs)
+ return (map (HsVar noExtField . noLocN) std_names, emptyFVs)
else
do { usr_names <-
mapM (lookupOccRnNone . mkRdrUnqual . nameOccName) std_names
- ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } }
+ ; return (map (HsVar noExtField . noLocN) usr_names, mkFVs usr_names) } }
{-
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index b68ff6a492..9bf95751f3 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -244,7 +244,7 @@ finishHsVar (L l name)
= do { this_mod <- getModule
; when (nameIsLocalOrFrom this_mod name) $
checkThLocalName name
- ; return (HsVar noExtField (L (la2na l) name), unitFV name) }
+ ; return (HsVar noExtField (L (l2l l) name), unitFV name) }
rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
rnUnboundVar v = do
@@ -278,7 +278,7 @@ rnExpr (HsVar _ (L l v))
-> rnExpr (ExplicitList noAnn [])
| otherwise
- -> finishHsVar (L (na2la l) $ greName gre)
+ -> finishHsVar (L (l2l l) $ greName gre)
}}}
rnExpr (HsIPVar x v)
@@ -477,7 +477,7 @@ rnExpr (RecordCon { rcon_con = con_id
, rcon_con = con_lname, rcon_flds = rec_binds' }
, fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
where
- mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n)
+ mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpanN l) n)
rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hfbRHS fld)
; return (L l (fld { hfbRHS = arg' }), fvs) }
@@ -966,7 +966,7 @@ methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)
-------------------------------------------------
-methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
+methodNamesGRHS :: LocatedAnS NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs
---------------------------------------------------
@@ -1118,7 +1118,7 @@ rnStmtsWithFreeVars ctxt _ [] thing_inside
rnStmtsWithFreeVars mDoExpr@(HsDoStmt MDoExpr{}) rnBody (nonEmpty -> Just stmts) thing_inside -- Deal with mdo
= -- Behave like do { rec { ...all but last... }; last }
do { ((stmts1, (stmts2, thing)), fvs)
- <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA (NE.init stmts))) $ \ _ ->
+ <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocI (NE.init stmts))) $ \ _ ->
do { last_stmt' <- checkLastStmt mDoExpr (NE.last stmts)
; rnStmt mDoExpr rnBody last_stmt' thing_inside }
; return (((stmts1 ++ stmts2), thing), fvs) }
@@ -1360,12 +1360,12 @@ lookupStmtNamePoly ctxt name
= do { rebindable_on <- xoptM LangExt.RebindableSyntax
; if rebindable_on
then do { fm <- lookupOccRn (nameRdrName name)
- ; return (HsVar noExtField (noLocA fm), unitFV fm) }
+ ; return (HsVar noExtField (noLocN fm), unitFV fm) }
else not_rebindable }
| otherwise
= not_rebindable
where
- not_rebindable = return (HsVar noExtField (noLocA name), emptyFVs)
+ not_rebindable = return (HsVar noExtField (noLocN name), emptyFVs)
-- | Is this a context where we respect RebindableSyntax?
-- but ListComp are never rebindable
@@ -1624,7 +1624,7 @@ segmentRecStmts loc ctxt empty_rec_stmt segs (fvs_later, might_be_more_fvs_later
| otherwise
= ([ L (noAnnSrcSpan loc) $
- empty_rec_stmt { recS_stmts = noLocA ss
+ empty_rec_stmt { recS_stmts = noLocI ss
, recS_later_ids = nameSetElemsStable final_fvs_later
, recS_rec_ids = nameSetElemsStable
(defs `intersectNameSet` uses) }]
@@ -1787,7 +1787,7 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
(later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
new_stmt | non_rec = head ss
| otherwise = L (getLoc (head ss)) rec_stmt
- rec_stmt = empty_rec_stmt { recS_stmts = noLocA ss
+ rec_stmt = empty_rec_stmt { recS_stmts = noLocI ss
, recS_later_ids = nameSetElemsStable used_later
, recS_rec_ids = nameSetElemsStable fwds }
-- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]
@@ -2695,7 +2695,7 @@ getMonadFailOp ctxt
nlHsApp (noLocA failExpr)
(nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)
let failAfterFromStringExpr :: HsExpr GhcRn =
- unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocA arg_name] body
+ unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocN arg_name] body
let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
mkSyntaxExpr failAfterFromStringExpr
return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 500a6f8407..9f65355b1c 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -394,7 +394,7 @@ rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside
-- Use the currently set SrcSpan as the new source location for each Name.
-- See Note [Source locations for implicitly bound type variables].
; loc <- getSrcSpanM
- ; let loc' = noAnnSrcSpan loc
+ ; let loc' = noAnnSrcSpanN loc
; vars <- mapM (newTyVarNameRn mb_assoc . L loc' . unLoc) implicit_vs
; bindLocalNamesFV vars $
@@ -592,7 +592,7 @@ rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
; return (HsTyVar noAnn ip (L loc name), unitFV name) }
rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)
- = setSrcSpan (getLocA l_op) $
+ = setSrcSpan (getLocN l_op) $
do { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op
; let op_name = unLoc l_op'
; fix <- lookupTyFixityRn l_op'
@@ -978,7 +978,7 @@ bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside
--
-- class C (a :: j) (b :: k) where
-- ^^^^^^^^^^^^^^^
- bndrs_loc = case map get_bndr_loc hs_tv_bndrs ++ map getLocA body_kv_occs of
+ bndrs_loc = case map get_bndr_loc hs_tv_bndrs ++ map getLocN body_kv_occs of
[] -> panic "bindHsQTyVars.bndrs_loc"
[loc] -> loc
(loc:locs) -> loc `combineSrcSpans` last locs
@@ -987,9 +987,9 @@ bindHsQTyVars doc mb_assoc body_kv_occs hsq_bndrs thing_inside
-- include surrounding parens. for error messages to be
-- compatible, we recreate the location from the contents
get_bndr_loc :: LHsTyVarBndr () GhcPs -> SrcSpan
- get_bndr_loc (L _ (UserTyVar _ _ ln)) = getLocA ln
+ get_bndr_loc (L _ (UserTyVar _ _ ln)) = getLocN ln
get_bndr_loc (L _ (KindedTyVar _ _ ln lk))
- = combineSrcSpans (getLocA ln) (getLocA lk)
+ = combineSrcSpans (getLocN ln) (getLocA lk)
{- Note [bindHsQTyVars examples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 1602b2b92d..123282fd5d 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -274,7 +274,7 @@ rnSrcWarnDecls _ []
rnSrcWarnDecls bndr_set decls'
= do { -- check for duplicates
; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups
- in addErrAt (locA loc) (TcRnDuplicateWarningDecls lrdr' rdr))
+ in addErrAt (locN loc) (TcRnDuplicateWarningDecls lrdr' rdr))
warn_rdr_dups
; pairs_s <- mapM (addLocMA rn_deprec) decls
; return (WarnSome ((concat pairs_s))) }
@@ -834,7 +834,7 @@ rnFamEqn doc atfi extra_kvars
--
-- type instance F a b c = Either a b
-- ^^^^^
- lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLocA extra_kvars of
+ lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLocN extra_kvars of
[] -> panic "rnFamEqn.lhs_loc"
[loc] -> loc
(loc:locs) -> loc `combineSrcSpans` last locs
@@ -2173,7 +2173,7 @@ rnLHsDerivingClause doc
, deriv_clause_tys = dct }))
= do { (dcs', dct', fvs)
<- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct
- ; warnNoDerivStrat dcs' (locA loc)
+ ; warnNoDerivStrat dcs' (locI loc)
; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField
, deriv_clause_strategy = dcs'
, deriv_clause_tys = dct' })
@@ -2211,7 +2211,7 @@ rnLDerivStrategy doc mds thing_inside
= case mds of
Nothing -> boring_case Nothing
Just (L loc ds) ->
- setSrcSpanA loc $ do
+ setSrcSpanI loc $ do
(ds', thing, fvs) <- rn_deriv_strat ds
pure (Just (L loc ds'), thing, fvs)
where
@@ -2268,7 +2268,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
; ((tyvars', res_sig', injectivity'), fv1) <-
bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ ->
do { let rn_sig = rnFamResultSig doc
- ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig
+ ; (res_sig', fv_kind) <- wrapLocFstMI rn_sig res_sig
; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
injectivity
; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
@@ -2375,7 +2375,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
; injTo' <- mapM rnLTyVar injTo
-- Note: srcSpan is unchanged, but typechecker gets
-- confused, l2l call makes it happy
- ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') }
+ ; return $ L (l2li srcSpan) (InjectivityAnn x injFrom' injTo') }
; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
resName = hsLTyVarName resTv
@@ -2387,12 +2387,12 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
-- not-in-scope variables) don't check the validity of injectivity
-- annotation. This gives better error messages.
; when (noRnErrors && not lhsValid) $
- addErrAt (getLocA injFrom) $
+ addErrAt (getLocN injFrom) $
TcRnIncorrectTyVarOnLhsOfInjCond resName injFrom
; when (noRnErrors && not (Set.null rhsValid)) $
do { let errorVars = Set.toList rhsValid
- ; addErrAt (locA srcSpan) $
+ ; addErrAt (locI srcSpan) $
TcRnUnknownTyVarsOnRhsOfInjCond errorVars }
; return injDecl' }
@@ -2406,7 +2406,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))
-- So we rename injectivity annotation like we normally would except that
-- this time we expect "result" to be reported not in scope by rnLTyVar.
rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =
- setSrcSpanA srcSpan $ do
+ setSrcSpanI srcSpan $ do
(injDecl', _) <- askNoErrs $ do
injFrom' <- rnLTyVar injFrom
injTo' <- mapM rnLTyVar injTo
@@ -2439,7 +2439,7 @@ rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
, con_mb_cxt = mcxt, con_args = args
, con_doc = mb_doc, con_forall = forall_ })
- = do { _ <- addLocMA checkConName name
+ = do { _ <- addLocMN checkConName name
; new_name <- lookupLocatedTopConstructorRnN name
-- We bind no implicit binders here; this is just like
@@ -2476,7 +2476,7 @@ rnConDecl (ConDeclGADT { con_names = names
, con_g_args = args
, con_res_ty = res_ty
, con_doc = mb_doc })
- = do { mapM_ (addLocMA checkConName) names
+ = do { mapM_ (addLocMN checkConName) names
; new_names <- mapM (lookupLocatedTopConstructorRnN) names
; let -- We must ensure that we extract the free tkvs in left-to-right
@@ -2594,13 +2594,13 @@ extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do {
, psb_args = RecCon as }))) <- bind
= do
bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)
- let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as
+ let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocN (foLabel f)) f) . recordPatSynField) as
flds <- mapM (newRecordFieldLabel dup_fields_ok has_sel [bnd_name]) field_occs
let con_info = mkConInfo (conDetailsArity length (RecCon as)) flds
return ((PatSynName bnd_name, con_info) : names)
| L bind_loc (PatSynBind _ (PSB { psb_id = L _ n, psb_args = as })) <- bind
= do
- bnd_name <- newTopSrcBinder (L (la2na bind_loc) n)
+ bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)
let con_info = mkConInfo (conDetailsArity length as) []
return ((PatSynName bnd_name, con_info) : names)
| otherwise
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 92cab86d05..2adf8c45d2 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -895,10 +895,10 @@ getLocalNonValBinders fixity_env
new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances
= do { let TyDeclBinders (main_bndr, tc_flav) at_bndrs sig_bndrs
(LConsWithFields cons_with_flds flds) = hsLTyClDeclBinders tc_decl
- ; tycon_name <- newTopSrcBinder $ l2n main_bndr
- ; at_names <- mapM (newTopSrcBinder . l2n . fst) at_bndrs
- ; sig_names <- mapM (newTopSrcBinder . l2n) sig_bndrs
- ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds
+ ; tycon_name <- newTopSrcBinder $ la2la main_bndr
+ ; at_names <- mapM (newTopSrcBinder . la2la . fst) at_bndrs
+ ; sig_names <- mapM (newTopSrcBinder . la2la) sig_bndrs
+ ; con_names_with_flds <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds
; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst con_names_with_flds) flds
; mapM_ (add_dup_fld_errs flds') con_names_with_flds
; let tc_gre = localTyConGRE (fmap (const tycon_name) tc_flav) tycon_name
@@ -956,7 +956,7 @@ getLocalNonValBinders fixity_env
-- See (1) above
L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty
-- See (2) above
- MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe SameOccName cls_rdr
+ MaybeT $ setSrcSpan (locN loc) $ lookupGlobalOccRn_maybe SameOccName cls_rdr
-- Assuming the previous step succeeded, process any associated data
-- family instances. If the previous step failed, bail out.
case mb_cls_gre of
@@ -973,7 +973,7 @@ getLocalNonValBinders fixity_env
new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl })
= do { main_name <- unLoc <$> lookupFamInstName mb_cls (feqn_tycon ti_decl)
; let LConsWithFields cons_with_flds flds = hsDataFamInstBinders dfid
- ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (l2n con)) cons_with_flds
+ ; sub_names <- mapM (\(con,flds) -> (,flds) <$> newTopSrcBinder (la2la con)) cons_with_flds
; flds' <- mapM (newRecordFieldLabel dup_fields_ok has_sel $ map fst sub_names) flds
; mapM_ (add_dup_fld_errs flds') sub_names
; let fld_env = mk_fld_env sub_names flds'
@@ -1971,7 +1971,7 @@ getMinimalImports ie_decls
; iface <- loadSrcInterface doc mod_name is_boot pkg_qual
; let used_avails = gresToAvailInfo used_gres
; lies <- map (L l) <$> concatMapM (to_ie rdr_env iface) used_avails
- ; return (L l (decl { ideclImportList = Just (Exactly, L (l2l l) lies) })) }
+ ; return (L l (decl { ideclImportList = Just (Exactly, L (nn2la l) lies) })) }
where
doc = text "Compute minimal imports for" <+> ppr decl
@@ -2030,7 +2030,7 @@ getMinimalImports ie_decls
idecl = unLoc decl
merge :: NonEmpty (LImportDecl GhcRn) -> LImportDecl GhcRn
- merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) })
+ merge decls@((L l decl) :| _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpanI (locA l)) lies) })
where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) $ NE.toList decls
classifyGREs :: [GlobalRdrElt] -> ([GlobalRdrElt], [FieldGlobalRdrElt])
@@ -2064,14 +2064,14 @@ printMinimalImports hsc_src imports_w_usage
to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
to_ie_post_rn_var (L l n)
- | isDataOcc $ occName n = L l (IEPattern (la2e l) (L (la2na l) n))
- | otherwise = L l (IEName noExtField (L (la2na l) n))
+ | isDataOcc $ occName n = L l (IEPattern (epaLocationFromEpAnnS l) (L (l2l l) n))
+ | otherwise = L l (IEName noExtField (L (l2l l) n))
to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn
to_ie_post_rn (L l n)
- | isTcOcc occ && isSymOcc occ = L l (IEType (la2e l) (L (la2na l) n))
- | otherwise = L l (IEName noExtField (L (la2na l) n))
+ | isTcOcc occ && isSymOcc occ = L l (IEType (epaLocationFromEpAnnS l) (L (l2l l) n))
+ | otherwise = L l (IEName noExtField (L (l2l l) n))
where occ = occName n
{-
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 0b01f2cbcb..2461bf6561 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -497,7 +497,7 @@ rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat
; return (BangPat noExtField pat') }
rnPatAndThen mk (VarPat x (L l rdr))
= do { loc <- liftCps getSrcSpanM
- ; name <- newPatName mk (L (noAnnSrcSpan loc) rdr)
+ ; name <- newPatName mk (L (noAnnSrcSpanN loc) rdr)
; return (VarPat x (L l name)) }
-- we need to bind pattern variables for view pattern expressions
-- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
@@ -524,7 +524,7 @@ rnPatAndThen mk (LitPat x lit)
= do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)
; if ovlStr
then rnPatAndThen mk
- (mkNPat (noLocA (mkHsIsString src s))
+ (mkNPat (noLocI (mkHsIsString src s))
Nothing noAnn)
else normal_lit }
| otherwise = normal_lit
@@ -546,14 +546,14 @@ rnPatAndThen _ (NPat x (L l lit) mb_neg _eq)
; return (NPat x (L l lit') mb_neg' eq') }
rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ )
- = do { new_name <- newPatName mk (l2n rdr)
+ = do { new_name <- newPatName mk rdr
; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]
-- We skip negateName as
-- negative zero doesn't make
-- sense in n + k patterns
; minus <- liftCpsFV $ lookupSyntax minusName
; ge <- liftCpsFV $ lookupSyntax geName
- ; return (NPlusKPat noExtField (L (noAnnSrcSpan $ nameSrcSpan new_name) new_name)
+ ; return (NPlusKPat noExtField (L (noAnnSrcSpanN $ nameSrcSpan new_name) new_name)
(L l lit') lit' ge minus) }
-- The Report says that n+k patterns must be in Integral
@@ -691,7 +691,7 @@ rnHsRecPatsAndThen mk (L _ con)
; check_unused_wildcard (implicit_binders flds' <$> dd)
; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }
where
- mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n)
+ mkVarPat l n = VarPat noExtField (L (noAnnSrcSpanN l) n)
rn_field (L l fld, n') =
do { arg' <- rnLPatAndThen (nested_mk dd mk (RecFieldsDotDot n')) (hfbRHS fld)
; return (L l (fld { hfbRHS = arg' })) }
@@ -840,7 +840,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
; return [ L (noAnnSrcSpan loc) (HsFieldBind
{ hfbAnn = noAnn
, hfbLHS
- = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))
+ = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpanN loc) arg_rdr))
, hfbRHS = L locn (mk_arg loc arg_rdr)
, hfbPun = False })
| fl <- dot_dot_fields
@@ -1087,7 +1087,7 @@ rnOverLit origLit
; (from_thing_name, fvs1) <- lookupSyntaxName std_name
; let rebindable = from_thing_name /= std_name
lit' = lit { ol_ext = OverLitRn { ol_rebindable = rebindable
- , ol_from_fun = noLocA from_thing_name } }
+ , ol_from_fun = noLocN from_thing_name } }
; if isNegativeZeroOverLit lit'
then do { (negate_name, fvs2) <- lookupSyntaxExpr negateName
; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index d8566ec747..11e25dae1e 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -173,7 +173,7 @@ rn_utbracket outer_stage br@(VarBr x flg rdr_name)
(quotedNameStageErr br) }
}
}
- ; return (VarBr x flg (noLocA name), unitFV name) }
+ ; return (VarBr x flg (noLocN name), unitFV name) }
rn_utbracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e
; return (ExpBr x e', fvs) }
@@ -305,7 +305,7 @@ rnUntypedSpliceGen run_splice pend_splice splice
-> do { (splice', fvs) <- setStage pop_stage $
rnUntypedSplice splice
; loc <- getSrcSpanM
- ; splice_name <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
+ ; splice_name <- newLocalBndrRn (L (noAnnSrcSpanN loc) unqualSplice)
; let (pending_splice, result) = pend_splice splice_name splice'
; ps <- readMutVar ps_var
; writeMutVar ps_var (pending_splice : ps)
@@ -410,12 +410,12 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name
mkQuasiQuoteExpr flavour quoter (L q_span' quote)
= L q_span $ HsApp noComments (L q_span
$ HsApp noComments (L q_span
- (HsVar noExtField (L (la2na q_span) quote_selector)))
+ (HsVar noExtField (L (l2l q_span) quote_selector)))
quoterExpr)
quoteExpr
where
- q_span = noAnnSrcSpan (locA q_span')
- quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter)
+ q_span = noAnnSrcSpan (locI q_span')
+ quoterExpr = L q_span $! HsVar noExtField $! (L (l2l q_span) quoter)
quoteExpr = L q_span $! HsLit noComments $! HsString NoSourceText quote
quote_selector = case flavour of
UntypedExpSplice -> quoteExpName
@@ -487,7 +487,7 @@ rnTypedSplice expr
do { loc <- getSrcSpanM
-- The renamer allocates a splice-point name to every typed splice
-- (incl the top level ones for which it will not ultimately be used)
- ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) unqualSplice)
+ ; n' <- newLocalBndrRn (L (noAnnSrcSpanN loc) unqualSplice)
; (expr', fvs) <- rnLExpr expr
; return (HsTypedSplice n' expr', fvs) }
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index a00d97dd0d..a333edf93d 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -18,7 +18,7 @@ module GHC.Rename.Utils (
warnForallIdentifier,
checkUnusedRecordWildcard,
badQualBndrErr, typeAppErr, badFieldConErr,
- wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
+ wrapGenSpan, wrapGenSpanI, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
genHsIntegralLit, genHsTyLit, genSimpleConPat,
genVarPat, genWildPat,
genSimpleFunBind, genFunBind,
@@ -85,9 +85,9 @@ newLocalBndrRn (L loc rdr_name)
-- See Note [Binders in Template Haskell] in "GHC.ThToHs"
| otherwise
= do { unless (isUnqual rdr_name)
- (addErrAt (locA loc) (badQualBndrErr rdr_name))
+ (addErrAt (locN loc) (badQualBndrErr rdr_name))
; uniq <- newUnique
- ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) }
+ ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locN loc)) }
newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name]
newLocalBndrsRn = mapM newLocalBndrRn
@@ -111,14 +111,14 @@ bindLocalNamesFV names enclosed_scope
checkDupRdrNames :: [LocatedN RdrName] -> RnM ()
-- Check for duplicated names in a binding group
checkDupRdrNames rdr_names_w_loc
- = mapM_ (dupNamesErr getLocA) dups
+ = mapM_ (dupNamesErr getLocN) dups
where
(_, dups) = removeDupsOn unLoc rdr_names_w_loc
checkDupRdrNamesN :: [LocatedN RdrName] -> RnM ()
-- Check for duplicated names in a binding group
checkDupRdrNamesN rdr_names_w_loc
- = mapM_ (dupNamesErr getLocA) dups
+ = mapM_ (dupNamesErr getLocN) dups
where
(_, dups) = removeDupsOn unLoc rdr_names_w_loc
@@ -141,7 +141,7 @@ checkShadowedRdrNames loc_rdr_names
where
filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names
-- See Note [Binders in Template Haskell] in "GHC.ThToHs"
- get_loc_occ (L loc rdr) = (locA loc,rdrNameOcc rdr)
+ get_loc_occ (L loc rdr) = (locN loc,rdrNameOcc rdr)
checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()
checkDupAndShadowedNames envs names
@@ -437,7 +437,7 @@ check_unused flag bound_names used_names
warnForallIdentifier :: LocatedN RdrName -> RnM ()
warnForallIdentifier (L l rdr_name@(Unqual occ))
| isKw (fsLit "forall") || isKw (fsLit "∀")
- = addDiagnosticAt (locA l) (TcRnForallIdentifier rdr_name)
+ = addDiagnosticAt (locN l) (TcRnForallIdentifier rdr_name)
where isKw = (occNameFS occ ==)
warnForallIdentifier _ = return ()
@@ -663,11 +663,16 @@ checkCTupSize tup_size
* *
********************************************************************* -}
-wrapGenSpan :: a -> LocatedAn an a
+wrapGenSpan :: (Monoid an) => a -> LocatedAnS an a
-- Wrap something in a "generatedSrcSpan"
-- See Note [Rebindable syntax and HsExpansion]
wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
+wrapGenSpanI :: a -> LocatedAn an a
+-- Wrap something in a "generatedSrcSpan"
+-- See Note [Rebindable syntax and HsExpansion]
+wrapGenSpanI x = L (noAnnSrcSpanI generatedSrcSpan) x
+
genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn
genHsApps fun args = foldl genHsApp (genHsVar fun) args
@@ -683,7 +688,7 @@ genHsVar nm = HsVar noExtField $ wrapGenSpan nm
genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) noHsTok (mkEmptyWildCardBndrs (wrapGenSpan ty))
-genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)
+genHsIntegralLit :: IntegralLit -> LocatedA (HsExpr GhcRn)
genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
genHsTyLit :: FastString -> HsType GhcRn
@@ -705,16 +710,17 @@ genWildPat = wrapGenSpan $ WildPat noExtField
genSimpleFunBind :: Name -> [LPat GhcRn]
-> LHsExpr GhcRn -> LHsBind GhcRn
genSimpleFunBind fun pats expr
- = L gen $ genFunBind (L gen fun)
- [mkMatch (mkPrefixFunRhs (L gen fun)) pats expr
+ = L gen $ genFunBind (L genN fun)
+ [mkMatch (mkPrefixFunRhs (L genN fun)) pats expr
emptyLocalBinds]
where
gen = noAnnSrcSpan generatedSrcSpan
+ genN = noAnnSrcSpanN generatedSrcSpan
genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn
genFunBind fn ms
= FunBind { fun_id = fn
- , fun_matches = mkMatchGroup Generated (wrapGenSpan ms)
+ , fun_matches = mkMatchGroup Generated (wrapGenSpanI ms)
, fun_ext = emptyNameSet
}
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 88dbe46626..b3ecfed284 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -1252,7 +1252,7 @@ dynCompileExpr expr = do
parsed_expr <- parseExpr expr
-- > Data.Dynamic.toDyn expr
let loc = getLoc parsed_expr
- to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (la2na loc) $ getRdrName toDynName)
+ to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (l2l loc) $ getRdrName toDynName)
parsed_expr
hval <- compileParsedExpr to_dyn_expr
return (unsafeCoerce hval :: Dynamic)
diff --git a/compiler/GHC/Tc/Deriv/Functor.hs b/compiler/GHC/Tc/Deriv/Functor.hs
index 9b5032531c..c89a0733b0 100644
--- a/compiler/GHC/Tc/Deriv/Functor.hs
+++ b/compiler/GHC/Tc/Deriv/Functor.hs
@@ -156,7 +156,7 @@ gen_Functor_binds loc (DerivInstTys{dit_rep_tc = tycon})
| Phantom <- last (tyConRoles tycon)
= (unitBag fmap_bind, emptyBag)
where
- fmap_name = L (noAnnSrcSpan loc) fmap_RDR
+ fmap_name = L (noAnnSrcSpanN loc) fmap_RDR
fmap_bind = mkRdrFunBind fmap_name fmap_eqns
fmap_eqns = [mkSimpleMatch fmap_match_ctxt
[nlWildPat]
@@ -168,7 +168,7 @@ gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
= (listToBag [fmap_bind, replace_bind], emptyBag)
where
data_cons = getPossibleDataCons tycon tycon_args
- fmap_name = L (noAnnSrcSpan loc) fmap_RDR
+ fmap_name = L (noAnnSrcSpanN loc) fmap_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
@@ -207,7 +207,7 @@ gen_Functor_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
, ft_co_var = panic "contravariant in ft_fmap" }
-- See Note [Deriving <$]
- replace_name = L (noAnnSrcSpan loc) replace_RDR
+ replace_name = L (noAnnSrcSpanN loc) replace_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
@@ -819,7 +819,7 @@ gen_Foldable_binds loc (DerivInstTys{dit_rep_tc = tycon})
| Phantom <- last (tyConRoles tycon)
= (unitBag foldMap_bind, emptyBag)
where
- foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
+ foldMap_name = L (noAnnSrcSpanN loc) foldMap_RDR
foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns
foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
[nlWildPat, nlWildPat]
@@ -837,9 +837,9 @@ gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
where
data_cons = getPossibleDataCons tycon tycon_args
- foldr_name = L (noAnnSrcSpan loc) foldable_foldr_RDR
+ foldr_name = L (noAnnSrcSpanN loc) foldable_foldr_RDR
- foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns
+ foldr_bind = mkRdrFunBind (L (noAnnSrcSpanN loc) foldable_foldr_RDR) eqns
eqns = map foldr_eqn data_cons
foldr_eqn con
= evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
@@ -847,7 +847,7 @@ gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
parts = sequence $ foldDataConArgs ft_foldr con dit
foldr_match_ctxt = mkPrefixFunRhs foldr_name
- foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
+ foldMap_name = L (noAnnSrcSpanN loc) foldMap_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)
@@ -871,7 +871,7 @@ gen_Foldable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
go NotNull = Nothing
go (NullM a) = Just (Just a)
- null_name = L (noAnnSrcSpan loc) null_RDR
+ null_name = L (noAnnSrcSpanN loc) null_RDR
null_match_ctxt = mkPrefixFunRhs null_name
null_bind = mkRdrFunBind null_name null_eqns
null_eqns = map null_eqn data_cons
@@ -1053,7 +1053,7 @@ gen_Traversable_binds loc (DerivInstTys{dit_rep_tc = tycon})
| Phantom <- last (tyConRoles tycon)
= (unitBag traverse_bind, emptyBag)
where
- traverse_name = L (noAnnSrcSpan loc) traverse_RDR
+ traverse_name = L (noAnnSrcSpanN loc) traverse_RDR
traverse_bind = mkRdrFunBind traverse_name traverse_eqns
traverse_eqns =
[mkSimpleMatch traverse_match_ctxt
@@ -1067,7 +1067,7 @@ gen_Traversable_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
where
data_cons = getPossibleDataCons tycon tycon_args
- traverse_name = L (noAnnSrcSpan loc) traverse_RDR
+ traverse_name = L (noAnnSrcSpanN loc) traverse_RDR
-- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index 7ada3093e5..e01b54ef22 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -601,7 +601,7 @@ nlConWildPat :: DataCon -> LPat GhcPs
-- The pattern (K {})
nlConWildPat con = noLocA $ ConPat
{ pat_con_ext = noAnn
- , pat_con = noLocA $ getRdrName con
+ , pat_con = noLocN $ getRdrName con
, pat_args = RecCon $ HsRecFields
{ rec_flds = []
, rec_dotdot = Nothing }
@@ -857,7 +857,7 @@ gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
enum_index
= mkSimpleGeneratedFunBind loc unsafeIndex_RDR
- [noLocA (AsPat noAnn (noLocA c_RDR) noHsTok
+ [noLocA (AsPat noAnn (noLocN c_RDR) noHsTok
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] (
untag_Expr [(a_RDR, ah_RDR)] (
@@ -1993,7 +1993,7 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
underlying_inst_tys :: [Type]
underlying_inst_tys = changeLast inst_tys rhs_ty
- locn = noAnnSrcSpan loc'
+ locn = noAnnSrcSpanN loc'
loca = noAnnSrcSpan loc'
-- For each class method, generate its derived binding and instance
-- signature. Using the first example from
@@ -2043,7 +2043,7 @@ gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
mk_hs_tvb (Bndr tv flag) = noLocA $ KindedTyVar noAnn
flag
- (noLocA (getRdrName tv))
+ (noLocN (getRdrName tv))
(nlHsCoreTy (tyVarKind tv))
meth_RDR = getRdrName meth_id
@@ -2081,7 +2081,7 @@ gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty
underlying_inst_tys = changeLast inst_tys rhs_ty
ats = classATs cls
- locn = noAnnSrcSpan loc'
+ locn = noAnnSrcSpanN loc'
cls_tvs = classTyVars cls
in_scope = mkInScopeSetList inst_tvs
lhs_env = zipTyEnv cls_tvs inst_tys
@@ -2167,7 +2167,7 @@ genAuxBindSpecOriginal loc spec
(genAuxBindSpecSig loc spec)))
where
loca = noAnnSrcSpan loc
- locn = noAnnSrcSpan loc
+ locn = noAnnSrcSpanN loc
gen_bind :: AuxBindSpec -> LHsBind GhcPs
gen_bind (DerivTag2Con _ tag2con_RDR)
= mkFunBindSE 0 loc tag2con_RDR
@@ -2222,7 +2222,7 @@ genAuxBindSpecDup loc original_rdr_name dup_spec
(genAuxBindSpecSig loc dup_spec)))
where
loca = noAnnSrcSpan loc
- locn = noAnnSrcSpan loc
+ locn = noAnnSrcSpanN loc
dup_rdr_name = auxBindSpecRdrName dup_spec
-- | Generate the type signature of an auxiliary binding.
@@ -2291,9 +2291,9 @@ mkFunBindSE :: Arity -> SrcSpan -> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindSE arity loc fun pats_and_exprs
- = mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches
+ = mkRdrFunBindSE arity (L (noAnnSrcSpanN loc) fun) matches
where
- matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
+ matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpanN loc) fun))
(map (parenthesizePat appPrec) p) e
emptyLocalBinds
| (p,e) <-pats_and_exprs]
@@ -2301,7 +2301,7 @@ mkFunBindSE arity loc fun pats_and_exprs
mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBind fun@(L loc _fun_rdr) matches
- = L (na2la loc) (mkFunBind Generated fun matches)
+ = L (l2l loc) (mkFunBind Generated fun matches)
-- | Make a function binding. If no equations are given, produce a function
-- with the given arity that uses an empty case expression for the last
@@ -2312,9 +2312,9 @@ mkFunBindEC :: Arity -> SrcSpan -> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC arity loc fun catch_all pats_and_exprs
- = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches
+ = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpanN loc) fun) matches
where
- matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
+ matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpanN loc) fun))
(map (parenthesizePat appPrec) p) e
emptyLocalBinds
| (p,e) <- pats_and_exprs ]
@@ -2329,7 +2329,7 @@ mkRdrFunBindEC :: Arity
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
- = L (na2la loc) (mkFunBind Generated fun matches')
+ = L (l2l loc) (mkFunBind Generated fun matches')
where
-- Catch-all eqn looks like
-- fmap _ z = case z of {}
@@ -2353,7 +2353,7 @@ mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
- = L (na2la loc) (mkFunBind Generated fun matches')
+ = L (l2l loc) (mkFunBind Generated fun matches')
where
-- Catch-all eqn looks like
-- compare _ _ = error "Void compare"
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index 41e7bb3e92..7ea70157cb 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -395,7 +395,7 @@ mkBindsRep dflags gk loc dit@(DerivInstTys{dit_rep_tc = tycon}) = (binds, sigs)
from_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
to_matches = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts ]
- loc' = noAnnSrcSpan loc
+ loc' = noAnnSrcSpanN loc
loc'' = noAnnSrcSpan loc
datacons = tyConDataCons tycon
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 33c67fee79..58da01ee7c 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -190,7 +190,7 @@ instance Diagnostic TcRnMessage where
TcRnDuplicateWarningDecls d rdr_name
-> mkSimpleDecorated $
vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
- text "also at " <+> ppr (getLocA d)]
+ text "also at " <+> ppr (getLocN d)]
TcRnSimplifierTooManyIterations simples limit wc
-> mkSimpleDecorated $
hang (text "solveWanteds: too many iterations"
@@ -307,7 +307,7 @@ instance Diagnostic TcRnMessage where
2 (vcat $ map pprLBind . bagToList $ binds)
where
pprLoc loc = parens (text "defined at" <+> ppr loc)
- pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc
+ pprLBind :: CollectPass GhcRn => LocatedAnS a (HsBindLR GhcRn idR) -> SDoc
pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)
<+> pprLoc (locA loc)
TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty
@@ -3110,7 +3110,7 @@ dodgy_msg kind tc ie
dodgy_msg_insert :: GlobalRdrElt -> IE GhcRn
dodgy_msg_insert tc_gre = IEThingAll noAnn ii
where
- ii = noLocA (IEName noExtField $ noLocA $ greName tc_gre)
+ ii = noLocA (IEName noExtField $ noLocN $ greName tc_gre)
pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc
pprTypeDoesNotHaveFixedRuntimeRep ty prov =
diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs
index cee24aa395..95739663ac 100644
--- a/compiler/GHC/Tc/Gen/Bind.hs
+++ b/compiler/GHC/Tc/Gen/Bind.hs
@@ -219,7 +219,7 @@ tcCompleteSigs sigs =
-- compatible with the result type constructor 'mb_tc'.
doOne (L loc c@(CompleteMatchSig (_ext, _src_txt) (L _ ns) mb_tc_nm))
= fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do
- cls <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns
+ cls <- mkUniqDSet <$> mapM (addLocMN tcLookupConLike) ns
mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm
pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc }
doOne _ = return Nothing
@@ -609,7 +609,7 @@ tcPolyCheck prag_fn
, fun_matches = matches }))
= do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
- ; mono_name <- newNameAt (nameOccName name) (locA nm_loc)
+ ; mono_name <- newNameAt (nameOccName name) (locN nm_loc)
; (wrap_gen, (wrap_res, matches'))
<- setSrcSpan sig_loc $ -- Sets the binding location for the skolems
tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty ->
@@ -639,7 +639,7 @@ tcPolyCheck prag_fn
; poly_id <- addInlinePrags poly_id prag_sigs
; mod <- getModule
- ; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs
+ ; tick <- funBindTicks (locN nm_loc) poly_id mod prag_sigs
; let bind' = FunBind { fun_id = L nm_loc poly_id2
, fun_matches = matches'
@@ -1467,7 +1467,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name
-- Just g = ...f...
-- Hence always typechecked with InferGen
do { mono_info <- tcLhsSigId no_gen (name, sig)
- ; return (TcFunBind mono_info (locA nm_loc) matches) }
+ ; return (TcFunBind mono_info (locN nm_loc) matches) }
| otherwise -- No type signature
= do { mono_ty <- newOpenFlexiTyVarTy
@@ -1478,7 +1478,7 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name
; let mono_info = MBI { mbi_poly_name = name
, mbi_sig = Nothing
, mbi_mono_id = mono_id }
- ; return (TcFunBind mono_info (locA nm_loc) matches) }
+ ; return (TcFunBind mono_info (locN nm_loc) matches) }
tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
= -- See Note [Typechecking pattern bindings]
@@ -1554,9 +1554,9 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
= tcExtendIdBinderStackForRhs [info] $
tcExtendTyVarEnvForRhs mb_sig $
do { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
- ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id))
+ ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpanN loc) (idName mono_id))
matches (mkCheckExpType $ idType mono_id)
- ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id
+ ; return ( FunBind { fun_id = L (noAnnSrcSpanN loc) mono_id
, fun_matches = matches'
, fun_ext = (co_fn, [])
} ) }
diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs
index eed125e8b0..1eac073791 100644
--- a/compiler/GHC/Tc/Gen/Export.hs
+++ b/compiler/GHC/Tc/Gen/Export.hs
@@ -192,8 +192,8 @@ rnExports explicit_mod exports
; let real_exports
| explicit_mod = exports
| has_main
- = Just (noLocA [noLocA (IEVar noExtField
- (noLocA (IEName noExtField $ noLocA default_main)))])
+ = Just (noLocI [noLocA (IEVar noExtField
+ (noLocA (IEName noExtField $ noLocN default_main)))])
-- ToDo: the 'noLoc' here is unhelpful if 'main'
-- turns out to be out of scope
| otherwise = Nothing
@@ -532,7 +532,7 @@ lookupChildrenExport spec_parent rdr_items = mapAndReportM doOne rdr_items
do { ub <- reportUnboundName unboundName
; let l = getLoc n
gre = localVanillaGRE NoParent ub
- ; return (L l (IEName noExtField (L (la2na l) ub)), gre)}
+ ; return (L l (IEName noExtField (L (l2l l) ub)), gre)}
FoundChild child@(GRE { gre_par = par }) ->
do { checkPatSynParent spec_parent par child
; let child_nm = greName child
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 8a7ce396bf..d400a1f810 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -254,7 +254,7 @@ tcExpr e@(HsIPVar _ x) res_ty
; ipClass <- tcLookupClass ipClassName
; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
; tcWrapResult e
- (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var)))
+ (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocN ip_var)))
ip_ty res_ty }
where
-- Coerces a dictionary for `IP "x" t` into `t`.
@@ -1253,7 +1253,7 @@ desugarRecordUpd record_expr possible_parents rbnds res_ty
ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr)
case_expr :: HsExpr GhcRn
- case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpan matches))
+ case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpanI matches))
matches :: [LMatch GhcRn (LHsExpr GhcRn)]
matches = map make_pat relevant_cons
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 31c42f86d6..ad6580b537 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -424,7 +424,7 @@ tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spe
-- We need to give a name to the new top-level binding that
-- is *stable* (i.e. the compiler won't change it later),
-- because this name will be referred to by the C code stub.
- id <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc
+ id <- mkStableIdFromName nm sig_ty (locN loc) mkForeignExportOcc
return ( mkVarBind id rhs
, ForeignExport { fd_name = L loc id
, fd_sig_ty = undefined
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index a5ad2f1733..e75f48c6a2 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -1009,7 +1009,7 @@ tcCheckId name res_ty
; addFunResCtxt rn_fun [] actual_res_ty res_ty $
tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty }
where
- rn_fun = HsVar noExtField (noLocA name)
+ rn_fun = HsVar noExtField (noLocN name)
------------------------
tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
@@ -1034,7 +1034,7 @@ tc_infer_assert assert_name
= do { assert_error_id <- tcLookupId assertErrorName
; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
(idType assert_error_id)
- ; return (mkHsWrap wrap (HsVar noExtField (noLocA assert_error_id)), id_rho)
+ ; return (mkHsWrap wrap (HsVar noExtField (noLocN assert_error_id)), id_rho)
}
tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
@@ -1086,7 +1086,7 @@ tc_infer_id id_name
lcl_env <- getLocalRdrEnv
unknownNameSuggestions lcl_env WL_Anything (mkRdrUnqual occ)
- return_id id = return (HsVar noExtField (noLocA id), idType id)
+ return_id id = return (HsVar noExtField (noLocN id), idType id)
check_local_id :: Id -> TcM ()
check_local_id id
@@ -1297,7 +1297,7 @@ checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
; lift <- if isStringTy id_ty then
do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName
-- See Note [Lifting strings]
- ; return (HsVar noExtField (noLocA sid)) }
+ ; return (HsVar noExtField (noLocN sid)) }
else
setConstraintVar lie_var $
-- Put the 'lift' constraint into the right LIE
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 9e8375b47d..bd366d688c 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -652,7 +652,7 @@ tcDerivStrategy mb_lds
= case mb_lds of
Nothing -> boring_case Nothing
Just (L loc ds) ->
- setSrcSpanA loc $ do
+ setSrcSpanI loc $ do
(ds', tvs) <- tc_deriv_strategy ds
pure (Just (L loc ds'), tvs)
where
@@ -765,7 +765,7 @@ tcFamTyPats fam_tc hs_pats
where
fam_name = tyConName fam_tc
fam_arity = tyConArity fam_tc
- lhs_fun = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name))
+ lhs_fun = noLocA (HsTyVar noAnn NotPromoted (noLocN fam_name))
{- Note [tcFamTyPats: zonking the result kind]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1525,7 +1525,7 @@ splitHsAppTys hs_ty
go (L _ (HsAppKindTy _ ty at k)) as = go ty (HsTypeArg at k : as)
go (L sp (HsParTy _ f)) as = go f (HsArgPar (locA sp) : as)
go (L _ (HsOpTy _ prom l op@(L sp _) r)) as
- = ( L (na2la sp) (HsTyVar noAnn prom op)
+ = ( L (l2l sp) (HsTyVar noAnn prom op)
, HsValArg l : HsValArg r : as )
go f as = (f, as)
diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs
index db48eec968..82e5b3b4d8 100644
--- a/compiler/GHC/Tc/Gen/Match.hs
+++ b/compiler/GHC/Tc/Gen/Match.hs
@@ -202,8 +202,8 @@ type AnnoBody body
, Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
, Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
, Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL
- , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns
- , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
+ , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ EpAnnS NoEpAnns
+ , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnS NoEpAnns
, Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
, Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
)
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 28b9891b91..a728a8161d 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -415,7 +415,7 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
AsPat x (L nm_loc name) at pat -> do
{ mult_wrap <- checkManyPattern pat_ty
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
- ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)
+ ; (wrap, bndr_id) <- setSrcSpanN nm_loc (tcPatBndr penv name pat_ty)
; (pat', res) <- tcExtendIdEnv1 name bndr_id $
tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))
penv pat thing_inside
@@ -662,7 +662,7 @@ AST is used for the subtraction operation.
<- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $
\ [lit2_ty, var_ty] _ ->
do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
- ; (wrap, bndr_id) <- setSrcSpanA nm_loc $
+ ; (wrap, bndr_id) <- setSrcSpanN nm_loc $
tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)
-- co :: var_ty ~ idType bndr_id
@@ -906,7 +906,7 @@ tcDataConPat (L con_span con_name) data_con pat_ty_scaled
; pat_ty <- readExpType (scaledThing pat_ty_scaled)
-- Add the stupid theta
- ; setSrcSpanA con_span $ addDataConStupidTheta data_con ctxt_res_tys
+ ; setSrcSpanN con_span $ addDataConStupidTheta data_con ctxt_res_tys
-- Check that this isn't a GADT pattern match
-- in situations in which that isn't allowed.
diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs
index 121c43b987..fa4be02107 100644
--- a/compiler/GHC/Tc/Gen/Rule.hs
+++ b/compiler/GHC/Tc/Gen/Rule.hs
@@ -185,7 +185,7 @@ tcRule (HsRule { rd_ext = ext
, rd_name = rname
, rd_act = act
, rd_tyvs = ty_bndrs -- preserved for ppr-ing
- , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA)
+ , rd_tmvs = map (noLocI . RuleBndr noAnn . noLocN)
(qtkvs ++ tpl_ids)
, rd_lhs = mkHsDictLet lhs_binds lhs'
, rd_rhs = mkHsDictLet rhs_binds rhs' } }
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index abd204fa50..f84e3eebfa 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -271,7 +271,7 @@ lhsSigWcTypeContextSpan (HsWC { hswc_body = sigType }) = lhsSigTypeContextSpan s
lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints
lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty
where
- go (L _ (HsQualTy { hst_ctxt = L span _ })) = WantRRC $ locA span -- Found it!
+ go (L _ (HsQualTy { hst_ctxt = L span _ })) = WantRRC $ locI span -- Found it!
go (L _ (HsForAllTy { hst_body = hs_ty })) = go hs_ty -- Look under foralls
go (L _ (HsParTy _ hs_ty)) = go hs_ty -- Look under parens
go _ = NoRRC -- Did not find it
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index e28ba6f24f..9977b867c9 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -998,7 +998,7 @@ runAnnotation target expr = do
; let loc' = noAnnSrcSpan loc
; let specialised_to_annotation_wrapper_expr
= L loc' (mkHsWrap wrapper
- (HsVar noExtField (L (noAnnSrcSpan loc) to_annotation_wrapper_id)))
+ (HsVar noExtField (L (noAnnSrcSpanN loc) to_annotation_wrapper_id)))
; return (L loc' (HsApp noComments
specialised_to_annotation_wrapper_expr expr'))
})
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 1b02340061..8cd1b5fd49 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -289,7 +289,7 @@ tcRnModuleTcRnM hsc_env mod_sum
++ import_decls))
; let { mkImport mod_name = noLocA
$ (simpleImportDecl mod_name)
- { ideclImportList = Just (Exactly, noLocA [])}}
+ { ideclImportList = Just (Exactly, noLocI [])}}
; let { withReason t imps = map (,text t) imps }
; let { all_imports = withReason "is implicitly imported" prel_imports
++ withReason "is directly imported" import_decls
@@ -2033,7 +2033,7 @@ generateMainBinding tcg_env main_name = do
{ traceTc "checkMain found" (ppr main_name)
; (io_ty, res_ty) <- getIOType
; let loc = getSrcSpan main_name
- main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name))
+ main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpanN loc) main_name))
; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $
tcCheckMonoExpr main_expr_rn io_ty
@@ -2371,7 +2371,7 @@ tcUserStmt (L loc (BodyStmt _ expr _ _))
-- Don't try to typecheck if the renamer fails!
; ghciStep <- getGhciStepIO
; uniq <- newUnique
- ; let loc' = noAnnSrcSpan $ locA loc
+ ; let loc' = noAnnSrcSpanN $ locA loc
; interPrintName <- getInteractivePrintName
; let fresh_it = itName uniq (locA loc)
matches = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr
@@ -2639,7 +2639,7 @@ tcGhciStmts stmts
stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)]
; return (ids, mkHsDictLet (EvBinds const_binds) $
- noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts)))
+ noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocI stmts)))
}
-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
@@ -2973,7 +2973,7 @@ tcRnLookupRdrName :: HscEnv -> LocatedN RdrName
-- ^ Find all the Names that this RdrName could mean, in GHCi
tcRnLookupRdrName hsc_env (L loc rdr_name)
= runTcInteractive hsc_env $
- setSrcSpanA loc $
+ setSrcSpanN loc $
do { -- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
-- constructor and type class identifiers.
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index de6ef49225..ee43b5937a 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -2827,7 +2827,7 @@ tcInjectivity _ Nothing
-- But this does not seem to be useful in any way so we don't do it. (Another
-- reason is that the implementation would not be straightforward.)
tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames)))
- = setSrcSpanA loc $
+ = setSrcSpanI loc $
do { let tvs = binderVars tcbs
; dflags <- getDynFlags
-- Fail eagerly to avoid reporting injectivity errors when
@@ -4346,7 +4346,7 @@ checkFieldCompat fld con1 con2 res1 res2 fty1 fty2
checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
checkValidDataCon dflags existential_ok tc con
= setSrcSpan con_loc $
- addErrCtxt (dataConCtxt (NE.singleton (L (noAnnSrcSpan con_loc) con_name))) $
+ addErrCtxt (dataConCtxt (NE.singleton (L (noAnnSrcSpanN con_loc) con_name))) $
do { let tc_tvs = tyConTyVars tc
res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
arg_tys = dataConOrigArgTys con
@@ -4992,7 +4992,7 @@ checkValidRoleAnnots role_annots tc
check_no_roles
= whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl
-checkRoleAnnot :: TyVar -> LocatedAn NoEpAnns (Maybe Role) -> Role -> TcM ()
+checkRoleAnnot :: TyVar -> LocatedAnS NoEpAnns (Maybe Role) -> Role -> TcM ()
checkRoleAnnot _ (L _ Nothing) _ = return ()
checkRoleAnnot tv (L _ (Just r1)) r2
= when (r1 /= r2) $
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 79374ac894..58d0b91d5d 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -177,7 +177,7 @@ tcClassSigs clas sigs def_methods
-> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))] -- AZ temp
tc_gen_sig (op_names, gen_hs_ty)
= do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
- ; return [ (op_name, (locA loc, gen_op_ty))
+ ; return [ (op_name, (locN loc, gen_op_ty))
| L loc op_name <- op_names ] }
{-
@@ -194,8 +194,8 @@ tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration
tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
= recoverM (return emptyLHsBinds) $
- setSrcSpan (getLocA class_name) $
- do { clas <- tcLookupLocatedClass (n2l class_name)
+ setSrcSpan (getLocN class_name) $
+ do { clas <- tcLookupLocatedClass class_name
-- We make a separate binding for each default method.
-- At one time I used a single AbsBinds for all of them, thus
@@ -281,7 +281,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
- lm_bind = dm_bind { fun_id = L (la2na bind_loc) local_dm_name }
+ lm_bind = dm_bind { fun_id = L (l2l bind_loc) local_dm_name }
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
@@ -345,7 +345,7 @@ tcClassMinimalDef _clas sigs op_info
where
-- By default require all methods without a default implementation
defMindef :: ClassMinimalDef
- defMindef = mkAnd [ noLocA (mkVar name)
+ defMindef = mkAnd [ noLocI (mkVar name)
| (name, _, Nothing) <- op_info ]
instantiateMethod :: Class -> TcId -> [TcType] -> TcType
@@ -395,7 +395,7 @@ findMethodBind sel_name binds prag_fn
f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
| op_name == sel_name
- = Just (bind, locA bndr_loc, prags)
+ = Just (bind, locN bndr_loc, prags)
f _other = Nothing
---------------------------
@@ -508,7 +508,7 @@ tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
(tv', cv') = partition isTyVar tcv'
tvs' = scopedSort tv'
cvs' = scopedSort cv'
- ; rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpan loc) (tyConName fam_tc)) pat_tys'
+ ; rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpanN loc) (tyConName fam_tc)) pat_tys'
; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs'
fam_tc pat_tys' rhs'
-- NB: no validity check. We check validity of default instances
diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs
index caae46ce36..937648d2f2 100644
--- a/compiler/GHC/Tc/TyCl/Instance.hs
+++ b/compiler/GHC/Tc/TyCl/Instance.hs
@@ -596,7 +596,7 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
-- For some reason we don't have a location for the equation
-- itself, so we make do with the location of family name
; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
- (L (na2la $ getLoc fam_lname) eqn)
+ (L (l2l $ getLoc fam_lname) eqn)
-- (2) check for validity
; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch
@@ -1366,7 +1366,7 @@ addDFunPrags dfun_id sc_meth_ids
is_newtype = isNewTyCon clas_tc
wrapId :: HsWrapper -> Id -> HsExpr GhcTc
-wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocA id))
+wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocN id))
{- Note [Typechecking plan for instance declarations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1938,7 +1938,7 @@ tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys
mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
- ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpan bndr_loc)
+ ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpanN bndr_loc)
(idName local_meth_id) }
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
@@ -2161,7 +2161,7 @@ mkDefMethBind loc dfun_id clas sel_id dm_name
-- Copy the inline pragma (if any) from the default method
-- to this version. Note [INLINE and default methods]
- fn = noLocA (idName sel_id)
+ fn = noLocN (idName sel_id)
visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
, tyConBinderForAllTyFlag tcb /= Inferred ]
rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
@@ -2410,4 +2410,3 @@ instDeclCtxt2 dfun_ty
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = hang (text "In the instance declaration for")
2 (quotes doc)
-
diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs
index c61c471bac..9f7e1374ba 100644
--- a/compiler/GHC/Tc/TyCl/PatSyn.hs
+++ b/compiler/GHC/Tc/TyCl/PatSyn.hs
@@ -768,7 +768,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
(univ_tvs, req_theta, req_ev_binds, req_dicts)
(ex_tvs, ex_tys, prov_theta, prov_dicts)
(args, arg_tys) pat_ty
- = do { let loc' = locA loc
+ = do { let loc' = locN loc
; rr_name <- newNameAt (mkTyVarOccFS (fsLit "rep")) loc'
; tv_name <- newNameAt (mkTyVarOccFS (fsLit "r")) loc'
; let rr_tv = mkTyVar rr_name runtimeRepTy
@@ -810,12 +810,12 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
body = mkLHsWrap (mkWpLet req_ev_binds) $
L (getLoc lpat) $
HsCase noExtField (nlHsVar scrutinee) $
- MG{ mg_alts = L (l2l $ getLoc lpat) cases
+ MG{ mg_alts = L (nn2la $ getLoc lpat) cases
, mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated
}
body' = noLocA $
HsLam noExtField $
- MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr
+ MG{ mg_alts = noLocI [mkSimpleMatch LambdaExpr
args body]
, mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated
}
@@ -824,7 +824,7 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
req_dicts body')
(EmptyLocalBinds noExtField)
mg :: MatchGroup GhcTc (LHsExpr GhcTc)
- mg = MG{ mg_alts = L (l2l $ getLoc match) [match]
+ mg = MG{ mg_alts = L (nn2la $ getLoc match) [match]
, mg_ext = MatchGroupTc [] res_ty Generated
}
matcher_arity = length req_theta + 3
@@ -958,9 +958,9 @@ tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)
Unidirectional -> panic "tcPatSynBuilderBind"
mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
- mk_mg body = mkMatchGroup Generated (noLocA [builder_match])
+ mk_mg body = mkMatchGroup Generated (noLocI [builder_match])
where
- builder_args = [L (na2la loc) (VarPat noExtField (L loc n))
+ builder_args = [L (l2l loc) (VarPat noExtField (L loc n))
| L loc n <- args]
builder_match = mkMatch (mkPrefixFunRhs ps_lname)
builder_args body
diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs
index 8e7b3b8c39..7b4367ccc5 100644
--- a/compiler/GHC/Tc/TyCl/Utils.hs
+++ b/compiler/GHC/Tc/TyCl/Utils.hs
@@ -876,7 +876,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel
where
loc = getSrcSpan sel_name
loc' = noAnnSrcSpan loc
- locn = noAnnSrcSpan loc
+ locn = noAnnSrcSpanN loc
locc = noAnnSrcSpan loc
lbl = flLabel fl
sel_name = flSelector fl
diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs
index 5f76ba7e0c..c2e9146c1d 100644
--- a/compiler/GHC/Tc/Utils/Backpack.hs
+++ b/compiler/GHC/Tc/Utils/Backpack.hs
@@ -584,7 +584,7 @@ mergeSignatures
-- a signature package (i.e., does not expose any
-- modules.) If so, we can thin it.
| isFromSignaturePackage
- -> setSrcSpanA loc $ do
+ -> setSrcSpanI loc $ do
-- Suppress missing errors; they might be used to refer
-- to entities from other signatures we are merging in.
-- If an identifier truly doesn't exist in any of the
@@ -638,7 +638,7 @@ mergeSignatures
is_mod = mod_name,
is_as = mod_name,
is_qual = False,
- is_dloc = locA loc
+ is_dloc = locI loc
} ImpAll
rdr_env = mkGlobalRdrEnv $ gresFromAvails hsc_env (Just ispec) as1
setGblEnv tcg_env {
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index b8f9d83912..8a033d8e3a 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -320,11 +320,11 @@ tcLookupAxiom name = do
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
tcLookupLocatedGlobalId = addLocMA tcLookupId
-tcLookupLocatedClass :: LocatedA Name -> TcM Class
-tcLookupLocatedClass = addLocMA tcLookupClass
+tcLookupLocatedClass :: LocatedN Name -> TcM Class
+tcLookupLocatedClass = addLocMN tcLookupClass
tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
-tcLookupLocatedTyCon = addLocMA tcLookupTyCon
+tcLookupLocatedTyCon = addLocMN tcLookupTyCon
-- Find the instance that exactly matches a type class application. The class arguments must be precisely
-- the same as in the instance declaration (modulo renaming & casts).
@@ -1074,11 +1074,11 @@ newDFunName clas tys loc
; newGlobalBinder mod dfun_occ loc }
newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name
-newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locA loc) name [tys]
+newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locN loc) name [tys]
newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name
newFamInstAxiomName (L loc name) branches
- = mk_fam_inst_name mkInstTyCoOcc (locA loc) name branches
+ = mk_fam_inst_name mkInstTyCoOcc (locN loc) name branches
mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name adaptOcc loc tc_name tyss
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index 85671a0af5..58a472ff8a 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -131,7 +131,7 @@ newMethodFromName origin name ty_args
; wrap <- assert (not (isForAllTy ty) && isSingleton theta) $
instCall origin ty_args theta
- ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) }
+ ; return (mkHsWrap wrap (HsVar noExtField (noLocN id))) }
{-
************************************************************************
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 75b74cbb35..5172484ce9 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -61,9 +61,10 @@ module GHC.Tc.Utils.Monad(
addDependentFiles,
-- * Error management
- getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode,
- wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,
- wrapLocMA_,wrapLocMA,
+ getSrcSpanM, setSrcSpan, setSrcSpanA, setSrcSpanI, setSrcSpanN, addLocM, addLocMA, addLocMN,
+ inGeneratedCode,
+ wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocFstMI, wrapLocSndM, wrapLocSndMA, wrapLocM_,
+ wrapLocMA_, wrapLocMA, wrapLocMI,
getErrsVar, setErrsVar,
addErr,
failWith, failAt,
@@ -993,26 +994,39 @@ setSrcSpan loc@(UnhelpfulSpan _) thing_inside
| otherwise
= thing_inside
-setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a
+setSrcSpanA :: EpAnnS ann -> TcRn a -> TcRn a
setSrcSpanA l = setSrcSpan (locA l)
+setSrcSpanI :: SrcAnn ann -> TcRn a -> TcRn a
+setSrcSpanI l = setSrcSpan (locI l)
+
+setSrcSpanN :: EpAnnS ann -> TcRn a -> TcRn a
+setSrcSpanN l = setSrcSpan (locN l)
+
addLocM :: (a -> TcM b) -> Located a -> TcM b
addLocM fn (L loc a) = setSrcSpan loc $ fn a
-addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
+addLocMA :: (a -> TcM b) -> LocatedAnS ann a -> TcM b
addLocMA fn (L loc a) = setSrcSpanA loc $ fn a
+addLocMN :: (a -> TcM b) -> LocatedN a -> TcM b
+addLocMN fn (L loc a) = setSrcSpanN loc $ fn a
+
wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a
; return (L loc b) }
-wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)
+wrapLocAM :: (a -> TcM b) -> LocatedAnS ann a -> TcM (Located b)
wrapLocAM fn a = wrapLocM fn (reLoc a)
-wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b)
+wrapLocMA :: (a -> TcM b) -> LocatedAnS ann a -> TcRn (LocatedAnS ann b)
wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a
; return (L loc b) }
+wrapLocMI :: (a -> TcM b) -> LocatedAn ann a -> TcRn (LocatedAn ann b)
+wrapLocMI fn (L loc a) = setSrcSpanI loc $ do { b <- fn a
+ ; return (L loc b) }
+
wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
setSrcSpan loc $ do
@@ -1024,12 +1038,18 @@ wrapLocFstM fn (L loc a) =
-- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedN a -> TcM (LocatedN b, c)
-- wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c)
-- and so on.
-wrapLocFstMA :: (a -> TcM (b,c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (GenLocated (SrcSpanAnn' ann) b, c)
+wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAnS ann a -> TcM (LocatedAnS ann b, c)
wrapLocFstMA fn (L loc a) =
setSrcSpanA loc $ do
(b,c) <- fn a
return (L loc b, c)
+wrapLocFstMI :: (a -> TcM (b,c)) -> GenLocated (SrcAnn ann) a -> TcM (GenLocated (SrcAnn ann) b, c)
+wrapLocFstMI fn (L loc a) =
+ setSrcSpanI loc $ do
+ (b,c) <- fn a
+ return (L loc b, c)
+
wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c)
wrapLocSndM fn (L loc a) =
setSrcSpan loc $ do
@@ -1041,7 +1061,7 @@ wrapLocSndM fn (L loc a) =
-- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedN a -> TcM (b, LocatedN c)
-- wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAn t a -> TcM (b, LocatedAn t c)
-- and so on.
-wrapLocSndMA :: (a -> TcM (b, c)) -> GenLocated (SrcSpanAnn' ann) a -> TcM (b, GenLocated (SrcSpanAnn' ann) c)
+wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedAnS ann a -> TcM (b, LocatedAnS ann c)
wrapLocSndMA fn (L loc a) =
setSrcSpanA loc $ do
(b,c) <- fn a
diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs
index aa2ffa8bae..0b667eabbb 100644
--- a/compiler/GHC/Tc/Utils/Zonk.hs
+++ b/compiler/GHC/Tc/Utils/Zonk.hs
@@ -669,7 +669,7 @@ zonkLTcSpecPrags env ps
************************************************************************
-}
-zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
+zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnS NoEpAnns
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> MatchGroup GhcTc (LocatedA (body GhcTc))
@@ -684,7 +684,7 @@ zonkMatchGroup env zBody (MG { mg_alts = L l ms
, mg_ext = MatchGroupTc arg_tys' res_ty' origin
}) }
-zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
+zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnS NoEpAnns
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> LMatch GhcTc (LocatedA (body GhcTc))
@@ -696,7 +696,7 @@ zonkMatch env zBody (L loc match@(Match { m_pats = pats
; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }
-------------------------------------------------------------------------
-zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
+zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ EpAnnS NoEpAnns
=> ZonkEnv
-> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))
-> GRHSs GhcTc (LocatedA (body GhcTc))
@@ -1152,7 +1152,7 @@ zonkStmt env zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs
; new_later_rets <- mapM (zonkExpr env5) later_rets
; new_rec_rets <- mapM (zonkExpr env5) rec_rets
; return (extendIdZonkEnvRec env3 new_lvs, -- Only the lvs are needed
- RecStmt { recS_stmts = noLocA new_segStmts
+ RecStmt { recS_stmts = noLocI new_segStmts
, recS_later_ids = new_lvs
, recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
, recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 39da7e0c51..33cf68524a 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -141,15 +141,25 @@ getL = CvtM (\_ loc -> Right (loc,loc))
setL :: SrcSpan -> CvtM ()
setL loc = CvtM (\_ _ -> Right (loc, ()))
-returnLA :: e -> CvtM (LocatedAn ann e)
+returnLA :: (Monoid ann) => e -> CvtM (LocatedAnS ann e)
returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x))
+returnLL :: e -> CvtM (LocatedAn ann e)
+returnLL x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpanI loc) x))
+
+
returnJustLA :: a -> CvtM (Maybe (LocatedA a))
returnJustLA = fmap Just . returnLA
-wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b
+wrapParLA :: (LocatedA a -> b) -> a -> CvtM b
wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x)))
+wrapParLL :: (LocatedL a -> b) -> a -> CvtM b
+wrapParLL add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpanI loc) x)))
+
+wrapParLN :: (LocatedN a -> b) -> a -> CvtM b
+wrapParLN add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpanN loc) x)))
+
wrapMsg :: ThingBeingConverted -> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
wrapMsg what = mapCvtMError (ConversionFail what)
@@ -161,7 +171,7 @@ wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of
wrapLN :: CvtM a -> CvtM (LocatedN a)
wrapLN (CvtM m) = CvtM $ \origin loc -> case m origin loc of
Left err -> Left err
- Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v)
+ Right (loc', v) -> Right (loc', L (noAnnSrcSpanN loc) v)
wrapLA :: CvtM a -> CvtM (LocatedA a)
wrapLA (CvtM m) = CvtM $ \origin loc -> case m origin loc of
@@ -327,7 +337,7 @@ cvtDec (InstanceD o ctxt ty decs)
, cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts'
, cid_overlap_mode
- = fmap (L (l2l loc) . overlap) o } }
+ = fmap (L (nn2la loc) . overlap) o } }
where
overlap pragma =
case pragma of
@@ -464,7 +474,8 @@ cvtDec (TH.PatSynD nm args dir pat)
cvtDir n (ExplBidir cls) =
do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
; th_origin <- getOrigin
- ; wrapParLA (ExplicitBidirectional . mkMatchGroup th_origin) ms }
+ ; wrapParLL (ExplicitBidirectional . mkMatchGroup th_origin) ms }
+
cvtDec (TH.PatSynSigD nm ty)
= do { nm' <- cNameN nm
@@ -681,7 +692,7 @@ cvtConstr _ do_con_name (NormalC c strtys)
cvtConstr parent_con do_con_name (RecC c varstrtys)
= do { c' <- do_con_name c
; args' <- mapM (cvt_id_arg parent_con) varstrtys
- ; con_decl <- wrapParLA (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args'
+ ; con_decl <- wrapParLL (mkConDeclH98 noAnn c' Nothing Nothing . RecCon) args'
; returnLA con_decl }
cvtConstr _ do_con_name (InfixC st1 c st2)
@@ -736,7 +747,7 @@ cvtConstr parent_con do_con_name (RecGadtC c varstrtys ty) = case nonEmpty c of
{ c' <- mapM do_con_name c
; ty' <- cvtType ty
; rec_flds <- mapM (cvt_id_arg parent_con) varstrtys
- ; lrec_flds <- returnLA rec_flds
+ ; lrec_flds <- returnLL rec_flds
; mk_gadt_decl c' (RecConGADT lrec_flds noHsUniTok) ty' }
mk_gadt_decl :: NonEmpty (LocatedN RdrName) -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs
@@ -906,7 +917,7 @@ cvtPragmaD (SpecialiseInstP ty)
cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
= do { let nm' = mkFastString nm
- ; rd_name' <- returnLA nm'
+ ; rd_name' <- returnLL nm'
; let act = cvtPhases phases AlwaysActive
; ty_bndrs' <- traverse cvtTvs ty_bndrs
; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
@@ -932,10 +943,10 @@ cvtPragmaD (AnnP target exp)
ModuleAnnotation -> return ModuleAnnProvenance
TypeAnnotation n -> do
n' <- tconName n
- wrapParLA TypeAnnProvenance n'
+ wrapParLN TypeAnnProvenance n'
ValueAnnotation n -> do
n' <- vcName n
- wrapParLA ValueAnnProvenance n'
+ wrapParLN ValueAnnProvenance n'
; returnJustLA $ Hs.AnnD noExtField
$ HsAnnotation (noAnn, (SourceText "{-# ANN")) target' exp'
}
@@ -973,11 +984,11 @@ cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
cvtRuleBndr (RuleVar n)
= do { n' <- vNameN n
- ; returnLA $ Hs.RuleBndr noAnn n' }
+ ; returnLL $ Hs.RuleBndr noAnn n' }
cvtRuleBndr (TypedRuleVar n ty)
= do { n' <- vNameN n
; ty' <- cvtType ty
- ; returnLA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }
+ ; returnLL $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }
---------------------------------------------------
-- Declarations
@@ -1013,7 +1024,7 @@ cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)
cvtImplicitParamBind n e = do
n' <- wrapL (ipName n)
e' <- cvtl e
- returnLA (IPBind noAnn (reLocA n') e')
+ returnLA (IPBind noAnn (reLocE n') e')
-------------------------------------------------------------------
-- Expressions
@@ -1022,8 +1033,8 @@ cvtImplicitParamBind n e = do
cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
cvtl e = wrapLA (cvt e)
where
- cvt (VarE s) = do { s' <- vName s; wrapParLA (HsVar noExtField) s' }
- cvt (ConE s) = do { s' <- cName s; wrapParLA (HsVar noExtField) s' }
+ cvt (VarE s) = do { s' <- vName s; wrapParLN (HsVar noExtField) s' }
+ cvt (ConE s) = do { s' <- cName s; wrapParLN (HsVar noExtField) s' }
cvt (LitE l)
| overloadedLit l = go cvtOverLit (HsOverLit noComments)
(hsOverLitNeedsParens appPrec)
@@ -1052,17 +1063,17 @@ cvtl e = wrapLA (cvt e)
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; let pats = map (parenthesizePat appPrec) ps'
; th_origin <- getOrigin
- ; wrapParLA (HsLam noExtField . mkMatchGroup th_origin)
+ ; wrapParLA (HsLam noExtField . mkMatchGroup th_origin . n2l)
[mkSimpleMatch LambdaExpr pats e']}
cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch $ LamCaseAlt LamCase) ms
; th_origin <- getOrigin
- ; wrapParLA (HsLamCase noAnn LamCase . mkMatchGroup th_origin) ms'
+ ; wrapParLA (HsLamCase noAnn LamCase . mkMatchGroup th_origin . n2l) ms'
}
cvt (LamCasesE ms)
| null ms = failWith CasesExprWithoutAlts
| otherwise = do { ms' <- mapM (cvtClause $ LamCaseAlt LamCases) ms
; th_origin <- getOrigin
- ; wrapParLA (HsLamCase noAnn LamCases . mkMatchGroup th_origin) ms'
+ ; wrapParLA (HsLamCase noAnn LamCases . mkMatchGroup th_origin . n2l) ms'
}
cvt (TupE es) = cvt_tup es Boxed
cvt (UnboxedTupE es) = cvt_tup es Unboxed
@@ -1079,7 +1090,7 @@ cvtl e = wrapLA (cvt e)
; e' <- cvtl e; return $ HsLet noAnn noHsTok ds' noHsTok e'}
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
; th_origin <- getOrigin
- ; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin) ms' }
+ ; wrapParLA (HsCase noAnn e' . mkMatchGroup th_origin .n2l) ms' }
cvt (DoE m ss) = cvtHsDo (DoExpr (mk_mod <$> m)) ss
cvt (MDoE m ss) = cvtHsDo (MDoExpr (mk_mod <$> m)) ss
cvt (CompE ss) = cvtHsDo ListComp ss
@@ -1134,11 +1145,11 @@ cvtl e = wrapLA (cvt e)
; let pe = parenthesizeHsExpr sigPrec e'
; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }
cvt (RecConE c flds) = do { c' <- cNameN c
- ; flds' <- mapM (cvtFld (wrapParLA mkFieldOcc)) flds
+ ; flds' <- mapM (cvtFld (wrapParLN mkFieldOcc)) flds
; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) noAnn }
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds'
- <- mapM (cvtFld (wrapParLA mkAmbiguousFieldOcc))
+ <- mapM (cvtFld (wrapParLN mkAmbiguousFieldOcc))
flds
; return $ RecordUpd noAnn e' $
RegularRecUpdFields
@@ -1149,14 +1160,14 @@ cvtl e = wrapLA (cvt e)
-- important, because UnboundVarE may contain
-- constructor names - see #14627.
{ s' <- vcName s
- ; wrapParLA (HsVar noExtField) s' }
+ ; wrapParLN (HsVar noExtField) s' }
cvt (LabelE s) = return $ HsOverLabel noComments NoSourceText (fsLit s)
cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' }
cvt (GetFieldE exp f) = do { e' <- cvtl exp
; return $ HsGetField noComments e'
- (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (FieldLabelString (fsLit f))))) }
+ (L noSrcSpanI (DotFieldOcc noAnn (L noSrcSpanN (FieldLabelString (fsLit f))))) }
cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap
- (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . FieldLabelString . fsLit) xs
+ (L noSrcSpanI . DotFieldOcc noAnn . L noSrcSpanN . FieldLabelString . fsLit) xs
cvt (TypedSpliceE e) = do { e' <- parenthesizeHsExpr appPrec <$> cvtl e
; return $ HsTypedSplice (noAnn, noAnn) e' }
cvt (TypedBracketE e) = do { e' <- cvtl e
@@ -1195,7 +1206,7 @@ which we don't want.
-}
cvtFld :: (RdrName -> CvtM t) -> (TH.Name, TH.Exp)
- -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs))
+ -> CvtM (LHsFieldBind GhcPs (LocatedAnS NoEpAnns t) (LHsExpr GhcPs))
cvtFld f (v,e)
= do { v' <- vNameL v
; lhs' <- traverse f v'
@@ -1301,7 +1312,7 @@ cvtHsDo do_or_lc stmts = case nonEmpty stmts of
-> return (L loc (mkLastStmt body))
_ -> failWith (bad_last last')
- ; wrapParLA (HsDo noAnn do_or_lc) (stmts'' ++ [last'']) }
+ ; wrapParLL (HsDo noAnn do_or_lc) (stmts'' ++ [last'']) }
where
bad_last stmt = IllegalLastStatement do_or_lc stmt
@@ -1319,7 +1330,7 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss
cvt_one ds = do { ds' <- cvtStmts ds
; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }
cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss
- ; rec_stmt <- wrapParLA (mkRecStmt noAnn) ss'
+ ; rec_stmt <- wrapParLL (mkRecStmt noAnn) ss'
; returnLA rec_stmt }
cvtMatch :: HsMatchContext GhcPs
@@ -1416,13 +1427,13 @@ cvtPat pat = wrapLA (cvtp pat)
cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)
cvtp (TH.LitP l)
| overloadedLit l = do { l' <- cvtOverLit l
- ; l'' <- returnLA l'
+ ; l'' <- returnLL l'
; return (mkNPat l'' Nothing noAnn) }
-- Not right for negative patterns;
-- need to think about that!
| otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' }
cvtp (TH.VarP s) = do { s' <- vName s
- ; wrapParLA (Hs.VarPat noExtField) s' }
+ ; wrapParLN (Hs.VarPat noExtField) s' }
cvtp (TupP ps) = do { ps' <- cvtPats ps
; return $ TuplePat noAnn ps' Boxed }
cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps
@@ -1484,7 +1495,7 @@ cvtPatFld (s,p)
; p' <- cvtPat p
; returnLA $ HsFieldBind { hfbAnn = noAnn
, hfbLHS
- = L (l2l ls) $ mkFieldOcc (L (l2l ls) s')
+ = L (l2l ls) $ mkFieldOcc (L ls s')
, hfbRHS = p'
, hfbPun = False} }
@@ -1542,7 +1553,7 @@ cvtRole TH.InferR = Nothing
cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)
cvtContext p tys = do { preds' <- mapM cvtPred tys
- ; parenthesizeHsContext p <$> returnLA preds' }
+ ; parenthesizeHsContext p <$> returnLL preds' }
cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
cvtPred = cvtType
@@ -1558,23 +1569,23 @@ cvtDerivClauseTys tys
; case tys' of
[ty'@(L l (HsSig { sig_bndrs = HsOuterImplicit{}
, sig_body = L _ (HsTyVar _ NotPromoted _) }))]
- -> return $ L (l2l l) $ DctSingle noExtField ty'
- _ -> returnLA $ DctMulti noExtField tys' }
+ -> return $ L (nn2la l) $ DctSingle noExtField ty'
+ _ -> returnLL $ DctMulti noExtField tys' }
cvtDerivClause :: TH.DerivClause
-> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause (TH.DerivClause ds tys)
= do { tys' <- cvtDerivClauseTys tys
; ds' <- traverse cvtDerivStrategy ds
- ; returnLA $ HsDerivingClause noAnn ds' tys' }
+ ; returnLL $ HsDerivingClause noAnn ds' tys' }
cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
-cvtDerivStrategy TH.StockStrategy = returnLA (Hs.StockStrategy noAnn)
-cvtDerivStrategy TH.AnyclassStrategy = returnLA (Hs.AnyclassStrategy noAnn)
-cvtDerivStrategy TH.NewtypeStrategy = returnLA (Hs.NewtypeStrategy noAnn)
+cvtDerivStrategy TH.StockStrategy = returnLL (Hs.StockStrategy noAnn)
+cvtDerivStrategy TH.AnyclassStrategy = returnLL (Hs.AnyclassStrategy noAnn)
+cvtDerivStrategy TH.NewtypeStrategy = returnLL (Hs.NewtypeStrategy noAnn)
cvtDerivStrategy (TH.ViaStrategy ty) = do
ty' <- cvtSigType ty
- returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')
+ returnLL $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')
cvtType :: TH.Type -> CvtM (LHsType GhcPs)
cvtType = cvtTypeKind TypeLevel
@@ -1788,7 +1799,7 @@ cvtTypeKind typeOrKind ty
ImplicitParamT n t
-> do { n' <- wrapL $ ipName n
; t' <- cvtType t
- ; returnLA (HsIParamTy noAnn (reLocA n') t')
+ ; returnLA (HsIParamTy noAnn (reLocE n') t')
}
_ -> failWith (MalformedType typeOrKind ty)
@@ -1913,18 +1924,18 @@ cvtSigKind = cvtSigTypeKind KindLevel
-- signature is possible).
cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
-> CvtM (LFamilyResultSig GhcPs)
-cvtMaybeKindToFamilyResultSig Nothing = returnLA (Hs.NoSig noExtField)
+cvtMaybeKindToFamilyResultSig Nothing = returnLL (Hs.NoSig noExtField)
cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
- ; returnLA (Hs.KindSig noExtField ki') }
+ ; returnLL (Hs.KindSig noExtField ki') }
-- | Convert type family result signature. Used with both open and closed type
-- families.
cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)
-cvtFamilyResultSig TH.NoSig = returnLA (Hs.NoSig noExtField)
+cvtFamilyResultSig TH.NoSig = returnLL (Hs.NoSig noExtField)
cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki
- ; returnLA (Hs.KindSig noExtField ki') }
+ ; returnLL (Hs.KindSig noExtField ki') }
cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
- ; returnLA (Hs.TyVarSig noExtField tv) }
+ ; returnLL (Hs.TyVarSig noExtField tv) }
-- | Convert injectivity annotation of a type family.
cvtInjectivityAnnotation :: TH.InjectivityAnn
@@ -1932,7 +1943,7 @@ cvtInjectivityAnnotation :: TH.InjectivityAnn
cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
= do { annLHS' <- tNameN annLHS
; annRHS' <- mapM tNameN annRHS
- ; returnLA (Hs.InjectivityAnn noAnn annLHS' annRHS') }
+ ; returnLL (Hs.InjectivityAnn noAnn annLHS' annRHS') }
cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs)
-- pattern synonym types are of peculiar shapes, which is why we treat
@@ -1941,7 +1952,7 @@ cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs)
cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
| null exis, null provs = cvtSigType (ForallT univs reqs ty)
| null univs, null reqs = do { ty' <- cvtType (ForallT exis provs ty)
- ; ctxt' <- returnLA []
+ ; ctxt' <- returnLL []
; cxtTy <- wrapParLA mkHsImplicitSigType $
HsQualTy { hst_ctxt = ctxt'
, hst_xqual = noExtField
@@ -1949,7 +1960,7 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
; returnLA cxtTy }
| null reqs = do { univs' <- cvtTvs univs
; ty' <- cvtType (ForallT exis provs ty)
- ; ctxt' <- returnLA []
+ ; ctxt' <- returnLL []
; let cxtTy = HsQualTy { hst_ctxt = ctxt'
, hst_xqual = noExtField
, hst_body = ty' }
diff --git a/compiler/GHC/Unit/Module/Warnings.hs b/compiler/GHC/Unit/Module/Warnings.hs
index 72f6586094..5c8c1778d8 100644
--- a/compiler/GHC/Unit/Module/Warnings.hs
+++ b/compiler/GHC/Unit/Module/Warnings.hs
@@ -176,10 +176,10 @@ data WarningTxt pass
(Maybe (Located WarningCategory))
-- ^ Warning category attached to this WARNING pragma, if any;
-- see Note [Warning categories]
- (Located SourceText)
+ SourceText
[Located (WithHsDocIdentifiers StringLiteral pass)]
| DeprecatedTxt
- (Located SourceText)
+ SourceText
[Located (WithHsDocIdentifiers StringLiteral pass)]
deriving Generic
@@ -194,12 +194,12 @@ deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass)
instance Outputable (WarningTxt pass) where
ppr (WarningTxt _ lsrc ws)
- = case unLoc lsrc of
+ = case lsrc of
NoSourceText -> pp_ws ws
SourceText src -> text src <+> pp_ws ws <+> text "#-}"
ppr (DeprecatedTxt lsrc ds)
- = case unLoc lsrc of
+ = case lsrc of
NoSourceText -> pp_ws ds
SourceText src -> text src <+> pp_ws ds <+> text "#-}"
@@ -207,21 +207,21 @@ instance Binary (WarningTxt GhcRn) where
put_ bh (WarningTxt c s w) = do
putByte bh 0
put_ bh $ unLoc <$> c
- put_ bh $ unLoc s
+ put_ bh s
put_ bh $ unLoc <$> w
put_ bh (DeprecatedTxt s d) = do
putByte bh 1
- put_ bh $ unLoc s
+ put_ bh s
put_ bh $ unLoc <$> d
get bh = do
h <- getByte bh
case h of
0 -> do c <- fmap noLoc <$> get bh
- s <- noLoc <$> get bh
+ s <- get bh
w <- fmap noLoc <$> get bh
return (WarningTxt c s w)
- _ -> do s <- noLoc <$> get bh
+ _ -> do s <- get bh
d <- fmap noLoc <$> get bh
return (DeprecatedTxt s d)
@@ -304,4 +304,3 @@ plusWarns NoWarnings d = d
plusWarns _ (WarnAll t) = WarnAll t
plusWarns (WarnAll t) _ = WarnAll t
plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)
-