[Git][ghc/ghc][master] EPA: Remove LocatedLW from LStmtLR

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: bf7b5ce6 by Alan Zimmerman at 2026-06-30T13:34:23-04:00 EPA: Remove LocatedLW from LStmtLR HsDo already had its XDo extension point for an AnnList, which also appeared in LocatedLW. So we remove the redundant one and use the one inside HsDo as originally intended. Also delete LocatedLC/LocatedLS as they were unused - - - - - 12 changed files: - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/Types.hs - compiler/GHC/Tc/Gen/Match.hs - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/printer/Test20297.stdout - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -69,6 +69,7 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` annotationAnnList `extQ` annotationAnnListWhere `extQ` annotationAnnListCommas + `extQ` annotationAnnListEpaLocation `extQ` annotationNoEpAnns `extQ` annotationExprBracket `extQ` annotationTypedBracket @@ -375,6 +376,12 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])") + annotationAnnListEpaLocation :: AnnList EpaLocation -> SDoc + annotationAnnListEpaLocation anns = case ba of + BlankEpAnnotations -> parens (text "blanked:" <+> text "AnnList EpaLocation") + NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns)) + $$ vcat (gmapQ showAstData' anns) + annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns") ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -535,9 +535,6 @@ type instance XPragE (GhcPass _) = NoExtField type instance XFunRhs = AnnFunRhs -type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW -type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA - mkHsVar :: forall p. IsPass p => LIdP (GhcPass p) -> HsExpr (GhcPass p) mkHsVar n = HsVar noExtField $ case ghcPass @p of @@ -2648,8 +2645,8 @@ instance UnXRec p => Outputable (DotFieldOcc p) where type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA type instance Anno [LocatedA (HsExpr (GhcPass p))] = SrcSpanAnnA -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnA +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnA type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA @@ -2665,7 +2662,7 @@ type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA -type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW +type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnA type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO type instance Anno FieldLabelString = SrcSpanAnnN ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -320,8 +320,8 @@ nlParPat p = noLocA (gParPat p) mkHsIntegral :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs -mkHsDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs -mkHsDoAnns :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs +mkHsDo :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsDoAnns :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs @@ -349,12 +349,12 @@ mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc) emptyRecStmt :: (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] - ~ SrcSpanAnnLW) + ~ SrcSpanAnnA) => StmtLR (GhcPass idL) GhcPs bodyR emptyRecStmtName :: (Anno [GenLocated (Anno (StmtLR GhcRn GhcRn bodyR)) (StmtLR GhcRn GhcRn bodyR)] - ~ SrcSpanAnnLW) + ~ SrcSpanAnnA) => StmtLR GhcRn GhcRn bodyR emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc)) @@ -362,9 +362,9 @@ mkRecStmt :: forall (idL :: Pass) bodyR. (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] - ~ SrcSpanAnnLW) + ~ SrcSpanAnnA) => AnnList (EpToken "rec") - -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR] + -> LocatedA [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR mkRecStmt anns stmts = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR) { recS_stmts = stmts } ===================================== compiler/GHC/Parser.y ===================================== @@ -3144,15 +3144,17 @@ aexp :: { ECP } return $ ECP $ $2 >>= \ $2 -> mkHsDoPV (comb2 $1 $2) + (stmtlistAnns $2) (fmap mkModuleNameFS (getDO $1)) - $2 + (stmtlistStmts $2) (glR $1) (glR $2) } | MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 -> fmap ecpFromExp $ amsA' (L (comb2 $1 $2) - (mkMDo (MDoExpr $ fmap mkModuleNameFS (getMDO $1)) - $2 + (mkMDo (stmtlistAnns $2) + (MDoExpr $ fmap mkModuleNameFS (getMDO $1)) + (stmtlistStmts $2) (glR $1) (glR $2))) } | 'proc' aexp '->' exp @@ -3648,11 +3650,11 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { forall b. DisambECP b => PV (LocatedLW [LocatedA (Stmt GhcPs (LocatedA b))]) } +stmtlist :: { forall b. DisambECP b => PV (LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), Located [LocatedA (Stmt GhcPs (LocatedA b))])) } : '{' stmts '}' { $2 >>= \ $2 -> - amsr (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) noAnn []) } - | vocurly stmts close { $2 >>= \ $2 -> amsr - (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) ListNone (fromOL $ fst $ unLoc $2) noAnn []) } + amsA' (sLL $1 $> ((epTok $1, fromOL $ fst $ unLoc $2, epTok $3), sL1 $2 $ reverse $ snd $ unLoc $2))} + | vocurly stmts close { $2 >>= \ $2 -> + amsA' (L (stmtsLoc $2) ((NoEpTok, fromOL $ fst $ unLoc $2, NoEpTok), sL1 $2 $ reverse $ snd $ unLoc $2))} -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce @@ -3694,7 +3696,8 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : qual { $1 } | 'rec' stmtlist { $2 >>= \ $2 -> - amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) $2) $2) } + amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) (stmtlistAnns $2) $2) + (stmtlistStmts $2)) } qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : bindpat '<-' exp { unECP $3 >>= \ $3 -> @@ -4717,9 +4720,9 @@ commentsPA la@(L l a) = do !cs <- getPriorCommentsFor (getLocA la) return (L (addCommentsToEpAnn l cs) a) -hsDoAnn :: EpToken "rec" -> LocatedAn t b -> AnnList (EpToken "rec") -hsDoAnn tok (L ll _) - = AnnList (Just $ spanAsAnchor (locA ll)) ListNone [] tok [] +hsDoAnn :: EpToken "rec" -> (EpToken "{", [EpToken ";"], EpToken "}") -> LocatedAn t b -> AnnList (EpToken "rec") +hsDoAnn rec (ob, semis, cb) (L ll _) + = AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis rec [] listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation listAsAnchorM [] = Nothing @@ -4745,6 +4748,17 @@ epExplicitBraces !t1 !t2 = EpExplicitBraces (epTok t1) (epTok t2) -- ------------------------------------- +stmtlistStmts :: LocatedA (a, Located [LocatedA (Stmt GhcPs (LocatedA b))]) + -> LocatedA [LocatedA (Stmt GhcPs (LocatedA b))] +stmtlistStmts (L la (_,L l stmts)) + = L ((noAnnSrcSpan l) {comments = comments la}) stmts + +stmtlistAnns :: LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), a) + -> (EpToken "{", [EpToken ";"], EpToken "}") +stmtlistAnns (L _ (an,_)) = an + +-- ------------------------------------- + addTrailingCommaFBind :: MonadP m => Fbind b -> EpToken "," -> m (Fbind b) addTrailingCommaFBind (Left b) l = fmap Left (addTrailingCommaA b l) addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l) ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -28,10 +28,10 @@ module GHC.Parser.Annotation ( -- ** Annotations in 'GenLocated' LocatedA, LocatedN, LocatedAn, LocatedP, - LocatedLC, LocatedLS, LocatedLW, + LocatedLW, LocatedE, LocatedBF, SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN, - SrcSpanAnnLC, SrcSpanAnnLW, SrcSpanAnnLS, + SrcSpanAnnLW, SrcSpanAnnBF, -- ** Annotation data types used in 'GenLocated' @@ -432,18 +432,13 @@ emptyComments = EpaComments [] type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN -type LocatedLC = GenLocated SrcSpanAnnLC -type LocatedLS = GenLocated SrcSpanAnnLS type LocatedLW = GenLocated SrcSpanAnnLW type LocatedP = GenLocated SrcSpanAnnP --- type LocatedC = GenLocated SrcSpanAnnC type LocatedBF = GenLocated SrcSpanAnnBF type SrcSpanAnnA = EpAnn AnnListItem type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnLC = EpAnn (AnnList [EpToken ","]) -type SrcSpanAnnLS = EpAnn (AnnList ()) type SrcSpanAnnLW = EpAnn (AnnList (EpToken "where")) type SrcSpanAnnP = EpAnn AnnPragma type SrcSpanAnnBF = EpAnn AnnBooleanFormula ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -436,9 +436,9 @@ mkRoleAnnotDecl loc tycon roles anns addFatalError $ mkPlainErrorMsgEnvelope loc_role $ (PsErrIllegalRoleName role nearby) -mkMDo :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs -mkMDo ctxt stmts tok loc - = mkHsDoAnns ctxt stmts (AnnList (Just loc) ListNone [] tok []) +mkMDo :: (EpToken "{", [EpToken ";"], EpToken "}") -> HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs +mkMDo (ob, semis, cb) ctxt stmts tok loc + = mkHsDoAnns ctxt stmts (AnnList (Just loc) (ListBraces ob cb) semis tok []) -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if @@ -1733,7 +1733,7 @@ type AnnoBody b , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA , Anno [LocatedA (StmtLR GhcPs GhcPs - (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnLW + (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnA ) -- | Disambiguate constructs that may appear when we do not know ahead of time whether we are @@ -1795,8 +1795,9 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -- | Disambiguate "do { ... }" (do notation) mkHsDoPV :: SrcSpan -> + (EpToken "{", [EpToken ";"], EpToken "}") -> Maybe ModuleName -> - LocatedLW [LStmt GhcPs (LocatedA b)] -> + LocatedA [LStmt GhcPs (LocatedA b)] -> EpaLocation -> -- Token EpaLocation -> -- Anchor PV (LocatedA b) @@ -1948,10 +1949,10 @@ instance DisambECP (HsCmd GhcPs) where checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) - mkHsDoPV l Nothing stmts tok_loc anc = do + mkHsDoPV l (ob,semis,cb) Nothing stmts tok_loc anc = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) ListNone [] tok_loc []) stmts) - mkHsDoPV l (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) (ListBraces ob cb) semis tok_loc []) stmts) + mkHsDoPV l _ (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m mkHsParPV l lpar c rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c) @@ -2047,9 +2048,9 @@ instance DisambECP (HsExpr GhcPs) where checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) - mkHsDoPV l mod stmts loc_tok anc = do + mkHsDoPV l (ob,semis,cb) mod stmts loc_tok anc = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) ListNone [] loc_tok []) (DoExpr mod) stmts) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) (ListBraces ob cb) semis loc_tok []) (DoExpr mod) stmts) mkHsParPV l lpar e rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) @@ -2145,7 +2146,7 @@ instance DisambECP (PatBuilder GhcPs) where !cs <- getCommentsFor (locA l) return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t)) mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat - mkHsDoPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat + 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 (l2l l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do ===================================== compiler/GHC/Parser/Types.hs ===================================== @@ -110,7 +110,7 @@ instance Outputable DataConBuilder where ppr (InfixDataConBuilder lhs data_con rhs) = ppr lhs <+> ppr data_con <+> ppr rhs -type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnLW +type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnA data ExplicitNamespaceKeyword = ExplicitTypeNamespace !(EpToken "type") ===================================== compiler/GHC/Tc/Gen/Match.hs ===================================== @@ -376,7 +376,7 @@ tcGRHSNE ctxt tc_body grhss res_ty -} tcDoStmts :: HsDoFlavour - -> LocatedLW [LStmt GhcRn (LHsExpr GhcRn)] + -> LocatedA [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType -> TcM (HsExpr GhcTc) -- Returns a HsDo tcDoStmts ListComp (L l stmts) res_ty ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -287,7 +287,9 @@ (AnnList (Just (EpaSpan { DumpParsedAstComments.hs:16:3 })) - (ListNone) + (ListBraces + (NoEpTok) + (NoEpTok)) [] (EpaSpan { DumpParsedAstComments.hs:14:7-8 }) []) @@ -296,12 +298,7 @@ (L (EpAnn (EpaSpan { DumpParsedAstComments.hs:16:3 }) - (AnnList - (Just - (EpaSpan { DumpParsedAstComments.hs:16:3 })) - (ListNone) - [] - (NoEpTok) + (AnnListItem []) (EpaComments [])) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -337,7 +337,9 @@ (AnnList (Just (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) - (ListNone) + (ListBraces + (NoEpTok) + (NoEpTok)) [] (EpaSpan { DumpSemis.hs:10:7-8 }) []) @@ -346,12 +348,7 @@ (L (EpAnn (EpaSpan { DumpSemis.hs:(11,3)-(12,3) }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) - (ListNone) - [] - (NoEpTok) + (AnnListItem []) (EpaComments [])) @@ -375,30 +372,25 @@ (AnnList (Just (EpaSpan { DumpSemis.hs:11:6-15 })) - (ListNone) - [] + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:11:6 })) + (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:11:8 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:9 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:10 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:11 }))] (EpaSpan { DumpSemis.hs:11:3-4 }) []) (DoExpr (Nothing)) (L (EpAnn - (EpaSpan { DumpSemis.hs:11:6-15 }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:11:8-13 })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:11:6 })) - (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:11:8 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:9 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:10 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:11 }))] - (NoEpTok) + (EpaSpan { DumpSemis.hs:11:8-13 }) + (AnnListItem []) (EpaComments [])) @@ -649,26 +641,21 @@ (AnnList (Just (EpaSpan { DumpSemis.hs:(16,3)-(19,3) })) - (ListNone) - [] + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:16:3 })) + (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:16:5 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:16:8 }))] (EpaSpan { DumpSemis.hs:15:7-8 }) []) (DoExpr (Nothing)) (L (EpAnn - (EpaSpan { DumpSemis.hs:(16,3)-(19,3) }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:(16,5)-(18,5) })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:16:3 })) - (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:16:5 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:16:8 }))] - (NoEpTok) + (EpaSpan { DumpSemis.hs:(16,5)-(18,5) }) + (AnnListItem []) (EpaComments [])) @@ -913,26 +900,21 @@ (AnnList (Just (EpaSpan { DumpSemis.hs:22:10-30 })) - (ListNone) - [] + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:22:10 })) + (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:22:12 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:22:13 }))] (EpaSpan { DumpSemis.hs:22:7-8 }) []) (DoExpr (Nothing)) (L (EpAnn - (EpaSpan { DumpSemis.hs:22:10-30 }) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:22:12-28 })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:22:10 })) - (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:22:12 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:22:13 }))] - (NoEpTok) + (EpaSpan { DumpSemis.hs:22:12-28 }) + (AnnListItem []) (EpaComments [])) ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -390,7 +390,9 @@ (AnnList (Just (EpaSpan { Test20297.hs:11:22-26 })) - (ListNone) + (ListBraces + (NoEpTok) + (NoEpTok)) [] (EpaSpan { Test20297.hs:11:19-20 }) []) @@ -399,12 +401,7 @@ (L (EpAnn (EpaSpan { Test20297.hs:11:22-26 }) - (AnnList - (Just - (EpaSpan { Test20297.hs:11:22-26 })) - (ListNone) - [] - (NoEpTok) + (AnnListItem []) (EpaComments [])) @@ -817,7 +814,9 @@ (AnnList (Just (EpaSpan { Test20297.ppr.hs:9:20-24 })) - (ListNone) + (ListBraces + (NoEpTok) + (NoEpTok)) [] (EpaSpan { Test20297.ppr.hs:9:17-18 }) []) @@ -826,12 +825,7 @@ (L (EpAnn (EpaSpan { Test20297.ppr.hs:9:20-24 }) - (AnnList - (Just - (EpaSpan { Test20297.ppr.hs:9:20-24 })) - (ListNone) - [] - (NoEpTok) + (AnnListItem []) (EpaComments [])) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1447,6 +1447,8 @@ instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where a' <- markAnnotated a return (L la a') +-- --------------------------------------------------------------------- + instance (ExactPrint a) => ExactPrint (Maybe a) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor ma _ _ _ = ma @@ -2417,7 +2419,7 @@ exactMatch (Match an mctxt pats grhss) = do epTokensToComments "(" opens epTokensToComments ")" closes fun' <- markAnnotated fun - pats' <- mapM markAnnotated pats + pats' <- markAnnotated pats return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), pats') Infix -> case pats of @@ -2438,11 +2440,11 @@ exactMatch (Match an mctxt pats grhss) = do _ -> panic "FunRhs" LamAlt v -> do - pats' <- markAnnotated pats + pats' <- (mapM . mapM) markAnnotated pats return (LamAlt v, pats') CaseAlt -> do - pats' <- markAnnotated pats + pats' <- (mapM . mapM) markAnnotated pats return (CaseAlt, pats') _ -> do @@ -2985,7 +2987,7 @@ instance ExactPrint (HsExpr GhcPs) where exact (HsDo an do_or_list_comp stmts) = do debugM $ "HsDo" - (an',stmts') <- markAnnListA' an $ \a -> exactDo a do_or_list_comp stmts + (an',stmts') <- exactDo an do_or_list_comp stmts return (HsDo an' do_or_list_comp stmts') exact (ExplicitList an es) = do @@ -3101,9 +3103,9 @@ instance ExactPrint (HsExpr GhcPs) where s' <- markAnnotated s return (HsTypedSplice an s') - exact (HsUntypedSplice an s) = do + exact (HsUntypedSplice x s) = do s' <- markAnnotated s - return (HsUntypedSplice an s') + return (HsUntypedSplice x s') exact (HsProc (pr,r) p c) = do debugM $ "HsProc start" @@ -3160,10 +3162,12 @@ instance ExactPrint (HsExpr GhcPs) where exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) => AnnList EpaLocation -> HsDoFlavour -> LocatedAn an a -> EP w m (AnnList EpaLocation, LocatedAn an a) -exactDo an (DoExpr m) stmts = exactMdo an m "do" >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an (DoExpr m) stmts = exactMdo an m "do" >>= + \an0 -> markMaybeDodgyStmts an0 stmts exactDo an GhciStmtCtxt stmts = markLensFun an lal_rest (\l -> printStringAtAA l "do") >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an (MDoExpr m) stmts = exactMdo an m "mdo" >>= \an0 -> markMaybeDodgyStmts an0 stmts +exactDo an (MDoExpr m) stmts = exactMdo an m "mdo" >>= + \an0 -> markMaybeDodgyStmts an0 stmts exactDo an ListComp stmts = markMaybeDodgyStmts an stmts exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts @@ -3179,8 +3183,9 @@ markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) markMaybeDodgyStmts an stmts = if notDodgy stmts then do - r <- markAnnotatedWithLayout stmts - return (an, r) + markAnnListA' an $ \a -> do + r <- markAnnotatedWithLayout stmts + return (a, r) else return (an, stmts) notDodgy :: GenLocated (EpAnn ann) a -> Bool @@ -3465,19 +3470,21 @@ instance ExactPrint (HsCmd GhcPs) where e' <- markAnnotated e return (HsCmdLet (tkLet', tkIn') binds' e') - exact (HsCmdDo an es) = do + exact (HsCmdDo an (L l es)) = do debugM $ "HsCmdDo" - an0 <- markLensFun an lal_rest (\l -> printStringAtAA l "do") - es' <- markAnnotated es - return (HsCmdDo an0 es') + an0 <- markLensFun an lal_rest (\ll -> printStringAtAA ll "do") + (an1,es') <- markAnnList' an0 $ do + ee <- mapM markAnnotated es + return ee + return (HsCmdDo an1 (L l es')) -- --------------------------------------------------------------------- instance ( ExactPrint (LocatedA (body GhcPs)), Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, - Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnLW, - (ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) + Anno [GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnA, + (ExactPrint (LocatedA [LocatedA (StmtLR GhcPs GhcPs (LocatedA (body GhcPs)))]))) => ExactPrint (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ _s = a @@ -4524,31 +4531,36 @@ instance (ExactPrint (Match GhcPs (LocatedA body))) an3 <- markLensBracketsC an2 lal_brackets return (L an3 a') -instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L an stmts) = do +instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))] where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact stmts = do debugM $ "LocatedL [ExprLStmt" - (an'', stmts') <- markAnnList an $ do - case snocView stmts of - Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do - debugM $ "LocatedL [ExprLStmt: snocView" - ls' <- markAnnotated ls - initStmts' <- mapM markAnnotated initStmts - return (initStmts' ++ [ls']) - _ -> do - mapM markAnnotated stmts - return (L an'' stmts') - -instance ExactPrint (LocatedLW [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn - exact (L ann es) = do - debugM $ "LocatedL [CmdLStmt" - an0 <- markLensBracketsO ann lal_brackets - es' <- mapM markAnnotated es - an1 <- markLensBracketsC an0 lal_brackets - return (L an1 es') + case snocView stmts of + Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do + debugM $ "LocatedL [ExprLStmt: snocView" + ls' <- markAnnotated ls + initStmts' <- markAnnotated initStmts + return (initStmts' ++ [ls']) + _ -> do + stmts' <- mapM markAnnotated stmts + return stmts' + +-- TODO: harmonise with prior, on payload +instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))] where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a + exact stmts = do + debugM $ "LocatedL [ExprLStmt" + case snocView stmts of + Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do + debugM $ "LocatedL [ExprLStmt: snocView" + ls' <- markAnnotated ls + initStmts' <- markAnnotated initStmts + return (initStmts' ++ [ls']) + _ -> do + stmts' <- markAnnotated stmts + return stmts' instance ExactPrint (LocatedBF (BF.BooleanFormula GhcPs)) where getAnnotationEntry = entryFromLocatedA View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf7b5ce65f470f21eee29007f3d6a110... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bf7b5ce65f470f21eee29007f3d6a110... You're receiving this email because of your account on gitlab.haskell.org.