diff options
-rw-r--r-- | compiler/GHC.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Driver/Backpack.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Driver/Env.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Driver/Errors.hs | 93 | ||||
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 40 | ||||
-rw-r--r-- | compiler/GHC/Driver/Make.hs | 55 | ||||
-rw-r--r-- | compiler/GHC/Driver/MakeFile.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Driver/Monad.hs | 1 | ||||
-rw-r--r-- | compiler/GHC/Driver/Pipeline.hs | 9 | ||||
-rw-r--r-- | compiler/GHC/HsToCore/Monad.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Iface/Rename.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Parser/Errors/Ppr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Parser/Header.hs | 40 | ||||
-rw-r--r-- | compiler/GHC/Tc/Module.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 15 | ||||
-rw-r--r-- | compiler/GHC/Types/Error.hs | 47 | ||||
-rw-r--r-- | compiler/GHC/Utils/Error.hs | 108 | ||||
-rw-r--r-- | compiler/ghc.cabal.in | 1 | ||||
-rw-r--r-- | ghc/GHCi/UI.hs | 1 | ||||
-rw-r--r-- | ghc/Main.hs | 1 | ||||
-rw-r--r-- | testsuite/tests/ghc-api/T18522-dbg-ppr.hs | 1 | ||||
-rw-r--r-- | testsuite/tests/parser/should_run/CountParserDeps.stdout | 3 | ||||
-rw-r--r-- | testsuite/tests/regalloc/regalloc_unit_tests.hs | 1 |
23 files changed, 237 insertions, 211 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs index 60b7a3e639..f52dc5b657 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -301,6 +301,7 @@ import GHC.Platform.Ways import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename , isSourceFilename, startPhase ) import GHC.Driver.Env +import GHC.Driver.Errors import GHC.Driver.CmdLine import GHC.Driver.Session hiding (WarnReason(..)) import GHC.Driver.Backend @@ -889,7 +890,7 @@ checkNewInteractiveDynFlags dflags0 = do -- the REPL. See #12356. if xopt LangExt.StaticPointers dflags0 then do liftIO $ printOrThrowWarnings dflags0 $ listToBag - [mkPlainWarnMsg dflags0 interactiveSrcSpan + [mkPlainWarnMsg interactiveSrcSpan $ text "StaticPointers is not supported in GHCi interactive expressions."] return $ xopt_unset dflags0 LangExt.StaticPointers else return dflags0 diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index 3a3f94d4f0..e5f1844474 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -30,6 +30,7 @@ import GHC.Driver.Ppr import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Env +import GHC.Driver.Errors import GHC.Parser import GHC.Parser.Header @@ -96,7 +97,7 @@ doBackpack [src_filename] = do (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) -- Cribbed from: preprocessFile / GHC.Driver.Pipeline - liftIO $ checkProcessArgsResult dflags unhandled_flags + liftIO $ checkProcessArgsResult unhandled_flags liftIO $ handleFlagWarnings dflags warns -- TODO: Preprocessing not implemented @@ -776,7 +777,6 @@ summariseDecl :: PackageName summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing = do hsc_env <- getSession - let dflags = hsc_dflags hsc_env -- TODO: this looks for modules in the wrong place r <- liftIO $ summariseModule hsc_env emptyModNodeMap -- GHC API recomp not supported @@ -786,7 +786,7 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing Nothing -- GHC API buffer support not supported [] -- No exclusions case r of - Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found")) + Nothing -> throwOneError (mkPlainErrMsg 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 1dfb88f8e4..5608c12b15 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -29,6 +29,7 @@ import GHC.Prelude import GHC.Driver.Ppr import GHC.Driver.Session +import GHC.Driver.Errors ( printOrThrowWarnings ) import GHC.Runtime.Context import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) ) @@ -59,7 +60,6 @@ import GHC.Data.Bag import GHC.Utils.Outputable import GHC.Utils.Monad -import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Misc diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs new file mode 100644 index 0000000000..de66b60a2c --- /dev/null +++ b/compiler/GHC/Driver/Errors.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ViewPatterns #-} + +module GHC.Driver.Errors ( + warningsToMessages + , printOrThrowWarnings + , printBagOfErrors + , isWarnMsgFatal + , handleFlagWarnings + ) where + +import GHC.Driver.Session +import GHC.Data.Bag +import GHC.Utils.Exception +import GHC.Utils.Error ( formatErrDoc, sortMsgBag ) +import GHC.Types.SourceError ( mkSrcErr ) +import GHC.Prelude +import GHC.Types.SrcLoc +import GHC.Types.Error +import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle ) +import qualified GHC.Driver.CmdLine as CmdLine + +-- | Converts a list of 'WarningMessages' into 'Messages', where the second element contains only +-- error, i.e. warnings that are considered fatal by GHC based on the input 'DynFlags'. +warningsToMessages :: DynFlags -> WarningMessages -> Messages +warningsToMessages dflags = + partitionBagWith $ \warn -> + case isWarnMsgFatal dflags warn of + Nothing -> Left warn + Just err_reason -> + Right warn{ errMsgSeverity = SevError + , errMsgReason = ErrReason err_reason } + +printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () +printBagOfErrors dflags bag_of_errors + = sequence_ [ let style = mkErrStyle unqual + ctx = initSDocContext dflags style + in putLogMsg dflags reason sev s $ withPprStyle style (formatErrDoc ctx doc) + | ErrMsg { errMsgSpan = s, + errMsgDoc = doc, + errMsgSeverity = sev, + errMsgReason = reason, + errMsgContext = unqual } <- sortMsgBag (Just dflags) + bag_of_errors ] + +handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO () +handleFlagWarnings dflags warns = do + let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns + + -- It would be nicer if warns :: [Located MsgDoc], but that + -- has circular import problems. + bag = listToBag [ mkPlainWarnMsg loc (text warn) + | CmdLine.Warn _ (L loc warn) <- warns' ] + + printOrThrowWarnings dflags bag + +-- | Checks if given 'WarnMsg' is a fatal warning. +isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) +isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag} + = if wopt_fatal wflag dflags + then Just (Just wflag) + else Nothing +isWarnMsgFatal dflags _ + = if gopt Opt_WarnIsError dflags + then Just Nothing + else Nothing + +-- Given a warn reason, check to see if it's associated -W opt is enabled +shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool +shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag + = wopt Opt_WarnDeprecatedFlags dflags +shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag + = wopt Opt_WarnUnrecognisedWarningFlags dflags +shouldPrintWarning _ _ + = True + +-- | Given a bag of warnings, turn them into an exception if +-- -Werror is enabled, or print them out otherwise. +printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings dflags warns = do + let (make_error, warns') = + mapAccumBagL + (\make_err warn -> + case isWarnMsgFatal dflags warn of + Nothing -> + (make_err, warn) + Just err_reason -> + (True, warn{ errMsgSeverity = SevError + , errMsgReason = ErrReason err_reason + })) + False warns + if make_error + then throwIO (mkSrcErr warns') + else printBagOfErrors dflags warns diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 22b0f1a07e..fe49f2a8e2 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -93,6 +93,7 @@ import GHC.Driver.Plugins import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Env +import GHC.Driver.Errors import GHC.Driver.CodeOutput import GHC.Driver.Config import GHC.Driver.Hooks @@ -562,7 +563,7 @@ tcRnModule' sum save_rn_syntax mod = do && wopt Opt_WarnMissingSafeHaskellMode dflags) $ logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $ - mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $ + mkPlainWarnMsg (getLoc (hpm_module mod)) $ warnMissingSafeHaskellMode tcg_res <- {-# SCC "Typecheck-Rename" #-} @@ -591,13 +592,13 @@ tcRnModule' sum save_rn_syntax mod = do | safeHaskell dflags == Sf_Safe -> return () | otherwise -> (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnSafe) $ - mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ + mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_res') False | safeHaskell dflags == Sf_Trustworthy && wopt Opt_WarnTrustworthySafe dflags -> (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ - mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ + mkPlainWarnMsg (trustworthyOnLoc dflags) $ errTwthySafe tcg_res') False -> return () return tcg_res' @@ -1119,22 +1120,22 @@ hscCheckSafeImports tcg_env = do case safeLanguageOn dflags of True -> do -- XSafe: we nuke user written RULES - logWarnings $ warns dflags (tcg_rules tcg_env') + logWarnings $ warns (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 dflags (tcg_rules tcg_env') + -> markUnsafeInfer tcg_env' $ warns (tcg_rules tcg_env') -- Trustworthy OR SafeInferred: with no RULES | otherwise -> return tcg_env' - warns dflags rules = listToBag $ map (warnRules dflags) rules + warns rules = listToBag $ map warnRules rules - warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg - warnRules dflags (L loc (HsRule { rd_name = n })) = - mkPlainWarnMsg dflags loc $ + warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg + warnRules (L loc (HsRule { rd_name = n })) = + mkPlainWarnMsg loc $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -1211,8 +1212,7 @@ checkSafeImports tcg_env cond' v1 v2 | imv_is_safe v1 /= imv_is_safe v2 = do - dflags <- getDynFlags - throwOneError $ mkPlainErrMsg dflags (imv_span v1) + throwOneError $ mkPlainErrMsg (imv_span v1) (text "Module" <+> ppr (imv_name v1) <+> (text $ "is imported both as a safe and unsafe import!")) | otherwise @@ -1280,7 +1280,7 @@ hscCheckSafe' m l = do iface <- lookup' m case iface of -- can't load iface to check trust! - Nothing -> throwOneError $ mkPlainErrMsg dflags l + Nothing -> throwOneError $ mkPlainErrMsg l $ text "Can't load the interface file for" <+> ppr m <> text ", to check that it can be safely imported" @@ -1314,20 +1314,20 @@ hscCheckSafe' m l = do state = hsc_units hsc_env inferredImportWarn = unitBag $ makeIntoWarning (Reason Opt_WarnInferredSafeImports) - $ mkWarnMsg dflags l (pkgQual state) + $ mkWarnMsg l (pkgQual state) $ sep [ text "Importing Safe-Inferred module " <> ppr (moduleName m) <> text " from explicitly Safe module" ] - pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $ + pkgTrustErr = unitBag $ mkErrMsg 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 $ mkErrMsg dflags l (pkgQual state) $ + modTrustErr = unitBag $ mkErrMsg l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -1366,7 +1366,6 @@ hscCheckSafe' m l = do -- | Check the list of packages are trusted. checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust pkgs = do - dflags <- getDynFlags hsc_env <- getHscEnv let errors = S.foldr go [] pkgs state = hsc_units hsc_env @@ -1374,7 +1373,7 @@ checkPkgTrust pkgs = do | unitIsTrusted $ unsafeLookupUnitId state pkg = acc | otherwise - = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state) + = (:acc) $ mkErrMsg noSrcSpan (pkgQual state) $ pprWithUnitState state $ text "The package (" <> ppr pkg @@ -1399,7 +1398,7 @@ markUnsafeInfer tcg_env whyUnsafe = do when (wopt Opt_WarnUnsafe dflags) (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $ - mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) + mkPlainWarnMsg (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 @@ -1925,7 +1924,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do case is of [L _ i] -> return i _ -> liftIO $ throwOneError $ - mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $ + mkPlainErrMsg noSrcSpan $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -1951,11 +1950,10 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do hscParseExpr :: String -> Hsc (LHsExpr GhcPs) hscParseExpr expr = do - hsc_env <- getHscEnv maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (BodyStmt _ expr _ _)) -> return expr - _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan + _ -> throwOneError $ mkPlainErrMsg 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 04354baf17..8c460b4b5c 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -59,6 +59,7 @@ import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Monad import GHC.Driver.Env +import GHC.Driver.Errors import GHC.Driver.Main import GHC.Parser.Header @@ -315,7 +316,7 @@ warnMissingHomeModules hsc_env mod_graph = (sep (map ppr missing)) warn = makeIntoWarning (Reason Opt_WarnMissingHomeModules) - (mkPlainErrMsg dflags noSrcSpan msg) + (mkPlainErrMsg noSrcSpan msg) -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch @@ -382,7 +383,7 @@ warnUnusedPackages = do let warn = makeIntoWarning (Reason Opt_WarnUnusedPackages) - (mkPlainErrMsg dflags noSrcSpan msg) + (mkPlainErrMsg noSrcSpan msg) msg = vcat [ text "The following packages were specified" <+> text "via -package or -package-id flags," , text "but were not needed for compilation:" @@ -2200,15 +2201,15 @@ warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () warnUnnecessarySourceImports sccs = do dflags <- getDynFlags when (wopt Opt_WarnUnusedImports dflags) - (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))) - where check dflags ms = + (logWarnings (listToBag (concatMap (check . flattenSCC) sccs))) + where check ms = let mods_in_this_cycle = map ms_mod_name ms in - [ warn dflags i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] + [ warn i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] - warn :: DynFlags -> Located ModuleName -> WarnMsg - warn dflags (L loc mod) = - mkPlainErrMsg dflags loc + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = + mkPlainErrMsg loc (text "Warning: {-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)) @@ -2277,14 +2278,14 @@ 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 $ mkPlainErrMsg dflags noSrcSpan $ + else return $ Left $ unitBag $ mkPlainErrMsg noSrcSpan $ text "can't find file:" <+> text file getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot (L rootLoc modl) obj_allowed maybe_buf excl_mods case maybe_summary of - Nothing -> return $ Left $ moduleNotFoundErr dflags modl + Nothing -> return $ Left $ moduleNotFoundErr modl Just s -> return s rootLoc = mkGeneralSrcSpan (fsLit "<command line>") @@ -2301,7 +2302,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots checkDuplicates root_map | allow_dup_roots = return () | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr dflags (emsModSummary <$> head dup_roots) + | otherwise = liftIO $ multiRootsErr (emsModSummary <$> head dup_roots) where dup_roots :: [[ExtendedModSummary]] -- Each at least of length 2 dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map @@ -2320,7 +2321,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots = if isSingleton summs then loop ss done else - do { multiRootsErr dflags (emsModSummary <$> rights summs) + do { multiRootsErr (emsModSummary <$> rights summs) ; return (ModNodeMap Map.empty) } | otherwise @@ -2696,7 +2697,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) -- It might have been deleted since the Finder last found it maybe_t <- modificationTimeIfExists src_fn case maybe_t of - Nothing -> return $ Left $ noHsFileErr dflags loc src_fn + Nothing -> return $ Left $ noHsFileErr loc src_fn Just t -> new_summary location' mod src_fn t new_summary location mod src_fn src_timestamp @@ -2717,7 +2718,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | otherwise = HsSrcFile when (pi_mod_name /= wanted_mod) $ - throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + throwE $ unitBag $ mkPlainErrMsg 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) @@ -2729,7 +2730,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 $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $ + in throwE $ unitBag $ mkPlainErrMsg 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) @@ -2888,21 +2889,21 @@ withDeferredDiagnostics f = do noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err - = mkPlainErrMsg (hsc_dflags hsc_env) loc $ cannotFindModule hsc_env wanted_mod err + = mkPlainErrMsg loc $ cannotFindModule hsc_env wanted_mod err -noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages -noHsFileErr dflags loc path - = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path +noHsFileErr :: SrcSpan -> String -> ErrorMessages +noHsFileErr loc path + = unitBag $ mkPlainErrMsg loc $ text "Can't find" <+> text path -moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages -moduleNotFoundErr dflags mod - = unitBag $ mkPlainErrMsg dflags noSrcSpan $ +moduleNotFoundErr :: ModuleName -> ErrorMessages +moduleNotFoundErr mod + = unitBag $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" -multiRootsErr :: DynFlags -> [ModSummary] -> IO () -multiRootsErr _ [] = panic "multiRootsErr" -multiRootsErr dflags summs@(summ1:_) - = throwOneError $ mkPlainErrMsg dflags noSrcSpan $ +multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" +multiRootsErr summs@(summ1:_) + = throwOneError $ mkPlainErrMsg 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 b54bbbea3e..220e1bf5b2 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -288,9 +288,8 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps -> return Nothing fail -> - let dflags = hsc_dflags hsc_env - in throwOneError $ mkPlainErrMsg dflags srcloc $ - cannotFindModule hsc_env imp fail + throwOneError $ mkPlainErrMsg srcloc $ + cannotFindModule hsc_env imp fail } ----------------------------- diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index d30f26999a..51329aead1 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -28,6 +28,7 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Env +import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors ) import GHC.Utils.Monad import GHC.Utils.Exception diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 717cd71369..5f79306e7e 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -46,6 +46,7 @@ import GHC.Tc.Types import GHC.Driver.Main import GHC.Driver.Env hiding ( Hsc ) +import GHC.Driver.Errors import GHC.Driver.Pipeline.Monad import GHC.Driver.Config import GHC.Driver.Phases @@ -149,7 +150,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 $ - mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg + mkPlainErrMsg srcspan $ text msg handler ex = throwGhcExceptionIO ex -- --------------------------------------------------------------------------- @@ -1127,7 +1128,7 @@ runPhase (RealPhase (Cpp sf)) input_fn (dflags1, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags0 src_opts setDynFlags dflags1 - liftIO $ checkProcessArgsResult dflags1 unhandled_flags + liftIO $ checkProcessArgsResult unhandled_flags if not (xopt LangExt.Cpp dflags1) then do -- we have to be careful to emit warnings only once. @@ -1148,7 +1149,7 @@ runPhase (RealPhase (Cpp sf)) input_fn src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags0 src_opts - liftIO $ checkProcessArgsResult dflags2 unhandled_flags + liftIO $ checkProcessArgsResult unhandled_flags unless (gopt Opt_Pp dflags2) $ liftIO $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings @@ -1182,7 +1183,7 @@ runPhase (RealPhase (HsPp sf)) input_fn = do (dflags1, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags src_opts setDynFlags dflags1 - liftIO $ checkProcessArgsResult dflags1 unhandled_flags + liftIO $ checkProcessArgsResult unhandled_flags liftIO $ handleFlagWarnings dflags1 warns return (RealPhase (Hsc sf), output_fn) diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index bdb275e5aa..7e52691124 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -453,9 +453,8 @@ warnDs :: WarnReason -> SDoc -> DsM () warnDs reason warn = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; dflags <- getDynFlags ; let msg = makeIntoWarning reason $ - mkWarnMsg dflags loc (ds_unqual env) warn + mkWarnMsg loc (ds_unqual env) warn ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) } -- | Emit a warning only if the correct WarnReason is set in the DynFlags @@ -468,8 +467,7 @@ errDs :: SDoc -> DsM () errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; dflags <- getDynFlags - ; let msg = mkErrMsg dflags loc (ds_unqual env) err + ; let msg = mkErrMsg loc (ds_unqual env) err ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) } -- | 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 aba0c006ca..7374239092 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -18,7 +18,6 @@ module GHC.Iface.Rename ( import GHC.Prelude -import GHC.Driver.Session import GHC.Driver.Env import GHC.Tc.Utils.Monad @@ -75,10 +74,9 @@ tcRnModExports x y = do failWithRn :: SDoc -> ShIfM a failWithRn doc = do errs_var <- fmap sh_if_errs getGblEnv - dflags <- getDynFlags errs <- readTcRef errs_var -- TODO: maybe associate this with a source location? - writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc) + writeTcRef errs_var (errs `snocBag` mkPlainErrMsg noSrcSpan doc) failM -- | What we have is a generalized ModIface, which corresponds to diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index edb9b04380..98b2341cf1 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -29,7 +29,6 @@ mkParserErr span doc = ErrMsg { errMsgSpan = span , errMsgContext = alwaysQualify , errMsgDoc = ErrDoc [doc] [] [] - , errMsgShortString = renderWithContext defaultSDocContext doc , errMsgSeverity = SevError , errMsgReason = NoReason } @@ -39,7 +38,6 @@ mkParserWarn flag span doc = ErrMsg { errMsgSpan = span , errMsgContext = alwaysQualify , errMsgDoc = ErrDoc [doc] [] [] - , errMsgShortString = renderWithContext defaultSDocContext doc , errMsgSeverity = SevWarning , errMsgReason = Reason flag } diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index 5abb0497d4..8c0a876c36 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -39,11 +39,11 @@ import GHC.Hs import GHC.Unit.Module import GHC.Builtin.Names +import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.SourceText -import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic @@ -259,7 +259,7 @@ getOptions' dflags toks | IToptions_prag str <- unLoc open , ITclose_prag <- unLoc close = case toArgs str of - Left _err -> optionsParseError str dflags $ -- #15053 + Left _err -> optionsParseError str $ -- #15053 combineSrcSpans (getLoc open) (getLoc close) Right args -> map (L (getLoc open)) args ++ parseToks xs parseToks (open:close:xs) @@ -284,10 +284,10 @@ getOptions' dflags toks case rest of (L _loc ITcomma):more -> parseLanguage more (L _loc ITclose_prag):more -> parseToks more - (L loc _):_ -> languagePragParseError dflags loc + (L loc _):_ -> languagePragParseError loc [] -> panic "getOptions'.parseLanguage(1) went past eof token" parseLanguage (tok:_) - = languagePragParseError dflags (getLoc tok) + = languagePragParseError (getLoc tok) parseLanguage [] = panic "getOptions'.parseLanguage(2) went past eof token" @@ -308,12 +308,12 @@ getOptions' dflags toks -- -- Throws a 'SourceError' if the input list is non-empty claiming that the -- input flags are unknown. -checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m () -checkProcessArgsResult dflags flags +checkProcessArgsResult :: MonadIO m => [Located String] -> m () +checkProcessArgsResult flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags where mkMsg (L loc flag) - = mkPlainErrMsg dflags loc $ + = mkPlainErrMsg loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) @@ -330,9 +330,9 @@ checkExtension dflags (L l ext) ext' = unpackFS ext supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags -languagePragParseError :: DynFlags -> SrcSpan -> a -languagePragParseError dflags loc = - throwErr dflags loc $ +languagePragParseError :: SrcSpan -> a +languagePragParseError loc = + throwErr loc $ vcat [ text "Cannot parse LANGUAGE pragma" , text "Expecting comma-separated list of language options," , text "each starting with a capital letter" @@ -340,7 +340,7 @@ languagePragParseError dflags loc = unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a unsupportedExtnError dflags loc unsup = - throwErr dflags loc $ + throwErr loc $ text "Unsupported extension: " <> text unsup $$ if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) where @@ -348,8 +348,8 @@ unsupportedExtnError dflags loc unsup = suggestions = fuzzyMatch unsup supported -optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages -optionsErrorMsgs dflags unhandled_flags flags_lines _filename +optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages +optionsErrorMsgs unhandled_flags flags_lines _filename = (emptyBag, listToBag (map mkMsg unhandled_flags_lines)) where unhandled_flags_lines :: [Located String] unhandled_flags_lines = [ L l f @@ -357,17 +357,17 @@ optionsErrorMsgs dflags unhandled_flags flags_lines _filename , L l f' <- flags_lines , f == f' ] mkMsg (L flagSpan flag) = - GHC.Utils.Error.mkPlainErrMsg dflags flagSpan $ + mkPlainErrMsg flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag -optionsParseError :: String -> DynFlags -> SrcSpan -> a -- #15053 -optionsParseError str dflags loc = - throwErr dflags loc $ +optionsParseError :: String -> SrcSpan -> a -- #15053 +optionsParseError str loc = + throwErr loc $ vcat [ text "Error while parsing OPTIONS_GHC pragma." , text "Expecting whitespace-separated list of GHC options." , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}" , text ("Input was: " ++ show str) ] -throwErr :: DynFlags -> SrcSpan -> SDoc -> a -- #15053 -throwErr dflags loc doc = - throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc +throwErr :: SrcSpan -> SDoc -> a -- #15053 +throwErr loc doc = + throw $ mkSrcErr $ unitBag $ mkPlainErrMsg loc doc diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 174055bd01..819740c341 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -208,7 +208,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax hsc_src = ms_hsc_src mod_sum dflags = hsc_dflags hsc_env home_unit = hsc_home_unit hsc_env - err_msg = mkPlainErrMsg dflags loc $ + err_msg = mkPlainErrMsg loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod pair :: (Module, SrcSpan) @@ -3119,5 +3119,5 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ recordUnsafeInfer pluginUnsafe where unsafeText = "Use of plugins makes the module unsafe" - pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan + pluginUnsafe = unitBag ( mkPlainWarnMsg noSrcSpan (Outputable.text unsafeText) ) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 7056ba898b..48348ce7d7 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -994,21 +994,19 @@ discardWarnings thing_inside mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg mkLongErrAt loc msg extra - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified ; + = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let msg' = pprWithUnitState unit_state msg in - return $ mkLongErrMsg dflags loc printer msg' extra } + return $ mkLongErrMsg loc printer msg' extra } mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg mkErrDocAt loc errDoc - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified ; + = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let f = pprWithUnitState unit_state errDoc' = mapErrDoc f errDoc in - return $ mkErrDoc dflags loc printer errDoc' } + return $ mkErrDoc loc printer errDoc' } addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError @@ -1515,9 +1513,8 @@ add_warn reason msg extra_info -- | Display a warning, with an optional flag, for a given location. add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () add_warn_at reason loc msg extra_info - = do { dflags <- getDynFlags ; - printer <- getPrintUnqualified ; - let { warn = mkLongWarnMsg dflags loc printer + = do { printer <- getPrintUnqualified ; + let { warn = mkLongWarnMsg loc printer msg extra_info } ; reportWarning reason warn } diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index cb624c6c99..6737edcda4 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -18,6 +18,14 @@ module GHC.Types.Error , getSeverityColour , getCaretDiagnostic , makeIntoWarning + -- * Constructing individual errors + , mkErrMsg + , mkPlainErrMsg + , mkErrDoc + , mkLongErrMsg + , mkWarnMsg + , mkPlainWarnMsg + , mkLongWarnMsg ) where @@ -41,14 +49,12 @@ type ErrorMessages = Bag ErrMsg type MsgDoc = SDoc type WarnMsg = ErrMsg - +-- | The main 'GHC' error type. data ErrMsg = ErrMsg { errMsgSpan :: SrcSpan -- ^ The SrcSpan is used for sorting errors into line-number order , errMsgContext :: PrintUnqualified , errMsgDoc :: ErrDoc - , errMsgShortString :: String - -- ^ This has the same text as errDocImportant . errMsgDoc. , errMsgSeverity :: Severity , errMsgReason :: WarnReason } @@ -102,7 +108,12 @@ instance ToJson Severity where json s = JSString (show s) instance Show ErrMsg where - show em = errMsgShortString em + show = showErrMsg + +-- | Shows an 'ErrMsg'. +showErrMsg :: ErrMsg -> String +showErrMsg err = + renderWithContext defaultSDocContext (vcat (errDocImportant $ errMsgDoc err)) pprMessageBag :: Bag MsgDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) @@ -238,3 +249,31 @@ makeIntoWarning reason err = err { errMsgSeverity = SevWarning , errMsgReason = reason } +-- +-- Creating ErrMsg(s) +-- + +mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg +mk_err_msg sev locn print_unqual err + = ErrMsg { errMsgSpan = locn + , errMsgContext = print_unqual + , errMsgDoc = err + , errMsgSeverity = sev + , errMsgReason = NoReason } + +mkErrDoc :: SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg +mkErrDoc = mk_err_msg SevError + +mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +-- ^ A long (multi-line) error message +mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +-- ^ A short (one-line) error message +mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg +-- ^ Variant that doesn't care about qualified/unqualified names + +mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual (ErrDoc [msg] [] [extra]) +mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual (ErrDoc [msg] [] []) +mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify (ErrDoc [msg] [] []) +mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual (ErrDoc [msg] [] [extra]) +mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual (ErrDoc [msg] [] []) +mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify (ErrDoc [msg] [] []) diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 1051a731c5..2c7edd30e9 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -21,12 +21,10 @@ module GHC.Utils.Error ( Messages, ErrorMessages, WarningMessages, unionMessages, errorsFound, isEmptyMessages, - isWarnMsgFatal, - warningsToMessages, -- ** Formatting pprMessageBag, pprErrMsgBagWithLoc, - pprLocErrMsg, printBagOfErrors, + pprLocErrMsg, formatErrDoc, -- ** Construction @@ -59,8 +57,7 @@ module GHC.Utils.Error ( prettyPrintGhcErrors, traceCmd, - -- * Compilation errors and warnings - printOrThrowWarnings, handleFlagWarnings, shouldPrintWarning + sortMsgBag ) where #include "HsVersions.h" @@ -69,13 +66,11 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Driver.Ppr -import qualified GHC.Driver.CmdLine as CmdLine import GHC.Data.Bag import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic -import GHC.Types.SourceError import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc @@ -125,32 +120,6 @@ orValid _ v = v -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. -mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg -mk_err_msg dflags sev locn print_unqual doc - = ErrMsg { errMsgSpan = locn - , errMsgContext = print_unqual - , errMsgDoc = doc - , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc)) - , errMsgSeverity = sev - , errMsgReason = NoReason } - -mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg -mkErrDoc dflags = mk_err_msg dflags SevError - -mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg --- ^ A long (multi-line) error message -mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg --- ^ A short (one-line) error message -mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg --- ^ Variant that doesn't care about qualified/unqualified names - -mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra]) -mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] []) -mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] []) -mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra]) -mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] []) -mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] []) - ---------------- emptyMessages :: Messages emptyMessages = (emptyBag, emptyBag) @@ -161,27 +130,6 @@ isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs errorsFound :: DynFlags -> Messages -> Bool errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) -warningsToMessages :: DynFlags -> WarningMessages -> Messages -warningsToMessages dflags = - partitionBagWith $ \warn -> - case isWarnMsgFatal dflags warn of - Nothing -> Left warn - Just err_reason -> - Right warn{ errMsgSeverity = SevError - , errMsgReason = ErrReason err_reason } - -printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () -printBagOfErrors dflags bag_of_errors - = sequence_ [ let style = mkErrStyle unqual - ctx = initSDocContext dflags style - in putLogMsg dflags reason sev s $ withPprStyle style (formatErrDoc ctx doc) - | ErrMsg { errMsgSpan = s, - errMsgDoc = doc, - errMsgSeverity = sev, - errMsgReason = reason, - errMsgContext = unqual } <- sortMsgBag (Just dflags) - bag_of_errors ] - formatErrDoc :: SDocContext -> ErrDoc -> SDoc formatErrDoc ctx (ErrDoc important context supplementary) = case msgs of @@ -629,17 +577,6 @@ prettyPrintGhcErrors dflags where ctx = initSDocContext dflags defaultUserStyle --- | Checks if given 'WarnMsg' is a fatal warning. -isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) -isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag} - = if wopt_fatal wflag dflags - then Just (Just wflag) - else Nothing -isWarnMsgFatal dflags _ - = if gopt Opt_WarnIsError dflags - then Just Nothing - else Nothing - traceCmd :: DynFlags -> String -> String -> IO a -> IO a -- trace the command (at two levels of verbosity) traceCmd dflags phase_name cmd_line action @@ -795,44 +732,3 @@ dumpAction dflags = dump_action dflags dflags -- | Helper for `trace_action` traceAction :: TraceAction traceAction dflags = trace_action dflags dflags - -handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO () -handleFlagWarnings dflags warns = do - let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns - - -- It would be nicer if warns :: [Located MsgDoc], but that - -- has circular import problems. - bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) - | CmdLine.Warn _ (L loc warn) <- warns' ] - - printOrThrowWarnings dflags bag - --- Given a warn reason, check to see if it's associated -W opt is enabled -shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool -shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag - = wopt Opt_WarnDeprecatedFlags dflags -shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag - = wopt Opt_WarnUnrecognisedWarningFlags dflags -shouldPrintWarning _ _ - = True - - --- | Given a bag of warnings, turn them into an exception if --- -Werror is enabled, or print them out otherwise. -printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () -printOrThrowWarnings dflags warns = do - let (make_error, warns') = - mapAccumBagL - (\make_err warn -> - case isWarnMsgFatal dflags warn of - Nothing -> - (make_err, warn) - Just err_reason -> - (True, warn{ errMsgSeverity = SevError - , errMsgReason = ErrReason err_reason - })) - False warns - if make_error - then throwIO (mkSrcErr warns') - else printBagOfErrors dflags warns - diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 323940d925..b7a68d8ba4 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -385,6 +385,7 @@ Library GHC.Driver.Config GHC.Driver.Env GHC.Driver.Env.Types + GHC.Driver.Errors GHC.Driver.Flags GHC.Driver.Hooks GHC.Driver.Main diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 5beca7882d..f78faae40d 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -45,6 +45,7 @@ import GHC.Runtime.Interpreter.Types import GHCi.RemoteTypes import GHCi.BreakArray import GHC.ByteCode.Types +import GHC.Driver.Errors import GHC.Driver.Phases import GHC.Driver.Session as DynFlags import GHC.Driver.Ppr hiding (printForUser) diff --git a/ghc/Main.hs b/ghc/Main.hs index 1f9e0bdf2a..12acd5a479 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -21,6 +21,7 @@ import GHC (parseTargetFiles, Ghc, GhcMonad(..), Backend (..), import GHC.Driver.CmdLine import GHC.Driver.Env +import GHC.Driver.Errors import GHC.Driver.Phases import GHC.Driver.Session hiding (WarnReason(..)) import GHC.Driver.Ppr diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs index f669bfbd6d..39da5f1292 100644 --- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs +++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs @@ -13,6 +13,7 @@ import GHC.Tc.Utils.Zonk import GHC.Utils.Error import GHC.Driver.Ppr import GHC.Driver.Env +import GHC.Driver.Errors import GHC import qualified GHC.LanguageExtensions as LangExt diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout index 332c15123f..90b5a3c4ab 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.stdout +++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout @@ -1,4 +1,4 @@ -Found 237 parser module dependencies +Found 238 parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -81,6 +81,7 @@ GHC.Driver.Backpack.Syntax GHC.Driver.CmdLine GHC.Driver.Env GHC.Driver.Env.Types +GHC.Driver.Errors GHC.Driver.Flags GHC.Driver.Hooks GHC.Driver.Monad diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index d889b90bc7..fee1302b8e 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -42,6 +42,7 @@ import GHC.Driver.Monad import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Driver.Session +import GHC.Driver.Errors import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Types.Basic |