- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/az/exactprint-annotation-rationalisation] EPA: Remove LocatedLW from LStmtLR
by Alan Zimmerman (＠alanz) 13 Jun '26

13 Jun '26

Alan Zimmerman pushed to branch wip/az/exactprint-annotation-rationalisation at Glasgow Haskell Compiler / GHC Commits: 642390f2 by Alan Zimmerman at 2026-06-13T17:26:30+01:00 EPA: Remove LocatedLW from LStmtLR - - - - - 11 changed files: - compiler/GHC/Hs/Dump.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/Parser.y - 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 @@ -2647,8 +2644,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 @@ -2664,7 +2661,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/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,10 +1447,7 @@ instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where a' <- markAnnotated a return (L la a') -instance (ExactPrint a) => ExactPrint [a] where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor ls _ _ _ = ls - exact ls = mapM markAnnotated ls +-- --------------------------------------------------------------------- instance (ExactPrint a) => ExactPrint (Maybe a) where getAnnotationEntry = const NoEntryVal @@ -1489,7 +1486,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- markAnnotated exps + exps' <- mapM markAnnotated exps tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) @@ -1570,7 +1567,7 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os - ws' <- markAnnotated ws + ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (WarningTxt src mb_cat' ws')) @@ -1578,7 +1575,7 @@ instance ExactPrint (LocatedP (WarningTxt GhcPs)) where exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" os' <- markEpToken os - ws' <- markAnnotated ws + ws' <- mapM markAnnotated ws cs' <- markEpToken cs c' <- markEpToken c return (L (EpAnn l (AnnPragma o' c' (os',cs') l1 l2 t m) css) (DeprecatedTxt src ws')) @@ -1706,7 +1703,7 @@ instance ExactPrint HsDocString where pe <- getPriorEndD debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x) x' <- markAnnotated x - xs' <- markAnnotated (map dedentDocChunk xs) + xs' <- mapM markAnnotated (map dedentDocChunk xs) return (MultiLineDocString decorator (x' :| xs')) exact x = do -- TODO: can this happen? @@ -1929,7 +1926,7 @@ instance ExactPrint (WarnDecls GhcPs) where exact (Warnings ((o,c),src) warns) = do o' <- markAnnOpen'' o src "{-# WARNING" -- Note: might be {-# DEPRECATED - warns' <- markAnnotated warns + warns' <- mapM markAnnotated warns c' <- markEpToken c return (Warnings ((o',c'),src) warns') @@ -1942,17 +1939,17 @@ instance ExactPrint (WarnDecl GhcPs) where exact (Warning (o,c) ns_spec lns (WarningTxt src mb_cat ls )) = do mb_cat' <- markAnnotated mb_cat ns_spec' <- exactNsSpec ns_spec - lns' <- markAnnotated lns + lns' <- mapM markAnnotated lns o' <- markEpToken o - ls' <- markAnnotated ls + ls' <- mapM markAnnotated ls c' <- markEpToken c return (Warning (o',c') ns_spec' lns' (WarningTxt src mb_cat' ls')) exact (Warning (o,c) ns_spec lns (DeprecatedTxt src ls)) = do ns_spec' <- exactNsSpec ns_spec - lns' <- markAnnotated lns + lns' <- mapM markAnnotated lns o' <- markEpToken o - ls' <- markAnnotated ls + ls' <- mapM markAnnotated ls c' <- markEpToken c return (Warning (o',c') ns_spec' lns' (DeprecatedTxt src ls')) @@ -1996,7 +1993,7 @@ instance ExactPrint (RuleDecls GhcPs) where case src of NoSourceText -> printStringAtAA o "{-# RULES" SourceText srcTxt -> printStringAtAA o (unpackFS srcTxt) - rules' <- markAnnotated rules + rules' <- mapM markAnnotated rules c' <- markEpToken c return (HsRules ((o',c'),src) rules') @@ -2188,7 +2185,7 @@ exactHsFamInstLHS ops cps thing bndrs typats fixity mb_ctxt = do exact_pats ops0 cps0 pats = do ops' <- mapM markEpToken ops0 thing' <- markAnnotated thing - pats' <- markAnnotated pats + pats' <- mapM markAnnotated pats cps' <- mapM markEpToken cps0 return (ops', cps', thing', pats') @@ -2318,7 +2315,7 @@ instance ExactPrint (HsBind GhcPs) where return (FunBind x fun_id' matches') exact (PatBind x pat q grhss) = do - q' <- markAnnotated q + q' <- mapM markAnnotated q pat' <- markAnnotated pat grhss' <- markAnnotated grhss return (PatBind x pat' q' grhss') @@ -2348,12 +2345,12 @@ instance ExactPrint (PatSynBind GhcPs GhcPs) where return (psyn', InfixCon x v1' v2') PrefixCon x vs -> do psyn' <- markAnnotated psyn - vs' <- markAnnotated vs + vs' <- mapM markAnnotated vs return (psyn', PrefixCon x vs') RecCon (ao,ac) vs -> do psyn' <- markAnnotated psyn ao' <- markEpToken ao - vs' <- markAnnotated vs + vs' <- mapM markAnnotated vs ac' <- markEpToken ac return (psyn', RecCon (ao',ac') vs') @@ -2424,7 +2421,7 @@ exactMatch (Match an mctxt pats grhss) = do epTokensToComments "(" opens epTokensToComments ")" closes fun' <- markAnnotated fun - pats' <- markAnnotated pats + pats' <- (mapM . mapM) markAnnotated pats return (FunRhs fun' fixity strictness (AnnFunRhs strict' [] []), pats') Infix -> case pats of @@ -2445,11 +2442,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 @@ -2548,7 +2545,7 @@ instance ExactPrint (HsIPBinds GhcPs) where setAnnotationAnchor a _ _ _ = a exact (IPBinds x binds) = setLayoutBoth $ do - binds' <- markAnnotated binds + binds' <- mapM markAnnotated binds return (IPBinds x binds') -- --------------------------------------------------------------------- @@ -2617,13 +2614,13 @@ instance ExactPrint (Sig GhcPs) where setAnnotationAnchor a _ _ _ = a exact (TypeSig (AnnSig dc mp md) mods vars ty) = do - mods' <- markAnnotated mods + mods' <- mapM markAnnotated mods (dc', vars', ty') <- exactVarSig dc vars ty return (TypeSig (AnnSig dc' mp md) mods' vars' ty') exact (PatSynSig (AnnSig dc mp md) lns typ) = do mp' <- mapM markEpToken mp - lns' <- markAnnotated lns + lns' <- mapM markAnnotated lns dc' <- markEpUniToken dc typ' <- markAnnotated typ return (PatSynSig (AnnSig dc' mp' md) lns' typ') @@ -2645,7 +2642,7 @@ instance ExactPrint (Sig GhcPs) where af' <- printStringAtAA af fixstr ma' <- mapM (\l -> printStringAtAA l (sourceTextToString src (show v))) ma ns' <- markAnnotated ns - names' <- markAnnotated names + names' <- mapM markAnnotated names return (FixSig ((af',ma'),src) (FixitySig noExtField ns' names' (Fixity v fdir))) exact (InlineSig (o,c,act) ln inl) = do @@ -2660,7 +2657,7 @@ instance ExactPrint (Sig GhcPs) where act' <- markActivation act (inlinePragmaActivation inl) ln' <- markAnnotated ln dc' <- traverse markEpUniToken dc - typs' <- markAnnotated typs + typs' <- mapM markAnnotated typs c' <- markEpToken c return (SpecSig (AnnSpecSig o' c' dc' act') ln' typs' inl) @@ -2749,11 +2746,11 @@ instance ExactPrint (DefaultDecl GhcPs) where setAnnotationAnchor a _ _ _ = a exact (DefaultDecl (d,op,cp) mods cl tys) = do - mods' <- markAnnotated mods + mods' <- mapM markAnnotated mods d' <- markEpToken d cl' <- markAnnotated cl op' <- markEpToken op - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys cp' <- markEpToken cp return (DefaultDecl (d',op',cp') mods' cl' tys') @@ -2792,10 +2789,10 @@ instance ExactPrint (BF.BooleanFormula GhcPs) where x' <- markAnnotated x return (BF.Var x') exact (BF.Or ls) = do - ls' <- markAnnotated ls + ls' <- mapM markAnnotated ls return (BF.Or ls') exact (BF.And ls) = do - ls' <- markAnnotated ls + ls' <- mapM markAnnotated ls return (BF.And ls') exact (BF.Parens x) = do x' <- markAnnotated x @@ -2992,13 +2989,13 @@ 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 debugM $ "ExplicitList start" an0 <- markLensBracketsO' an lal_brackets - es' <- markAnnotated es + es' <- mapM markAnnotated es an1 <- markLensBracketsC' an0 lal_brackets debugM $ "ExplicitList end" return (ExplicitList an1 es') @@ -3081,7 +3078,7 @@ instance ExactPrint (HsExpr GhcPs) where exact (HsUntypedBracket a (DecBrL (o,c, (oc,cc)) e)) = do o' <- markEpToken o oc' <- markEpToken oc - e' <- markAnnotated e + e' <- mapM markAnnotated e cc' <- markEpToken cc c' <- markEpUniToken c return (HsUntypedBracket a (DecBrL (o',c',(oc',cc')) e')) @@ -3108,9 +3105,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" @@ -3151,7 +3148,7 @@ instance ExactPrint (HsExpr GhcPs) where exact (HsQual (op,cp,da) ctxt body) = do op' <- mapM markEpToken op - ctxt' <- markAnnotated ctxt + ctxt' <- mapM markAnnotated ctxt cp' <- mapM markEpToken cp da' <- markEpUniToken da body' <- markAnnotated body @@ -3170,10 +3167,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 @@ -3189,8 +3188,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 @@ -3277,7 +3277,7 @@ instance (ExactPrint body) => ExactPrint (HsRecFields GhcPs body) where setAnnotationAnchor a _ _ _ = a exact (HsRecFields (oc,cc) fields mdot) = do oc' <- markEpToken oc - fields' <- markAnnotated fields + fields' <- mapM markAnnotated fields mdot' <- case mdot of Nothing -> return Nothing Just (L ss d) -> do @@ -3329,11 +3329,11 @@ instance ExactPrint (LHsRecUpdFields GhcPs) where exact flds@(RegularRecUpdFields { recUpdFields = rbinds }) = do debugM $ "RegularRecUpdFields" - rbinds' <- markAnnotated rbinds + rbinds' <- mapM markAnnotated rbinds return $ flds { recUpdFields = rbinds' } exact flds@(OverloadedRecUpdFields { olRecUpdFields = pbinds }) = do debugM $ "OverloadedRecUpdFields" - pbinds' <- markAnnotated pbinds + pbinds' <- mapM markAnnotated pbinds return $ flds { olRecUpdFields = pbinds' } -- --------------------------------------------------------------------- @@ -3419,11 +3419,11 @@ instance ExactPrint (HsCmd GhcPs) where (Infix, (arg1:argrest)) -> do arg1' <- markAnnotated arg1 e' <- markAnnotated e - argrest' <- markAnnotated argrest + argrest' <- mapM markAnnotated argrest return (e', arg1':argrest') (Prefix, _) -> do e' <- markAnnotated e - cs' <- markAnnotated cs + cs' <- mapM markAnnotated cs return (e', cs') (Infix, []) -> error "Not possible" an1 <- markLensBracketsC' an0 lal_brackets @@ -3475,19 +3475,22 @@ 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 + -- es' <- mapM markAnnotated es + 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 @@ -3657,7 +3660,7 @@ instance ExactPrint (TyClDecl GhcPs) where tcdModifiers = mods'}) where top_matter = do - mods' <- markAnnotated mods + mods' <- mapM markAnnotated mods epTokensToComments "(" ops epTokensToComments ")" cps c' <- markEpToken c @@ -3666,7 +3669,7 @@ instance ExactPrint (TyClDecl GhcPs) where then return (vb, fds) else do vb' <- markEpToken vb - fds' <- markAnnotated fds + fds' <- mapM markAnnotated fds return (vb', fds') w' <- markEpToken w return (mods', c', w', vb', fds', lclas', tyvars',context') @@ -3679,9 +3682,9 @@ instance ExactPrint (FunDep GhcPs) where setAnnotationAnchor a _ _ _ = a exact (FunDep an ls rs') = do - ls' <- markAnnotated ls + ls' <- mapM markAnnotated ls an0 <- markEpUniToken an - rs'' <- markAnnotated rs' + rs'' <- mapM markAnnotated rs' return (FunDep an0 ls' rs'') -- --------------------------------------------------------------------- @@ -3723,7 +3726,7 @@ instance ExactPrint (FamilyDecl GhcPs) where dd' <- markEpToken dd return (dd', mb_eqns) Just eqns -> do - eqns' <- markAnnotated eqns + eqns' <- mapM markAnnotated eqns return (dd, Just eqns') cc' <- markEpToken cc return (w',oc',dd',cc', ClosedTypeFamily mb_eqns') @@ -3844,12 +3847,12 @@ exactVanillaDeclHead thing tvs@(HsQTvs { hsq_explicit = tyvars }) fixity context varl' <- markAnnotated varl thing' <- markAnnotated thing hvarsr' <- markAnnotated hvarsr - tvarsr' <- markAnnotated tvarsr + tvarsr' <- mapM markAnnotated tvarsr return (thing', varl':hvarsr':tvarsr') | fixity == Infix = do varl' <- markAnnotated varl thing' <- markAnnotated thing - varsr' <- markAnnotated varsr + varsr' <- mapM markAnnotated varsr return (thing', varl':varsr') | otherwise = do thing' <- markAnnotated thing @@ -3984,12 +3987,12 @@ instance ExactPrint (HsType GhcPs) where return (HsListTy (o',c') t') exact (HsTupleTy an con tys) = do an0 <- markOpeningParen an - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys an1 <- markClosingParen an0 return (HsTupleTy an1 con tys') exact (HsSumTy an tys) = do an0 <- markOpeningParen an - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys an1 <- markClosingParen an0 return (HsSumTy an1 tys') exact (HsOpTy x t1 lo t2) = do @@ -4030,7 +4033,7 @@ instance ExactPrint (HsType GhcPs) where then markEpToken sq else return sq o' <- markEpToken o - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys c' <- markEpToken c return (HsExplicitListTy (sq',o',c') prom tys') exact (HsExplicitTupleTy (sq, an) prom tys) = do @@ -4038,7 +4041,7 @@ instance ExactPrint (HsType GhcPs) where then markEpToken sq else return sq an0 <- markOpeningParen an - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys an1 <- markClosingParen an0 return (HsExplicitTupleTy (sq', an1) prom tys') exact (HsTyLit an lit) = do @@ -4060,13 +4063,13 @@ instance ExactPrint (HsForAllTelescope GhcPs) where exact (HsForAllVis (EpAnn l (f,r) cs) bndrs) = do f' <- markEpUniToken f - bndrs' <- markAnnotated bndrs + bndrs' <- mapM markAnnotated bndrs r' <- markEpUniToken r return (HsForAllVis (EpAnn l (f',r') cs) bndrs') exact (HsForAllInvis (EpAnn l (f,d) cs) bndrs) = do f' <- markEpUniToken f - bndrs' <- markAnnotated bndrs + bndrs' <- mapM markAnnotated bndrs d' <- markEpToken d return (HsForAllInvis (EpAnn l (f',d') cs) bndrs') @@ -4119,7 +4122,7 @@ instance (ExactPrint a) => ExactPrint (HsContextDetails GhcPs a) where exact (HsContext (opens, closes) tys) = do opens' <- mapM markEpToken opens - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys closes' <- mapM markEpToken closes return (HsContext (opens', closes') tys') @@ -4135,7 +4138,7 @@ instance ExactPrint (DerivClauseTys GhcPs) where return (DctSingle x ty') exact (DctMulti (op,cp) tys) = do op' <- markEpToken op - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys cp' <- markEpToken cp return (DctMulti (op',cp') tys') @@ -4326,12 +4329,12 @@ instance ExactPrint (ConDecl GhcPs) where return (con', InfixCon x t1' t2') exact_details (PrefixCon x tys) = do con' <- markAnnotated con - tys' <- markAnnotated tys + tys' <- mapM markAnnotated tys return (con', PrefixCon x tys') exact_details (RecCon (oc,cc) (L an fields)) = do con' <- markAnnotated con oc' <- markEpToken oc - fields' <- markAnnotated fields + fields' <- mapM markAnnotated fields cc' <- markEpToken cc return (con', RecCon (oc',cc') (L an fields')) @@ -4365,7 +4368,7 @@ instance ExactPrint (ConDecl GhcPs) where return (PrefixConGADT x args0') (RecConGADT (oc,cc,rarr) (L an fields)) -> do oc' <- markEpToken oc - fields' <- markAnnotated fields + fields' <- mapM markAnnotated fields cc' <- markEpToken cc rarr' <- markEpUniToken rarr return (RecConGADT (oc',cc',rarr') (L an fields')) @@ -4397,7 +4400,7 @@ instance ExactPrintTVFlag flag => ExactPrint (HsOuterTyVarBndrs flag GhcPs) wher exact b@(HsOuterImplicit _) = pure b exact (HsOuterExplicit (EpAnn l (f,d) cs) bndrs) = do f' <- markEpUniToken f - bndrs' <- markAnnotated bndrs + bndrs' <- mapM markAnnotated bndrs d' <- markEpToken d return (HsOuterExplicit (EpAnn l (f',d') cs) bndrs') @@ -4408,7 +4411,7 @@ instance ExactPrint (HsConDeclRecField GhcPs) where setAnnotationAnchor a _ _ _ = a exact (HsConDeclRecField _ names ftype) = do - names' <- markAnnotated names + names' <- mapM markAnnotated names ftype' <- markAnnotated ftype return (HsConDeclRecField noExtField names' ftype') @@ -4436,7 +4439,7 @@ markModifiedFunArrOf :: (Monad m, Monoid w, ExactPrint a) -> EP w m (HsModifiedFunArrOf a GhcPs, b) markModifiedFunArrOf (HsModifiedFunArr _ mods arr) tyM = do ty' <- if isColon then pure (Left ()) else Right <$> tyM - mods' <- markAnnotated mods + mods' <- mapM markAnnotated mods arr' <- case arr of HsStandardArr (EpArrow a) -> HsStandardArr . EpArrow <$> markEpUniToken a HsStandardArr (EpColon c) -> HsStandardArr . EpColon <$> markEpUniToken c @@ -4530,46 +4533,47 @@ instance (ExactPrint (Match GhcPs (LocatedA body))) an0 <- markLensFun' an lal_rest markEpToken an1 <- markLensBracketsO an0 lal_brackets an2 <- markEpAnnAllLT an1 lal_semis - a' <- markAnnotated a + a' <- mapM markAnnotated a 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' <- markAnnotated initStmts - return (initStmts' ++ [ls']) - _ -> do - 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 (LocatedA [LocatedA (HsConDeclRecField GhcPs)]) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn exact (L an fs) = do debugM $ "LocatedCB [LHsConDeclRecField" - -- let (oc,cc) = anns an - -- oc' <- markEpToken oc fs' <- mapM markAnnotated fs - -- cc' <- markEpToken cc - -- return (L (an { anns = (oc',cc')}) fs') return (L an fs') instance ExactPrint (LocatedBF (BF.BooleanFormula GhcPs)) where @@ -4619,14 +4623,14 @@ instance ExactPrint (IE GhcPs) where (dd',c', wc', withs') <- case wc of NoIEWildcard -> do - withs'' <- markAnnotated withs + withs'' <- mapM markAnnotated withs return (dd, c, wc, withs'') IEWildcard pos -> do let (bs, as) = splitAt pos withs - bs' <- markAnnotated bs + bs' <- mapM markAnnotated bs dd' <- markEpToken dd c' <- markEpToken c - as' <- markAnnotated as + as' <- mapM markAnnotated as return (dd',c', wc, bs'++as') cp' <- markEpToken cp doc' <- markAnnotated doc @@ -4719,12 +4723,12 @@ instance ExactPrint (Pat GhcPs) where return (BangPat an0 pat') exact (ListPat an pats) = do - (an', pats') <- markAnnList' an (markAnnotated pats) + (an', pats') <- markAnnList' an (mapM markAnnotated pats) return (ListPat an' pats') exact (TuplePat an pats boxity) = do an0 <- markOpeningParen an - pats' <- markAnnotated pats + pats' <- mapM markAnnotated pats an1 <- markClosingParen an0 return (TuplePat an1 pats' boxity) @@ -4737,7 +4741,7 @@ instance ExactPrint (Pat GhcPs) where return (SumPat an3 pat' alt arity) exact (OrPat an pats) = do - pats' <- markAnnotated (NE.toList pats) + pats' <- mapM markAnnotated (NE.toList pats) return (OrPat an (NE.fromList pats')) exact (ConPat x con details) = do @@ -4783,7 +4787,7 @@ instance ExactPrint (Pat GhcPs) where pure (InvisPat (tokat', spec) tp') exact (ModifiedPat x mods pat) = do - mods' <- markAnnotated mods + mods' <- mapM markAnnotated mods pat' <- markAnnotated pat return (ModifiedPat x mods' pat') @@ -4878,7 +4882,7 @@ exactUserCon c details = do exactConArgs :: (Monad m, Monoid w) => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) exactConArgs (PrefixCon x pats) = do - pats' <- markAnnotated pats + pats' <- mapM markAnnotated pats return (PrefixCon x pats') exactConArgs (InfixCon x p1 p2) = do p1' <- markAnnotated p1 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/642390f2f396fafea84af2e26581947… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/642390f2f396fafea84af2e26581947… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] hadrian: run haddock against the library_stage for cross builds
by Sven Tennie (＠supersven) 13 Jun '26

13 Jun '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 2324c73f by Sven Tennie at 2026-06-13T12:49:53+00:00 hadrian: run haddock against the library_stage for cross builds The iface magic number is platform-dependent: - 32-bit targets (wasm32): 0x1face = 129742 - 64-bit targets (x86_64): 0x1face64 = 33214052 In a cross build, _build/stage1/lib/settings says target=wasm32, so Stage1 haddock (launched with -B_build/stage1/lib) expects magic 129742. Stage1 libraries are compiled by the native Stage0 GHC (x86_64) and have magic 33214052 → mismatch. Fix: use the library_stage from BindistConfig (Stage2 for cross builds) for doc generation instead of hardcoded Stage1. Stage2 libraries are compiled by the wasm32 cross-compiler and have magic 129742, matching what Stage1 haddock expects. Non-cross builds are unaffected because library_stage = Stage1 in that case. - - - - - 1 changed file: - hadrian/src/Rules/Documentation.hs Changes: ===================================== hadrian/src/Rules/Documentation.hs ===================================== @@ -26,6 +26,7 @@ import Utilities import qualified Data.Set as Set import qualified Text.Parsec as Parsec import Oracles.Flavour +import BindistConfig docRoot :: FilePath docRoot = "doc" @@ -242,10 +243,16 @@ buildLibraryDocumentation = do need neededDocs build $ target docContext (Haddock BuildIndex) libDocs [file] +-- | The stage whose libraries are documented. For cross builds this is +-- Stage2 (the wasm32/cross-target libraries); for native builds Stage1. +pkgDocStage :: Action Stage +pkgDocStage = library_stage <$> implicitBindistConfig + allHaddocks :: Action [FilePath] allHaddocks = do - pkgs <- stagePackages Stage1 - sequence [ pkgHaddockFile $ vanillaContext Stage1 pkg + docStage <- pkgDocStage + pkgs <- stagePackages docStage + sequence [ pkgHaddockFile $ vanillaContext docStage pkg | pkg <- pkgs, isLibrary pkg, pkgName pkg `notElem` haddockExclude ] -- Note: this build rule creates plenty of files, not just the .haddock one. @@ -257,14 +264,14 @@ buildPackageDocumentation = do -- Per-package haddocks root -/- htmlRoot -/- "libraries/*/haddock-prologue.txt" %> \file -> do - ctx <- pkgDocContext <$> getPkgDocTarget root file + ctx <- pkgDocContext =<< getPkgDocTarget root file syn <- pkgSynopsis (Context.package ctx) desc <- pkgDescription (Context.package ctx) let prologue = if null desc then syn else desc liftIO $ writeFile file prologue root -/- htmlRoot -/- "libraries/*/*.haddock" %> \file -> do - context <- pkgDocContext <$> getPkgDocTarget root file + context <- pkgDocContext =<< getPkgDocTarget root file need [ takeDirectory file -/- "haddock-prologue.txt"] haddocks <- haddockDependencies context @@ -290,8 +297,10 @@ buildPackageDocumentation = do data PkgDocTarget = DotHaddock PackageName | HaddockPrologue PackageName deriving (Eq, Show) -pkgDocContext :: PkgDocTarget -> Context -pkgDocContext target = Context Stage1 (unsafeFindPackageByName name) vanilla Final +pkgDocContext :: PkgDocTarget -> Action Context +pkgDocContext target = do + docStage <- pkgDocStage + return $ Context docStage (unsafeFindPackageByName name) vanilla Final where name = case target of DotHaddock n -> n HaddockPrologue n -> n @@ -417,5 +426,5 @@ buildManPage = do haddockDependencies :: Context -> Action [(Package, FilePath)] haddockDependencies context = do depNames <- interpretInContext context (getContextData depNames) - sequence [ (,) <$> pure depPkg <*> (pkgHaddockFile $ vanillaContext Stage1 depPkg) + sequence [ (,) <$> pure depPkg <*> (pkgHaddockFile $ vanillaContext (stage context) depPkg) | Just depPkg <- map findPackageByName depNames, (pkgName depPkg) `notElem` haddockExclude ] View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2324c73f7e5623ff04acea14e070286… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2324c73f7e5623ff04acea14e070286… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/mangoiv/bp-process-bump
by Magnus (＠MangoIV) 13 Jun '26

13 Jun '26

Magnus pushed new branch wip/mangoiv/bp-process-bump at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/mangoiv/bp-process-bump You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/lazifier] Clean up diff
by Jaro Reinders (＠jaro) 13 Jun '26

