diff options
Diffstat (limited to 'compiler/GHC/Driver')
| -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 |
8 files changed, 74 insertions, 100 deletions
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) |