diff options
Diffstat (limited to 'compiler/GHC')
-rw-r--r-- | compiler/GHC/Core/Lint.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Monad.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Specialise.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Driver/Backpack.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Driver/Env.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Errors.hs | 53 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 67 | ||||
-rw-r--r-- | compiler/GHC/Driver/Make.hs | 34 | ||||
-rw-r--r-- | compiler/GHC/Driver/MakeFile.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/Monad.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Monad.hs | 7 | ||||
-rw-r--r-- | compiler/GHC/Iface/Rename.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Linker/Loader.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 49 | ||||
-rw-r--r-- | compiler/GHC/Parser/Header.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Stg/Lint.hs | 47 | ||||
-rw-r--r-- | compiler/GHC/SysTools/Process.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Tc/Errors.hs | 360 | ||||
-rw-r--r-- | compiler/GHC/Tc/Module.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/Types/Error.hs | 106 | ||||
-rw-r--r-- | compiler/GHC/Utils/Error.hs | 109 |
23 files changed, 451 insertions, 438 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 116e26b3d1..3438f372fc 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -2774,7 +2774,7 @@ addMsg is_error env msgs msg , isGoodSrcSpan span ] of [] -> noSrcSpan (s:_) -> s - mk_msg msg = mkLocMessage (mkMCDiagnostic WarningWithoutFlag) msg_span + mk_msg msg = mkLocMessage (mkMCDiagnostic (le_dynflags env) WarningWithoutFlag) msg_span (msg $$ context) addLoc :: LintLocInfo -> LintM a -> LintM a diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 8b1b94b14f..3c6ff07a65 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -64,6 +64,7 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Error +import GHC.Utils.Error ( errorDiagnostic ) import GHC.Utils.Outputable as Outputable import GHC.Utils.Logger ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger ) import GHC.Utils.Monad @@ -820,7 +821,7 @@ errorMsgS = errorMsg . text -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM () -errorMsg = msg (mkMCDiagnostic ErrorWithoutFlag) +errorMsg doc = msg errorDiagnostic doc -- | Output a fatal error to the screen. Does not cause the compiler to die. fatalErrorMsgS :: String -> CoreM () diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 5caae8bf77..8efebd0cd5 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -55,6 +55,7 @@ import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Error +import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad ( foldlM ) import GHC.Utils.Misc import GHC.Utils.Outputable @@ -809,7 +810,7 @@ tryWarnMissingSpecs dflags callers fn calls_for_fn where allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers doWarn reason = - msg (mkMCDiagnostic reason) + msg (mkMCDiagnostic dflags reason) (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) 2 (vcat [ text "when specialising" <+> quotes (ppr caller) | caller <- callers]) diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 4789af6fe7..5c45858570 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -107,7 +107,7 @@ doBackpack [src_filename] = do buf <- liftIO $ hGetStringBuffer src_filename let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of - PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst)) + PFailed pst -> throwErrors (fmap mkParserErr (getErrorMessages pst)) POk _ pkgname_bkp -> do -- OK, so we have an LHsUnit PackageName, but we want an -- LHsUnit HsComponentId. So let's rename it. @@ -802,8 +802,8 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing Nothing -- GHC API buffer support not supported [] -- No exclusions case r of - Nothing -> throwOneError (mkPlainMsgEnvelope ErrorWithoutFlag - loc (text "module" <+> ppr modname <+> text "was not found")) + Nothing -> throwOneError (mkPlainErrorMsgEnvelope loc + (text "module" <+> ppr modname <+> text "was not found")) Just (Left err) -> throwErrors err Just (Right summary) -> return summary diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 6e843d2ea4..3fff8ab65c 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -30,7 +30,7 @@ import GHC.Prelude import GHC.Driver.Ppr import GHC.Driver.Session -import GHC.Driver.Errors ( printOrThrowWarnings ) +import GHC.Driver.Errors ( printOrThrowDiagnostics ) import GHC.Runtime.Context import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) ) @@ -70,7 +70,7 @@ import Data.IORef runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do (a, w) <- hsc hsc_env emptyBag - printOrThrowWarnings (hsc_logger hsc_env) (hsc_dflags hsc_env) w + printOrThrowDiagnostics (hsc_logger hsc_env) (hsc_dflags hsc_env) w return a -- | Switches in the DynFlags and Plugins from the InteractiveContext diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index 9127e7d094..b6fdee5c9b 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -1,5 +1,5 @@ module GHC.Driver.Errors ( - printOrThrowWarnings + printOrThrowDiagnostics , printBagOfErrors , handleFlagWarnings , partitionMessageBag @@ -8,7 +8,7 @@ module GHC.Driver.Errors ( import GHC.Driver.Session import GHC.Data.Bag import GHC.Utils.Exception -import GHC.Utils.Error ( formatBulleted, sortMsgBag ) +import GHC.Utils.Error ( formatBulleted, sortMsgBag, mkPlainMsgEnvelope ) import GHC.Types.SourceError ( mkSrcErr ) import GHC.Prelude import GHC.Types.SrcLoc @@ -40,10 +40,10 @@ handleFlagWarnings logger dflags warns = do -- It would be nicer if warns :: [Located SDoc], but that -- has circular import problems. - bag = listToBag [ mkPlainMsgEnvelope WarningWithoutFlag loc (text warn) + bag = listToBag [ mkPlainMsgEnvelope dflags WarningWithoutFlag loc (text warn) | CmdLine.Warn _ (L loc warn) <- warns' ] - printOrThrowWarnings logger dflags bag + printOrThrowDiagnostics logger dflags bag -- Given a warn reason, check to see if it's associated -W opt is enabled shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool @@ -54,40 +54,11 @@ shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag shouldPrintWarning _ _ = True --- | Given a bag of warnings, turn them into an exception if --- -Werror is enabled, or print them out otherwise. -printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO () -printOrThrowWarnings logger dflags warns = do - let (make_error, warns') = - mapAccumBagL - (\make_err warn -> - case warn_msg_severity dflags warn of - SevWarning -> - (make_err, warn) - SevError -> - (True, set_severity SevError warn)) - False warns - if make_error - then throwIO (mkSrcErr warns') - else printBagOfErrors logger dflags warns - - where - - -- | Sets the 'Severity' of the input 'WarnMsg' according to the 'DynFlags'. - warn_msg_severity :: DynFlags -> WarnMsg -> Severity - warn_msg_severity dflags msg = - case diagnosticReason (errMsgDiagnostic msg) of - ErrorWithoutFlag -> SevError - WarningWithoutFlag -> - if gopt Opt_WarnIsError dflags - then SevError - else SevWarning - WarningWithFlag wflag -> - if wopt_fatal wflag dflags - then SevError - else SevWarning - - -- | Adjust the 'Severity' of the input 'WarnMsg'. - set_severity :: Severity -> WarnMsg -> MsgEnvelope DiagnosticMessage - set_severity newSeverity msg = msg { errMsgSeverity = newSeverity } - +-- | Given a bag of diagnostics, turn them into an exception if +-- any has 'SevError', or print them out otherwise. +printOrThrowDiagnostics :: Logger -> DynFlags -> Bag WarnMsg -> IO () +printOrThrowDiagnostics logger dflags warns + | any ((==) SevError . errMsgSeverity) warns + = throwIO (mkSrcErr warns) + | otherwise + = printBagOfErrors logger dflags warns diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 0c67d05d3a..07f1e7acda 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -281,15 +281,16 @@ handleWarnings = do dflags <- getDynFlags logger <- getLogger w <- getWarnings - liftIO $ printOrThrowWarnings logger dflags w + liftIO $ printOrThrowDiagnostics logger dflags w clearWarnings -- | log warning in the monad, and if there are errors then -- throw a SourceError exception. logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc () logWarningsReportErrors (warnings,errors) = do - let warns = fmap pprWarning warnings - errs = fmap pprError errors + dflags <- getDynFlags + let warns = fmap (mkParserWarn dflags) warnings + errs = fmap mkParserErr errors logDiagnostics warns when (not $ isEmptyBag errs) $ throwErrors errs @@ -297,10 +298,10 @@ logWarningsReportErrors (warnings,errors) = do -- contain at least one error (e.g. coming from PFailed) handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a handleWarningsThrowErrors (warnings, errors) = do - let warns = fmap pprWarning warnings - errs = fmap pprError errors - logDiagnostics warns dflags <- getDynFlags + let warns = fmap (mkParserWarn dflags) warnings + errs = fmap mkParserErr errors + logDiagnostics warns logger <- getLogger let (wWarns, wErrs) = partitionMessageBag warns liftIO $ printBagOfErrors logger dflags wWarns @@ -415,7 +416,7 @@ hscParse' mod_summary PFailed pst -> handleWarningsThrowErrors (getMessages pst) POk pst rdr_module -> do - let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst) + let (warns, errs) = bimap (fmap (mkParserWarn dflags)) (fmap mkParserErr) (getMessages pst) logDiagnostics warns liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) @@ -563,7 +564,7 @@ tcRnModule' sum save_rn_syntax mod = do when (not (safeHaskellModeEnabled dflags) && wopt Opt_WarnMissingSafeHaskellMode dflags) $ logDiagnostics $ unitBag $ - mkPlainMsgEnvelope reason (getLoc (hpm_module mod)) $ + mkPlainMsgEnvelope dflags reason (getLoc (hpm_module mod)) $ warnMissingSafeHaskellMode tcg_res <- {-# SCC "Typecheck-Rename" #-} @@ -591,13 +592,13 @@ tcRnModule' sum save_rn_syntax mod = do True | safeHaskell dflags == Sf_Safe -> return () | otherwise -> (logDiagnostics $ unitBag $ - mkPlainMsgEnvelope (WarningWithFlag Opt_WarnSafe) + mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnSafe) (warnSafeOnLoc dflags) $ errSafe tcg_res') False | safeHaskell dflags == Sf_Trustworthy && wopt Opt_WarnTrustworthySafe dflags -> (logDiagnostics $ unitBag $ - mkPlainMsgEnvelope (WarningWithFlag Opt_WarnTrustworthySafe) + mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnTrustworthySafe) (trustworthyOnLoc dflags) $ errTwthySafe tcg_res') False -> return () @@ -1127,22 +1128,22 @@ hscCheckSafeImports tcg_env = do case safeLanguageOn dflags of True -> do -- XSafe: we nuke user written RULES - logDiagnostics $ warns (tcg_rules tcg_env') + logDiagnostics $ warns dflags (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False -- SafeInferred: user defined RULES, so not safe | safeInferOn dflags && not (null $ tcg_rules tcg_env') - -> markUnsafeInfer tcg_env' $ warns (tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') -- Trustworthy OR SafeInferred: with no RULES | otherwise -> return tcg_env' - warns rules = listToBag $ map warnRules rules + warns dflags rules = listToBag $ map (warnRules dflags) rules - warnRules :: LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage - warnRules (L loc (HsRule { rd_name = n })) = - mkPlainMsgEnvelope WarningWithoutFlag (locA loc) $ + warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage + warnRules df (L loc (HsRule { rd_name = n })) = + mkPlainMsgEnvelope df WarningWithoutFlag (locA loc) $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -1218,9 +1219,9 @@ checkSafeImports tcg_env cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1 v2 | imv_is_safe v1 /= imv_is_safe v2 - = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag (imv_span v1) - (text "Module" <+> ppr (imv_name v1) <+> - (text $ "is imported both as a safe and unsafe import!")) + = throwOneError $ mkPlainErrorMsgEnvelope (imv_span v1) + (text "Module" <+> ppr (imv_name v1) <+> + (text $ "is imported both as a safe and unsafe import!")) | otherwise = return v1 @@ -1286,7 +1287,7 @@ hscCheckSafe' m l = do iface <- lookup' m case iface of -- can't load iface to check trust! - Nothing -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag l + Nothing -> throwOneError $ mkPlainErrorMsgEnvelope l $ text "Can't load the interface file for" <+> ppr m <> text ", to check that it can be safely imported" @@ -1304,7 +1305,7 @@ hscCheckSafe' m l = do warns = if wopt Opt_WarnInferredSafeImports dflags && safeLanguageOn dflags && trust == Sf_SafeInferred - then inferredImportWarn + then inferredImportWarn dflags else emptyBag -- General errors we throw but Safe errors we log errs = case (safeM, safeP) of @@ -1318,23 +1319,25 @@ hscCheckSafe' m l = do where state = hsc_units hsc_env - inferredImportWarn = unitBag - $ mkShortMsgEnvelope (WarningWithFlag Opt_WarnInferredSafeImports) + inferredImportWarn dflags = unitBag + $ mkShortMsgEnvelope dflags (WarningWithFlag Opt_WarnInferredSafeImports) l (pkgQual state) $ sep [ text "Importing Safe-Inferred module " <> ppr (moduleName m) <> text " from explicitly Safe module" ] - pkgTrustErr = unitBag $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $ - sep [ ppr (moduleName m) + pkgTrustErr = unitBag + $ mkShortErrorMsgEnvelope l (pkgQual state) + $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The package (" <> (pprWithUnitState state $ ppr (moduleUnit m)) <> text ") the module resides in isn't trusted." ] - modTrustErr = unitBag $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $ - sep [ ppr (moduleName m) + modTrustErr = unitBag + $ mkShortErrorMsgEnvelope l (pkgQual state) + $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -1379,7 +1382,7 @@ checkPkgTrust pkgs = do | unitIsTrusted $ unsafeLookupUnitId state pkg = acc | otherwise - = (:acc) $ mkShortMsgEnvelope ErrorWithoutFlag noSrcSpan (pkgQual state) + = (:acc) $ mkShortErrorMsgEnvelope noSrcSpan (pkgQual state) $ pprWithUnitState state $ text "The package (" <> ppr pkg @@ -1405,7 +1408,7 @@ markUnsafeInfer tcg_env whyUnsafe = do let reason = WarningWithFlag Opt_WarnUnsafe when (wopt Opt_WarnUnsafe dflags) (logDiagnostics $ unitBag $ - mkPlainMsgEnvelope reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) + mkPlainMsgEnvelope dflags reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe) -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other @@ -1637,7 +1640,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do $ do (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags cmm_mod home_unit filename - return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm) + return (mkMessages (fmap (mkParserWarn dflags) warns `unionBags` fmap mkParserErr errs), cmm) liftIO $ do dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) @@ -1998,7 +2001,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do case is of [L _ i] -> return i _ -> liftIO $ throwOneError $ - mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $ + mkPlainErrorMsgEnvelope noSrcSpan $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -2027,7 +2030,7 @@ hscParseExpr expr = do maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (BodyStmt _ expr _ _)) -> return expr - _ -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan + _ -> throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan (text "not an expression:" <+> quotes (text expr)) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 4036208954..b677f63681 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -319,7 +319,7 @@ warnMissingHomeModules hsc_env mod_graph = 4 (sep (map ppr missing)) warn = - mkPlainMsgEnvelope (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg + mkPlainMsgEnvelope (hsc_dflags hsc_env) (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch @@ -385,7 +385,7 @@ warnUnusedPackages = do requestedArgs let warn = - mkPlainMsgEnvelope (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg + mkPlainMsgEnvelope dflags (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg msg = vcat [ text "The following packages were specified" <+> text "via -package or -package-id flags," , text "but were not needed for compilation:" @@ -2214,15 +2214,15 @@ warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () warnUnnecessarySourceImports sccs = do dflags <- getDynFlags when (wopt Opt_WarnUnusedImports dflags) - (logWarnings (listToBag (concatMap (check . flattenSCC) sccs))) - where check ms = + (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))) + where check dflags ms = let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] + [ warn dflags i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] - warn :: Located ModuleName -> WarnMsg - warn (L loc mod) = - mkPlainMsgEnvelope WarningWithoutFlag loc + warn :: DynFlags -> Located ModuleName -> WarnMsg + warn dflags (L loc mod) = + mkPlainMsgEnvelope dflags WarningWithoutFlag loc (text "{-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)) @@ -2295,7 +2295,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots if exists || isJust maybe_buf then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else return $ Left $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $ + else return $ Left $ unitBag $ mkPlainErrorMsgEnvelope noSrcSpan $ text "can't find file:" <+> text file getRootSummary Target { targetId = TargetModule modl , targetAllowObjCode = obj_allowed @@ -2730,7 +2730,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | otherwise = HsSrcFile when (pi_mod_name /= wanted_mod) $ - throwE $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag pi_mod_name_loc $ + throwE $ unitBag $ mkPlainErrorMsgEnvelope pi_mod_name_loc $ text "File name does not match module name:" $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) @@ -2742,7 +2742,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : homeUnitInstantiations home_unit) ]) - in throwE $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag pi_mod_name_loc $ + in throwE $ unitBag $ mkPlainErrorMsgEnvelope pi_mod_name_loc $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) $$ if gopt Opt_BuildingCabalPackage dflags then parens (text "Try adding" <+> quotes (ppr pi_mod_name) @@ -2855,7 +2855,7 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags popts = initParserOpts pi_local_dflags mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn - return (first (fmap pprError) mimps) + return (first (fmap mkParserErr) mimps) return PreprocessedImports {..} @@ -2902,21 +2902,21 @@ withDeferredDiagnostics f = do noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DiagnosticMessage -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err - = mkPlainMsgEnvelope ErrorWithoutFlag loc $ cannotFindModule hsc_env wanted_mod err + = mkPlainErrorMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err noHsFileErr :: SrcSpan -> String -> ErrorMessages noHsFileErr loc path - = unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag loc $ text "Can't find" <+> text path + = unitBag $ mkPlainErrorMsgEnvelope loc $ text "Can't find" <+> text path moduleNotFoundErr :: ModuleName -> ErrorMessages moduleNotFoundErr mod - = unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $ + = unitBag $ mkPlainErrorMsgEnvelope noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) - = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $ + = throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index 9324755d3d..ea1bf1f501 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -305,7 +305,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do -> return Nothing fail -> - throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag srcloc $ + throwOneError $ mkPlainErrorMsgEnvelope srcloc $ cannotFindModule hsc_env imp fail ----------------------------- diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index 39ccdc7c21..1a42d8402f 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -36,7 +36,7 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Env -import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors ) +import GHC.Driver.Errors ( printOrThrowDiagnostics, printBagOfErrors ) import GHC.Utils.Monad import GHC.Utils.Exception @@ -147,7 +147,7 @@ logWarnings :: GhcMonad m => WarningMessages -> m () logWarnings warns = do dflags <- getSessionDynFlags logger <- getLogger - liftIO $ printOrThrowWarnings logger dflags warns + liftIO $ printOrThrowDiagnostics logger dflags warns -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 514c3c9701..e79d1ecab9 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -151,7 +151,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = where srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 handler (ProgramError msg) = return $ Left $ unitBag $ - mkPlainMsgEnvelope ErrorWithoutFlag srcspan $ text msg + mkPlainErrorMsgEnvelope srcspan $ text msg handler ex = throwGhcExceptionIO ex -- --------------------------------------------------------------------------- @@ -1255,7 +1255,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn popts = initParserOpts dflags eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of - Left errs -> throwErrors (fmap pprError errs) + Left errs -> throwErrors (fmap mkParserErr errs) Right (src_imps,imps,L _ mod_name) -> return (Just buf, mod_name, imps, src_imps) diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index f5be46006a..a16f70cded 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -105,9 +105,9 @@ import GHC.Types.CostCentre.State import GHC.Types.TyThing import GHC.Types.Error +import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Utils.Error import Data.IORef @@ -460,7 +460,8 @@ diagnosticDs :: DiagnosticReason -> SDoc -> DsM () diagnosticDs reason warn = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkShortMsgEnvelope reason loc (ds_unqual env) warn + ; dflags <- getDynFlags + ; let msg = mkShortMsgEnvelope dflags reason loc (ds_unqual env) warn ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags @@ -473,7 +474,7 @@ errDs :: SDoc -> DsM () errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkShortMsgEnvelope ErrorWithoutFlag loc (ds_unqual env) err + ; let msg = mkShortErrorMsgEnvelope loc (ds_unqual env) err ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Issue an error, but return the expression for (), so that we can continue diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index beb7aadbbb..f4e8b449f5 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -43,6 +43,7 @@ import GHC.Types.Name.Shape import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Error import GHC.Utils.Fingerprint import GHC.Utils.Panic @@ -76,7 +77,7 @@ failWithRn doc = do errs_var <- fmap sh_if_errs getGblEnv errs <- readTcRef errs_var -- TODO: maybe associate this with a source location? - writeTcRef errs_var (errs `snocBag` mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan doc) + writeTcRef errs_var (errs `snocBag` mkPlainErrorMsgEnvelope noSrcSpan doc) failM -- | What we have is a generalized ModIface, which corresponds to diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index 86fff45160..735f6ceb16 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -1433,7 +1433,7 @@ load_dyn interp hsc_env crash_early dll = do else when (wopt Opt_WarnMissedExtraSharedLib dflags) $ putLogMsg logger dflags - (mkMCDiagnostic $ WarningWithFlag Opt_WarnMissedExtraSharedLib) + (mkMCDiagnostic dflags $ WarningWithFlag Opt_WarnMissedExtraSharedLib) noSrcSpan $ withPprStyle defaultUserStyle (note err) where dflags = hsc_dflags hsc_env diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index c0c09d6173..7b9f2e64a0 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -3,8 +3,8 @@ {-# LANGUAGE FlexibleContexts #-} module GHC.Parser.Errors.Ppr - ( pprWarning - , pprError + ( mkParserWarn + , mkParserErr ) where @@ -24,27 +24,32 @@ import GHC.Hs.Expr (prependQualified,HsExpr(..)) import GHC.Hs.Type (pprLHsContext) import GHC.Builtin.Names (allNameStrings) import GHC.Builtin.Types (filterCTuple) +import GHC.Driver.Session (DynFlags) +import GHC.Utils.Error (diagReasonSeverity) -mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage -mkParserErr span doc = MsgEnvelope +mk_parser_err :: SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage +mk_parser_err span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify , errMsgDiagnostic = DiagnosticMessage (mkDecorated [doc]) ErrorWithoutFlag , errMsgSeverity = SevError } -mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage -mkParserWarn flag span doc = MsgEnvelope +mk_parser_warn :: DynFlags -> WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DiagnosticMessage +mk_parser_warn df flag span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = DiagnosticMessage (mkDecorated [doc]) (WarningWithFlag flag) - , errMsgSeverity = SevWarning + , errMsgDiagnostic = DiagnosticMessage (mkDecorated [doc]) reason + , errMsgSeverity = diagReasonSeverity df reason } + where + reason :: DiagnosticReason + reason = WarningWithFlag flag -pprWarning :: PsWarning -> MsgEnvelope DiagnosticMessage -pprWarning = \case +mkParserWarn :: DynFlags -> PsWarning -> MsgEnvelope DiagnosticMessage +mkParserWarn df = \case PsWarnTab loc tc - -> mkParserWarn Opt_WarnTabs loc $ + -> mk_parser_warn df Opt_WarnTabs loc $ text "Tab character found here" <> (if tc == 1 then text "" @@ -53,7 +58,7 @@ pprWarning = \case $+$ text "Please use spaces instead." PsWarnTransitionalLayout loc reason - -> mkParserWarn Opt_WarnAlternativeLayoutRuleTransitional loc $ + -> mk_parser_warn df Opt_WarnAlternativeLayoutRuleTransitional loc $ text "transitional layout will not be accepted in the future:" $$ text (case reason of TransLayout_Where -> "`where' clause at the same depth as implicit layout block" @@ -61,20 +66,20 @@ pprWarning = \case ) PsWarnUnrecognisedPragma loc - -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $ + -> mk_parser_warn df Opt_WarnUnrecognisedPragmas loc $ text "Unrecognised pragma" PsWarnHaddockInvalidPos loc - -> mkParserWarn Opt_WarnInvalidHaddock loc $ + -> mk_parser_warn df Opt_WarnInvalidHaddock loc $ text "A Haddock comment cannot appear in this position and will be ignored." PsWarnHaddockIgnoreMulti loc - -> mkParserWarn Opt_WarnInvalidHaddock loc $ + -> mk_parser_warn df Opt_WarnInvalidHaddock loc $ text "Multiple Haddock comments for a single entity are not allowed." $$ text "The extraneous comment will be ignored." PsWarnStarBinder loc - -> mkParserWarn Opt_WarnStarBinder loc $ + -> mk_parser_warn df Opt_WarnStarBinder loc $ text "Found binding occurrence of" <+> quotes (text "*") <+> text "yet StarIsType is enabled." $$ text "NB. To use (or export) this operator in" @@ -82,7 +87,7 @@ pprWarning = \case $$ text " including the definition module, you must qualify it." PsWarnStarIsType loc - -> mkParserWarn Opt_WarnStarIsType loc $ + -> mk_parser_warn df Opt_WarnStarIsType loc $ text "Using" <+> quotes (text "*") <+> text "(or its Unicode variant) to mean" <+> quotes (text "Data.Kind.Type") @@ -92,7 +97,7 @@ pprWarning = \case <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." PsWarnImportPreQualified loc - -> mkParserWarn Opt_WarnPrepositiveQualifiedModule loc $ + -> mk_parser_warn df Opt_WarnPrepositiveQualifiedModule loc $ text "Found" <+> quotes (text "qualified") <+> text "in prepositive position" $$ text "Suggested fix: place " <+> quotes (text "qualified") @@ -100,7 +105,7 @@ pprWarning = \case $$ text "To allow this, enable language extension 'ImportQualifiedPost'" PsWarnOperatorWhitespaceExtConflict loc sym - -> mkParserWarn Opt_WarnOperatorWhitespaceExtConflict loc $ + -> mk_parser_warn df Opt_WarnOperatorWhitespaceExtConflict loc $ let mk_prefix_msg operator_symbol extension_name syntax_meaning = text "The prefix use of a" <+> quotes (text operator_symbol) <+> text "would denote" <+> text syntax_meaning @@ -115,7 +120,7 @@ pprWarning = \case PsWarnOperatorWhitespace loc sym occ_type - -> mkParserWarn Opt_WarnOperatorWhitespace loc $ + -> mk_parser_warn df Opt_WarnOperatorWhitespace loc $ let mk_msg occ_type_str = text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym) <+> text "might be repurposed as special syntax" @@ -127,8 +132,8 @@ pprWarning = \case OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix" OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" -pprError :: PsError -> MsgEnvelope DiagnosticMessage -pprError err = mkParserErr (errLoc err) $ vcat +mkParserErr :: PsError -> MsgEnvelope DiagnosticMessage +mkParserErr err = mk_parser_err (errLoc err) $ vcat (pp_err (errDesc err) : map pp_hint (errHints err)) pp_err :: PsErrorDesc -> SDoc diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index a80620eed4..c45cae45ca 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -48,6 +48,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Monad +import GHC.Utils.Error import GHC.Utils.Exception as Exception import GHC.Data.StringBuffer @@ -90,7 +91,7 @@ getImports popts implicit_prelude buf filename source_filename = do -- don't log warnings: they'll be reported when we parse the file -- for real. See #2500. if not (isEmptyBag errs) - then throwIO $ mkSrcErr (fmap pprError errs) + then throwIO $ mkSrcErr (fmap mkParserErr errs) else let hsmod = unLoc rdr_module mb_mod = hsmodName hsmod @@ -314,7 +315,7 @@ checkProcessArgsResult flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags where mkMsg (L loc flag) - = mkPlainMsgEnvelope ErrorWithoutFlag loc $ + = mkPlainErrorMsgEnvelope loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) @@ -358,7 +359,7 @@ optionsErrorMsgs unhandled_flags flags_lines _filename , L l f' <- flags_lines , f == f' ] mkMsg (L flagSpan flag) = - mkPlainMsgEnvelope ErrorWithoutFlag flagSpan $ + mkPlainErrorMsgEnvelope flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag optionsParseError :: String -> SrcSpan -> a -- #15053 @@ -371,4 +372,4 @@ optionsParseError str loc = throwErr :: SrcSpan -> SDoc -> a -- #15053 throwErr loc doc = - throw $ mkSrcErr $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag loc doc + throw $ mkSrcErr $ unitBag $ mkPlainErrorMsgEnvelope loc doc diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 412d221794..abdc5e8328 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -75,7 +75,7 @@ lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds = {-# SCC "StgLint" #-} - case initL this_mod unarised opts top_level_binds (lint_binds binds) of + case initL dflags this_mod unarised opts top_level_binds (lint_binds binds) of Nothing -> return () Just msg -> do @@ -247,6 +247,7 @@ The Lint monad newtype LintM a = LintM { unLintM :: Module -> LintFlags + -> DynFlags -> StgPprOpts -- Pretty-printing options -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope @@ -281,16 +282,16 @@ pp_binders bs pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] -initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc -initL this_mod unarised opts locals (LintM m) = do - let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag +initL :: DynFlags -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc +initL dflags this_mod unarised opts locals (LintM m) = do + let (_, errs) = m this_mod (LintFlags unarised) dflags opts [] locals emptyBag if isEmptyBag errs then Nothing else Just (vcat (punctuate blankLine (bagToList errs))) instance Applicative LintM where - pure a = LintM $ \_mod _lf _opts _loc _scope errs -> (a, errs) + pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs) (<*>) = ap (*>) = thenL_ @@ -299,14 +300,14 @@ instance Monad LintM where (>>) = (*>) thenL :: LintM a -> (a -> LintM b) -> LintM b -thenL m k = LintM $ \mod lf opts loc scope errs - -> case unLintM m mod lf opts loc scope errs of - (r, errs') -> unLintM (k r) mod lf opts loc scope errs' +thenL m k = LintM $ \mod lf dflags opts loc scope errs + -> case unLintM m mod lf dflags opts loc scope errs of + (r, errs') -> unLintM (k r) mod lf dflags opts loc scope errs' thenL_ :: LintM a -> LintM b -> LintM b -thenL_ m k = LintM $ \mod lf opts loc scope errs - -> case unLintM m mod lf opts loc scope errs of - (_, errs') -> unLintM k mod lf opts loc scope errs' +thenL_ m k = LintM $ \mod lf dflags opts loc scope errs + -> case unLintM m mod lf dflags opts loc scope errs of + (_, errs') -> unLintM k mod lf dflags opts loc scope errs' checkL :: Bool -> SDoc -> LintM () checkL True _ = return () @@ -351,37 +352,37 @@ checkPostUnariseId id = is_sum <|> is_tuple <|> is_void addErrL :: SDoc -> LintM () -addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc) +addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) -addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc -addErr errs_so_far msg locs +addErr :: DynFlags -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc +addErr dflags errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in mkLocMessage (Err.mkMCDiagnostic WarningWithoutFlag) + in mkLocMessage (Err.mkMCDiagnostic dflags WarningWithoutFlag) l (hdr $$ msg) mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a -addLoc extra_loc m = LintM $ \mod lf opts loc scope errs - -> unLintM m mod lf opts (extra_loc:loc) scope errs +addLoc extra_loc m = LintM $ \mod lf dflags opts loc scope errs + -> unLintM m mod lf dflags opts (extra_loc:loc) scope errs addInScopeVars :: [Id] -> LintM a -> LintM a -addInScopeVars ids m = LintM $ \mod lf opts loc scope errs +addInScopeVars ids m = LintM $ \mod lf dflags opts loc scope errs -> let new_set = mkVarSet ids - in unLintM m mod lf opts loc (scope `unionVarSet` new_set) errs + in unLintM m mod lf dflags opts loc (scope `unionVarSet` new_set) errs getLintFlags :: LintM LintFlags -getLintFlags = LintM $ \_mod lf _opts _loc _scope errs -> (lf, errs) +getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs) getStgPprOpts :: LintM StgPprOpts -getStgPprOpts = LintM $ \_mod _lf opts _loc _scope errs -> (opts, errs) +getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs) checkInScope :: Id -> LintM () -checkInScope id = LintM $ \mod _lf _opts loc scope errs +checkInScope id = LintM $ \mod _lf dflags _opts loc scope errs -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then - ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id), + ((), addErr dflags errs (hsep [ppr id, dcolon, ppr (idType id), text "is out of scope"]) loc) else ((), errs) diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs index c9cd24cf89..522c50f354 100644 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -310,7 +310,7 @@ builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do logInfo logger dflags $ withPprStyle defaultUserStyle msg log_loop chan t BuildError loc msg -> do - putLogMsg logger dflags (mkMCDiagnostic ErrorWithoutFlag) (mkSrcSpan loc loc) + putLogMsg logger dflags errorDiagnostic (mkSrcSpan loc loc) $ withPprStyle defaultUserStyle msg log_loop chan t EOF -> diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index 23cad15976..abb58cd58b 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -66,9 +66,10 @@ import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.FV ( fvVarList, unionFV ) -import Control.Monad ( when, unless ) +import Control.Monad ( unless, when ) import Data.Foldable ( toList ) import Data.List ( partition, mapAccumL, sortBy, unfoldr ) +import Data.Traversable ( for ) import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) @@ -758,24 +759,21 @@ machinery, in cases where it is definitely going to be a no-op. mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt - = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct - ; maybeReportError ctxt err + = mapM_ $ \ct -> do { let err = mkUserTypeError ct + ; maybeReportError ctxt ct err ; addDeferredBinding ctxt err ct } -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage) -mkUserTypeError ctxt ct = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct - $ important - $ pprUserTypeErrorTy - $ case getUserTypeErrorMsg ct of - Just msg -> msg - Nothing -> pprPanic "mkUserTypeError" (ppr ct) - +mkUserTypeError :: Ct -> Report +mkUserTypeError ct = important + $ pprUserTypeErrorTy + $ case getUserTypeErrorMsg ct of + Just msg -> msg + Nothing -> pprPanic "mkUserTypeError" (ppr ct) mkGivenErrorReporter :: Reporter -- See Note [Given errors] mkGivenErrorReporter ctxt cts = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct - ; dflags <- getDynFlags ; let (implic:_) = cec_encl ctxt -- Always non-empty when mkGivenErrorReporter is called ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic)) @@ -788,7 +786,9 @@ mkGivenErrorReporter ctxt cts report = important inaccessible_msg `mappend` mk_relevant_bindings binds_msg - ; err <- mkEqErr_help (WarningWithFlag Opt_WarnInaccessibleCode) dflags ctxt report ct' ty1 ty2 + ; report <- mkEqErr_help ctxt report ct' ty1 ty2 + ; err <- mkErrorReport (WarningWithFlag Opt_WarnInaccessibleCode) ctxt + (ctLocEnv (ctLoc ct')) report ; traceTc "mkGivenErrorReporter" (ppr ct) ; reportDiagnostic err } @@ -838,7 +838,7 @@ pattern match which binds some equality constraints. If we find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM Report) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, @@ -847,7 +847,8 @@ mkGroupReporter mk_err ctxt cts = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) -- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM Report) + -> Reporter mkSuppressReporter mk_err ctxt cts = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -865,15 +866,15 @@ cmp_loc ct1 ct2 = get ct1 `compare` get ct2 -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter -reportGroup mk_err ctxt cts = - ASSERT( not (null cts)) +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter +reportGroup mk_err ctxt cts + | ct1 : _ <- cts = do { err <- mk_err ctxt cts ; traceTc "About to maybeReportErr" $ vcat [ text "Constraint:" <+> ppr cts , text "cec_suppress =" <+> ppr (cec_suppress ctxt) , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ] - ; maybeReportError ctxt err + ; maybeReportError ctxt ct1 err -- But see Note [Always warn with -fdefer-type-errors] ; traceTc "reportGroup" (ppr cts) ; mapM_ (addDeferredBinding ctxt err) cts } @@ -881,51 +882,34 @@ reportGroup mk_err ctxt cts = -- Redundant if we are going to abort compilation, -- but that's hard to know for sure, and if we don't -- abort, we need bindings for all (e.g. #12156) + | otherwise = panic "empty reportGroup" -- like reportGroup, but does not actually report messages. It still adds -- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter suppressGroup mk_err ctxt cts = do { err <- mk_err ctxt cts ; traceTc "Suppressing errors for" (ppr cts) ; mapM_ (addDeferredBinding ctxt err) cts } -maybeReportError :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> TcM () --- Report the error and/or make a deferred binding for it -maybeReportError ctxt msg - | cec_suppress ctxt -- Some worse error has occurred; - = return () -- so suppress this error/warning - +maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM () +maybeReportError ctxt ct report | Just reason <- cec_defer_type_errors ctxt - = reportDiagnostic (reclassify reason msg) + = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic + do msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report + reportDiagnostic msg + | otherwise - = return () - where - -- Reclassifies a 'DiagnosticMessage', by explicitly setting its 'Severity' and - -- 'DiagnosticReason'. This function has to be considered unsafe and local to this - -- module, and it's a temporary stop-gap in the context of #18516. In particular, - -- diagnostic messages should have both their 'DiagnosticReason' and 'Severity' computed - -- \"at birth\": the former is statically computer, the latter is computed using the - -- 'DynFlags' in scope at the time of construction. However, due to the intricacies of - -- the current error-deferring logic, we are not always able to enforce this invariant - -- and we rather have to change one or the other /a posteriori/. - reclassify :: DiagnosticReason - -> MsgEnvelope DiagnosticMessage - -> MsgEnvelope DiagnosticMessage - reclassify rea msg = - let set_reason r m = m { errMsgDiagnostic = (errMsgDiagnostic m) { diagReason = r } } - set_severity s m = m { errMsgSeverity = s } - in set_severity (defaultReasonSeverity rea) . set_reason rea $ msg - -addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> Ct -> TcM () + = return () -- nothing to report + +addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct | deferringAnyBindings ctxt , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct -- Only add deferred bindings for Wanted constraints - = do { dflags <- getDynFlags - ; let err_tm = mkErrorTerm dflags pred err - ev_binds_var = cec_binds ctxt + = do { err_tm <- mkErrorTerm ctxt (ctLoc ct) pred err + ; let ev_binds_var = cec_binds ctxt ; case dest of EvVarDest evar @@ -939,13 +923,17 @@ addDeferredBinding ctxt err ct | otherwise -- Do not set any evidence for Given/Derived = return () -mkErrorTerm :: DynFlags -> Type -- of the error term - -> MsgEnvelope DiagnosticMessage -> EvTerm -mkErrorTerm dflags ty err = evDelayedError ty err_fs - where - err_msg = pprLocMsgEnvelope err - err_fs = mkFastString $ showSDoc dflags $ - err_msg $$ text "(deferred type error)" +mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type -- of the error term + -> Report -> TcM EvTerm +mkErrorTerm ctxt ct_loc ty report + = do { msg <- mkErrorReport ErrorWithoutFlag ctxt (ctLocEnv ct_loc) report + -- This will be reported at runtime, so we always want "error:" in the report, never "warning:" + ; dflags <- getDynFlags + ; let err_msg = pprLocMsgEnvelope msg + err_fs = mkFastString $ showSDoc dflags $ + err_msg $$ text "(deferred type error)" + + ; return $ evDelayedError ty err_fs } tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -- Use the first reporter in the list whose predicate says True @@ -1015,10 +1003,6 @@ pprWithArising (ct:cts) ppr_one ct' = hang (parens (pprType (ctPred ct'))) 2 (pprCtLoc (ctLoc ct')) -mkErrorMsgFromCt :: DiagnosticReason -> ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DiagnosticMessage) -mkErrorMsgFromCt rea ctxt ct report - = mkErrorReport rea ctxt (ctLocEnv (ctLoc ct)) report - mkErrorReport :: DiagnosticReason -> ReportErrCtxt -> TcLclEnv @@ -1033,6 +1017,17 @@ mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs) (vcat $ relevant_bindings ++ valid_subs) } +-- This version does not include the context +mkErrorReportNC :: DiagnosticReason + -> TcLclEnv + -> Report + -> TcM (MsgEnvelope DiagnosticMessage) +mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs) + = mkDecoratedSDocAt rea (RealSrcSpan (tcl_loc tcl_env) Nothing) + (vcat important) + O.empty + (vcat $ relevant_bindings ++ valid_subs) + type UserGiven = Implication getUserGivens :: ReportErrCtxt -> [UserGiven] @@ -1051,12 +1046,9 @@ would get errors without -fdefer-type-errors, but if we suppress any of them you might get a runtime error that wasn't warned about at compile time. -This is an easy design choice to change; just flip the order of the -first two equations for maybeReportError - To be consistent, we should also report multiple warnings from a single location in mkGroupReporter, when -fdefer-type-errors is on. But that -is perhaps a bit *over*-consistent! Again, an easy choice to change. +is perhaps a bit *over*-consistent! With #10283, you can now opt out of deferred type error warnings. @@ -1127,13 +1119,12 @@ solve it. ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage) +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM Report mkIrredErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig) - ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 $ - msg `mappend` mk_relevant_bindings binds_msg } + ; return $ msg `mappend` mk_relevant_bindings binds_msg } where (ct1:_) = cts @@ -1183,14 +1174,15 @@ mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ ; imp_info <- getImports ; curr_mod <- getModule ; hpt <- getHpt - ; let mk_err rea = do - mkDecoratedSDocAt rea (RealSrcSpan (tcl_loc lcl_env) Nothing) - out_of_scope_msg O.empty - (unknownNameSuggestions dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) - - ; maybeAddDeferredBindings ctxt hole mk_err - ; whenNotDeferring (cec_out_of_scope_holes ctxt) mk_err + ; let err = important out_of_scope_msg `mappend` + (mk_relevant_bindings $ + unknownNameSuggestions dflags hpt curr_mod rdr_env + (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) + + ; maybeAddDeferredBindings ctxt hole err + ; for (cec_out_of_scope_holes ctxt) $ \ rea -> + mkErrorReportNC rea lcl_env err + -- Use NC variant: the context is generally not helpful here } where herald | isDataOcc occ = text "Data constructor not in scope:" @@ -1223,18 +1215,15 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ then validHoleFits ctxt tidy_simples hole else return (ctxt, empty) - ; let mk_err rea = - mkErrorReport rea ctxt lcl_env $ - important hole_msg `mappend` - mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend` - valid_hole_fits sub_msg + ; let err = important hole_msg `mappend` + mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend` + valid_hole_fits sub_msg - ; maybeAddDeferredBindings ctxt hole mk_err + ; maybeAddDeferredBindings ctxt hole err ; let holes | ExprHole _ <- sort = cec_expr_holes ctxt | otherwise = cec_type_holes ctxt - ; whenNotDeferring holes mk_err - + ; for holes $ \ rea -> mkErrorReport rea ctxt lcl_env err } where @@ -1293,10 +1282,6 @@ mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ quotes (ppr tv) <+> text "is a coercion variable" --- | Similar in spirit to 'whenIsJust', but the action returns a value of type @Maybe b@. -whenNotDeferring :: Monad m => Maybe a -> (a -> m b) -> m (Maybe b) -whenNotDeferring = flip traverse - {- Note [Adding deferred bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1313,18 +1298,16 @@ so that the correct 'Severity' can be computed out of that later on. -- See Note [Adding deferred bindings]. maybeAddDeferredBindings :: ReportErrCtxt -> Hole - -> (DiagnosticReason -> TcM (MsgEnvelope DiagnosticMessage)) + -> Report -> TcM () -maybeAddDeferredBindings ctxt hole mk_err = do +maybeAddDeferredBindings ctxt hole report = do case hole_sort hole of ExprHole (HER ref ref_ty _) -> do -- Only add bindings for holes in expressions -- not for holes in partial type signatures -- cf. addDeferredBinding when (deferringAnyBindings ctxt) $ do - dflags <- getDynFlags - err <- mk_err ErrorWithoutFlag - let err_tm = mkErrorTerm dflags ref_ty err + err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. -- See Note [Holes] in GHC.Tc.Types.Constraint writeMutVar ref err_tm @@ -1365,7 +1348,7 @@ givenConstraintsMsg ctxt = 2 (vcat $ map pprConstraint constraints) ---------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage) +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM Report mkIPErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 @@ -1378,8 +1361,7 @@ mkIPErr ctxt cts | otherwise = couldNotDeduce givens (preds, orig) - ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 $ - msg `mappend` mk_relevant_bindings binds_msg } + ; return $ msg `mappend` mk_relevant_bindings binds_msg } where (ct1:_) = cts @@ -1442,11 +1424,11 @@ any more. So we don't assert that it is. -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage) +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM Report mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage) +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM Report mkEqErr1 ctxt ct -- Wanted or derived; -- givens handled in mkGivenErrorReporter = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct @@ -1455,11 +1437,10 @@ mkEqErr1 ctxt ct -- Wanted or derived; ; let coercible_msg = case ctEqRel ct of NomEq -> empty ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2 - ; dflags <- getDynFlags ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) ; let report = mconcat [ important coercible_msg , mk_relevant_bindings binds_msg] - ; mkEqErr_help ErrorWithoutFlag dflags ctxt report ct ty1 ty2 } + ; mkEqErr_help ctxt report ct ty1 ty2 } where (ty1, ty2) = getEqPredTys (ctPred ct) @@ -1510,77 +1491,78 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 | otherwise = False -mkEqErr_help :: DiagnosticReason -> DynFlags -> ReportErrCtxt -> Report +mkEqErr_help :: ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage) -mkEqErr_help rea dflags ctxt report ct ty1 ty2 + -> TcType -> TcType -> TcM Report +mkEqErr_help ctxt report ct ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 - = mkTyVarEqErr rea dflags ctxt report ct tv1 ty2 + = mkTyVarEqErr ctxt report ct tv1 ty2 | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2 - = mkTyVarEqErr rea dflags ctxt report ct tv2 ty1 + = mkTyVarEqErr ctxt report ct tv2 ty1 | otherwise - = reportEqErr rea ctxt report ct ty1 ty2 + = return $ reportEqErr ctxt report ct ty1 ty2 -reportEqErr :: DiagnosticReason -> ReportErrCtxt -> Report +reportEqErr :: ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage) -reportEqErr rea ctxt report ct ty1 ty2 - = mkErrorMsgFromCt rea ctxt ct (mconcat [misMatch, report, eqInfo]) + -> TcType -> TcType -> Report +reportEqErr ctxt report ct ty1 ty2 + = mconcat [misMatch, report, eqInfo] where misMatch = misMatchOrCND False ctxt ct ty1 ty2 eqInfo = mkEqInfoMsg ct ty1 ty2 -mkTyVarEqErr, mkTyVarEqErr' - :: DiagnosticReason - -> DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> TcM (MsgEnvelope DiagnosticMessage) +mkTyVarEqErr :: ReportErrCtxt -> Report -> Ct + -> TcTyVar -> TcType -> TcM Report -- tv1 and ty2 are already tidied -mkTyVarEqErr reason dflags ctxt report ct tv1 ty2 +mkTyVarEqErr ctxt report ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) - ; mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2 } + ; dflags <- getDynFlags + ; return $ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 } -mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2 +mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct + -> TcTyVar -> TcType -> Report +mkTyVarEqErr' dflags ctxt report ct tv1 ty2 | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) || ctEqRel ct == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) - = mkErrorMsgFromCt reason ctxt ct $ mconcat - [ headline_msg - , extraTyVarEqInfo ctxt tv1 ty2 - , suggestAddSig ctxt ty1 ty2 - , report - ] + = mconcat [ headline_msg + , extraTyVarEqInfo ctxt tv1 ty2 + , suggestAddSig ctxt ty1 ty2 + , report + ] | CTE_Occurs <- occ_check_expand -- We report an "occurs check" even for a ~ F t a, where F is a type -- function; it's not insoluble (because in principle F could reduce) -- but we have certainly been unable to solve it -- See Note [Occurs check error] in GHC.Tc.Solver.Canonical - = do { let extra2 = mkEqInfoMsg ct ty1 ty2 - - interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ - filter isTyVar $ - fvVarList $ - tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 - extra3 = mk_relevant_bindings $ - ppWhen (not (null interesting_tyvars)) $ - hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) - interesting_tyvars) - - tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) - ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ - mconcat [headline_msg, extra2, extra3, report] } + = let extra2 = mkEqInfoMsg ct ty1 ty2 + + interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $ + filter isTyVar $ + fvVarList $ + tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2 + extra3 = mk_relevant_bindings $ + ppWhen (not (null interesting_tyvars)) $ + hang (text "Type variable kinds:") 2 $ + vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) + interesting_tyvars) + + tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) + in + mconcat [headline_msg, extra2, extra3, report] | CTE_Bad <- occ_check_expand - = do { let msg = vcat [ text "Cannot instantiate unification variable" - <+> quotes (ppr tv1) - , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] + = let msg = vcat [ text "Cannot instantiate unification variable" + <+> quotes (ppr tv1) + , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ] + in -- Unlike the other reports, this discards the old 'report_important' -- instead of augmenting it. This is because the details are not likely -- to be helpful since this is just an unimplemented feature. - ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat [ headline_msg, important msg, report ] } + mconcat [ headline_msg, important msg, report ] -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably @@ -1589,35 +1571,35 @@ mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2 | (implic:_) <- cec_encl ctxt , Implic { ic_skols = skols } <- implic , tv1 `elem` skols - = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat - [ misMatchMsg ctxt ct ty1 ty2 - , extraTyVarEqInfo ctxt tv1 ty2 - , report - ] + = mconcat [ misMatchMsg ctxt ct ty1 ty2 + , extraTyVarEqInfo ctxt tv1 ty2 + , report + ] -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context , Implic { ic_skols = skols, ic_info = skol_info } <- implic , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols) - = do { let msg = misMatchMsg ctxt ct ty1 ty2 - esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols - <+> pprQuotedList esc_skols - , text "would escape" <+> - if isSingleton esc_skols then text "its scope" - else text "their scope" ] - tv_extra = important $ - vcat [ nest 2 $ esc_doc - , sep [ (if isSingleton esc_skols - then text "This (rigid, skolem)" <+> - what <+> text "variable is" - else text "These (rigid, skolem)" <+> - what <+> text "variables are") - <+> text "bound by" - , nest 2 $ ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] ] - ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct (mconcat [msg, tv_extra, report]) } + = let msg = misMatchMsg ctxt ct ty1 ty2 + esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols + <+> pprQuotedList esc_skols + , text "would escape" <+> + if isSingleton esc_skols then text "its scope" + else text "their scope" ] + tv_extra = important $ + vcat [ nest 2 $ esc_doc + , sep [ (if isSingleton esc_skols + then text "This (rigid, skolem)" <+> + what <+> text "variable is" + else text "These (rigid, skolem)" <+> + what <+> text "variables are") + <+> text "bound by" + , nest 2 $ ppr skol_info + , nest 2 $ text "at" <+> + ppr (tcl_loc (ic_env implic)) ] ] + in + mconcat [msg, tv_extra, report] -- Nastiest case: attempt to unify an untouchable variable -- So tv is a meta tyvar (or started that way before we @@ -1628,21 +1610,21 @@ mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2 , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic = ASSERT2( not (isTouchableMetaTyVar lvl tv1) , ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables] - do { let msg = misMatchMsg ctxt ct ty1 ty2 - tclvl_extra = important $ - nest 2 $ - sep [ quotes (ppr tv1) <+> text "is untouchable" - , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given - , nest 2 $ text "bound by" <+> ppr skol_info - , nest 2 $ text "at" <+> - ppr (tcl_loc (ic_env implic)) ] - tv_extra = extraTyVarEqInfo ctxt tv1 ty2 - add_sig = suggestAddSig ctxt ty1 ty2 - ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat - [msg, tclvl_extra, tv_extra, add_sig, report] } + let msg = misMatchMsg ctxt ct ty1 ty2 + tclvl_extra = important $ + nest 2 $ + sep [ quotes (ppr tv1) <+> text "is untouchable" + , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given + , nest 2 $ text "bound by" <+> ppr skol_info + , nest 2 $ text "at" <+> + ppr (tcl_loc (ic_env implic)) ] + tv_extra = extraTyVarEqInfo ctxt tv1 ty2 + add_sig = suggestAddSig ctxt ty1 ty2 + in + mconcat [msg, tclvl_extra, tv_extra, add_sig, report] | otherwise - = reportEqErr ErrorWithoutFlag ctxt report ct (mkTyVarTy tv1) ty2 + = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2 -- This *can* happen (#6123, and test T2627b) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function. @@ -1733,10 +1715,9 @@ pp_givens givens -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage) -mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct report +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM Report +mkBlockedEqErr _ (ct:_) = return $ important msg where - report = important msg msg = vcat [ hang (text "Cannot use equality for substitution:") 2 (ppr (ctPred ct)) , text "Doing so would be ill-kinded." ] @@ -2340,12 +2321,11 @@ Warn of loopy local equalities that were dropped. ************************************************************************ -} -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage) +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM Report mkDictErr ctxt cts = ASSERT( not (null cts) ) do { inst_envs <- tcGetInstEnvs - ; let (ct1:_) = cts -- ct1 just for its location - min_cts = elim_superclasses cts + ; let min_cts = elim_superclasses cts lookups = map (lookup_cls_inst inst_envs) min_cts (no_inst_cts, overlap_cts) = partition is_no_inst lookups @@ -2354,8 +2334,8 @@ mkDictErr ctxt cts -- But we report only one of them (hence 'head') because they all -- have the same source-location origin, to try avoid a cascade -- of error from one location - ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) - ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 (important err) } + ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts)) + ; return $ important err } where no_givens = null (getUserGivens ctxt) @@ -2377,20 +2357,20 @@ mkDictErr ctxt cts elim_superclasses cts = mkMinimalBySCs ctPred cts mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult) - -> TcM (ReportErrCtxt, SDoc) + -> TcM SDoc -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred) mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) | null matches -- No matches but perhaps several unifiers - = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct + = do { (_, binds_msg, ct) <- relevantBindings True ctxt ct ; candidate_insts <- get_candidate_instances - ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) } + ; return (cannot_resolve_msg ct candidate_insts binds_msg) } | null unsafe_overlapped -- Some matches => overlap errors - = return (ctxt, overlap_msg) + = return overlap_msg | otherwise - = return (ctxt, safe_haskell_msg) + = return safe_haskell_msg where orig = ctOrigin ct pred = ctPred ct diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 8833abe03d..0883ba1c8b 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -212,7 +212,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env - err_msg = mkPlainMsgEnvelope ErrorWithoutFlag loc $ + err_msg = mkPlainErrorMsgEnvelope loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod pair :: (Module, SrcSpan) @@ -3148,5 +3148,5 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ recordUnsafeInfer pluginUnsafe where unsafeText = "Use of plugins makes the module unsafe" - pluginUnsafe = unitBag ( mkPlainMsgEnvelope WarningWithoutFlag noSrcSpan + pluginUnsafe = unitBag ( mkPlainMsgEnvelope dflags WarningWithoutFlag noSrcSpan (Outputable.text unsafeText) ) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 6fb31e2d7d..a8f6cbbc19 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -1033,8 +1033,9 @@ mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DiagnosticMessage) mkLongErrAt loc msg extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; + dflags <- getDynFlags ; let msg' = pprWithUnitState unit_state msg in - return $ mkLongMsgEnvelope ErrorWithoutFlag loc printer msg' extra } + return $ mkLongMsgEnvelope dflags ErrorWithoutFlag loc printer msg' extra } mkDecoratedSDocAt :: DiagnosticReason -> SrcSpan @@ -1048,11 +1049,12 @@ mkDecoratedSDocAt :: DiagnosticReason mkDecoratedSDocAt reason loc important context extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; + dflags <- getDynFlags ; let f = pprWithUnitState unit_state errDoc = [important, context, extra] errDoc' = DiagnosticMessage (mkDecorated $ map f errDoc) reason in - return $ mkMsgEnvelope (defaultReasonSeverity reason) loc printer errDoc' } + return $ mkMsgEnvelope dflags loc printer errDoc' } addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic @@ -1558,7 +1560,8 @@ add_diagnostic reason msg extra_info add_diagnostic_at :: DiagnosticReason -> SrcSpan -> SDoc -> SDoc -> TcRn () add_diagnostic_at reason loc msg extra_info = do { printer <- getPrintUnqualified ; - let { dia = mkLongMsgEnvelope reason + dflags <- getDynFlags ; + let { dia = mkLongMsgEnvelope dflags reason loc printer msg extra_info } ; reportDiagnostic dia } diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 7edf599c9f..48cb9eaedd 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -19,7 +19,6 @@ module GHC.Types.Error , MessageClass (..) , Severity (..) - , mkMCDiagnostic , Diagnostic (..) , DiagnosticMessage (..) , DiagnosticReason (..) @@ -33,14 +32,8 @@ module GHC.Types.Error , mkLocMessage , mkLocMessageAnn , getCaretDiagnostic - -- * Constructing individual diagnostic messages - , mkMsgEnvelope - , mkPlainMsgEnvelope - , mkLongMsgEnvelope - , mkShortMsgEnvelope - , defaultReasonSeverity -- * Queries - , isErrorMessage + , isIntrinsicErrorMessage , isWarningMessage , getErrorMessages , getWarningMessages @@ -193,9 +186,9 @@ data DiagnosticReason instance Outputable DiagnosticReason where ppr = \case - WarningWithoutFlag -> text "WarningWithoutFlag" - WarningWithFlag wf -> text ("WarningWithFlag " ++ show wf) - ErrorWithoutFlag -> text "ErrorWithoutFlag" + WarningWithoutFlag -> text "WarningWithoutFlag" + WarningWithFlag wf -> text ("WarningWithFlag " ++ show wf) + ErrorWithoutFlag -> text "ErrorWithoutFlag" -- | An envelope for GHC's facts about a running program, parameterised over the -- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics. @@ -237,11 +230,6 @@ data MessageClass -- /especially/ when emitting compiler diagnostics, use the smart constructor. deriving (Eq, Show) --- | Make a 'MessageClass' for a given 'DiagnosticReason', without consulting the 'DynFlags'. --- This will not respect -Werror or warning suppression and so is probably wrong --- for any warning. -mkMCDiagnostic :: DiagnosticReason -> MessageClass -mkMCDiagnostic reason = MCDiagnostic (defaultReasonSeverity reason) reason -- | Used to describe warnings and errors -- o The message has a file\/line\/column heading, @@ -325,14 +313,6 @@ mkLocMessageAnn ann msg_class locn msg MCFatal -> text "fatal:" _ -> empty --- | Computes a severity from a reason in the absence of DynFlags. This will likely --- be wrong in the presence of -Werror. It will be removed in the context of #18516. -defaultReasonSeverity :: DiagnosticReason -> Severity -defaultReasonSeverity = \case - WarningWithoutFlag -> SevWarning - WarningWithFlag _flag -> SevWarning - ErrorWithoutFlag -> SevError - getMessageClassColour :: MessageClass -> Col.Scheme -> Col.PprColour getMessageClassColour (MCDiagnostic SevError _reason) = Col.sError getMessageClassColour (MCDiagnostic SevWarning _reason) = Col.sWarning @@ -416,76 +396,40 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis -- --- Creating MsgEnvelope(s) +-- Queries -- -mkMsgEnvelope - :: Diagnostic e - => Severity - -> SrcSpan - -> PrintUnqualified - -> e - -> MsgEnvelope e -mkMsgEnvelope sev locn print_unqual err - = MsgEnvelope { errMsgSpan = locn - , errMsgContext = print_unqual - , errMsgDiagnostic = err - , errMsgSeverity = sev - } - --- | A long (multi-line) diagnostic message. --- The 'Severity' will be calculated out of the 'DiagnosticReason', and will likely be --- incorrect in the presence of '-Werror'. -mkLongMsgEnvelope :: DiagnosticReason - -> SrcSpan - -> PrintUnqualified - -> SDoc - -> SDoc - -> MsgEnvelope DiagnosticMessage -mkLongMsgEnvelope rea locn unqual msg extra = - mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings - locn unqual (DiagnosticMessage (mkDecorated [msg,extra]) rea) - --- | A short (one-line) diagnostic message. --- Same 'Severity' considerations as for 'mkLongMsgEnvelope'. -mkShortMsgEnvelope :: DiagnosticReason - -> SrcSpan - -> PrintUnqualified - -> SDoc - -> MsgEnvelope DiagnosticMessage -mkShortMsgEnvelope rea locn unqual msg = - mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings - locn unqual (DiagnosticMessage (mkDecorated [msg]) rea) - --- | Variant that doesn't care about qualified/unqualified names. --- Same 'Severity' considerations as for 'mkLongMsgEnvelope'. -mkPlainMsgEnvelope :: DiagnosticReason - -> SrcSpan - -> SDoc - -> MsgEnvelope DiagnosticMessage -mkPlainMsgEnvelope rea locn msg = - mkMsgEnvelope (defaultReasonSeverity rea) -- wrong, but will be fixed in printOrThrowWarnings - locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) rea) +{- Note [Intrinsic And Extrinsic Failures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We distinguish between /intrinsic/ and /extrinsic/ failures. We classify in the former category +those diagnostics which are /essentially/ failures, and their nature can't be changed. This is +the case for 'ErrorWithoutFlag'. We classify as /extrinsic/ all those diagnostics (like fatal warnings) +which are born as warnings but which are still failures under particular 'DynFlags' settings. It's important +to be aware of such logic distinction, because when we are inside the typechecker or the desugarer, we are +interested about intrinsic errors, and to bail out as soon as we find one of them. Conversely, if we find +an /extrinsic/ one, for example because a particular 'WarningFlag' makes a warning and error, we /don't/ +want to bail out, that's still not the right time to do so: Rather, we want to first collect all the +diagnostics, and later classify and report them appropriately (in the driver). + +-} --- --- Queries --- -isErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool -isErrorMessage MsgEnvelope { errMsgSeverity = SevError } = True -isErrorMessage _ = False +-- | Returns 'True' if this is, intrinsically, a failure. See Note [Intrinsic And Extrinsic Failures]. +isIntrinsicErrorMessage :: Diagnostic e => MsgEnvelope e -> Bool +isIntrinsicErrorMessage = (==) ErrorWithoutFlag . diagnosticReason . errMsgDiagnostic isWarningMessage :: Diagnostic e => MsgEnvelope e -> Bool -isWarningMessage = not . isErrorMessage +isWarningMessage = not . isIntrinsicErrorMessage errorsFound :: Diagnostic e => Messages e -> Bool -errorsFound (Messages msgs) = any isErrorMessage msgs +errorsFound (Messages msgs) = any isIntrinsicErrorMessage msgs getWarningMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e) getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs getErrorMessages :: Diagnostic e => Messages e -> Bag (MsgEnvelope e) -getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs +getErrorMessages (Messages xs) = fst $ partitionBag isIntrinsicErrorMessage xs -- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the -- second the errors. diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index aba5e64357..2ee1763ebb 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -31,8 +31,9 @@ module GHC.Utils.Error ( -- ** Construction emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, - mkMsgEnvelope, mkPlainMsgEnvelope, mkLongMsgEnvelope, - mkMCDiagnostic, + mkMsgEnvelope, mkPlainMsgEnvelope, mkPlainErrorMsgEnvelope, + mkShortMsgEnvelope, mkShortErrorMsgEnvelope, mkLongMsgEnvelope, + mkMCDiagnostic, errorDiagnostic, diagReasonSeverity, -- * Utilities doIfSet, doIfSet_dyn, @@ -80,6 +81,106 @@ import Control.Monad.Catch as MC (handle) import GHC.Conc ( getAllocationCounter ) import System.CPUTime +-- | Computes the /right/ 'Severity' for the input 'DiagnosticReason' out of +-- the 'DynFlags'. This function /has/ to be called when a diagnostic is constructed, +-- i.e. with a 'DynFlags' \"snapshot\" taken as close as possible to where a +-- particular diagnostic message is built, otherwise the computed 'Severity' might +-- not be correct, due to the mutable nature of the 'DynFlags' in GHC. +diagReasonSeverity :: DynFlags -> DiagnosticReason -> Severity +diagReasonSeverity dflags (WarningWithFlag wflag) | wopt_fatal wflag dflags = SevError + | otherwise = SevWarning +diagReasonSeverity dflags WarningWithoutFlag | gopt Opt_WarnIsError dflags = SevError + | otherwise = SevWarning +diagReasonSeverity _ ErrorWithoutFlag = SevError + + + +-- +-- Creating MsgEnvelope(s) +-- + +mk_msg_envelope + :: Diagnostic e + => Severity + -> SrcSpan + -> PrintUnqualified + -> e + -> MsgEnvelope e +mk_msg_envelope severity locn print_unqual err + = MsgEnvelope { errMsgSpan = locn + , errMsgContext = print_unqual + , errMsgDiagnostic = err + , errMsgSeverity = severity + } + +mkMsgEnvelope + :: Diagnostic e + => DynFlags + -> SrcSpan + -> PrintUnqualified + -> e + -> MsgEnvelope e +mkMsgEnvelope dflags locn print_unqual err + = mk_msg_envelope (diagReasonSeverity dflags (diagnosticReason err)) locn print_unqual err + +-- | Make a 'MessageClass' for a given 'DiagnosticReason', consulting the 'DynFlags'. +mkMCDiagnostic :: DynFlags -> DiagnosticReason -> MessageClass +mkMCDiagnostic dflags reason = MCDiagnostic (diagReasonSeverity dflags reason) reason + +-- | Varation of 'mkMCDiagnostic' which can be used when we are /sure/ the +-- input 'DiagnosticReason' /is/ 'ErrorWithoutFlag'. +errorDiagnostic :: MessageClass +errorDiagnostic = MCDiagnostic SevError ErrorWithoutFlag + +-- | A long (multi-line) diagnostic message. +-- The 'Severity' will be calculated out of the 'DiagnosticReason', and will likely be +-- incorrect in the presence of '-Werror'. +mkLongMsgEnvelope :: DynFlags + -> DiagnosticReason + -> SrcSpan + -> PrintUnqualified + -> SDoc + -> SDoc + -> MsgEnvelope DiagnosticMessage +mkLongMsgEnvelope dflags rea locn unqual msg extra = + mkMsgEnvelope dflags locn unqual (DiagnosticMessage (mkDecorated [msg,extra]) rea) + +-- | A short (one-line) diagnostic message. +-- Same 'Severity' considerations as for 'mkLongMsgEnvelope'. +mkShortMsgEnvelope :: DynFlags + -> DiagnosticReason + -> SrcSpan + -> PrintUnqualified + -> SDoc + -> MsgEnvelope DiagnosticMessage +mkShortMsgEnvelope dflags rea locn unqual msg = + mkMsgEnvelope dflags locn unqual (DiagnosticMessage (mkDecorated [msg]) rea) + +mkShortErrorMsgEnvelope :: SrcSpan + -> PrintUnqualified + -> SDoc + -> MsgEnvelope DiagnosticMessage +mkShortErrorMsgEnvelope locn unqual msg = + mk_msg_envelope SevError locn unqual (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag) + +-- | Variant that doesn't care about qualified/unqualified names. +-- Same 'Severity' considerations as for 'mkLongMsgEnvelope'. +mkPlainMsgEnvelope :: DynFlags + -> DiagnosticReason + -> SrcSpan + -> SDoc + -> MsgEnvelope DiagnosticMessage +mkPlainMsgEnvelope dflags rea locn msg = + mkMsgEnvelope dflags locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) rea) + +-- | Variant of 'mkPlainMsgEnvelope' which can be used when we are /sure/ we +-- are constructing a diagnostic with a 'ErrorWithoutFlag' reason. +mkPlainErrorMsgEnvelope :: SrcSpan + -> SDoc + -> MsgEnvelope DiagnosticMessage +mkPlainErrorMsgEnvelope locn msg = + mk_msg_envelope SevError locn alwaysQualify (DiagnosticMessage (mkDecorated [msg]) ErrorWithoutFlag) + ------------------------- data Validity = IsValid -- ^ Everything is fine @@ -171,12 +272,12 @@ ifVerbose dflags val act errorMsg :: Logger -> DynFlags -> SDoc -> IO () errorMsg logger dflags msg - = putLogMsg logger dflags (mkMCDiagnostic ErrorWithoutFlag) noSrcSpan $ + = putLogMsg logger dflags errorDiagnostic noSrcSpan $ withPprStyle defaultErrStyle msg warningMsg :: Logger -> DynFlags -> SDoc -> IO () warningMsg logger dflags msg - = putLogMsg logger dflags (mkMCDiagnostic WarningWithoutFlag) noSrcSpan $ + = putLogMsg logger dflags (mkMCDiagnostic dflags WarningWithoutFlag) noSrcSpan $ withPprStyle defaultErrStyle msg fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO () |