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