13 Jun '26

Jaro Reinders pushed to branch wip/lazifier at Glasgow Haskell Compiler / GHC Commits: 11151914 by Jaro Reinders at 2026-06-13T13:07:44+02:00 Clean up diff - - - - - 3 changed files: - compiler/GHC/Builtin/Types/Prim.hs - compiler/GHC/StgToCmm/Expr.hs - rts/PrimOps.cmm Changes: ===================================== compiler/GHC/Builtin/Types/Prim.hs ===================================== @@ -70,7 +70,6 @@ module GHC.Builtin.Types.Prim( arrayPrimTyCon, mkArrayPrimTy, byteArrayPrimTyCon, byteArrayPrimTy, - -- byteArrayLiftedPrimTyCon, smallArrayPrimTyCon, mkSmallArrayPrimTy, mutableArrayPrimTyCon, mkMutableArrayPrimTy, mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy, ===================================== compiler/GHC/StgToCmm/Expr.hs ===================================== @@ -64,7 +64,7 @@ import GHC.Platform.Profile (profileIsProfiling) -- cgExpr: the main function ------------------------------------------------------------------------ -cgExpr :: HasCallStack => CgStgExpr -> FCode ReturnKind +cgExpr :: CgStgExpr -> FCode ReturnKind cgExpr (StgApp fun args) = cgIdApp fun args ===================================== rts/PrimOps.cmm ===================================== @@ -120,7 +120,6 @@ stg_newByteArrayzh ( W_ n ) return (p); } - #define BA_ALIGN 16 #define BA_MASK (BA_ALIGN-1) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/11151914541f786efb733bb78d15c9a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/11151914541f786efb733bb78d15c9a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/lazifier
by Jaro Reinders (＠jaro) 13 Jun '26

