Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: b831ab31 by Simon Jakobi at 2026-08-05T05:21:25-04:00 testsuite: Don't crash on non-UTF-8 test output read_stdout, read_stderr_for, read_comp_stderr and read_diff decoded strictly (the first three with UTF-8, read_diff with the locale encoding), so a test emitting invalid UTF-8 (binary output, or a crash truncating a multi-byte character) raised UnicodeDecodeError and was reported as a framework failure instead of its actual result. Decode with errors='replace', like read_no_crs and safe_print. Assisted-by: Claude Fable 5 - - - - - 693503ec by Simon Jakobi at 2026-08-05T05:21:25-04:00 testsuite: Colorize the test summary, also in CI The summary headings were plain, and SUMMARY was colored unconditionally, so the escapes also ended up in the file written by --summary-file. Color is now decided per output sink via term_color.colored_if; see the comments in term_color. CI logs are not a tty, but GitLab's log viewer renders ANSI colors, so add --force-colors and pass it in .gitlab/ci.sh. Assisted-by: Claude Opus 5 - - - - - cd41db96 by Simon Jakobi at 2026-08-05T05:21:25-04:00 testsuite: Repeat unexpected failure output in the summary Finding out why a test failed meant scrolling back through a possibly very long log to the point where the test ran. The summary now repeats the captured output of unexpected failures, before the statistics, so the most interesting part is at the end of the log (#16720). Output mismatches report their diff instead of the mismatching stream (see Note [Redundant output in test results]). The repeated output is bounded per stream, and skipped altogether beyond MAX_SUMMARY_OUTPUT_TESTS failure blocks. Tests failing identically in several ways share one block. Test results now report a source-relative directory, stable regardless of where the run was started from. Assisted-by: Claude Fable 5 - - - - - 8274828d by Ben Gamari at 2026-08-05T05:21:26-04:00 base: Don't drop exception context in SomeException(toException) For reasons that are lost to time, the implementation of [CLC #200] that was merged inappropriately dropped `ExceptionContext` in the `toException` implementation given to `SomeException`. Fix this infelicity. [CLC #200]: https://github.com/haskell/core-libraries-committee/issues/200 - - - - - d6d1e0fc by Vladislav Zavialov at 2026-08-05T05:21:26-04:00 Test case for #20902 Starting with GHC 9.14.1 (the first major release to include 51e3ec83), and from point releases GHC 9.10.2 and GHC 9.12.3 (backports cc4470be68 and b30f25591e), all examples in this ticket are handled as expected. - - - - - 3efd9085 by Alan Zimmerman at 2026-08-05T05:21:27-04:00 EPA: Remove LocatedP, last use in WarningTxt The last step of removing LocatedP, by moving the AnnPragma for WarningTxt into its TTG extension point instead. This also allows us to remove LocatedP and SrcSpanAnnP - - - - - 15244d80 by Vladislav Zavialov at 2026-08-05T05:21:28-04:00 Test cases for #18725 Starting with GHC 9.4 (the first release to include 268efcc9a4), the program in this ticket no longer panics. A standalone kind signature breaks the recursive loop, so the type constructor can be used in a kind within its own group. T18725a checks that this is accepted with the signature present, while T18725b confirms it is still rejected without it. - - - - - 25 changed files: - .gitlab/ci.sh - + changelog.d/T27455 - compiler/GHC/Builtin/Utils.hs - compiler/GHC/Hs/Decls.hs - compiler/GHC/Hs/Dump.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Warnings.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Unit/Module/Warnings.hs - libraries/base/changelog.md - libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs - testsuite/driver/runtests.py - testsuite/driver/term_color.py - testsuite/driver/testlib.py - testsuite/tests/ghc-e/should_fail/T18441fail7.stderr - testsuite/tests/ghc-e/should_run/ghc-e005.stderr - + testsuite/tests/saks/should_compile/T18725a.hs - testsuite/tests/saks/should_compile/all.T - + testsuite/tests/saks/should_fail/T18725b.hs - + testsuite/tests/saks/should_fail/T18725b.stderr - testsuite/tests/saks/should_fail/all.T - + testsuite/tests/th/T20902.hs - testsuite/tests/th/all.T - utils/check-exact/ExactPrint.hs Changes: ===================================== .gitlab/ci.sh ===================================== @@ -652,6 +652,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="" ===================================== changelog.d/T27455 ===================================== @@ -0,0 +1,8 @@ +section: base +issues: #27455 +mrs: !16274 +synopsis: + Don't drop `ExceptionContext` in `SomeException(toException)` +description: + Previously the implementation of ``Exception(toException)`` given to `SomeException` would inappropriately drop the carried `ExceptionContext`. Now ``toException = id``, faithfully implementing the semantics proposed in :ref:`CLC Proposal #200 <https://github.com/haskell/core-libraries-committee/issues/200>`. + ===================================== compiler/GHC/Builtin/Utils.hs ===================================== @@ -301,7 +301,7 @@ ghcPrimWarns = WarnSome [] where mk_txt msg = - DeprecatedTxt NoSourceText [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []] + DeprecatedTxt (NoSourceText, noAnn) [noLocA $ WithHsDocIdentifiers (StringLiteral NoSourceText (fastStringToShortText msg)) []] mk_decl_dep (occ, msg) = (occ, mk_txt msg) ghcPrimFixities :: [(OccName,Fixity)] ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -1043,7 +1043,7 @@ cidDeprecation :: forall p. IsPass p cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> ClsInstDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _) } ) = depr decl_deprecation GhcRn (ClsInstDecl{ cid_ext = (depr, _) }) @@ -1242,7 +1242,7 @@ derivDeprecation :: forall p. IsPass p derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p) where decl_deprecation :: GhcPass p -> DerivDecl (GhcPass p) - -> Maybe (LocatedP (WarningTxt (GhcPass p))) + -> Maybe (LocatedA (WarningTxt (GhcPass p))) decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) }) = depr decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) }) ===================================== compiler/GHC/Hs/Dump.hs ===================================== @@ -99,7 +99,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet `ext2Q` located `extQ` srcSpanAnnA - `extQ` srcSpanAnnP `extQ` srcSpanAnnN `extQ` srcSpanAnnBF @@ -409,9 +408,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 srcSpanAnnA :: EpAnn [TrailingAnn] -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - srcSpanAnnP :: EpAnn AnnPragma -> SDoc - srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") - srcSpanAnnN :: EpAnn NameAnn -> SDoc srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -83,7 +83,7 @@ import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisForAllTyFlag ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.EnforceEpt.TagSig -import GHC.Parser.Annotation (noLocA) +import GHC.Parser.Annotation (noLocA, noAnn) import GHC.Hs.Extension ( GhcPass, GhcRn, GhcTc ) import GHC.Hs.Decls.Overlap ( OverlapFlag ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) @@ -666,8 +666,8 @@ fromIfaceWarnings = \case fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn fromIfaceWarningTxt = \case - IfWarningTxt src mb_cat strs -> WarningTxt src (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) - IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfWarningTxt src mb_cat strs -> WarningTxt (src, noAnn) (noLocA . fromWarningCategory <$> mb_cat) (noLocA <$> map fromIfaceStringLiteralWithNames strs) + IfDeprecatedTxt src strs -> DeprecatedTxt (src, noAnn) (noLocA <$> map fromIfaceStringLiteralWithNames strs) fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers (StringLiteral GhcRn) GhcRn fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLocA names) ===================================== compiler/GHC/Iface/Warnings.hs ===================================== @@ -22,12 +22,11 @@ toIfaceWarnings (WarnSome vs ds) = IfWarnSome vs' ds' ds' = [(occ, toIfaceWarningTxt txt) | (occ, txt) <- ds] toIfaceWarningTxt :: WarningTxt GhcRn -> IfaceWarningTxt -toIfaceWarningTxt (WarningTxt src mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) -toIfaceWarningTxt (DeprecatedTxt src strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (WarningTxt (src, _) mb_cat strs) = IfWarningTxt src (unLoc . iwc_wc . unLoc <$> mb_cat) (map (toIfaceStringLiteralWithNames . unLoc) strs) +toIfaceWarningTxt (DeprecatedTxt (src, _) strs) = IfDeprecatedTxt src (map (toIfaceStringLiteralWithNames . unLoc) strs) toIfaceStringLiteralWithNames :: WithHsDocIdentifiers (StringLiteral GhcRn) GhcRn -> (IfaceStringLiteral, [IfExtName]) toIfaceStringLiteralWithNames (WithHsDocIdentifiers src names) = (toIfaceStringLiteral src, map unLoc names) toIfaceStringLiteral :: StringLiteral GhcRn -> IfaceStringLiteral -toIfaceStringLiteral sLit = - IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit) +toIfaceStringLiteral sLit = IfStringLiteral (stringLitSourceText sLit) (sl_fs sLit) ===================================== compiler/GHC/Parser.y ===================================== @@ -2077,11 +2077,13 @@ to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated. maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) } : '{-# DEPRECATED' strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (snd $ unLoc $2)) - (AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) } + {% fmap Just $ amsA' (sLL $1 $> $ + DeprecatedTxt (getDEPRECATED_PRAGs $1, AnnPragma (glR $1) (epTok $3) (fst $ unLoc $2) noAnn noAnn noAnn noAnn) + (snd $ unLoc $2))} | '{-# WARNING' warning_category strings '#-}' - {% fmap Just $ amsr (sLL $1 $> $ WarningTxt (getWARNING_PRAGs $1) $2 (snd $ unLoc $3)) - (AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn)} + {% fmap Just $ amsA' (sLL $1 $> $ + WarningTxt (getWARNING_PRAGs $1, AnnPragma (glR $1) (epTok $4) (fst $ unLoc $3) noAnn noAnn noAnn noAnn) + $2 (snd $ unLoc $3))} | {- empty -} { Nothing } warning_category :: { Maybe (LocatedE (InWarningCategory GhcPs)) } @@ -2110,7 +2112,7 @@ warning :: { OrdList (LWarnDecl GhcPs) } : warning_category namespace_spec namelist strings {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4) (Warning (fst $ unLoc $4) (unLoc $2) (unLoc $3) - (WarningTxt NoSourceText $1 (snd $ unLoc $4)))) } + (WarningTxt (NoSourceText, noAnn) $1 (snd $ unLoc $4)))) } namespace_spec :: { Located (NamespaceSpecifier GhcPs) } : 'type' { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) } @@ -2138,7 +2140,7 @@ deprecations :: { OrdList (LWarnDecl GhcPs) } deprecation :: { OrdList (LWarnDecl GhcPs) } : namespace_spec namelist strings {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (fst $ unLoc $3) (unLoc $1) (unLoc $2) - (DeprecatedTxt NoSourceText $ snd $ unLoc $3))) } + (DeprecatedTxt (NoSourceText, noAnn) $ snd $ unLoc $3))) } strings :: { Located ((EpToken "[", EpToken "]"), [LocatedA (WithHsDocIdentifiers (StringLiteral GhcPs) GhcPs)]) } : STRING { sL1 $1 (noAnn,[stringLiteralToHsDocWst (L (gl $1) (getStringLiteral $1))]) } ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -27,9 +27,9 @@ module GHC.Parser.Annotation ( EpAnnCO, -- ** Annotations in 'GenLocated' - LocatedA, LocatedN, LocatedAn, LocatedP, + LocatedA, LocatedN, LocatedAn, LocatedE, LocatedBF, - SrcSpanAnnA, SrcSpanAnnP, SrcSpanAnnN, + SrcSpanAnnA, SrcSpanAnnN, SrcSpanAnnBF, -- ** Annotation data types used in 'GenLocated' @@ -430,7 +430,6 @@ emptyComments = EpaComments [] type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN -type LocatedP = GenLocated SrcSpanAnnP type LocatedBF = GenLocated SrcSpanAnnBF -- | Annotation for items appearing in a list. They can have one or @@ -441,7 +440,6 @@ type SrcSpanAnnA = EpAnn [TrailingAnn] -- on the context, such as backticks. type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnP = EpAnn AnnPragma type SrcSpanAnnBF = EpAnn AnnBooleanFormula type LocatedE = GenLocated EpaLocation ===================================== compiler/GHC/Unit/Module/Warnings.hs ===================================== @@ -158,8 +158,8 @@ warningTxtSame w1 w2 instance Outputable (InWarningCategory (GhcPass pass)) where ppr (InWarningCategory _ wt) = text "in" <+> doubleQuotes (ppr wt) -type instance XDeprecatedTxt (GhcPass _) = SourceText -type instance XWarningTxt (GhcPass _) = SourceText +type instance XDeprecatedTxt (GhcPass _) = (SourceText, AnnPragma) +type instance XWarningTxt (GhcPass _) = (SourceText, AnnPragma) type instance XXWarningTxt (GhcPass _) = DataConCantHappen type instance XInWarningCategory (GhcPass _) = (EpToken "in", SourceText) type instance XXInWarningCategory (GhcPass _) = DataConCantHappen @@ -167,7 +167,7 @@ type instance XXInWarningCategory (GhcPass _) = DataConCantHappen type instance Anno (WithHsDocIdentifiers (StringLiteral pass) pass) = SrcSpanAnnA type instance Anno (InWarningCategory (GhcPass pass)) = EpaLocation type instance Anno (WarningCategory) = EpaLocation -type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP +type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnA deriving stock instance Eq (WarningTxt GhcPs) deriving stock instance Eq (WarningTxt GhcRn) @@ -190,15 +190,15 @@ deriving instance Outputable WarningCategory instance Outputable (WarningTxt (GhcPass pass)) where ppr (WarningTxt lsrc mcat ws) = case lsrc of - NoSourceText -> pp_ws ws - SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" + (NoSourceText, _) -> pp_ws ws + (SourceText src, _) -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}" where ctg_doc = maybe empty (\ctg -> ppr ctg) mcat ppr (DeprecatedTxt lsrc ds) = case lsrc of - NoSourceText -> pp_ws ds - SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" + (NoSourceText, _) -> pp_ws ds + (SourceText src, _) -> ftext src <+> pp_ws ds <+> text "#-}" pp_ws :: [LocatedA (WithHsDocIdentifiers (StringLiteral (GhcPass p)) (GhcPass p))] -> SDoc pp_ws [l] = ppr $ unLoc l ===================================== libraries/base/changelog.md ===================================== @@ -38,6 +38,7 @@ * Show `ExceptionContext` in `displayExceptionAnnotation` implementation of `WhileHandling` ([GHC #27456](https://gitlab.haskell.org/ghc/ghc/-/issues/27456)) * Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387)) * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371)) + * The implementation of `toException` in `SomeException`'s `Exception` instance no longer drops exception context, in keeping with the behavior originally proposed in [CLC Proposal #200](https://github.com/haskell/core-libraries-committee/issues/200). * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397)) * Improve error message for `Data.Char.chr`. ([CLC Proposal #384](https://github.com/haskell/core-libraries-committee/issues/384)) ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Type.hs ===================================== @@ -55,7 +55,7 @@ import GHC.Internal.Data.Maybe import GHC.Internal.Data.Typeable (Typeable, TypeRep, cast) import qualified GHC.Internal.Data.Typeable as Typeable -- loop: GHC.Internal.Data.Typeable -> GHC.Internal.Err -> GHC.Internal.Exception -import GHC.Internal.Base (String, Void, fmap, return, ($), (.), (++)) +import GHC.Internal.Base (String, Void, fmap, return, ($), (.), (++), id) import GHC.Internal.Show import GHC.Internal.Types (Bool(..)) import GHC.Internal.Exception.Context @@ -208,7 +208,16 @@ Caught MismatchedParentheses -} class (Typeable e, Show e) => Exception e where - -- | @toException@ should produce a 'SomeException' with no attached 'ExceptionContext'. + -- | 'toException' converts an exception into the existential 'SomeException' + -- wrapper type. + -- + -- In doing so, 'toException' should not /add/ an 'ExceptionContext'. + -- + -- - In most cases, the exception does not store its own 'ExceptionContext'. + -- The default implementation of 'toException' (which does not store any + -- 'ExceptionContext') is suitable for these cases. + -- - In the rare case that the exception itself stores an 'ExceptionContext', + -- this context should be preserved by 'toException'. toException :: e -> SomeException fromException :: SomeException -> Maybe e @@ -231,13 +240,11 @@ class (Typeable e, Show e) => Exception e where -- | @since base-4.8.0.0 instance Exception Void --- | This drops any attached 'ExceptionContext'. +-- | NB: this instance preserves the attached 'ExceptionContext'. -- -- @since base-3.0 instance Exception SomeException where - toException (SomeException e) = - let ?exceptionContext = emptyExceptionContext - in SomeException e + toException = id fromException = Just backtraceDesired (SomeException e) = backtraceDesired e displayException (SomeException e) = displayException e ===================================== 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, junit_path=args.junit) # 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/term_color.py ===================================== @@ -1,5 +1,6 @@ from enum import Enum +# Whether to emit color escapes; set in runtests.py. enable_color = True class Color(Enum): @@ -18,3 +19,7 @@ def colored(color: Color, s: str) -> str: else: return s +# For renderers that serve several sinks: `enabled` says whether *this* sink +# takes color (the summary is written both to stdout and to a plain-text file). +def colored_if(enabled: bool, color: Color, s: str) -> str: + return colored(color, s) if enabled else s ===================================== testsuite/driver/testlib.py ===================================== @@ -27,7 +27,7 @@ from testutil import strip_quotes, lndir, link_or_copy_file, passed, \ failBecause, testing_metrics, residency_testing_metrics, \ stable_perf_counters, \ PassFail, badResult, str_warn, str_removeprefix -from term_color import Color, colored +from term_color import Color, colored_if import testutil from cpu_features import have_cpu_feature import perf_notes as Perf @@ -1499,6 +1499,19 @@ def _newTestDir(name: TestName, opts: TestOptions, tempdir, dir): opts.testdir_raw = Path(os.path.join(tempdir, testdir, name + testdir_suffix)) opts.compiler_always_flags = config.compiler_always_flags +def _result_directory(opts: TestOptions) -> str: + # The test's source directory, relative to the GHC source root, so it reads + # the same regardless of which directory `make` was invoked from. + srcdir = opts.srcdir + if srcdir is None: + return '' + try: + return os.path.relpath(srcdir, config.top.parent) + except ValueError: + # No relative path exists (e.g. different Windows drives); the + # absolute path is still more useful than nothing. + return str(srcdir) + # ----------------------------------------------------------------------------- # Actually doing tests @@ -1823,7 +1836,7 @@ async def do_test(name: TestName, if opts.expect not in ['pass', 'fail', 'missing-lib']: framework_fail(name, way, 'bad expected ' + opts.expect) - directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\') + directory = _result_directory(opts) if way in opts.fragile_ways: if_verbose(1, '*** fragile test %s resulted in %s' % (full_name, 'pass' if result.passed else 'fail')) @@ -1877,7 +1890,7 @@ def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str # so we need to take care not to blow up with the wrong way # and report the actual reason for the failure. try: - directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\') + directory = _result_directory(opts) except: directory = '' full_name = '%s(%s)' % (name, way) @@ -1890,7 +1903,7 @@ def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str def framework_warn(name: TestName, way: WayName, reason: str) -> None: opts = getTestOpts() - directory = str_removeprefix(str_removeprefix(str(opts.testdir), './'), '.\\') + directory = _result_directory(opts) full_name = name + '(' + way + ')' if_verbose(1, '*** framework warning for %s %s ' % (full_name, reason)) t.framework_warnings.append(TestResult(directory, name, reason, way)) @@ -2445,19 +2458,23 @@ async def simple_run(name: TestName, way: WayName, prog: str, extra_run_opts: st dump_stdout(name) dump_stderr(name) message = format_bad_exit_code_message(exit_code) - return failBecause(message) + return failBecause(message, + stderr=read_stderr(name), + stdout=read_stdout(name)) stderr_match = CompareOutput(True) if (opts.ignore_stderr or opts.combined_output) else await stderr_ok(name, way) if not stderr_match: + # The diff already contains the mismatching stream; see Note [Redundant + # output in test results]. return failBecause('bad stderr', - stderr=read_stderr(name), + stderr=None if stderr_match.diff else read_stderr(name), stdout=read_stdout(name), diff=stderr_match.diff) stdout_match = CompareOutput(True) if opts.ignore_stdout else await stdout_ok(name, way) if not stdout_match: return failBecause('bad stdout', stderr=read_stderr(name), - stdout=read_stdout(name), + stdout=None if stdout_match.diff else read_stdout(name), diff=stdout_match.diff) check_hp = '-hT' in my_rts_flags and opts.check_hp @@ -2567,8 +2584,9 @@ async def interpreter_run(name: TestName, if not stderr_match: if _expect_pass(way): dump_stderr_for('comp', name) + # See Note [Redundant output in test results]. return failBecause('bad stderr', - stderr=read_stderr(name), + stderr=None if stderr_match.diff else read_stderr(name), stdout=read_stdout(name), diff=stderr_match.diff) stdout_match = CompareOutput(True) if opts.ignore_stdout else await stdout_ok(name, way) @@ -2577,7 +2595,7 @@ async def interpreter_run(name: TestName, dump_stderr_for('comp', name) return failBecause('bad stdout', stderr=read_stderr(name), - stdout=read_stdout(name), + stdout=None if stdout_match.diff else read_stdout(name), diff=stdout_match.diff) return passed() @@ -2635,13 +2653,13 @@ async def stdout_ok(name: TestName, way: WayName) -> CompareOutput: def read_stdout( name: TestName ) -> str: path = in_testdir(name, 'run.stdout') if path.exists(): - return path.read_text(encoding='UTF-8') + return path.read_text(encoding='UTF-8', errors='replace') else: return '' def read_diff( diff_file: Path ) -> Optional[str]: if diff_file.exists(): - diff = diff_file.read_text() + diff = diff_file.read_text(encoding='UTF-8', errors='replace') diff_file.unlink() return diff or None else: @@ -2665,14 +2683,14 @@ async def stderr_ok(name: TestName, way: WayName) -> CompareOutput: def read_comp_stderr( name: TestName ) -> str: path = in_testdir(name, 'comp.stderr') if path.exists(): - return path.read_text(encoding='UTF-8') + return path.read_text(encoding='UTF-8', errors='replace') else: return '' def read_stderr_for( phase: str, name: TestName ) -> str: path = in_testdir(name, phase + '.stderr') if path.exists(): - return path.read_text(encoding='UTF-8') + return path.read_text(encoding='UTF-8', errors='replace') else: return '' @@ -3571,12 +3589,50 @@ def findTFiles(roots: List[str]) -> Iterator[str]: # ----------------------------------------------------------------------------- # Output a test summary to the specified file object -def summary(t: TestRun, file: TextIO, color=False) -> None: +def summary(t: TestRun, file: TextIO, color=False, junit_path: Optional[Path]=None) -> None: file.write('\n') + + if t.unexpected_failures: + # Count output blocks rather than results: a test failing in many ways + # collapses to a single block. + groups = groupTestOutput(t.unexpected_failures) + if len(groups) <= MAX_SUMMARY_OUTPUT_TESTS: + printTestOutputSummary(file, groups, color, junit_path) + else: + where = '; see {}'.format(junit_path) if junit_path else '' + header = ('Unexpected failures (more than {}, output omitted{}):' + .format(MAX_SUMMARY_OUTPUT_TESTS, where)) + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.unexpected_failures) + + if t.unexpected_passes: + header = 'Unexpected passes:' + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.unexpected_passes) + + if t.unexpected_stat_failures: + header = 'Unexpected stat failures:' + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.unexpected_stat_failures) + + if t.framework_failures: + header = 'Framework failures:' + file.write(colored_if(color, Color.RED, header) + '\n') + printTestInfosSummary(file, t.framework_failures) + + if t.framework_warnings: + header = 'Framework warnings:' + file.write(colored_if(color, Color.YELLOW, header) + '\n') + printTestInfosSummary(file, t.framework_warnings) + + if stopping(): + warning = 'WARNING: Testsuite run was terminated early' + file.write(colored_if(color, Color.YELLOW, warning) + '\n') + printUnexpectedTests(file, [t.unexpected_passes, t.unexpected_failures, - t.unexpected_stat_failures, t.framework_failures]) + t.unexpected_stat_failures, t.framework_failures], color) if len(t.unexpected_failures) > 0 or \ len(t.unexpected_stat_failures) > 0 or \ @@ -3587,7 +3643,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_if(color, summary_color, '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' @@ -3619,46 +3676,107 @@ def summary(t: TestRun, file: TextIO, color=False) -> None: + ' fragile tests\n' + '\n') - if t.unexpected_passes: - file.write('Unexpected passes:\n') - printTestInfosSummary(file, t.unexpected_passes) - - if t.unexpected_failures: - file.write('Unexpected failures:\n') - printTestInfosSummary(file, t.unexpected_failures) - - if t.unexpected_stat_failures: - file.write('Unexpected stat failures:\n') - printTestInfosSummary(file, t.unexpected_stat_failures) - - if t.framework_failures: - file.write('Framework failures:\n') - printTestInfosSummary(file, t.framework_failures) - - if t.framework_warnings: - file.write('Framework warnings:\n') - printTestInfosSummary(file, t.framework_warnings) - - if stopping(): - file.write('WARNING: Testsuite run was terminated early\n') - -def printUnexpectedTests(file: TextIO, testInfoss): +def printUnexpectedTests(file: TextIO, testInfoss, color=False): unexpected = set(result.testname for testInfos in testInfoss for result in testInfos if not result.testname.endswith('.T')) if unexpected: - file.write('Unexpected results from:\n') + header = 'Unexpected results from:' + file.write(colored_if(color, Color.RED, header) + '\n') file.write('TEST="' + ' '.join(sorted(unexpected)) + '"\n') file.write('\n') +# Per-stream cap on a failing test's output repeated in the final summary. +MAX_SUMMARY_OUTPUT_LINES = 100 + +# Above this many output blocks, skip repeating output entirely: the dump +# would drown out the summary. +MAX_SUMMARY_OUTPUT_TESTS = 20 + +# Note [Redundant output in test results] +# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# A failing test result carries up to three pieces of output: `diff`, `stdout` +# and `stderr`. For an output mismatch these overlap: the diff's `+` lines are +# the very stream that mismatched, normalised. Reporting both would print the +# same text twice, so the mismatching stream is dropped at the call sites in +# favour of the diff, which additionally shows what was expected. The *other* +# stream is kept: on a stdout mismatch, stderr is independent context. +# +# The drop is conditional on there being a diff at all: compare_outputs only +# runs `diff` when config.verbose >= 1, so under -v0 the stream is the only +# output there is. +# +# Note that, since the drop happens at result construction, it also affects the +# JUnit report (junit.py). + +def strip_diff_header(diff: Optional[str]) -> Optional[str]: + # Drop diff(1)'s ---/+++ lines: they name normalised files in the test + # directory and carry timestamps, which would also keep otherwise + # identical failures from being grouped. + if diff is None: + return None + lines = diff.split('\n') + if len(lines) >= 2 and lines[0].startswith('--- ') and lines[1].startswith('+++ '): + return '\n'.join(lines[2:]) + return diff + +def sorted_results(testInfos: List[TestResult]) -> List[TestResult]: + return sorted(testInfos, key=lambda r: (r.testname.lower(), r.directory, r.way)) + +# A failure-output block: a representative result, its header-stripped diff, +# and the ways that share it. +OutputGroup = Tuple[TestResult, Optional[str], List[WayName]] + +# Tests that fail identically in several ways (e.g. normal and g1) share one +# output block, with the ways collected in the header. +def groupTestOutput(testInfos: List[TestResult]) -> List[OutputGroup]: + # Relies on dicts preserving insertion order. + groups = {} # type: Dict[Tuple, OutputGroup] + for result in sorted_results(testInfos): + diff = strip_diff_header(result.diff) + key = (result.testname, result.directory, result.reason, + diff, result.stdout, result.stderr) + groups.setdefault(key, (result, diff, []))[2].append(result.way) + return list(groups.values()) + +def printTestOutputSummary(file: TextIO, + groups: List[OutputGroup], + color: bool=False, + junit_path: Optional[Path]=None) -> 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. + header = '=====> Unexpected failures output summary' + file.write(colored_if(color, Color.RED, header) + '\n\n') + + where = ', see {}'.format(junit_path) if junit_path else '' + for result, diff, ways in groups: + header = '=====> {}({}) ({}) [{}]'.format( + result.testname, ', '.join(ways), result.directory + os.sep, result.reason) + file.write(colored_if(color, Color.RED, header) + '\n') + # See Note [Redundant output in test results] for why these don't overlap. + for label, contents in [('Output diff (expected vs actual):', diff), + ('Captured stdout:', result.stdout), + ('Captured stderr:', result.stderr)]: + if contents and contents.strip(): + 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{})'.format(omitted, where)] + s = colored_if(color, Color.CYAN, 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)) + footer = '<===== end of unexpected failures output summary' + file.write(colored_if(color, Color.RED, footer) + '\n\n') + def printTestInfosSummary(file: TextIO, testInfos): - maxDirLen = max(len(tr.directory) for tr in testInfos) - for result in sorted(testInfos, key=lambda r: (r.testname.lower(), r.way, r.directory)): - directory = result.directory.ljust(maxDirLen) - file.write(' {directory} {r.testname} [{r.reason}] ({r.way})\n'.format( - r = result, - directory = directory)) + for result in sorted_results(testInfos): + path = os.path.join(result.directory, result.testname) + file.write(' {path} [{r.reason}] ({r.way})\n'.format(r=result, path=path)) file.write('\n') def modify_lines(s: str, f: Callable[[str], str]) -> str: ===================================== testsuite/tests/ghc-e/should_fail/T18441fail7.stderr ===================================== @@ -5,8 +5,12 @@ IO error: "Abcde" does not exist While handling ghc-10.1-inplace:GHC.Utils.Panic.GhcException: | | IO error: "Abcde" does not exist + | + | HasCallStack backtrace: + | throw, called at compiler/GHC/Utils/Panic.hs:180:21 in ghc-10.1-inplace:GHC.Utils.Panic + | throwGhcException, called at ghc/GHCi/UI.hs:2851:21 in ghc-bin-10.1.20260801-inplace:GHCi.UI HasCallStack backtrace: - throwIO, called at compiler\GHC\Utils\Error.hs:499:19 in ghc-10.1-inplace:GHC.Utils.Error + throwIO, called at compiler/GHC/Utils/Error.hs:513:19 in ghc-10.1-inplace:GHC.Utils.Error 1 ===================================== testsuite/tests/ghc-e/should_run/ghc-e005.stderr ===================================== @@ -4,3 +4,8 @@ foo HasCallStack backtrace: error, called at ghc-e005.hs:12:10 in main:Main + + +HasCallStack backtrace: + throwIO, called at ghc\GHCi\UI.hs:1655:31 in ghc-bin-10.1.20260629-inplace:GHCi.UI + ===================================== testsuite/tests/saks/should_compile/T18725a.hs ===================================== @@ -0,0 +1,10 @@ +{-# LANGUAGE ExplicitForAll, KindSignatures, StandaloneKindSignatures, + DataKinds, GADTs #-} + +module T18725a where + +import Data.Kind (Type) + +type U :: Type +data U where P :: forall u. E u -> U +data E (u :: U) ===================================== testsuite/tests/saks/should_compile/all.T ===================================== @@ -35,6 +35,7 @@ test('T16726', normal, compile, ['']) test('T16731', normal, compile, ['']) test('T16721', normal, ghci_script, ['T16721.script']) test('T16756a', normal, compile, ['']) +test('T18725a', normal, compile, ['']) test('saks027', req_th, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('saks028', req_th, compile, ['']) ===================================== testsuite/tests/saks/should_fail/T18725b.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE ExplicitForAll, KindSignatures, StandaloneKindSignatures, + DataKinds, GADTs #-} + +module T18725b where + +-- type U :: Type -- Rejected without the sig +data U where P :: forall u. E u -> U +data E (u :: U) ===================================== testsuite/tests/saks/should_fail/T18725b.stderr ===================================== @@ -0,0 +1,6 @@ +T18725b.hs:8:14: error: [GHC-85413] + • Type constructor ‘U’ cannot be used here + (it is defined and used in the same recursive group) + • In the kind ‘U’ + In the data type declaration for ‘E’ + ===================================== testsuite/tests/saks/should_fail/all.T ===================================== @@ -38,3 +38,5 @@ test('T18863d', normal, compile_fail, ['']) test('T20916', normal, compile_fail, ['']) test('saks018-fail', normal, compile_fail, ['']) test('saks021-fail', normal, compile_fail, ['']) +test('T18725b', normal, compile_fail, ['']) + ===================================== testsuite/tests/th/T20902.hs ===================================== @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T20902 where + +import Language.Haskell.TH + +data T = FU | FUN deriving Show + +expr1 = $( conE (mkName "FU") ) +expr2 = $( conE (mkName "FUN") ) +expr3 = $( [| FU |] ) +expr4 = $( [| FUN |] ) + ===================================== testsuite/tests/th/all.T ===================================== @@ -651,3 +651,5 @@ test('T26099', normal, compile_fail, ['']) test('T8306_th', only_ways(['ghci']), ghci_script, ['T8306_th.script']) test('T26862_th', only_ways(['ghci']), ghci_script, ['T26862_th.script']) test('T27022', normal, compile_and_run, ['']) +test('T20902', normal, compile, ['']) + ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1555,26 +1555,26 @@ instance ExactPrint ModuleName where -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP (WarningTxt GhcPs)) where - getAnnotationEntry = entryFromLocatedA - setAnnotationAnchor = setAnchorAn +instance ExactPrint (WarningTxt GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ _ = a - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (WarningTxt src mb_cat ws)) = do + exact (WarningTxt (src, AnnPragma o c (os,cs) l1 l2 t m) mb_cat ws) = do o' <- markAnnOpen'' o src "{-# WARNING" mb_cat' <- markAnnotated mb_cat os' <- markEpToken os 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')) + return (WarningTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) mb_cat' ws') - exact (L (EpAnn l (AnnPragma o c (os,cs) l1 l2 t m) css) (DeprecatedTxt src ws)) = do + exact (DeprecatedTxt (src, AnnPragma o c (os,cs) l1 l2 t m) ws) = do o' <- markAnnOpen'' o src "{-# DEPRECATED" os' <- markEpToken os 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')) + return (DeprecatedTxt (src, AnnPragma o' c' (os',cs') l1 l2 t m) ws') instance ExactPrint (InWarningCategory GhcPs) where getAnnotationEntry _ = NoEntryVal View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a2bc8f4d302166c3d13c258c24223f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1a2bc8f4d302166c3d13c258c24223f... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help