- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/sjakobi/T16720] testsuite: Colorize the failure-output summary, also in CI
by Simon Jakobi (＠sjakobi2) 13 Jun '26

13 Jun '26

Simon Jakobi pushed to branch wip/sjakobi/T16720 at Glasgow Haskell Compiler / GHC Commits: 18e8c673 by Simon Jakobi at 2026-06-13T22:01:14+02:00 testsuite: Colorize the failure-output summary, also in CI Make the per-test blocks in the "Output of unexpected failures" section easier to scan: * the '=====> test(way) [reason]' header is red, * the 'Captured stdout/stderr:' labels are cyan, * a closing '<===== end of output of unexpected failures' marker, also red, fences the section off from subsequent build output. Colors were previously disabled in CI because the driver only emits them when stdout is a tty, yet the GitLab log viewer renders ANSI colors fine. Add a --force-colors driver flag and pass it from .gitlab/ci.sh. Note that config.supports_colors stays tty-based, since it also guards terminal-title escape sequences, which must not end up in a CI log. The SUMMARY header and the new section now honor summary()'s color parameter, so the plain-text summary file no longer receives escape codes when colors are enabled. Co-Authored-By: Claude Fable 5 <noreply(a)anthropic.com> - - - - - 3 changed files: - .gitlab/ci.sh - testsuite/driver/runtests.py - testsuite/driver/testlib.py Changes: ===================================== .gitlab/ci.sh ===================================== @@ -644,6 +644,10 @@ function test_hadrian() { check_msys2_deps _build/stage1/bin/ghc --version check_release_build + # GitLab's log viewer renders ANSI colors, but stdout here is not a tty, + # so the driver must be told to emit them. + RUNTEST_ARGS="${RUNTEST_ARGS:-} --force-colors" + # Ensure that statically-linked builds are actually static if [[ "${BUILD_FLAVOUR}" = *static* ]]; then bad_execs="" ===================================== testsuite/driver/runtests.py ===================================== @@ -94,6 +94,8 @@ parser.add_argument("--ignore-perf-failures", choices=['increases','decreases',' help="Do not fail due to out-of-tolerance perf tests") parser.add_argument("--only-report-hadrian-deps", type=Path, help="Dry run the testsuite and report all extra hadrian dependencies needed on the given file") +parser.add_argument("--force-colors", action="store_true", + help="emit ANSI colors even when stdout is not a tty (e.g. for CI logs)") args = parser.parse_args() @@ -259,7 +261,9 @@ def supports_colors(): return True config.supports_colors = supports_colors() -term_color.enable_color = config.supports_colors +# config.supports_colors deliberately stays tty-based: it also guards +# terminal-title updates, which must not end up in a CI log. +term_color.enable_color = config.supports_colors or args.force_colors # This has to come after arg parsing as the args can change the compiler get_compiler_info() @@ -587,7 +591,7 @@ else: print(Perf.allow_changes_string([(m.change, m.stat) for m in t.metrics])) print('-' * 25) - summary(t, sys.stdout, color=config.supports_colors) + summary(t, sys.stdout, color=term_color.enable_color) # Write perf stats if any exist or if a metrics file is specified. stats_metrics = [stat for (_, stat, __) in t.metrics] # type: List[PerfStat] ===================================== testsuite/driver/testlib.py ===================================== @@ -3543,7 +3543,8 @@ def summary(t: TestRun, file: TextIO, color=False) -> None: summary_color = Color.GREEN assert t.start_time is not None - file.write(colored(summary_color, 'SUMMARY') + ' for test run started at ' + summary_header = colored(summary_color, 'SUMMARY') if color else 'SUMMARY' + file.write(summary_header + ' for test run started at ' + t.start_time.strftime("%c %Z") + '\n' + str(datetime.datetime.now() - t.start_time).rjust(8) + ' spent to go through\n' @@ -3597,7 +3598,7 @@ def summary(t: TestRun, file: TextIO, color=False) -> None: if t.unexpected_failures: file.write('Output of unexpected failures:\n\n') - printTestOutputSummary(file, t.unexpected_failures) + printTestOutputSummary(file, t.unexpected_failures, color) if stopping(): file.write('WARNING: Testsuite run was terminated early\n') @@ -3615,26 +3616,34 @@ def printUnexpectedTests(file: TextIO, testInfoss): # Per-stream cap on a failing test's output repeated in the final summary. MAX_SUMMARY_OUTPUT_LINES = 100 -def printTestOutputSummary(file: TextIO, testInfos) -> None: +def printTestOutputSummary(file: TextIO, testInfos, color: bool=False) -> None: # Repeat failing tests' captured output in the summary, so one needn't # hunt for it earlier in a possibly very long log; see #16720. for result in sorted(testInfos, key=lambda r: (r.testname.lower(), r.way, r.directory)): - file.write(colored(Color.RED, - '=====> {}({}) [{}]'.format(result.testname, result.way, result.reason)) - + '\n') + header = '=====> {}({}) [{}]'.format(result.testname, result.way, result.reason) + if color: + header = colored(Color.RED, header) + file.write(header + '\n') for stream_name, contents in [('stdout', result.stdout), ('stderr', result.stderr)]: if contents and contents.strip(): + label = 'Captured {}:'.format(stream_name) + if color: + label = colored(Color.CYAN, label) lines = contents.rstrip('\n').split('\n') if len(lines) > MAX_SUMMARY_OUTPUT_LINES: omitted = len(lines) - MAX_SUMMARY_OUTPUT_LINES lines = lines[:MAX_SUMMARY_OUTPUT_LINES] \ + ['... ({} more lines omitted, see junit.xml)'.format(omitted)] - s = 'Captured {}:\n{}\n'.format(stream_name, '\n'.join(lines)) + s = label + '\n' + ''.join(l + '\n' for l in lines) # Test output can contain characters that file's encoding # cannot represent; replace rather than crash (cf safe_print). enc = getattr(file, 'encoding', None) or 'utf-8' file.write(s.encode(enc, errors='replace').decode(enc)) file.write('\n') + footer = '<===== end of output of unexpected failures' + if color: + footer = colored(Color.RED, footer) + file.write(footer + '\n\n') def printTestInfosSummary(file: TextIO, testInfos): maxDirLen = max(len(tr.directory) for tr in testInfos) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18e8c673894f55b7eb06cd9ec2fc3f6… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/18e8c673894f55b7eb06cd9ec2fc3f6… 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: regenerate bindist settings against the library_stage
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: 5bbd7336 by Sven Tennie at 2026-06-13T17:55:39+00:00 hadrian: regenerate bindist settings against the library_stage Use library_stage (Stage2 for cross builds) when regenerating the bindist lib/settings file, so that: * 'unlit command' picks up the cross-prefixed wasm32-wasi-unlit rather than the bootstrap 'unlit', matching the binary actually shipped in bin/. * 'Use interpreter' resolves to YES for wasm32-wasi (Stage1's target supports the interpreter), matching the autoconf logic in config.mk.in that 'make install' uses to regenerate the file. * 'RTS ways' is the set advertised by build.mk (also generated against library_stage), removing the inconsistency between settings and the install-time Makefile. Previously the call passed executable_stage (Stage1), which made generateSettings' compilerStage = predStage Stage1 = Stage0 and queried the bootstrap toolchain instead of the shipped cross compiler. Also drop the createDirectory call for lib/bin: the bindist Makefile never writes there (binaries are installed to \${ghclibdir}/bin), so the empty directory served no purpose. - - - - - 1 changed file: - hadrian/src/Rules/BinaryDist.hs Changes: ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -164,7 +164,6 @@ buildBinDistDir root conf@BindistConfig{..} = do createDirectory bindistFilesDir createDirectory (bindistFilesDir -/- "bin") createDirectory (bindistFilesDir -/- "lib") - createDirectory (bindistFilesDir -/- "lib" -/- "bin") -- Also create wrappers with version suffixes (#20074) forM_ bin_targets $ \(pkg, prog_path) -> do let orig_filename = takeFileName prog_path @@ -227,7 +226,7 @@ buildBinDistDir root conf@BindistConfig{..} = do -- relocatable. The package DB is always at "package.conf.d" relative to -- the lib dir, matching the known bindist layout. let bindistSettings = bindistFilesDir -/- "lib" -/- "settings" - bindistContext = vanillaContext executable_stage compiler + bindistContext = vanillaContext library_stage compiler bindistSettingsContent <- interpretInContext bindistContext $ generateSettings bindistSettings False "package.conf.d" writeFile' bindistSettings bindistSettingsContent View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bbd73360da2da06e4abfe7b196bef2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5bbd73360da2da06e4abfe7b196bef2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[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