13 Jun '26

Jaro Reinders pushed new branch wip/lazifier at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/lazifier You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL] hadrian: build docs in cross-compiler bindist
by Sven Tennie (＠supersven) 13 Jun '26

13 Jun '26

Sven Tennie pushed to branch wip/romes/hadrian-cross-stage2-rebase_SVEN_FINAL at Glasgow Haskell Compiler / GHC Commits: 86713ac2 by Sven Tennie at 2026-06-13T08:47:04+00:00 hadrian: build docs in cross-compiler bindist Remove the cross → Set.empty guard from defaultDocsTargets so that cross-compiler bindists include documentation, matching the behaviour of native bindists. The guard was introduced as a TODO in 9183601bbf; stage1 haddock support for cross GHC was subsequently added in 272eaef0be, making docs buildable in cross configurations. - - - - - 1 changed file: - hadrian/src/Settings/Default.hs Changes: ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -300,21 +300,10 @@ defaultFlavour = Flavour , ghcThreaded = const True , ghcDebugAssertions = const False , ghcSplitSections = False - , ghcDocs = defaultDocsTargets + , ghcDocs = cmdDocsArgs , ghcHieFiles = const False , hashUnitIds = False } -defaultDocsTargets :: Action DocTargets -defaultDocsTargets = do - cross <- flag CrossCompiling - -- MP: Building documentation in cross configurations can work and should - -- work but currently is left as a TODO - -- - -- This is the ONLY place where we should branch on building documentation in - -- the cross setting. - if cross then return Set.empty - else cmdDocsArgs - -- | Default logic for determining whether to build -- dynamic GHC programs. -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86713ac21a91d74cfafb5ce6b744e2e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/86713ac21a91d74cfafb5ce6b744e2e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] CI: lint-changelog checks for no-changelog label in script instead of rules
by Marge Bot (＠marge-bot) 13 Jun '26

