summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/ErrUtils.hs10
-rw-r--r--compiler/main/GHC.hs16
-rw-r--r--compiler/main/HeaderInfo.hs7
-rw-r--r--compiler/main/HscMain.hs36
-rw-r--r--compiler/main/HscTypes.hs9
-rw-r--r--compiler/main/InteractiveEval.hs8
6 files changed, 49 insertions, 37 deletions
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index ac97f173f2..9ee6856275 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -22,6 +22,7 @@ module ErrUtils (
errMsgSpan, errMsgContext,
errorsFound, isEmptyMessages,
isWarnMsgFatal,
+ warningsToMessages,
-- ** Formatting
pprMessageBag, pprErrMsgBagWithLoc,
@@ -359,6 +360,15 @@ 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 dflags unqual
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index a1cc4a7cb6..9e58f356f6 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -337,7 +337,7 @@ import Annotations
import Module
import Panic
import Platform
-import Bag ( listToBag, unitBag )
+import Bag ( listToBag )
import ErrUtils
import MonadUtils
import Util
@@ -1363,9 +1363,9 @@ getTokenStream mod = do
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
- PFailed _ span err ->
+ PFailed pst ->
do dflags <- getDynFlags
- liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+ throwErrors (getErrorMessages pst dflags)
-- | Give even more information on the source than 'getTokenStream'
-- This function allows reconstructing the source completely with
@@ -1376,9 +1376,9 @@ getRichTokenStream mod = do
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
- PFailed _ span err ->
+ PFailed pst ->
do dflags <- getDynFlags
- liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+ throwErrors (getErrorMessages pst dflags)
-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
@@ -1553,9 +1553,9 @@ parser str dflags filename =
in
case unP Parser.parseModule (mkPState dflags buf loc) of
- PFailed warnFn span err ->
- let (warns,_) = warnFn dflags in
- (warns, Left $ unitBag (mkPlainErrMsg dflags span err))
+ PFailed pst ->
+ let (warns,errs) = getMessages pst dflags in
+ (warns, Left errs)
POk pst rdr_module ->
let (warns,_) = getMessages pst dflags in
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 3fd510bb86..450ac95f96 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -66,9 +66,9 @@ getImports :: DynFlags
getImports dflags buf filename source_filename = do
let loc = mkRealSrcLoc (mkFastString filename) 1 1
case unP parseHeader (mkPState dflags buf loc) of
- PFailed _ span err -> do
+ PFailed pst -> do
-- assuming we're not logging warnings here as per below
- parseError dflags span err
+ throwErrors (getErrorMessages pst dflags)
POk pst rdr_module -> do
let _ms@(_warns, errs) = getMessages pst dflags
-- don't log warnings: they'll be reported when we parse the file
@@ -136,9 +136,6 @@ mkPrelImports this_mod loc implicit_prelude import_decls
ideclAs = Nothing,
ideclHiding = Nothing }
-parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a
-parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err
-
--------------------------------------------------------------
-- Get options
--------------------------------------------------------------
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 9a4dd4aafe..5bc0f38eca 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -233,9 +233,15 @@ logWarningsReportErrors (warns,errs) = do
logWarnings warns
when (not $ isEmptyBag errs) $ throwErrors errs
--- | Throw some errors.
-throwErrors :: ErrorMessages -> Hsc a
-throwErrors = liftIO . throwIO . mkSrcErr
+-- | Log warnings and throw errors, assuming the messages
+-- contain at least one error (e.g. coming from PFailed)
+handleWarningsThrowErrors :: Messages -> Hsc a
+handleWarningsThrowErrors (warns, errs) = do
+ logWarnings warns
+ dflags <- getDynFlags
+ (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings
+ liftIO $ printBagOfErrors dflags wWarns
+ throwErrors (unionBags errs wErrs)
-- | Deal with errors and warnings returned by a compilation step
--
@@ -341,19 +347,18 @@ hscParse' mod_summary
| otherwise = parseModule
case unP parseMod (mkPState dflags buf loc) of
- PFailed warnFn span err -> do
- logWarningsReportErrors (warnFn dflags)
- handleWarnings
- liftIO $ throwOneError (mkPlainErrMsg dflags span err)
-
+ PFailed pst ->
+ handleWarningsThrowErrors (getMessages pst dflags)
POk pst rdr_module -> do
- logWarningsReportErrors (getMessages pst dflags)
+ let (warns, errs) = getMessages pst dflags
+ logWarnings warns
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
ppr rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
showAstData NoBlankSrcSpan rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
ppSourceStats False rdr_module
+ when (not $ isEmptyBag errs) $ throwErrors errs
-- To get the list of extra source files, we take the list
-- that the parser gave us,
@@ -1022,7 +1027,7 @@ checkSafeImports tcg_env
| imv_is_safe v1 /= imv_is_safe v2
= do
dflags <- getDynFlags
- throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)
+ throwOneError $ mkPlainErrMsg dflags (imv_span v1)
(text "Module" <+> ppr (imv_name v1) <+>
(text $ "is imported both as a safe and unsafe import!"))
| otherwise
@@ -1088,7 +1093,7 @@ hscCheckSafe' m l = do
iface <- lookup' m
case iface of
-- can't load iface to check trust!
- Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
+ Nothing -> throwOneError $ mkPlainErrMsg dflags l
$ text "Can't load the interface file for" <+> ppr m
<> text ", to check that it can be safely imported"
@@ -1759,7 +1764,7 @@ hscParseExpr expr = do
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (BodyStmt _ expr _ _)) -> return expr
- _ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
+ _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
(text "not an expression:" <+> quotes (text expr))
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
@@ -1793,11 +1798,8 @@ hscParseThingWithLocation source linenumber parser str
loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
- PFailed warnFn span err -> do
- logWarningsReportErrors (warnFn dflags)
- handleWarnings
- let msg = mkPlainErrMsg dflags span err
- throwErrors $ unitBag msg
+ PFailed pst -> do
+ handleWarningsThrowErrors (getMessages pst dflags)
POk pst thing -> do
logWarningsReportErrors (getMessages pst dflags)
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index d17fa5fcef..0ca7bdae45 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -133,7 +133,7 @@ module HscTypes (
-- * Compilation errors and warnings
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
- throwOneError, handleSourceError,
+ throwOneError, throwErrors, handleSourceError,
handleFlagWarnings, printOrThrowWarnings,
-- * COMPLETE signature
@@ -278,8 +278,11 @@ srcErrorMessages (SourceError msgs) = msgs
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
-throwOneError :: MonadIO m => ErrMsg -> m ab
-throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
+throwErrors :: MonadIO io => ErrorMessages -> io a
+throwErrors = liftIO . throwIO . mkSrcErr
+
+throwOneError :: MonadIO io => ErrMsg -> io a
+throwOneError = throwErrors . unitBag
-- | A source error is an error that is caused by one or more errors in the
-- source code. A 'SourceError' is thrown by many functions in the
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 4e6d26b1d6..5ff1b03a97 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -816,14 +816,14 @@ isStmt :: DynFlags -> String -> Bool
isStmt dflags stmt =
case parseThing Parser.parseStmt dflags stmt of
Lexer.POk _ _ -> True
- Lexer.PFailed _ _ _ -> False
+ Lexer.PFailed _ -> False
-- | Returns @True@ if passed string has an import declaration.
hasImport :: DynFlags -> String -> Bool
hasImport dflags stmt =
case parseThing Parser.parseModule dflags stmt of
Lexer.POk _ thing -> hasImports thing
- Lexer.PFailed _ _ _ -> False
+ Lexer.PFailed _ -> False
where
hasImports = not . null . hsmodImports . unLoc
@@ -832,7 +832,7 @@ isImport :: DynFlags -> String -> Bool
isImport dflags stmt =
case parseThing Parser.parseImport dflags stmt of
Lexer.POk _ _ -> True
- Lexer.PFailed _ _ _ -> False
+ Lexer.PFailed _ -> False
-- | Returns @True@ if passed string is a declaration but __/not a splice/__.
isDecl :: DynFlags -> String -> Bool
@@ -842,7 +842,7 @@ isDecl dflags stmt = do
case unLoc thing of
SpliceD _ _ -> False
_ -> True
- Lexer.PFailed _ _ _ -> False
+ Lexer.PFailed _ -> False
parseThing :: Lexer.P thing -> DynFlags -> String -> Lexer.ParseResult thing
parseThing parser dflags stmt = do
View Lorry Controller Status