summaryrefslogtreecommitdiff
path: root/compiler/GHC/Driver
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Driver')
-rw-r--r--compiler/GHC/Driver/Backpack.hs3
-rw-r--r--compiler/GHC/Driver/Main.hs30
-rw-r--r--compiler/GHC/Driver/Make.hs6
-rw-r--r--compiler/GHC/Driver/Pipeline.hs3
4 files changed, 29 insertions, 13 deletions
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 494cffb785..242ecd9aa4 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -24,6 +24,7 @@ import GHC.Prelude
import GHC.Driver.Backpack.Syntax
import GHC.Parser.Annotation
+import GHC.Parser.Errors.Ppr
import GHC hiding (Failed, Succeeded)
import GHC.Parser
import GHC.Parser.Lexer
@@ -85,7 +86,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 (getErrorMessages pst dflags)
+ PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))
POk _ pkgname_bkp -> do
-- OK, so we have an LHsUnit PackageName, but we want an
-- LHsUnit HsComponentId. So let's rename it.
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 593251a253..a2fa2e2aea 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -101,6 +101,8 @@ import GHC.Utils.Panic
import GHC.Core.ConLike
import GHC.Parser.Annotation
+import GHC.Parser.Errors
+import GHC.Parser.Errors.Ppr
import GHC.Unit
import GHC.Unit.State
import GHC.Types.Name.Reader
@@ -177,7 +179,7 @@ import qualified Data.Set as S
import Data.Set (Set)
import Data.Functor
import Control.DeepSeq (force)
-import Data.Bifunctor (first)
+import Data.Bifunctor (first, bimap)
import GHC.Iface.Ext.Ast ( mkHieFile )
import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
@@ -237,15 +239,19 @@ handleWarnings = do
-- | log warning in the monad, and if there are errors then
-- throw a SourceError exception.
-logWarningsReportErrors :: Messages -> Hsc ()
-logWarningsReportErrors (warns,errs) = do
+logWarningsReportErrors :: (Bag Warning, Bag Error) -> Hsc ()
+logWarningsReportErrors (warnings,errors) = do
+ let warns = fmap pprWarning warnings
+ errs = fmap pprError errors
logWarnings warns
when (not $ isEmptyBag errs) $ throwErrors errs
-- | 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
+handleWarningsThrowErrors :: (Bag Warning, Bag Error) -> Hsc a
+handleWarningsThrowErrors (warnings, errors) = do
+ let warns = fmap pprWarning warnings
+ errs = fmap pprError errors
logWarnings warns
dflags <- getDynFlags
(wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings
@@ -356,9 +362,9 @@ hscParse' mod_summary
case unP parseMod (initParserState (initParserOpts dflags) buf loc) of
PFailed pst ->
- handleWarningsThrowErrors (getMessages pst dflags)
+ handleWarningsThrowErrors (getMessages pst)
POk pst rdr_module -> do
- let (warns, errs) = getMessages pst dflags
+ let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst)
logWarnings warns
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"
FormatHaskell (ppr rdr_module)
@@ -1496,7 +1502,11 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
home_unit = mkHomeUnitFromFlags dflags
platform = targetPlatform dflags
- cmm <- ioMsgMaybe $ parseCmmFile dflags filename
+ cmm <- ioMsgMaybe
+ $ do
+ (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
+ $ parseCmmFile dflags filename
+ return ((fmap pprWarning warns, fmap pprError errs), cmm)
liftIO $ do
dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
let -- Make up a module name to give the NCG. We can't pass bottom here
@@ -1878,10 +1888,10 @@ hscParseThingWithLocation source linenumber parser str
case unP parser (initParserState (initParserOpts dflags) buf loc) of
PFailed pst -> do
- handleWarningsThrowErrors (getMessages pst dflags)
+ handleWarningsThrowErrors (getMessages pst)
POk pst thing -> do
- logWarningsReportErrors (getMessages pst dflags)
+ logWarningsReportErrors (getMessages pst)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"
FormatHaskell (ppr thing)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index de1746c815..a40efb74aa 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -45,6 +45,7 @@ import GHC.Utils.Error
import GHC.Driver.Finder
import GHC.Driver.Monad
import GHC.Parser.Header
+import GHC.Parser.Errors.Ppr
import GHC.Driver.Types
import GHC.Unit
import GHC.Unit.State
@@ -94,6 +95,7 @@ import Data.Foldable (toList)
import Data.Maybe
import Data.Ord ( comparing )
import Data.Time
+import Data.Bifunctor (first)
import System.Directory
import System.FilePath
import System.IO ( fixIO )
@@ -2669,7 +2671,9 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
<- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
(pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)
- <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
+ <- ExceptT $ do
+ mimps <- getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
+ return (first (fmap pprError) mimps)
return PreprocessedImports {..}
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 66487c497d..0dd3d0f8fa 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -45,6 +45,7 @@ import GHC.Unit.State
import GHC.Platform.Ways
import GHC.Platform.ArchOS
import GHC.Parser.Header
+import GHC.Parser.Errors.Ppr
import GHC.Driver.Phases
import GHC.SysTools
import GHC.SysTools.ExtraObj
@@ -1117,7 +1118,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
buf <- hGetStringBuffer input_fn
eimps <- getImports dflags buf input_fn (basename <.> suff)
case eimps of
- Left errs -> throwErrors errs
+ Left errs -> throwErrors (fmap pprError errs)
Right (src_imps,imps,L _ mod_name) -> return
(Just buf, mod_name, imps, src_imps)
View Lorry Controller Status