diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2021-10-28 19:05:51 +0100 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2021-11-02 21:39:32 +0000 |
| commit | 39eed84c2188b15ed312b4468f1a44c6a49fb268 (patch) | |
| tree | 0db2b8b53a33d4f61c273504b5665ba333474476 | |
| parent | a7e1be3d84d2b7d0515f909175cdfa5dcf0dc55c (diff) | |
| download | haskell-39eed84c2188b15ed312b4468f1a44c6a49fb268.tar.gz | |
EPA: Get rid of bare SrcSpan's in the ParsedSource
The ghc-exactPrint library has had to re-introduce the relatavise
phase.
This is needed if you change the length of an identifier and want the
layout to be preserved afterwards.
It is not possible to relatavise a bare SrcSpan, so introduce `SrcAnn
NoEpAnns` for them instead.
Updates haddock submodule.
44 files changed, 408 insertions, 312 deletions
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 86424b71b6..f25d28bee9 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -699,7 +699,7 @@ type instance Anno [LocatedN Id] = SrcSpan type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA -type instance Anno StringLiteral = SrcSpan +type instance Anno StringLiteral = SrcAnn NoEpAnns type instance Anno (LocatedN RdrName) = SrcSpan type instance Anno (LocatedN Name) = SrcSpan type instance Anno (LocatedN Id) = SrcSpan diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 997fbdceca..3a58ddfce1 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -1017,7 +1017,7 @@ type instance XHsRule GhcTc = HsRuleRn type instance XXRuleDecl (GhcPass _) = NoExtCon -type instance Anno (SourceText, RuleName) = SrcSpan +type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns data HsRuleAnn = HsRuleAnn @@ -1130,7 +1130,7 @@ type instance XCRoleAnnotDecl GhcTc = NoExtField type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon -type instance Anno (Maybe Role) = SrcSpan +type instance Anno (Maybe Role) = SrcAnn NoEpAnns instance OutputableBndr (IdP (GhcPass p)) => Outputable (RoleAnnotDecl (GhcPass p)) where @@ -1156,15 +1156,15 @@ type instance Anno (HsDecl (GhcPass _)) = SrcSpanAnnA type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA -type instance Anno (FamilyResultSig (GhcPass p)) = SrcSpan +type instance Anno (FamilyResultSig (GhcPass p)) = SrcAnn NoEpAnns type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno (InjectivityAnn (GhcPass p)) = SrcSpan +type instance Anno (InjectivityAnn (GhcPass p)) = SrcAnn NoEpAnns type instance Anno CType = SrcSpanAnnP -type instance Anno (HsDerivingClause (GhcPass p)) = SrcSpan +type instance Anno (HsDerivingClause (GhcPass p)) = SrcAnn NoEpAnns type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno Bool = SrcSpan +type instance Anno Bool = SrcAnn NoEpAnns type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA @@ -1175,15 +1175,15 @@ type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno DocDecl = SrcSpanAnnA type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA type instance Anno OverlapMode = SrcSpanAnnP -type instance Anno (DerivStrategy (GhcPass p)) = SrcSpan +type instance Anno (DerivStrategy (GhcPass p)) = SrcAnn NoEpAnns type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno (SourceText, RuleName) = SrcSpan -type instance Anno (RuleBndr (GhcPass p)) = SrcSpan +type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns +type instance Anno (RuleBndr (GhcPass p)) = SrcAnn NoEpAnns 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) = SrcSpan +type instance Anno (Maybe Role) = SrcAnn NoEpAnns diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index eb51021b83..9d3b5b12c3 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -1942,13 +1942,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)) = SrcSpan +type instance Anno (HsCmdTop (GhcPass p)) = SrcAnn 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)))) = SrcSpan -type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p)))) = SrcSpan +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 (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))) = SrcSpanAnnA type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))) = SrcSpanAnnA @@ -1957,9 +1957,9 @@ type instance Anno (HsSplice (GhcPass p)) = SrcSpanAnnA type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnL type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnL -type instance Anno (FieldLabelStrings (GhcPass p)) = SrcSpan -type instance Anno (FieldLabelString) = SrcSpan -type instance Anno (DotFieldOcc (GhcPass p)) = SrcSpan +type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns +type instance Anno (FieldLabelString) = SrcAnn NoEpAnns +type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns instance (Anno a ~ SrcSpanAnn' (EpAnn an)) => WrapXRec (GhcPass p) a where diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index a4b3bed851..a98070c6a7 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -243,10 +243,10 @@ hsRecFieldId :: HsRecField GhcTc arg -> Id hsRecFieldId = hsRecFieldSel hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName -hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hfbLHS +hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . reLoc . hfbLHS hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id -hsRecUpdFieldId = fmap foExt . hsRecUpdFieldOcc +hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc hsRecUpdFieldOcc :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS @@ -726,6 +726,6 @@ collectEvVarsPat pat = -} type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA -type instance Anno (HsOverLit (GhcPass p)) = SrcSpan +type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns type instance Anno ConLike = SrcSpanAnnN type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index e1f137052b..0e6d8564ae 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -1245,8 +1245,8 @@ type instance Anno (HsTyVarBndr _flag GhcRn) = SrcSpanAnnA type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA -type instance Anno HsIPName = SrcSpan +type instance Anno HsIPName = SrcAnn NoEpAnns type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA -type instance Anno (FieldOcc (GhcPass p)) = SrcSpan -type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcSpan +type instance Anno (FieldOcc (GhcPass p)) = SrcAnn NoEpAnns +type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcAnn NoEpAnns diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index eb410a3c6a..c32ec443af 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -172,7 +172,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)))) - ~ SrcSpan) + ~ SrcAnn NoEpAnns) => HsMatchContext (GhcPass p) -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) @@ -186,17 +186,17 @@ mkSimpleMatch ctxt pats rhs (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs) unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) - ~ SrcSpan + ~ SrcAnn 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)))) - ~ SrcSpan + ~ SrcAnn NoEpAnns => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p)) -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))] -unguardedRHS an loc rhs = [L loc (GRHS an [] rhs)] +unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)] type AnnoBody p body = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField @@ -264,7 +264,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)))) - ~ SrcSpan, + ~ SrcAnn NoEpAnns, Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA) => LPat (GhcPass p) -> (LocatedA (body (GhcPass p))) @@ -306,9 +306,9 @@ mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> EpAnn AnnList -> HsExpr GhcPs -mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] +mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs -mkNPlusKPat :: LocatedN RdrName -> Located (HsOverLit GhcPs) -> EpAnn EpaLocation +mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation -> Pat GhcPs -- NB: The following functions all use noSyntaxExpr: the generated expressions diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs index 9694256e18..a581a961b5 100644 --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -568,7 +568,7 @@ tidyNPat (OverLit (OverLitTc False _ ty) val) mb_neg _eq outer_ty _ -> Nothing tidyNPat over_lit mb_neg eq outer_ty - = NPat outer_ty (noLoc over_lit) mb_neg eq + = NPat outer_ty (noLocA over_lit) mb_neg eq {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Pmc.hs b/compiler/GHC/HsToCore/Pmc.hs index 0b2ef7f8cb..ab6479f75b 100644 --- a/compiler/GHC/HsToCore/Pmc.hs +++ b/compiler/GHC/HsToCore/Pmc.hs @@ -116,7 +116,7 @@ pmcGRHSs -> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long -- distance info pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do - let combined_loc = foldl1 combineSrcSpans (map getLoc grhss) + let combined_loc = foldl1 combineSrcSpans (map getLocA grhss) ctxt = DsMatchContext hs_ctxt combined_loc !missing <- getLdiNablas matches <- noCheckDs $ desugarGRHSs combined_loc empty guards diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index bb74be0ab9..d6db406b44 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1439,7 +1439,7 @@ repMaybeLTy m = do k_ty <- wrapName kindTyConName repMaybeT k_ty repLTy m -repRole :: Located (Maybe Role) -> MetaM (Core TH.Role) +repRole :: LocatedAn 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 [] diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index a783833317..9c71235a98 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -396,9 +396,9 @@ getRealSpan :: SrcSpan -> Maybe Span getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing -grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) +grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns) => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan -grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLoc xs) +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLocA xs) bindingsOnly :: [Context Name] -> HieM [HieAST a] bindingsOnly [] = pure [] @@ -818,7 +818,7 @@ type AnnoBody p body , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) - ~ SrcSpan + ~ SrcAnn NoEpAnns , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA , Data (body (GhcPass p)) @@ -1059,8 +1059,8 @@ instance ( ToHie (LocatedA (body (GhcPass p))) instance ( ToHie (LocatedA (body (GhcPass p))) , HiePass p , AnnoBody p body - ) => ToHie (Located (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where - toHie (L span g) = concatM $ makeNode g span : case g of + ) => ToHie (LocatedAn 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 , toHie body @@ -1074,7 +1074,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 (locA mspan) fld) + [ toHie $ RFC RecFieldOcc Nothing (L (l2l mspan:: SrcAnn NoEpAnns) fld) ] HsOverLabel {} -> [] HsIPVar _ _ -> [] @@ -1169,7 +1169,7 @@ instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where [ toHie expr ] HsProc _ pat cmdtop -> - [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat + [ toHie $ PS Nothing (mkLScopeA cmdtop) NoScope pat , toHie cmdtop ] HsStatic _ expr -> @@ -1334,23 +1334,23 @@ instance ( ToHie (RFContext label) , toHie expr ] -instance HiePass p => ToHie (RFContext (Located (FieldOcc (GhcPass p)))) where +instance HiePass p => ToHie (RFContext (LocatedAn 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 nspan fld)] - HieTc -> [toHie $ C (RecField c rhs) (L nspan fld)] + 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 (Located (AmbiguousFieldOcc (GhcPass p)))) where +instance HiePass p => ToHie (RFContext (LocatedAn NoEpAnns (AmbiguousFieldOcc (GhcPass p)))) where toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of Unambiguous fld _ -> case hiePass @p of - HieRn -> [toHie $ C (RecField c rhs) $ L nspan fld] - HieTc -> [toHie $ C (RecField c rhs) $ L nspan fld] + HieRn -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld] + HieTc -> [toHie $ C (RecField c rhs) $ L (locA nspan) fld] Ambiguous fld _ -> case hiePass @p of HieRn -> [] - HieTc -> [ toHie $ C (RecField c rhs) (L nspan fld) ] + HieTc -> [ toHie $ C (RecField c rhs) (L (locA nspan) fld) ] instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM @@ -1371,8 +1371,8 @@ instance ToHie (HsConDeclGADTDetails GhcRn) where toHie (PrefixConGADT args) = toHie args toHie (RecConGADT rec _) = toHie rec -instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where - toHie (L span top) = concatM $ makeNode top span : case top of +instance HiePass p => ToHie (LocatedAn NoEpAnns (HsCmdTop (GhcPass p))) where + toHie (L span top) = concatM $ makeNodeA top span : case top of HsCmdTop _ cmd -> [ toHie cmd ] @@ -1451,7 +1451,7 @@ instance ToHie (LocatedA (TyClDecl GhcRn)) where rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn con_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_cons defn - deriv_sc = foldr combineScopes NoScope $ map mkLScope $ dd_derivs defn + deriv_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_derivs defn ClassDecl { tcdCtxt = context , tcdLName = name , tcdTyVars = vars @@ -1487,8 +1487,8 @@ instance ToHie (LocatedA (FamilyDecl GhcRn)) where ] where rhsSpan = sigSpan `combineScopes` injSpan - sigSpan = mkScope $ getLoc sig - injSpan = maybe NoScope (mkScope . getLoc) inj + sigSpan = mkScope $ getLocA sig + injSpan = maybe NoScope (mkScope . getLocA) inj instance ToHie (FamilyInfo GhcRn) where toHie (ClosedTypeFamily (Just eqns)) = concatM $ @@ -1499,8 +1499,8 @@ instance ToHie (FamilyInfo GhcRn) where go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib toHie _ = pure [] -instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where - toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of +instance ToHie (RScoped (LocatedAn NoEpAnns (FamilyResultSig GhcRn))) where + toHie (RS sc (L span sig)) = concatM $ makeNodeA sig span : case sig of NoSig _ -> [] KindSig _ k -> @@ -1536,8 +1536,8 @@ instance (ToHie rhs, HasLoc rhs) patsScope = mkScope (loc pats) rhsScope = mkScope (loc rhs) -instance ToHie (Located (InjectivityAnn GhcRn)) where - toHie (L span ann) = concatM $ makeNode ann span : case ann of +instance ToHie (LocatedAn NoEpAnns (InjectivityAnn GhcRn)) where + toHie (L span ann) = concatM $ makeNodeA ann span : case ann of InjectivityAnn _ lhs rhs -> [ toHie $ C Use lhs , toHie $ map (C Use) rhs @@ -1551,14 +1551,14 @@ instance ToHie (HsDataDefn GhcRn) where , toHie derivs ] -instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where +instance ToHie (Located [LocatedAn NoEpAnns (HsDerivingClause GhcRn)]) where toHie (L span clauses) = concatM [ locOnly span , toHie clauses ] -instance ToHie (Located (HsDerivingClause GhcRn)) where - toHie (L span cl) = concatM $ makeNode cl span : case cl of +instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where + toHie (L span cl) = concatM $ makeNodeA cl span : case cl of HsDerivingClause _ strat dct -> [ toHie strat , toHie dct @@ -1569,8 +1569,8 @@ instance ToHie (LocatedC (DerivClauseTys GhcRn)) where DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ] DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ] -instance ToHie (Located (DerivStrategy GhcRn)) where - toHie (L span strat) = concatM $ makeNode strat span : case strat of +instance ToHie (LocatedAn NoEpAnns (DerivStrategy GhcRn)) where + toHie (L span strat) = concatM $ makeNodeA strat span : case strat of StockStrategy _ -> [] AnyclassStrategy _ -> [] NewtypeStrategy _ -> [] @@ -1690,7 +1690,7 @@ instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where ] SCCFunSig _ _ name mtxt -> [ toHie $ (C Use) name - , maybe (pure []) (locOnly . getLoc) mtxt + , maybe (pure []) (locOnly . getLocA) mtxt ] CompleteMatchSig _ _ (L ispan names) typ -> [ locOnly ispan @@ -1872,8 +1872,8 @@ instance ToHie (LBooleanFormula (LocatedN Name)) where [ toHie f ] -instance ToHie (Located HsIPName) where - toHie (L span e) = makeNode e span +instance ToHie (LocatedAn NoEpAnns HsIPName) where + toHie (L span e) = makeNodeA e span instance HiePass p => ToHie (LocatedA (HsSplice (GhcPass p))) where toHie (L span sp) = concatM $ makeNodeA sp span : case sp of @@ -1899,7 +1899,7 @@ instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where toHie (L span annot) = concatM $ makeNodeA annot span : case annot of RoleAnnotDecl _ var roles -> [ toHie $ C Use var - , concatMapM (locOnly . getLoc) roles + , concatMapM (locOnly . getLocA) roles ] instance ToHie (LocatedA (InstDecl GhcRn)) where @@ -2022,19 +2022,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 $ getLoc rname + , locOnly $ getLocA 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 mkLScope (listToMaybe bndrs) + bndrs_sc = maybe NoScope mkLScopeA (listToMaybe bndrs) exprA_sc = mkLScopeA exprA exprB_sc = mkLScopeA exprB -instance ToHie (RScoped (Located (RuleBndr GhcRn))) where - toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of +instance ToHie (RScoped (LocatedAn NoEpAnns (RuleBndr GhcRn))) where + toHie (RS sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of RuleBndr _ var -> [ toHie $ C (ValBind RegularBind sc Nothing) var ] diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index fc546c515d..075f7bff00 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -1356,18 +1356,18 @@ overlap_pragma :: { Maybe (LocatedP OverlapMode) } | {- empty -} { Nothing } deriv_strategy_no_via :: { LDerivStrategy GhcPs } - : 'stock' {% acs (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) } - | 'anyclass' {% acs (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) } - | 'newtype' {% acs (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) } + : '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))) } deriv_strategy_via :: { LDerivStrategy GhcPs } - : 'via' sigktype {% acs (\cs -> sLLlA $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glR $1) [mj AnnVia $1] cs) + : 'via' sigktype {% acsA (\cs -> sLLlA $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glR $1) [mj AnnVia $1] cs) $2))) } deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) } - : 'stock' {% fmap Just $ acs (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) } - | 'anyclass' {% fmap Just $ acs (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) } - | 'newtype' {% fmap Just $ acs (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) } + : '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))) } | deriv_strategy_via { Just $1 } | {- empty -} { Nothing } @@ -1375,12 +1375,12 @@ deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) } opt_injective_info :: { Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)) } : {- empty -} { noLoc ([], Nothing) } - | '|' injectivity_cond { sLL $1 $> ([mj AnnVbar $1] + | '|' injectivity_cond { sLL $1 (reLoc $>) ([mj AnnVbar $1] , Just ($2)) } injectivity_cond :: { LInjectivityAnn GhcPs } : tyvarid '->' inj_varids - {% acs (\cs -> sLL (reLocN $1) $> (InjectivityAnn (EpAnn (glNR $1) [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) } + {% acsA (\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) } @@ -1516,24 +1516,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 ([] , noLoc (NoSig noExtField) )} - | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLL $1 (reLoc $>) (KindSig noExtField $2))} + : { noLoc ([] , noLocA (NoSig noExtField) )} + | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLa $1 (reLoc $>) (KindSig noExtField $2))} opt_tyfam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) } - : { noLoc ([] , noLoc (NoSig noExtField) )} - | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLL $1 (reLoc $>) (KindSig noExtField $2))} + : { noLoc ([] , noLocA (NoSig noExtField) )} + | '::' kind { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLa $1 (reLoc $>) (KindSig noExtField $2))} | '=' tv_bndr {% do { tvb <- fromSpecTyVarBndr $2 - ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLL $1 (reLoc $>) (TyVarSig noExtField tvb))} } + ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLLa $1 (reLoc $>) (TyVarSig noExtField tvb))} } opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs , Maybe (LInjectivityAnn GhcPs)))} - : { noLoc ([], (noLoc (NoSig noExtField), Nothing)) } + : { noLoc ([], (noLocA (NoSig noExtField), Nothing)) } | '::' kind { sLL $1 (reLoc $>) ( [mu AnnDcolon $1] - , (sL1A $> (KindSig noExtField $2), Nothing)) } + , (sL1a (reLoc $>) (KindSig noExtField $2), Nothing)) } | '=' tv_bndr_no_braces '|' injectivity_cond {% do { tvb <- fromSpecTyVarBndr $2 - ; return $ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3] - , (sLL $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} } + ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1, mj AnnVbar $3] + , (sLLa $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} } -- tycl_hdr parses the header of a class or data type decl, -- which takes the form @@ -1839,7 +1839,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 - , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1) + , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRINGs $1, getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 , rd_lhs = $4, rd_rhs = $6 })) } @@ -1898,8 +1898,8 @@ rule_vars :: { [LRuleTyTmVar] } | {- empty -} { [] } rule_var :: { LRuleTyTmVar } - : varid { sL1N $1 (RuleTyTmVar noAnn $1 Nothing) } - | '(' varid '::' ctype ')' {% acs (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) } + : 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))) } {- Note [Parsing explicit foralls in Rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2118,7 +2118,7 @@ ctype :: { LHsType GhcPs } , hst_xqual = NoExtField , hst_body = $3 })) } - | ipvar '::' type {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (EpAnn (glR $1) [mu AnnDcolon $2] cs) $1 $3)) } + | ipvar '::' type {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (EpAnn (glR $1) [mu AnnDcolon $2] cs) (reLocA $1) $3)) } | type { $1 } ---------------------- @@ -2439,7 +2439,7 @@ fielddecl :: { LConDeclField GhcPs } : sig_vars '::' ctype {% acsA (\cs -> L (comb2 $1 (reLoc $3)) (ConDeclField (EpAnn (glR $1) [mu AnnDcolon $2] cs) - (reverse (map (\ln@(L l n) -> L (locA l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))} + (reverse (map (\ln@(L l n) -> L (l2l l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))} -- Reversed! maybe_derivings :: { Located (HsDeriving GhcPs) } @@ -2448,23 +2448,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 $> ($2 : unLoc $1) } -- AZ: order? - | deriving { sLL $1 $> [$1] } + : derivings deriving { sLL $1 (reLoc $>) ($2 : unLoc $1) } -- AZ: order? + | deriving { sL1 (reLoc $>) [$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 acs (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) Nothing $2) } + in acsA (\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 acs (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $2) $3) } + in acsA (\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 $> } - in acs (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) } + {% let { full_loc = comb2 $1 (reLoc $>) } + in acsA (\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 $ @@ -2533,12 +2533,12 @@ rhs :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) } (GRHSs (cs Semi.<> csw) (reverse (unLoc $1)) bs)) }} gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] } - : gdrhs gdrh { sLL $1 $> ($2 : unLoc $1) } - | gdrh { sL1 $1 [$1] } + : gdrhs gdrh { sLL $1 (reLoc $>) ($2 : unLoc $1) } + | gdrh { sL1 (reLoc $1) [$1] } gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) } : '|' guardquals '=' exp {% runPV (unECP $4) >>= \ $4 -> - acs (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) } + acsA (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) } sigdecl :: { LHsDecl GhcPs } : @@ -2581,7 +2581,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 ( sL1 $3 str_lit))))) }} + ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $4] cs) (getSCC_PRAGs $1) $2 (Just ( sL1a $3 str_lit))))) }} | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' {% acsA (\cs -> @@ -2846,7 +2846,7 @@ aexp :: { ECP } {% (checkPattern <=< runPV) (unECP $2) >>= \ p -> runPV (unECP $4) >>= \ $4@cmd -> fmap ecpFromExp $ - acsA (\cs -> sLLlA $1 $> $ HsProc (EpAnn (glR $1) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLlA $1 $> $ HsCmdTop noExtField cmd)) } + acsA (\cs -> sLLlA $1 $> $ HsProc (EpAnn (glR $1) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLa $1 (reLoc $>) $ HsCmdTop noExtField cmd)) } | aexp1 { $1 } @@ -2863,7 +2863,7 @@ aexp1 :: { ECP } | aexp1 TIGHT_INFIX_PROJ field {% runPV (unECP $1) >>= \ $1 -> fmap ecpFromExp $ acsa (\cs -> - let fl = sLL $2 $> (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in + let fl = sLLa $2 $> (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) (reLocA $3)) in mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (EpAnn (glAR $1) NoEpAnns cs)) } @@ -2880,8 +2880,8 @@ aexp2 :: { ECP } -- into HsOverLit when -foverloaded-strings is on. -- | STRING { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1) -- (getSTRING $1) noExtField) } - | INTEGER { ECP $ pvA $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral (getINTEGER $1)) } - | RATIONAL { ECP $ pvA $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) } + | INTEGER { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsIntegral (getINTEGER $1)) } + | RATIONAL { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsFractional (getRATIONAL $1)) } -- N.B.: sections get parsed by these next two productions. -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't @@ -2945,12 +2945,12 @@ aexp2 :: { ECP } acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix Nothing (reverse $3)) } -projection :: { Located [Located (DotFieldOcc GhcPs)] } +projection :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] } projection -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer : projection TIGHT_INFIX_PROJ field - {% acs (\cs -> sLL $1 $> ((sLL $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) : unLoc $1)) } - | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> [sLL $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2]) } + {% acs (\cs -> sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) (reLocA $3)) : unLoc $1)) } + | PREFIX_PROJ field {% acs (\cs -> sLL $1 $> [sLLa $1 $> $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) (reLocA $2)]) } splice_exp :: { LHsExpr GhcPs } : splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) } @@ -2974,7 +2974,7 @@ cmdargs :: { [LHsCmdTop GhcPs] } acmd :: { LHsCmdTop GhcPs } : aexp {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) -> runPV (checkCmdBlockArguments cmd) >>= \ _ -> - return (sL1A cmd $ HsCmdTop noExtField cmd) } + return (sL1a (reLoc cmd) $ HsCmdTop noExtField cmd) } cvtopbody :: { ([AddEpAnn],[LHsDecl GhcPs]) } : '{' cvtopdecls0 '}' { ([mj AnnOpenC $1 @@ -3260,8 +3260,8 @@ ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) } gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) } : gdpats gdpat { $1 >>= \gdpats -> $2 >>= \gdpat -> - return $ sLL gdpats gdpat (gdpat : unLoc gdpats) } - | gdpat { $1 >>= \gdpat -> return $ sL1 gdpat [gdpat] } + return $ sLL gdpats (reLoc gdpat) (gdpat : unLoc gdpats) } + | gdpat { $1 >>= \gdpat -> return $ sL1A gdpat [gdpat] } -- layout for MultiWayIf doesn't begin with an open brace, because it's hard to -- generate the open brace in addition to the vertical bar in the lexer, and @@ -3275,7 +3275,7 @@ ifgdpats :: { Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) } gdpat :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) } : '|' guardquals '->' exp { unECP $4 >>= \ $4 -> - acs (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) } + acsA (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) } -- 'pat' recognises a pattern, including one with a bang at the top -- e.g. "!x" or "!(x,y)" or "C a b" etc @@ -3377,13 +3377,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) (sL1N $1 $ mkFieldOcc $1) $3 False) } + fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsFieldBind (EpAnn (glNR $1) [mj AnnEqual $2] cs) (sL1l $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) (sL1N $1 $ mkFieldOcc $1) rhs True) } + fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsFieldBind (EpAnn (glNR $1) [] cs) (sL1l $1 $ mkFieldOcc $1) rhs True) } -- In the punning case, use a place-holder -- The renamer fills in the final value @@ -3391,10 +3391,10 @@ 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 $1 $ DotFieldOcc noAnn $1 + let top = sL1a $1 $ DotFieldOcc noAnn (reLocA $1) ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3) - lf' = comb2 $2 (L lf ()) - fields = top : L lf' (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t + lf' = comb2 $2 (reLoc $ L lf ()) + fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t final = last fields l = comb2 $1 $3 isPun = False @@ -3407,24 +3407,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 $1 $ DotFieldOcc noAnn $1 + let top = sL1a $1 $ DotFieldOcc noAnn (reLocA $1) ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3) - lf' = comb2 $2 (L lf ()) - fields = top : L lf' (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t + lf' = comb2 $2 (reLoc $ L lf ()) + fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t final = last fields l = comb2 $1 $3 isPun = True - var <- mkHsVarPV (L (noAnnSrcSpan $ getLoc final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . dfoLabel . unLoc $ final)) + var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . dfoLabel . unLoc $ final)) fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun [] } -fieldToUpdate :: { Located [Located (DotFieldOcc GhcPs)] } +fieldToUpdate :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] } fieldToUpdate -- See Note [Whitespace-sensitive operator parsing] in Lexer.x : fieldToUpdate TIGHT_INFIX_PROJ field {% getCommentsFor (getLoc $3) >>= \cs -> - return (sLL $1 $> ((sLL $2 $> (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) } + return (sLL $1 $> ((sLLa $2 $> (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) (reLocA $3))) : unLoc $1)) } | field {% getCommentsFor (getLoc $1) >>= \cs -> - return (sL1 $1 [sL1 $1 (DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) $1)]) } + return (sL1 $1 [sL1a $1 (DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) (reLocA $1))]) } ----------------------------------------------------------------------------- -- Implicit Parameter Bindings @@ -3445,7 +3445,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) (Left $1) $3)) } + acsA (\cs -> sLLlA $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (Left (reLocA $1)) $3)) } ipvar :: { Located HsIPName } : IPDUPVARID { sL1 $1 (HsIPName (getIPDUPVARID $1)) } @@ -4021,6 +4021,10 @@ sL1N x = sL (getLocA x) -- #define sL1 sL (getLoc $1) sL1a :: Located a -> b -> LocatedAn t b sL1a x = sL (noAnnSrcSpan $ 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) + {-# INLINE sL1n #-} sL1n :: Located a -> b -> LocatedN b sL1n x = L (noAnnSrcSpan $ getLoc x) -- #define sL1 sL (getLoc $1) diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index abe5cdd731..964278920a 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -1203,6 +1203,9 @@ instance (Outputable a) => Outputable (EpAnn a) where ppr (EpAnn l a c) = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c ppr EpAnnNotUsed = text "EpAnnNotUsed" +instance Outputable NoEpAnns where + ppr NoEpAnns = text "NoEpAnns" + instance Outputable Anchor where ppr (Anchor a o) = text "Anchor" <+> ppr a <+> ppr o diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index e553348ea7..96e08d781f 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -342,7 +342,7 @@ mkFamDecl :: SrcSpan -> FamilyInfo GhcPs -> TopLevelFlag -> LHsType GhcPs -- LHS - -> Located (FamilyResultSig GhcPs) -- Optional result signature + -> LFamilyResultSig GhcPs -- Optional result signature -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation -> [AddEpAnn] -> P (LTyClDecl GhcPs) @@ -407,10 +407,10 @@ mkRoleAnnotDecl loc tycon roles anns all_roles = map fromConstr $ dataTypeConstrs role_data_type possible_roles = [(fsFromRole role, role) | role <- all_roles] - parse_role (L loc_role Nothing) = return $ L loc_role Nothing + parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing parse_role (L loc_role (Just role)) = case lookup role possible_roles of - Just found_role -> return $ L loc_role $ Just found_role + Just found_role -> return $ L (noAnnSrcSpan loc_role) $ Just found_role Nothing -> let nearby = fuzzyLookup (unpackFS role) (mapFst unpackFS possible_roles) @@ -898,7 +898,7 @@ checkDatatypeContext (Just c) unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $ (PsErrIllegalDataTypeContext c) -type LRuleTyTmVar = Located RuleTyTmVar +type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs)) -- ^ Essentially a wrapper for a @RuleBndr GhcPs@ @@ -913,9 +913,9 @@ mkRuleBndrs = fmap (fmap cvt_one) mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs] mkRuleTyVarBndrs = fmap cvt_one where cvt_one (L l (RuleTyTmVar ann v Nothing)) - = L (noAnnSrcSpan l) (UserTyVar ann () (fmap tm_to_ty v)) + = L (l2l l) (UserTyVar ann () (fmap tm_to_ty v)) cvt_one (L l (RuleTyTmVar ann v (Just sig))) - = L (noAnnSrcSpan l) (KindedTyVar ann () (fmap tm_to_ty v) sig) + = L (l2l 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" @@ -1156,7 +1156,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 (locA loc) pos_lit) Nothing noAnn) + PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn) -- n+k patterns PatBuilderOpApp @@ -1165,7 +1165,7 @@ 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 (locA lloc) lit) + -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit) (EpAnn anc (epaLocationFromSrcAnn l) cs)) -- Improve error messages for the @-operator when the user meant an @-pattern @@ -1438,7 +1438,7 @@ instance DisambInfixOp RdrName where mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole type AnnoBody b - = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan + = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcAnn 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 @@ -1456,7 +1456,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b) -- | Return an expression without ambiguity, or fail in a non-expression context. ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b) - mkHsProjUpdatePV :: SrcSpan -> Located [Located (DotFieldOcc GhcPs)] + mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b)) -- | Disambiguate "\... -> ..." (lambda) mkHsLamPV @@ -1516,7 +1516,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 :: Located (HsOverLit GhcPs) -> PV (Located b) + mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b) -- | Disambiguate a wildcard mkHsWildCardPV :: SrcSpan -> PV (Located b) -- | Disambiguate "a :: t" (type annotation) @@ -1615,7 +1615,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 (getLocA c) $ HsCmdTop noExtField c + let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField 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 @@ -1647,7 +1647,7 @@ instance DisambECP (HsCmd GhcPs) where return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar) mkHsVarPV (L l v) = cmdFail (locA l) (ppr v) mkHsLitPV (L l a) = cmdFail l (ppr a) - mkHsOverLitPV (L l a) = cmdFail l (ppr a) + mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a) mkHsWildCardPV l = cmdFail l (text "_") mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig) mkHsExplicitListPV l xs _ = cmdFail l $ @@ -1737,8 +1737,8 @@ instance DisambECP (HsExpr GhcPs) where cs <- getCommentsFor l return $ L l (HsLit (comment (realSrcSpan l) cs) a) mkHsOverLitPV (L l a) = do - cs <- getCommentsFor l - return $ L l (HsOverLit (comment (realSrcSpan l) cs) a) + cs <- getCommentsFor (locA l) + return $ L l (HsOverLit (comment (realSrcSpan (locA l)) cs) a) mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn) mkHsTySigPV l a sig anns = do cs <- getCommentsFor (locA l) @@ -1778,7 +1778,7 @@ instance DisambECP (HsExpr GhcPs) where hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs hsHoleExpr anns = HsUnboundVar anns (mkVarOcc "_") -type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpan +type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcAnn 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 @@ -1833,7 +1833,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 (locA lp) pos_lit) + PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit) _ -> patFail l $ PsErrInPat p PEIP_NegApp cs <- getCommentsFor l let an = EpAnn (spanAsAnchor l) anns cs @@ -2463,6 +2463,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do -- overloaded_on) is in effect because it affects the Left/Right nature -- of the RecordUpd value we calculate. let (fs, ps) = partitionEithers fbinds + fs' :: [LHsRecUpdField GhcPs] fs' = map (fmap mk_rec_upd_field) fs case overloaded_on of False | not $ null ps -> @@ -2481,7 +2482,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do ] if not $ null qualifiedFields then - addFatalError $ mkPlainErrorMsgEnvelope (getLoc (head qualifiedFields)) $ + addFatalError $ mkPlainErrorMsgEnvelope (getLocA (head qualifiedFields)) $ PsErrOverloadedRecordUpdateNoQualifiedFields else -- This is a RecordDotSyntax update. return RecordUpd { @@ -2498,9 +2499,9 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) = -- The idea here is to convert the label to a singleton [FastString]. let f = occNameFS . rdrNameOcc $ rdr - fl = DotFieldOcc noAnn (L lf f) -- AZ: what about the ann? + fl = DotFieldOcc noAnn (L (l2l loc) f) -- AZ: what about the ann? lf = locA loc - in mkRdrProjUpdate l (L lf [L lf fl]) (punnedVar f) pun anns + in mkRdrProjUpdate l (L lf [L (l2l 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 @@ -3047,7 +3048,7 @@ starSym False = "*" ----------------------------------------- -- Bits and pieces for RecordDotSyntax. -mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (DotFieldOcc GhcPs) +mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> EpAnnCO -> LHsExpr GhcPs mkRdrGetField loc arg field anns = L loc HsGetField { @@ -3056,7 +3057,7 @@ mkRdrGetField loc arg field anns = , gf_field = field } -mkRdrProjection :: [Located (DotFieldOcc GhcPs)] -> EpAnn AnnProjection -> HsExpr GhcPs +mkRdrProjection :: [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] -> EpAnn AnnProjection -> HsExpr GhcPs mkRdrProjection [] _ = panic "mkRdrProjection: The impossible has happened!" mkRdrProjection flds anns = HsProjection { @@ -3064,14 +3065,14 @@ mkRdrProjection flds anns = , proj_flds = flds } -mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (DotFieldOcc GhcPs)] +mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] -> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn] -> LHsRecProj GhcPs (LHsExpr GhcPs) mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!" mkRdrProjUpdate loc (L l flds) arg isPun anns = L loc HsFieldBind { hfbAnn = anns - , hfbLHS = L l (FieldLabelStrings flds) + , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds) , hfbRHS = arg , hfbPun = isPun } diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index f0adba4e6f..540a807428 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -592,7 +592,7 @@ instance HasHaddock (HsDataDefn GhcPs) where -- Process the deriving clauses of a data/newtype declaration. -- Not used for standalone deriving. -instance HasHaddock (Located [Located (HsDerivingClause GhcPs)]) where +instance HasHaddock (Located [LocatedAn NoEpAnns (HsDerivingClause GhcPs)]) where addHaddock lderivs = extendHdkA (getLoc lderivs) $ traverse @Located addHaddock lderivs @@ -604,10 +604,10 @@ instance HasHaddock (Located [Located (HsDerivingClause GhcPs)]) where -- deriving (Ord {- ^ Comment on Ord N -}) via Down N -- -- Not used for standalone deriving. -instance HasHaddock (Located (HsDerivingClause GhcPs)) where +instance HasHaddock (LocatedAn NoEpAnns (HsDerivingClause GhcPs)) where addHaddock lderiv = - extendHdkA (getLoc lderiv) $ - for @Located lderiv $ \deriv -> + extendHdkA (getLocA lderiv) $ + for @(LocatedAn NoEpAnns) lderiv $ \deriv -> case deriv of HsDerivingClause { deriv_clause_ext, deriv_clause_strategy, deriv_clause_tys } -> do let @@ -620,8 +620,8 @@ instance HasHaddock (Located (HsDerivingClause GhcPs)) where (register_strategy_before, register_strategy_after) = case deriv_clause_strategy of Nothing -> (pure (), pure ()) - Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA l) - Just (L l _) -> (registerLocHdkA l, pure ()) + Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA (locA l)) + Just (L l _) -> (registerLocHdkA (locA l), pure ()) register_strategy_before deriv_clause_tys' <- addHaddock deriv_clause_tys register_strategy_after diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 1e4c43cf7d..b85cee2a51 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -1181,8 +1181,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))) ~ SrcSpan - , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcSpan + , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns + , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcAnn NoEpAnns , Outputable (body GhcPs) ) @@ -1254,7 +1254,7 @@ rnGRHS :: AnnoBody body -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> LGRHS GhcPs (LocatedA (body GhcPs)) -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars) -rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) +rnGRHS ctxt rnBody = wrapLocFstMA (rnGRHS' ctxt rnBody) rnGRHS' :: HsMatchContext GhcRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 35129a55cd..d02d04515e 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -721,7 +721,7 @@ See #18151. ************************************************************************ -} -rnDotFieldOcc :: Located (DotFieldOcc GhcPs) -> Located (DotFieldOcc GhcRn) +rnDotFieldOcc :: LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> LocatedAn NoEpAnns (DotFieldOcc GhcRn) rnDotFieldOcc (L l (DotFieldOcc x label)) = L l (DotFieldOcc x label) rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn @@ -743,7 +743,7 @@ rnCmdArgs (arg:args) ; return (arg':args', fvArg `plusFV` fvArgs) } rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) -rnCmdTop = wrapLocFstM rnCmdTop' +rnCmdTop = wrapLocFstMA rnCmdTop' where rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars) rnCmdTop' (HsCmdTop _ cmd) @@ -888,7 +888,7 @@ methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss) ------------------------------------------------- -methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds +methodNamesGRHS :: LocatedAn NoEpAnns (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs --------------------------------------------------- @@ -2621,33 +2621,33 @@ mkExpandedExpr a b = XExpr (HsExpanded a b) -- mkGetField arg field calcuates a get_field @field arg expression. -- e.g. z.x = mkGetField z x = get_field @x z -mkGetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn +mkGetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field) -- mkSetField a field b calculates a set_field @field expression. -- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b"). -mkSetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn +mkSetField :: Name -> LHsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn mkSetField set_field a (L _ field) b = genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field) a) b -mkGet :: Name -> [LHsExpr GhcRn] -> Located FieldLabelString -> [LHsExpr GhcRn] +mkGet :: Name -> [LHsExpr GhcRn] -> LocatedAn NoEpAnns FieldLabelString -> [LHsExpr GhcRn] mkGet get_field l@(r : _) (L _ field) = wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l mkGet _ [] _ = panic "mkGet : The impossible has happened!" -mkSet :: Name -> LHsExpr GhcRn -> (Located FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn +mkSet :: Name -> LHsExpr GhcRn -> (LocatedAn NoEpAnns FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc) -- mkProjection fields calculates a projection. -- e.g. .x = mkProjection [x] = getField @"x" -- .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x" -mkProjection :: Name -> Name -> [Located FieldLabelString] -> HsExpr GhcRn +mkProjection :: Name -> Name -> [LocatedAn NoEpAnns FieldLabelString] -> HsExpr GhcRn mkProjection getFieldName circName (field : fields) = foldl' f (proj field) fields where - f :: HsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn + f :: HsExpr GhcRn -> LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc] - proj :: Located FieldLabelString -> HsExpr GhcRn + proj :: LocatedAn NoEpAnns FieldLabelString -> HsExpr GhcRn proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f mkProjection _ _ [] = panic "mkProjection: The impossible happened" diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 674cfe6198..1340993084 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -1469,7 +1469,7 @@ mkOpFormRn a1@(L loc | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm noExtField op1 f (Just fix1) - [a11, L loc (HsCmdTop [] (L (noAnnSrcSpan loc) new_c))]) + [a11, L loc (HsCmdTop [] (L (l2l loc) new_c))]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index c99098963b..bdb5a29e55 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1996,7 +1996,7 @@ rnLHsDerivingClause doc , deriv_clause_tys = dct })) = do { (dcs', dct', fvs) <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct - ; warnNoDerivStrat dcs' loc + ; warnNoDerivStrat dcs' (locA loc) ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs' , deriv_clause_tys = dct' }) @@ -2034,7 +2034,7 @@ rnLDerivStrategy doc mds thing_inside = case mds of Nothing -> boring_case Nothing Just (L loc ds) -> - setSrcSpan loc $ do + setSrcSpanA loc $ do (ds', thing, fvs) <- rn_deriv_strat ds pure (Just (L loc ds'), thing, fvs) where @@ -2117,7 +2117,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) <- wrapLocFstM rn_sig res_sig + ; (res_sig', fv_kind) <- wrapLocFstMA rn_sig res_sig ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') injectivity ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } @@ -2225,7 +2225,9 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) -- e.g. type family F a = (r::*) | r -> a do { injFrom' <- rnLTyVar injFrom ; injTo' <- mapM rnLTyVar injTo - ; return $ L srcSpan (InjectivityAnn x injFrom' injTo') } + -- Note: srcSpan is unchanged, but typechecker gets + -- confused, l2l call makes it happy + ; return $ L (l2l srcSpan) (InjectivityAnn x injFrom' injTo') } ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs resName = hsLTyVarName resTv @@ -2246,7 +2248,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv)) ; when (noRnErrors && not (Set.null rhsValid)) $ do { let errorVars = Set.toList rhsValid - ; addErrAt srcSpan $ TcRnUnknownMessage $ mkPlainError noHints $ + ; addErrAt (locA srcSpan) $ TcRnUnknownMessage $ mkPlainError noHints $ ( hsep [ text "Unknown type variable" <> plural errorVars , text "on the RHS of injectivity condition:" @@ -2263,7 +2265,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)) = - setSrcSpan srcSpan $ do + setSrcSpanA srcSpan $ do (injDecl', _) <- askNoErrs $ do injFrom' <- rnLTyVar injFrom injTo' <- mapM rnLTyVar injTo @@ -2444,7 +2446,7 @@ 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 (getLocA (foLabel f)) f) . recordPatSynField) as + let field_occs = map ((\ f -> L (noAnnSrcSpan $ getLocA (foLabel f)) f) . recordPatSynField) as flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs return ((bnd_name, flds): names) | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 67350973b5..768e43fca1 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -1028,7 +1028,7 @@ getLocalNonValBinders fixity_env newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!" newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld))) - = do { selName <- newTopSrcBinder $ L (noAnnSrcSpan loc) $ field + = do { selName <- newTopSrcBinder $ L (l2l loc) $ field ; return $ FieldLabel { flLabel = fieldLabelString , flHasDuplicateRecordFields = dup_fields_ok , flHasFieldSelector = has_sel diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 534b03e602..a011b709cf 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -516,7 +516,7 @@ rnPatAndThen mk (LitPat x lit) = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings) ; if ovlStr then rnPatAndThen mk - (mkNPat (noLoc (mkHsIsString src s)) + (mkNPat (noLocA (mkHsIsString src s)) Nothing noAnn) else normal_lit } | otherwise = normal_lit @@ -778,12 +778,12 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) (L loc (FieldOcc _ (L ll lbl))) , hfbRHS = arg , hfbPun = pun })) - = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl + = do { sel <- setSrcSpanA loc $ lookupRecFieldOcc parent lbl ; arg' <- if pun - then do { checkErr pun_ok (TcRnIllegalFieldPunning (L loc lbl)) + then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) } + ; return (L (l2l loc) (mk_arg (locA loc) arg_rdr)) } else return arg ; return (L l (HsFieldBind { hfbAnn = noAnn @@ -833,7 +833,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; return [ L (noAnnSrcSpan loc) (HsFieldBind { hfbAnn = noAnn , hfbLHS - = L loc (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr)) + = L (noAnnSrcSpan loc) (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr)) , hfbRHS = L locn (mk_arg loc arg_rdr) , hfbPun = False }) | fl <- dot_dot_fields @@ -881,23 +881,23 @@ rnHsRecUpdFields flds , hfbRHS = arg , hfbPun = pun })) = do { let lbl = rdrNameAmbiguousFieldOcc f - ; mb_sel <- setSrcSpan loc $ + ; mb_sel <- setSrcSpanA loc $ -- Defer renaming of overloaded fields to the typechecker -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head lookupRecFieldOcc_update dup_fields_ok lbl ; arg' <- if pun - then do { checkErr pun_ok (TcRnIllegalFieldPunning (L loc lbl)) + then do { checkErr pun_ok (TcRnIllegalFieldPunning (L (locA loc) lbl)) -- Discard any module qualifier (#11662) ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L (noAnnSrcSpan loc) (HsVar noExtField - (L (noAnnSrcSpan loc) arg_rdr))) } + ; return (L (l2l loc) (HsVar noExtField + (L (l2l loc) arg_rdr))) } else return arg ; (arg'', fvs) <- rnLExpr arg' ; let (lbl', fvs') = case mb_sel of UnambiguousGre gname -> let sel_name = greNameMangledName gname - in (Unambiguous sel_name (L (noAnnSrcSpan loc) lbl), fvs `addOneFV` sel_name) - AmbiguousFields -> (Ambiguous noExtField (L (noAnnSrcSpan loc) lbl), fvs) + in (Unambiguous sel_name (L (l2l loc) lbl), fvs `addOneFV` sel_name) + AmbiguousFields -> (Ambiguous noExtField (L (l2l loc) lbl), fvs) ; return (L l (HsFieldBind { hfbAnn = noAnn , hfbLHS = L loc lbl' diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs index fa6b5ba4c2..da8bf7901f 100644 --- a/compiler/GHC/Tc/Gen/Arrow.hs +++ b/compiler/GHC/Tc/Gen/Arrow.hs @@ -98,7 +98,7 @@ tcProc pat cmd@(L loc (HsCmdTop names _)) exp_ty ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 -- start with the names as they are used to desugar the proc itself -- See #17423 - ; names' <- setSrcSpan loc $ + ; names' <- setSrcSpanA loc $ mapM (tcSyntaxName ProcOrigin arr_ty) names ; let cmd_env = CmdEnv { cmd_arr = arr_ty } ; (pat', cmd') <- newArrowScope @@ -136,7 +136,7 @@ tcCmdTop :: CmdEnv -> TcM (LHsCmdTop GhcTc) tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { cmd' <- tcCmd env cmd cmd_ty ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') } @@ -301,7 +301,7 @@ tc_cmd env tc_grhss (GRHSs x grhss binds) stk_ty res_ty = do { (binds', grhss') <- tcLocalBinds binds $ - mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss + mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss ; return (GRHSs x grhss' binds') } tc_grhs stk_ty res_ty (GRHS x guards body) @@ -349,7 +349,7 @@ tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty) = do { arr_ty <- newFlexiTyVarTy arrowTyConKind ; stk_ty <- newFlexiTyVarTy liftedTypeKind ; res_ty <- newFlexiTyVarTy liftedTypeKind - ; names' <- setSrcSpan loc $ + ; names' <- setSrcSpanA loc $ mapM (tcSyntaxName ArrowCmdOrigin arr_ty) names ; let env' = env { cmd_arr = arr_ty } ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty) diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 87d8560fab..c9e9129251 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -406,7 +406,7 @@ tcExpr (HsIf x pred b1 b2) res_ty ; return (HsIf x pred' b1' b2') } tcExpr (HsMultiIf _ alts) res_ty - = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts + = do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts ; res_ty <- readExpType res_ty ; return (HsMultiIf res_ty alts') } where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody } @@ -1269,7 +1269,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- (giving duplicate deprecation warnings). Just gre -> do { unless (null (tail xs)) $ do let L loc _ = hfbLHS (unLoc upd) - setSrcSpan loc $ addUsedGRE True gre + setSrcSpanA loc $ addUsedGRE True gre ; lookupSelector (upd, greMangledName gre) } -- The field doesn't belong to this parent, so report -- an error but keep going through all the fields @@ -1285,12 +1285,10 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty = do { i <- tcLookupId n ; let L loc af = hfbLHS upd lbl = rdrNameAmbiguousFieldOcc af - -- ; return $ L l upd { hfbLHS - -- = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) } ; return $ L l HsFieldBind { hfbAnn = hfbAnn upd , hfbLHS - = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl)) + = L (l2l loc) (Unambiguous i (L (l2l loc) lbl)) , hfbRHS = hfbRHS upd , hfbPun = hfbPun upd } @@ -1368,7 +1366,7 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds , hfbRHS = rhs })) = do { let lbl = rdrNameAmbiguousFieldOcc af sel_id = selectorAmbiguousFieldOcc af - f = L loc (FieldOcc (idName sel_id) (L (noAnnSrcSpan loc) lbl)) + f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl)) ; mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing @@ -1377,7 +1375,7 @@ tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds (L l (fld { hfbLHS = L loc (Unambiguous (foExt (unLoc f')) - (L (noAnnSrcSpan loc) lbl)) + (L (l2l loc) lbl)) , hfbRHS = rhs' }))) } tcRecordField :: ConLike -> Assoc Name Type @@ -1392,7 +1390,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs field_ty ; let field_id = mkUserLocal (nameOccName sel_name) (nameUnique sel_name) - Many field_ty loc + Many field_ty (locA loc) -- Yuk: the field_id has the *unique* of the selector Id -- (so we can find it easily) -- but is a LocalId with the appropriate type of the RHS diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 6f01091200..3c502c557d 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -641,7 +641,7 @@ tcDerivStrategy mb_lds = case mb_lds of Nothing -> boring_case Nothing Just (L loc ds) -> - setSrcSpan loc $ do + setSrcSpanA loc $ do (ds', tvs) <- tc_deriv_strategy ds pure (Just (L loc ds'), tvs) where diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index ab767b877c..1b2ebf797a 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -205,8 +205,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))) ~ SrcSpan - , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan + , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns + , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA ) @@ -289,7 +289,7 @@ tcGRHSs :: AnnoBody body tcGRHSs ctxt (GRHSs _ grhss binds) res_ty = do { (binds', ugrhss) <- tcLocalBinds binds $ - mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss + mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt res_ty)) grhss ; let (usages, grhss') = unzip ugrhss ; tcEmitBindingUsage $ supUEs usages ; return (GRHSs emptyComments grhss' binds') } diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 3d740948ca..a09d77b6f7 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -1258,7 +1258,7 @@ tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of (L l (HsFieldBind ann (L loc (FieldOcc sel (L lr rdr))) pat pun)) thing_inside = do { sel' <- tcLookupId sel - ; pat_ty <- setSrcSpan loc $ find_field_ty sel + ; pat_ty <- setSrcSpanA loc $ find_field_ty sel (occNameFS $ rdrNameOcc rdr) ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside ; return (L l (HsFieldBind ann (L loc (FieldOcc sel' (L lr rdr))) pat' diff --git a/compiler/GHC/Tc/Gen/Rule.hs b/compiler/GHC/Tc/Gen/Rule.hs index a712ab4020..0fabfa626c 100644 --- a/compiler/GHC/Tc/Gen/Rule.hs +++ b/compiler/GHC/Tc/Gen/Rule.hs @@ -175,7 +175,7 @@ tcRule (HsRule { rd_ext = ext , rd_name = rname , rd_act = act , rd_tyvs = ty_bndrs -- preserved for ppr-ing - , rd_tmvs = map (noLoc . RuleBndr noAnn . noLocA) + , rd_tmvs = map (noLocA . RuleBndr noAnn . noLocA) (qtkvs ++ tpl_ids) , rd_lhs = mkHsDictLet lhs_binds lhs' , rd_rhs = mkHsDictLet rhs_binds rhs' } } diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index dc12ac0735..5dfa4cec86 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -2822,7 +2822,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))) - = setSrcSpan loc $ + = setSrcSpanA loc $ do { let tvs = binderVars tcbs ; dflags <- getDynFlags ; checkTc (xopt LangExt.TypeFamilyDependencies dflags) @@ -4964,7 +4964,7 @@ checkValidRoleAnnots role_annots tc check_no_roles = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl -checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM () +checkRoleAnnot :: TyVar -> LocatedAn 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/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index b7d47d57d8..1ce9ef8f82 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -886,6 +886,7 @@ mkOneRecordSelector all_cons idDetails fl has_sel loc = getSrcSpan sel_name loc' = noAnnSrcSpan loc locn = noAnnSrcSpan loc + locc = noAnnSrcSpan loc lbl = flLabel fl sel_name = flSelector fl @@ -930,8 +931,8 @@ mkOneRecordSelector all_cons idDetails fl has_sel rec_field = noLocA (HsFieldBind { hfbAnn = noAnn , hfbLHS - = L loc (FieldOcc sel_name - (L locn $ mkVarUnqual lbl)) + = L locc (FieldOcc sel_name + (L locn $ mkVarUnqual lbl)) , hfbRHS = L loc' (VarPat noExtField (L locn field_var)) , hfbPun = False }) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 1c80acdf9b..fc293654ec 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -963,7 +963,7 @@ wrapLocFstM fn (L loc a) = (b,c) <- fn a return (L loc b, c) -wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c) +wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedAn t a -> TcM (LocatedAn t b, c) wrapLocFstMA 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 142d09f9ee..fec8d90d5d 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -672,7 +672,7 @@ zonkLTcSpecPrags env ps ************************************************************************ -} -zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan +zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns => ZonkEnv -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) -> MatchGroup GhcTc (LocatedA (body GhcTc)) @@ -687,7 +687,7 @@ zonkMatchGroup env zBody (MG { mg_alts = L l ms , mg_ext = MatchGroupTc arg_tys' res_ty' , mg_origin = origin }) } -zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan +zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns => ZonkEnv -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) -> LMatch GhcTc (LocatedA (body GhcTc)) @@ -699,7 +699,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))) ~ SrcSpan +zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns => ZonkEnv -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc))) -> GRHSs GhcTc (LocatedA (body GhcTc)) @@ -712,7 +712,7 @@ zonkGRHSs env zBody (GRHSs x grhss binds) = do = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded new_rhs <- zBody env2 rhs return (GRHS xx new_guarded new_rhs) - new_grhss <- mapM (wrapLocM zonk_grhs) grhss + new_grhss <- mapM (wrapLocMA zonk_grhs) grhss return (GRHSs x new_grhss new_binds) {- @@ -842,7 +842,7 @@ zonkExpr env (HsIf x e1 e2 e3) return (HsIf x new_e1 new_e2 new_e3) zonkExpr env (HsMultiIf ty alts) - = do { alts' <- mapM (wrapLocM zonk_alt) alts + = do { alts' <- mapM (wrapLocMA zonk_alt) alts ; ty' <- zonkTcTypeToTypeX env ty ; return $ HsMultiIf ty' alts' } where zonk_alt (GRHS x guard expr) @@ -1040,7 +1040,7 @@ zonkCmd env (HsCmdDo ty (L l stmts)) zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTc -> TcM (LHsCmdTop GhcTc) -zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd +zonkCmdTop env cmd = wrapLocMA (zonk_cmd_top env) cmd zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTc -> TcM (HsCmdTop GhcTc) zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) @@ -1302,7 +1302,7 @@ zonkRecFields env (HsRecFields flds dd) ; return (HsRecFields flds' dd) } where zonk_rbind (L l fld) - = do { new_id <- wrapLocM (zonkFieldOcc env) (hfbLHS fld) + = do { new_id <- wrapLocMA (zonkFieldOcc env) (hfbLHS fld) ; new_expr <- zonkLExpr env (hfbRHS fld) ; return (L l (fld { hfbLHS = new_id , hfbRHS = new_expr })) } @@ -1312,14 +1312,14 @@ zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc] zonkRecUpdFields env = mapM zonk_rbind where zonk_rbind (L l fld) - = do { new_id <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld) + = do { new_id <- wrapLocMA (zonkFieldOcc env) (hsRecUpdFieldOcc fld) ; new_expr <- zonkLExpr env (hfbRHS fld) ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id , hfbRHS = new_expr })) } ------------------------------------------------------------------------- -mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a - -> TcM (Either (Located HsIPName) b) +mapIPNameTc :: (a -> TcM b) -> Either (LocatedAn NoEpAnns HsIPName) a + -> TcM (Either (LocatedAn NoEpAnns HsIPName) b) mapIPNameTc _ (Left x) = return (Left x) mapIPNameTc f (Right x) = do r <- f x return (Right r) diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index e923307f15..a0c7b7e222 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -127,19 +127,12 @@ getL = CvtM (\_ loc -> Right (loc,loc)) setL :: SrcSpan -> CvtM () setL loc = CvtM (\_ _ -> Right (loc, ())) -returnL :: a -> CvtM (Located a) -returnL x = CvtM (\_ loc -> Right (loc, L loc x)) - --- returnLA :: a -> CvtM (LocatedA a) returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e) returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x)) returnJustLA :: a -> CvtM (Maybe (LocatedA a)) returnJustLA = fmap Just . returnLA --- wrapParL :: (Located a -> a) -> a -> CvtM a --- wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x))) - wrapParLA :: (LocatedA a -> a) -> a -> CvtM a wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x))) @@ -401,7 +394,7 @@ cvtDec (ClosedTypeFamilyD head eqns) cvtDec (TH.RoleAnnotD tc roles) = do { tc' <- tconNameN tc - ; let roles' = map (noLoc . cvtRole) roles + ; let roles' = map (noLocA . cvtRole) roles ; returnJustLA $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') } @@ -701,7 +694,7 @@ cvt_id_arg (i, str, ty) ; return $ noLocA (ConDeclField { cd_fld_ext = noAnn , cd_fld_names - = [L (locA li) $ FieldOcc noExtField (L li i')] + = [L (l2l li) $ FieldOcc noExtField (L li i')] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -824,7 +817,7 @@ cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) , rds_src = SourceText "{-# RULES" , rds_rules = [noLocA $ HsRule { rd_ext = noAnn - , rd_name = (noLoc (quotedSourceText nm,nm')) + , rd_name = (noLocA (quotedSourceText nm,nm')) , rd_act = act , rd_tyvs = ty_bndrs' , rd_tmvs = tm_bndrs' @@ -878,11 +871,11 @@ cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n) = do { n' <- vNameN n - ; return $ noLoc $ Hs.RuleBndr noAnn n' } + ; return $ noLocA $ Hs.RuleBndr noAnn n' } cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameN n ; ty' <- cvtType ty - ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' } + ; return $ noLocA $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' } --------------------------------------------------- -- Declarations @@ -917,7 +910,7 @@ cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) cvtImplicitParamBind n e = do n' <- wrapL (ipName n) e' <- cvtl e - returnLA (IPBind noAnn (Left n') e') + returnLA (IPBind noAnn (Left (reLocA n')) e') ------------------------------------------------------------------- -- Expressions @@ -1056,8 +1049,8 @@ cvtl e = wrapLA (cvt e) cvt (LabelE s) = return $ HsOverLabel noComments (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 noSrcSpan (DotFieldOcc noAnn (L noSrcSpan (fsLit f)))) } - cvt (ProjectionE xs) = return $ HsProjection noAnn $ map (L noSrcSpan . DotFieldOcc noAnn . L noSrcSpan . fsLit) xs + ; return $ HsGetField noComments e' (L noSrcSpanA (DotFieldOcc noAnn (L noSrcSpanA (fsLit f)))) } + cvt (ProjectionE xs) = return $ HsProjection noAnn $ map (L noSrcSpanA . DotFieldOcc noAnn . L noSrcSpanA . fsLit) xs {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example: @@ -1093,11 +1086,11 @@ which we don't want. -} cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) - -> CvtM (LHsFieldBind GhcPs (Located t) (LHsExpr GhcPs)) + -> CvtM (LHsFieldBind GhcPs (LocatedAn NoEpAnns t) (LHsExpr GhcPs)) cvtFld f (v,e) = do { v' <- vNameL v; e' <- cvtl e ; return (noLocA $ HsFieldBind { hfbAnn = noAnn - , hfbLHS = reLoc $ fmap f v' + , hfbLHS = la2la $ fmap f v' , hfbRHS = e' , hfbPun = False}) } @@ -1228,14 +1221,14 @@ cvtMatch ctxt (TH.Match p body decs) cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (NormalB e) = do { e' <- cvtl e - ; g' <- returnL $ GRHS noAnn [] e'; return [g'] } + ; g' <- returnLA $ GRHS noAnn [] e'; return [g'] } cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs ; g' <- returnLA $ mkBodyStmt ge' - ; returnL $ GRHS noAnn [g'] rhs' } + ; returnLA $ GRHS noAnn [g'] rhs' } cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs - ; returnL $ GRHS noAnn gs' rhs' } + ; returnLA $ GRHS noAnn gs' rhs' } cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i) @@ -1308,7 +1301,7 @@ cvtPat pat = wrapLA (cvtp pat) cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) cvtp (TH.LitP l) | overloadedLit l = do { l' <- cvtOverLit l - ; return (mkNPat (noLoc l') Nothing noAnn) } + ; return (mkNPat (noLocA l') Nothing noAnn) } -- Not right for negative patterns; -- need to think about that! | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } @@ -1374,7 +1367,7 @@ cvtPatFld (s,p) ; p' <- cvtPat p ; return (noLocA $ HsFieldBind { hfbAnn = noAnn , hfbLHS - = L (locA ls) $ mkFieldOcc (L ls s') + = L (l2l ls) $ mkFieldOcc (L (l2l ls) s') , hfbRHS = p' , hfbPun = False}) } @@ -1456,15 +1449,15 @@ cvtDerivClause :: TH.DerivClause cvtDerivClause (TH.DerivClause ds tys) = do { tys' <- cvtDerivClauseTys tys ; ds' <- traverse cvtDerivStrategy ds - ; returnL $ HsDerivingClause noAnn ds' tys' } + ; returnLA $ HsDerivingClause noAnn ds' tys' } cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs) -cvtDerivStrategy TH.StockStrategy = returnL (Hs.StockStrategy noAnn) -cvtDerivStrategy TH.AnyclassStrategy = returnL (Hs.AnyclassStrategy noAnn) -cvtDerivStrategy TH.NewtypeStrategy = returnL (Hs.NewtypeStrategy noAnn) +cvtDerivStrategy TH.StockStrategy = returnLA (Hs.StockStrategy noAnn) +cvtDerivStrategy TH.AnyclassStrategy = returnLA (Hs.AnyclassStrategy noAnn) +cvtDerivStrategy TH.NewtypeStrategy = returnLA (Hs.NewtypeStrategy noAnn) cvtDerivStrategy (TH.ViaStrategy ty) = do ty' <- cvtSigType ty - returnL $ Hs.ViaStrategy (XViaStrategyPs noAnn ty') + returnLA $ Hs.ViaStrategy (XViaStrategyPs noAnn ty') cvtType :: TH.Type -> CvtM (LHsType GhcPs) cvtType = cvtTypeKind "type" @@ -1677,7 +1670,7 @@ cvtTypeKind ty_str ty ImplicitParamT n t -> do { n' <- wrapL $ ipName n ; t' <- cvtType t - ; returnLA (HsIParamTy noAnn n' t') + ; returnLA (HsIParamTy noAnn (reLocA n') t') } _ -> failWith (text "Malformed " <> text ty_str <+> text (show ty)) @@ -1796,18 +1789,18 @@ cvtSigKind = cvtSigTypeKind "kind" -- signature is possible). cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind -> CvtM (LFamilyResultSig GhcPs) -cvtMaybeKindToFamilyResultSig Nothing = returnL (Hs.NoSig noExtField) +cvtMaybeKindToFamilyResultSig Nothing = returnLA (Hs.NoSig noExtField) cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki - ; returnL (Hs.KindSig noExtField ki') } + ; returnLA (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 = returnL (Hs.NoSig noExtField) +cvtFamilyResultSig TH.NoSig = returnLA (Hs.NoSig noExtField) cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki - ; returnL (Hs.KindSig noExtField ki') } + ; returnLA (Hs.KindSig noExtField ki') } cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr - ; returnL (Hs.TyVarSig noExtField tv) } + ; returnLA (Hs.TyVarSig noExtField tv) } -- | Convert injectivity annotation of a type family. cvtInjectivityAnnotation :: TH.InjectivityAnn @@ -1815,7 +1808,7 @@ cvtInjectivityAnnotation :: TH.InjectivityAnn cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS) = do { annLHS' <- tNameN annLHS ; annRHS' <- mapM tNameN annRHS - ; returnL (Hs.InjectivityAnn noAnn annLHS' annRHS') } + ; returnLA (Hs.InjectivityAnn noAnn annLHS' annRHS') } cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs) -- pattern synonym types are of peculiar shapes, which is why we treat diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index df06635ab3..410d709bec 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -1694,7 +1694,7 @@ data RuleBndr pass collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] -pprFullRuleName :: Located (SourceText, RuleName) -> SDoc +pprFullRuleName :: GenLocated a (SourceText, RuleName) -> SDoc pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) {- diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr index 566d319538..28393796b1 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr @@ -692,7 +692,9 @@ {OccName: a}))))]) (Prefix) (L - { <no location info> } + (SrcSpanAnn + (EpAnnNotUsed) + { <no location info> }) (NoSig (NoExtField))) (Nothing)))] @@ -952,7 +954,9 @@ {OccName: a}))))]) (Prefix) (L - { <no location info> } + (SrcSpanAnn + (EpAnnNotUsed) + { <no location info> }) (NoSig (NoExtField))) (Nothing)))] @@ -1212,7 +1216,9 @@ {OccName: a}))))]) (Prefix) (L - { <no location info> } + (SrcSpanAnn + (EpAnnNotUsed) + { <no location info> }) (NoSig (NoExtField))) (Nothing)))] @@ -1472,7 +1478,9 @@ {OccName: a}))))]) (Prefix) (L - { <no location info> } + (SrcSpanAnn + (EpAnnNotUsed) + { <no location info> }) (NoSig (NoExtField))) (Nothing)))] @@ -1732,7 +1740,9 @@ {OccName: a}))))]) (Prefix) (L - { <no location info> } + (SrcSpanAnn + (EpAnnNotUsed) + { <no location info> }) (NoSig (NoExtField))) (Nothing)))] @@ -1992,7 +2002,9 @@ {OccName: a}))))]) (Prefix) (L - { <no location info> } + (SrcSpanAnn + (EpAnnNotUsed) + { <no location info> }) (NoSig (NoExtField))) (Nothing)))] diff --git a/testsuite/tests/module/mod185.stderr b/testsuite/tests/module/mod185.stderr index 663f963e99..04dc4758b1 100644 --- a/testsuite/tests/module/mod185.stderr +++ b/testsuite/tests/module/mod185.stderr @@ -100,7 +100,9 @@ (EpaComments []) [(L - { mod185.hs:5:6-24 } + (SrcSpanAnn + (EpAnnNotUsed) + { mod185.hs:5:6-24 }) (GRHS (EpAnn (Anchor diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 72609565a8..60230b3b63 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -430,7 +430,9 @@ {OccName: k}))))))))]) (Prefix) (L - { DumpParsedAst.hs:10:32-39 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpParsedAst.hs:10:32-39 }) (KindSig (NoExtField) (L @@ -873,7 +875,9 @@ {OccName: Type}))))))))]) (Prefix) (L - { DumpParsedAst.hs:17:42-48 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpParsedAst.hs:17:42-48 }) (KindSig (NoExtField) (L @@ -935,7 +939,9 @@ (EpaComments []) [(L - { DumpParsedAst.hs:20:6-23 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpParsedAst.hs:20:6-23 }) (GRHS (EpAnn (Anchor diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index b7ef9c2ce6..77061c1f84 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -44,7 +44,9 @@ (EpaComments []) [(L - { DumpRenamedAst.hs:34:6-23 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpRenamedAst.hs:34:6-23 }) (GRHS (EpAnnNotUsed) [] @@ -331,7 +333,9 @@ {Name: k})))))))]) (Prefix) (L - { DumpRenamedAst.hs:12:32-39 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpRenamedAst.hs:12:32-39 }) (KindSig (NoExtField) (L @@ -371,7 +375,9 @@ []) (Prefix) (L - { DumpRenamedAst.hs:16:17-33 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpRenamedAst.hs:16:17-33 }) (KindSig (NoExtField) (L @@ -1006,7 +1012,9 @@ {Name: GHC.Types.Type})))))))]) (Prefix) (L - { DumpRenamedAst.hs:24:42-48 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpRenamedAst.hs:24:42-48 }) (KindSig (NoExtField) (L @@ -1101,7 +1109,9 @@ {Name: b})))]) (Prefix) (L - { <no location info> } + (SrcSpanAnn + (EpAnnNotUsed) + { <no location info> }) (NoSig (NoExtField))) (Nothing)))] diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr index bc3d2cca04..b5836252ad 100644 --- a/testsuite/tests/parser/should_compile/DumpSemis.stderr +++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr @@ -237,7 +237,9 @@ (EpaComments []) [(L - { DumpSemis.hs:(10,5)-(12,3) } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:(10,5)-(12,3) }) (GRHS (EpAnn (Anchor @@ -481,7 +483,9 @@ (EpaComments []) [(L - { DumpSemis.hs:(15,5)-(19,3) } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:(15,5)-(19,3) }) (GRHS (EpAnn (Anchor @@ -685,7 +689,9 @@ (EpaComments []) [(L - { DumpSemis.hs:22:5-30 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:22:5-30 }) (GRHS (EpAnn (Anchor @@ -853,7 +859,9 @@ (EpaComments []) [(L - { DumpSemis.hs:24:3-13 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:24:3-13 }) (GRHS (EpAnn (Anchor @@ -920,7 +928,9 @@ (EpaComments []) [(L - { DumpSemis.hs:25:3-13 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:25:3-13 }) (GRHS (EpAnn (Anchor @@ -988,7 +998,9 @@ (EpaComments []) [(L - { DumpSemis.hs:26:3-13 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:26:3-13 }) (GRHS (EpAnn (Anchor @@ -1389,7 +1401,9 @@ (EpaComments []) [(L - { DumpSemis.hs:32:5-7 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:32:5-7 }) (GRHS (EpAnn (Anchor @@ -1459,7 +1473,9 @@ (EpaComments []) [(L - { DumpSemis.hs:34:9-35 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:34:9-35 }) (GRHS (EpAnn (Anchor @@ -1559,7 +1575,9 @@ (EpaComments []) [(L - { DumpSemis.hs:34:20-21 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:34:20-21 }) (GRHS (EpAnn (Anchor @@ -1640,7 +1658,9 @@ (EpaComments []) [(L - { DumpSemis.hs:34:25-26 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:34:25-26 }) (GRHS (EpAnn (Anchor @@ -1748,7 +1768,9 @@ (EpaComments []) [(L - { DumpSemis.hs:(36,7)-(44,4) } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:(36,7)-(44,4) }) (GRHS (EpAnn (Anchor @@ -1827,7 +1849,9 @@ (NPat (EpAnnNotUsed) (L - { DumpSemis.hs:39:6 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:39:6 }) (OverLit (NoExtField) (HsIntegral @@ -1841,7 +1865,9 @@ (EpaComments []) [(L - { DumpSemis.hs:39:8-13 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:39:8-13 }) (GRHS (EpAnn (Anchor @@ -1892,7 +1918,9 @@ (NPat (EpAnnNotUsed) (L - { DumpSemis.hs:40:6 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:40:6 }) (OverLit (NoExtField) (HsIntegral @@ -1906,7 +1934,9 @@ (EpaComments []) [(L - { DumpSemis.hs:40:8-13 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:40:8-13 }) (GRHS (EpAnn (Anchor @@ -1959,7 +1989,9 @@ (NPat (EpAnnNotUsed) (L - { DumpSemis.hs:41:6 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:41:6 }) (OverLit (NoExtField) (HsIntegral @@ -1973,7 +2005,9 @@ (EpaComments []) [(L - { DumpSemis.hs:41:8-13 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:41:8-13 }) (GRHS (EpAnn (Anchor @@ -2028,7 +2062,9 @@ (NPat (EpAnnNotUsed) (L - { DumpSemis.hs:42:6 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:42:6 }) (OverLit (NoExtField) (HsIntegral @@ -2042,7 +2078,9 @@ (EpaComments []) [(L - { DumpSemis.hs:42:8-13 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpSemis.hs:42:8-13 }) (GRHS (EpAnn (Anchor diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index 55c10d4729..afd80e9cdd 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -1571,7 +1571,9 @@ (EpaComments []) [(L - { DumpTypecheckedAst.hs:19:6-23 } + (SrcSpanAnn + (EpAnnNotUsed) + { DumpTypecheckedAst.hs:19:6-23 }) (GRHS (EpAnnNotUsed) [] diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 3bd3964024..634d488cf7 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -182,7 +182,9 @@ {OccName: a}))))]) (Prefix) (L - { <no location info> } + (SrcSpanAnn + (EpAnnNotUsed) + { <no location info> }) (NoSig (NoExtField))) (Nothing))))) @@ -880,7 +882,9 @@ (EpaComments []) [(L - { KindSigs.hs:23:9-12 } + (SrcSpanAnn + (EpAnnNotUsed) + { KindSigs.hs:23:9-12 }) (GRHS (EpAnn (Anchor @@ -1485,7 +1489,9 @@ (EpaComments []) [(L - { KindSigs.hs:35:6-11 } + (SrcSpanAnn + (EpAnnNotUsed) + { KindSigs.hs:35:6-11 }) (GRHS (EpAnn (Anchor diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index 6accce1c99..9eda4089be 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -133,7 +133,9 @@ (ConDeclField (EpAnnNotUsed) [(L - { T14189.hs:6:33 } + (SrcSpanAnn + (EpAnnNotUsed) + { T14189.hs:6:33 }) (FieldOcc {Name: T14189.f} (L diff --git a/testsuite/tests/printer/Test20297.stdout b/testsuite/tests/printer/Test20297.stdout index 615f265e76..6d7212f250 100644 --- a/testsuite/tests/printer/Test20297.stdout +++ b/testsuite/tests/printer/Test20297.stdout @@ -91,7 +91,9 @@ (EpaComments []) [(L - { Test20297.hs:(5,5)-(7,7) } + (SrcSpanAnn + (EpAnnNotUsed) + { Test20297.hs:(5,5)-(7,7) }) (GRHS (EpAnn (Anchor @@ -184,7 +186,9 @@ (EpaComments []) [(L - { Test20297.hs:(9,5)-(11,26) } + (SrcSpanAnn + (EpAnnNotUsed) + { Test20297.hs:(9,5)-(11,26) }) (GRHS (EpAnn (Anchor @@ -271,7 +275,9 @@ (EpaComments []) [(L - { Test20297.hs:11:17-26 } + (SrcSpanAnn + (EpAnnNotUsed) + { Test20297.hs:11:17-26 }) (GRHS (EpAnn (Anchor @@ -430,7 +436,9 @@ (EpaComments []) [(L - { Test20297.ppr.hs:(4,3)-(5,7) } + (SrcSpanAnn + (EpAnnNotUsed) + { Test20297.ppr.hs:(4,3)-(5,7) }) (GRHS (EpAnn (Anchor @@ -516,7 +524,9 @@ (EpaComments []) [(L - { Test20297.ppr.hs:(7,3)-(9,24) } + (SrcSpanAnn + (EpAnnNotUsed) + { Test20297.ppr.hs:(7,3)-(9,24) }) (GRHS (EpAnn (Anchor @@ -596,7 +606,9 @@ (EpaComments []) [(L - { Test20297.ppr.hs:9:15-24 } + (SrcSpanAnn + (EpAnnNotUsed) + { Test20297.ppr.hs:9:15-24 }) (GRHS (EpAnn (Anchor diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index 13d6f4869b..44cadff4c1 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -374,6 +374,10 @@ instance (ExactPrint a) => ExactPrint (LocatedA a) where markAnnotated a markALocatedA (ann la) +instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where + getAnnotationEntry = entryFromLocatedA + exact (L _ a) = markAnnotated a + instance (ExactPrint a) => ExactPrint [a] where getAnnotationEntry = const NoEntryVal exact ls = mapM_ markAnnotated ls @@ -1100,8 +1104,8 @@ instance ExactPrint (RoleAnnotDecl GhcPs) where markEpAnn an AnnType markEpAnn an AnnRole markAnnotated ltycon - let markRole (L l (Just r)) = markAnnotated (L l r) - markRole (L l Nothing) = printStringAtSs l "_" + let markRole (L l (Just r)) = markAnnotated (L (locA l) r) + markRole (L l Nothing) = printStringAtSs (locA l) "_" mapM_ markRole roles -- --------------------------------------------------------------------- @@ -2214,7 +2218,7 @@ instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where -- instance (ExactPrint body) => ExactPrint (HsRecField GhcPs body) where instance (ExactPrint body) - => ExactPrint (HsFieldBind (Located (FieldOcc GhcPs)) body) where + => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) body) where getAnnotationEntry x = fromAnn (hfbAnn x) exact (HsFieldBind an f arg isPun) = do debugM $ "HsFieldBind" @@ -2227,7 +2231,7 @@ instance (ExactPrint body) -- --------------------------------------------------------------------- instance (ExactPrint body) - => ExactPrint (HsFieldBind (Located (FieldLabelStrings GhcPs)) body) where + => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where getAnnotationEntry x = fromAnn (hfbAnn x) exact (HsFieldBind an f arg isPun) = do debugM $ "HsFieldBind FieldLabelStrings" @@ -2241,7 +2245,7 @@ instance (ExactPrint body) -- instance ExactPrint (HsRecUpdField GhcPs ) where instance (ExactPrint (LocatedA body)) - => ExactPrint (HsFieldBind (Located (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where + => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where -- instance (ExactPrint body) -- => ExactPrint (HsFieldBind (AmbiguousFieldOcc GhcPs) body) where getAnnotationEntry x = fromAnn (hfbAnn x) @@ -2254,11 +2258,11 @@ instance (ExactPrint (LocatedA body)) -- --------------------------------------------------------------------- instance - (ExactPrint (HsFieldBind (Located (a GhcPs)) body), - ExactPrint (HsFieldBind (Located (b GhcPs)) body)) + (ExactPrint (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body), + ExactPrint (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)) => ExactPrint - (Either [LocatedA (HsFieldBind (Located (a GhcPs)) body)] - [LocatedA (HsFieldBind (Located (b GhcPs)) body)]) where + (Either [LocatedA (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body)] + [LocatedA (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)]) where getAnnotationEntry = const NoEntryVal exact (Left rbinds) = markAnnotated rbinds exact (Right pbinds) = markAnnotated pbinds diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index fc13371f77..f59359a61d 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -693,7 +693,7 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do -- --------------------------------- (EpAnn anc an lgc) = ag - lgc' = splitCommentsEnd (realSrcSpan lg) $ addCommentOrigDeltas lgc + lgc' = splitCommentsEnd (realSrcSpan $ locA lg) $ addCommentOrigDeltas lgc ag' = if moved then EpAnn anc an lgc' else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move)) diff --git a/utils/haddock b/utils/haddock -Subproject d8b79d35ddd96c83f4a3a0303011defc209aa31 +Subproject 1ef24e617651955f07c4fb6f2d488806cc6785e |