13 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6c65e1e1 by David Eichmann at 2026-06-13T04:43:23-04:00 CI: lint-changelog checks for no-changelog label in script instead of rules - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -255,6 +255,9 @@ lint-changelog: BUILD_FLAVOUR: default CHANGELOG_EXPECT_MR: "$CI_MERGE_REQUEST_IID" script: + # Cancel the job if there is a no-changelog label + - | + [[ ",${CI_MERGE_REQUEST_LABELS}," == *",no-changelog,"* ]] && exit 0 # Check that the MR adds at least one changelog entry - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" "$CI_MERGE_REQUEST_TARGET_BRANCH_NAME" - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)" @@ -274,8 +277,6 @@ lint-changelog: rules: - if: '$CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/' when: never - - if: '$CI_MERGE_REQUEST_LABELS =~ /.*no-changelog.*/' - when: never - if: $CI_MERGE_REQUEST_ID - *drafts-can-fail-lint View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c65e1e1bfe4ca51d4ce4399bc667d5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6c65e1e1bfe4ca51d4ce4399bc667d5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] ghc-toolchain: don't throw when candidate executables are not found
by Marge Bot (＠marge-bot) 13 Jun '26

13 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 6ebaaba3 by David Eichmann at 2026-06-13T04:42:37-04:00 ghc-toolchain: don't throw when candidate executables are not found Fixes #27369 - - - - - 2 changed files: - utils/ghc-toolchain/src/GHC/Toolchain/Program.hs - utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs Changes: ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Program.hs ===================================== @@ -148,12 +148,14 @@ findProgram description userSpec candidates Just prefix -> map (prefix++) candidates Nothing -> [] candidates' = prefixedCandidates ++ candidates - err = - [ "Failed to find " ++ description ++ "." - , "Looked for one of " ++ show candidates' ++ " in the system search path." - ] - path <- oneOf' err (map findExecutableErr candidates') - return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) } + pathMay <- findM doesExecutableExist candidates' + case pathMay of + Nothing -> throwEs + [ "Failed to find " ++ description ++ "." + , "Looked for one of " ++ show candidates' ++ " in the system search path." + ] + Just path -> + return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) } -- Note that @configure.ac@ checks these llvm version constants (using @sed@) to -- ensure they are the same as the @$LlvmMinVersion@ and @$LlvmMaxVersion@ @@ -222,21 +224,18 @@ maybeFindProgramFromProgOpts :: String -> ProgOpt -> Maybe (M Program) maybeFindProgramFromProgOpts description userSpec = case poPath userSpec of Nothing -> Nothing Just path -> Just $ do - let err = - [ "Failed to find " ++ description ++ "." - , "Looked for user-specified program '" ++ path ++ "' in the system search path." - ] - path' <- findExecutableErr path <|> throwEs err - return Program { prgPath = path', prgFlags = fromMaybe [] (poFlags userSpec) } - -findExecutableErr :: String -> M FilePath -findExecutableErr name = do - r <- liftIO $ findExecutable name - case r of - Nothing -> throwE $ name ++ " not found in search path" - -- Use the given `prgPath` or candidate name rather than the - -- absolute path returned by `findExecutable`. - Just _x -> return name + exists <- doesExecutableExist path + unless exists $ throwEs + [ "Failed to find " ++ description ++ "." + , "Looked for user-specified program '" ++ path ++ "' in the system search path." + ] + return Program { prgPath = path, prgFlags = fromMaybe [] (poFlags userSpec) } + +doesExecutableExist + :: String -- ^ executable name + -> M Bool +doesExecutableExist name = isJust <$> liftIO (findExecutable name) + -------------------- Compiling utilities -------------------- ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Utils.hs ===================================== @@ -9,6 +9,7 @@ module GHC.Toolchain.Utils , oneOf' , isSuccess , lastLine + , findM ) where import Control.Exception @@ -69,3 +70,10 @@ isSuccess = \case lastLine :: String -> String lastLine = maybe "" snd . unsnoc . lines + +findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) +findM f = \case + [] -> return Nothing + a:as -> do + found <- f a + if found then return (Just a) else findM f as View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6ebaaba387480c9f8daa8ee1a89bfc5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6ebaaba387480c9f8daa8ee1a89bfc5… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] libraries/process: bump submodule to v1.6.30.0
by Marge Bot (＠marge-bot) 13 Jun '26

13 Jun '26

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: d9ea2d76 by mangoiv at 2026-06-13T04:41:51-04:00 libraries/process: bump submodule to v1.6.30.0 - bump the submodule to the appropriate tag - suppress benign warning resulting from the change - - - - - 2 changed files: - libraries/process - testsuite/driver/testlib.py Changes: ===================================== libraries/process ===================================== @@ -1 +1 @@ -Subproject commit 92deb52c1781bf10ad390296dbc435abe103bfe4 +Subproject commit 11fd247ad33208da7a914acf15d4a09d64a6a4c4 ===================================== testsuite/driver/testlib.py ===================================== @@ -3066,11 +3066,15 @@ def normalise_errmsg(s: str) -> str: # Old emcc warns when we export HEAP8 but new one requires it (see #26290) s = s.replace('warning: invalid item in EXPORTED_RUNTIME_METHODS: HEAP8\nwarning: invalid item in EXPORTED_RUNTIME_METHODS: HEAPU8\nemcc: warning: warnings in JS library compilation [-Wjs-compiler]\n','') - # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols, - # however, these are completely benign stubs. - # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116 if opsys('darwin'): + # on newer versions of MacOS X, the shipped ranlib warns about object files with no symbols, + # however, these are completely benign stubs. + # See https://gitlab.haskell.org/ghc/ghc/-/issues/27116 s = modify_lines(s, lambda l: re.sub(r'.*ranlib:.*has no symbols', '', l)) + # we also want to remove linker warnings having to do with undefined dynamic_lookup in combination with + # making a single weak symbol undefined as this is dependent on other linker flags + # See also https://github.com/haskell/process/pull/377 + s = drop_lines_containing(s, 'ld: warning: -U option is redundant when using -undefined dynamic_lookup') return s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d9ea2d76545452a7df567b162340079… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d9ea2d76545452a7df567b162340079… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/sjakobi/T27379
by Simon Jakobi (＠sjakobi2) 13 Jun '26

13 Jun '26

Simon Jakobi pushed new branch wip/sjakobi/T27379 at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/sjakobi/T27379 You're receiving this email because of your account on gitlab.haskell.org.

1 0