summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/CodeOutput.hs2
-rw-r--r--compiler/main/DriverPipeline.hs4
-rw-r--r--compiler/main/DynFlags.hs11
-rw-r--r--compiler/main/ErrUtils.hs46
-rw-r--r--compiler/main/ErrUtils.hs-boot1
-rw-r--r--compiler/main/GhcMake.hs12
-rw-r--r--compiler/main/SysTools.hs6
-rw-r--r--compiler/main/TidyPgm.hs3
8 files changed, 54 insertions, 31 deletions
diff --git a/compiler/main/CodeOutput.hs b/compiler/main/CodeOutput.hs
index 00a0801c47..083133c70f 100644
--- a/compiler/main/CodeOutput.hs
+++ b/compiler/main/CodeOutput.hs
@@ -67,7 +67,7 @@ codeOutput dflags this_mod filenm location foreign_stubs pkg_deps cmm_stream
do_lint cmm = do
{ showPass dflags "CmmLint"
; case cmmLint dflags cmm of
- Just err -> do { log_action dflags dflags SevDump noSrcSpan defaultDumpStyle err
+ Just err -> do { log_action dflags dflags Nothing SevDump noSrcSpan defaultDumpStyle err
; ghcExit dflags 1
}
Nothing -> return ()
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 3de94fd403..bbc190812e 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -1594,7 +1594,7 @@ mkExtraObj dflags extn xs
mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath
mkExtraObjToLinkIntoBinary dflags = do
when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do
- log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
+ log_action dflags dflags Nothing SevInfo noSrcSpan defaultUserStyle
(text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$
text " Call hs_init_ghc() from your main() function to set these options.")
@@ -1969,7 +1969,7 @@ linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()
linkDynLibCheck dflags o_files dep_packages
= do
when (haveRtsOptsFlags dflags) $ do
- log_action dflags dflags SevInfo noSrcSpan defaultUserStyle
+ log_action dflags dflags Nothing SevInfo noSrcSpan defaultUserStyle
(text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$
text " Call hs_init_ghc() from your main() function to set these options.")
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 52da3005bf..df95312edc 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -173,7 +173,7 @@ import FastString
import Outputable
import Foreign.C ( CInt(..) )
import System.IO.Unsafe ( unsafeDupablePerformIO )
-import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessage )
+import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn )
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef
@@ -1616,13 +1616,13 @@ interpreterDynamic dflags
--------------------------------------------------------------------------
type FatalMessager = String -> IO ()
-type LogAction = DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
+type LogAction = DynFlags -> Maybe WarningFlag -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
defaultFatalMessager :: FatalMessager
defaultFatalMessager = hPutStrLn stderr
defaultLogAction :: LogAction
-defaultLogAction dflags severity srcSpan style msg
+defaultLogAction dflags flag severity srcSpan style msg
= case severity of
SevOutput -> printSDoc msg style
SevDump -> printSDoc (msg $$ blankLine) style
@@ -1630,7 +1630,7 @@ defaultLogAction dflags severity srcSpan style msg
SevInfo -> printErrs msg style
SevFatal -> printErrs msg style
_ -> do hPutChar stderr '\n'
- printErrs (mkLocMessage severity srcSpan msg) style
+ printErrs (mkLocMessageAnn flagMsg severity srcSpan msg) style
-- careful (#2302): printErrs prints in UTF-8,
-- whereas converting to string first and using
-- hPutStr would just emit the low 8 bits of
@@ -1638,6 +1638,9 @@ defaultLogAction dflags severity srcSpan style msg
where printSDoc = defaultLogActionHPrintDoc dflags stdout
printErrs = defaultLogActionHPrintDoc dflags stderr
putStrSDoc = defaultLogActionHPutStrDoc dflags stdout
+ -- Pretty print the warning flag, if any (#10752)
+ flagMsg = (\wf -> '-':'W':flagSpecName wf) <$> (flag >>= \f ->
+ listToMaybe $ filter (\fs -> flagSpecFlag fs == f) wWarningFlags)
defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
defaultLogActionHPrintDoc dflags h d sty
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index eafe4e802f..585cab5f22 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -23,7 +23,7 @@ module ErrUtils (
pprLocErrMsg, printBagOfErrors,
-- ** Construction
- emptyMessages, mkLocMessage, makeIntoWarning,
+ emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,
mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,
mkPlainWarnMsg,
warnIsErrorMsg, mkLongWarnMsg,
@@ -110,7 +110,8 @@ data ErrMsg = ErrMsg {
errMsgDoc :: ErrDoc,
-- | This has the same text as errDocImportant . errMsgDoc.
errMsgShortString :: String,
- errMsgSeverity :: Severity
+ errMsgSeverity :: Severity,
+ errMsgFlag :: Maybe WarningFlag
}
-- The SrcSpan is used for sorting errors into line-number order
@@ -160,15 +161,18 @@ pprMessageBag :: Bag MsgDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
+mkLocMessage = mkLocMessageAnn Nothing
+
+mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
-- Always print the location, even if it is unhelpful. Error messages
-- are supposed to be in a standard format, and one without a location
-- would look strange. Better to say explicitly "<no location info>".
-mkLocMessage severity locn msg
+mkLocMessageAnn ann severity locn msg
= sdocWithDynFlags $ \dflags ->
let locn' = if gopt Opt_ErrorSpans dflags
then ppr locn
else ppr (srcSpanStart locn)
- in hang (locn' <> colon <+> sev_info) 4 msg
+ in hang (locn' <> colon <+> sev_info <> opt_ann) 4 msg
where
-- Add prefixes, like Foo.hs:34: warning:
-- <the warning message>
@@ -178,8 +182,13 @@ mkLocMessage severity locn msg
SevFatal -> text "fatal:"
_ -> empty
-makeIntoWarning :: ErrMsg -> ErrMsg
-makeIntoWarning err = err { errMsgSeverity = SevWarning }
+ -- Add optional information
+ opt_ann = text $ maybe "" (\i -> " ["++i++"]") ann
+
+makeIntoWarning :: Maybe WarningFlag -> ErrMsg -> ErrMsg
+makeIntoWarning flag err
+= err { errMsgSeverity = SevWarning
+ , errMsgFlag = flag }
-- -----------------------------------------------------------------------------
-- Collecting up messages for later ordering and printing.
@@ -190,7 +199,8 @@ mk_err_msg dflags sev locn print_unqual doc
, errMsgContext = print_unqual
, errMsgDoc = doc
, errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))
- , errMsgSeverity = sev }
+ , errMsgSeverity = sev
+ , errMsgFlag = Nothing }
mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mkErrDoc dflags = mk_err_msg dflags SevError
@@ -226,10 +236,11 @@ errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle dflags unqual
- in log_action dflags dflags sev s style (formatErrDoc dflags doc)
+ in log_action dflags dflags flag sev s style (formatErrDoc dflags doc)
| ErrMsg { errMsgSpan = s,
errMsgDoc = doc,
errMsgSeverity = sev,
+ errMsgFlag = flag,
errMsgContext = unqual } <- sortMsgBag (Just dflags)
bag_of_errors ]
@@ -283,7 +294,8 @@ doIfSet_dyn dflags flag action | gopt flag dflags = action
dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()
dumpIfSet dflags flag hdr doc
| not flag = return ()
- | otherwise = log_action dflags dflags SevDump noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
+ | otherwise = log_action dflags dflags Nothing SevDump
+ noSrcSpan defaultDumpStyle (mkDumpDoc hdr doc)
-- | a wrapper around 'dumpSDoc'.
-- First check whether the dump flag is set
@@ -359,7 +371,7 @@ dumpSDoc dflags print_unqual flag hdr doc
let (doc', severity)
| null hdr = (doc, SevOutput)
| otherwise = (mkDumpDoc hdr doc, SevDump)
- log_action dflags dflags severity noSrcSpan dump_style doc'
+ log_action dflags dflags Nothing severity noSrcSpan dump_style doc'
-- | Choose where to put a dump file based on DynFlags
@@ -416,18 +428,20 @@ ifVerbose dflags val act
errorMsg :: DynFlags -> MsgDoc -> IO ()
errorMsg dflags msg
- = log_action dflags dflags SevError noSrcSpan (defaultErrStyle dflags) msg
+ = log_action dflags dflags Nothing SevError noSrcSpan
+ (defaultErrStyle dflags) msg
warningMsg :: DynFlags -> MsgDoc -> IO ()
warningMsg dflags msg
- = log_action dflags dflags SevWarning noSrcSpan (defaultErrStyle dflags) msg
+ = log_action dflags dflags Nothing SevWarning noSrcSpan
+ (defaultErrStyle dflags) msg
fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()
fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) dflags msg
fatalErrorMsg' :: LogAction -> DynFlags -> MsgDoc -> IO ()
fatalErrorMsg' la dflags msg =
- la dflags SevFatal noSrcSpan (defaultErrStyle dflags) msg
+ la dflags Nothing SevFatal noSrcSpan (defaultErrStyle dflags) msg
fatalErrorMsg'' :: FatalMessager -> String -> IO ()
fatalErrorMsg'' fm msg = fm msg
@@ -458,11 +472,13 @@ printOutputForUser dflags print_unqual msg
= logOutput dflags (mkUserStyle print_unqual AllTheWay) msg
logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO ()
-logInfo dflags sty msg = log_action dflags dflags SevInfo noSrcSpan sty msg
+logInfo dflags sty msg
+ = log_action dflags dflags Nothing SevInfo noSrcSpan sty msg
logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO ()
-- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'
-logOutput dflags sty msg = log_action dflags dflags SevOutput noSrcSpan sty msg
+logOutput dflags sty msg
+ = log_action dflags dflags Nothing SevOutput noSrcSpan sty msg
prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a
prettyPrintGhcErrors dflags
diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot
index 31edcc05ee..b991ec4958 100644
--- a/compiler/main/ErrUtils.hs-boot
+++ b/compiler/main/ErrUtils.hs-boot
@@ -16,3 +16,4 @@ data Severity
type MsgDoc = SDoc
mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc
+mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 7bbe4be495..3e62d8dea4 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -678,7 +678,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
-- | Each module is given a unique 'LogQueue' to redirect compilation messages
-- to. A 'Nothing' value contains the result of compilation, and denotes the
-- end of the message queue.
-data LogQueue = LogQueue !(IORef [Maybe (Severity, SrcSpan, PprStyle, MsgDoc)])
+data LogQueue = LogQueue !(IORef [Maybe (Maybe WarningFlag, Severity, SrcSpan, PprStyle, MsgDoc)])
!(MVar ())
-- | The graph of modules to compile and their corresponding result 'MVar' and
@@ -879,7 +879,7 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
return (success_flag,ok_results)
where
- writeLogQueue :: LogQueue -> Maybe (Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
+ writeLogQueue :: LogQueue -> Maybe (Maybe WarningFlag,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
writeLogQueue (LogQueue ref sem) msg = do
atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
_ <- tryPutMVar sem ()
@@ -888,8 +888,8 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
-- The log_action callback that is used to synchronize messages from a
-- worker thread.
parLogAction :: LogQueue -> LogAction
- parLogAction log_queue _dflags !severity !srcSpan !style !msg = do
- writeLogQueue log_queue (Just (severity,srcSpan,style,msg))
+ parLogAction log_queue _dflags !flag !severity !srcSpan !style !msg = do
+ writeLogQueue log_queue (Just (flag,severity,srcSpan,style,msg))
-- Print each message from the log_queue using the log_action from the
-- session's DynFlags.
@@ -902,8 +902,8 @@ parUpsweep n_jobs old_hpt stable_mods cleanup sccs = do
print_loop [] = read_msgs
print_loop (x:xs) = case x of
- Just (severity,srcSpan,style,msg) -> do
- log_action dflags dflags severity srcSpan style msg
+ Just (flag,severity,srcSpan,style,msg) -> do
+ log_action dflags dflags flag severity srcSpan style msg
print_loop xs
-- Exit the loop once we encounter the end marker.
Nothing -> return ()
diff --git a/compiler/main/SysTools.hs b/compiler/main/SysTools.hs
index c3436edd9e..d7de69ae8d 100644
--- a/compiler/main/SysTools.hs
+++ b/compiler/main/SysTools.hs
@@ -1367,10 +1367,12 @@ builderMainLoop dflags filter_fn pgm real_args mb_env = do
msg <- readChan chan
case msg of
BuildMsg msg -> do
- log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
+ log_action dflags dflags Nothing SevInfo noSrcSpan
+ defaultUserStyle msg
loop chan hProcess t p exitcode
BuildError loc msg -> do
- log_action dflags dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
+ log_action dflags dflags Nothing SevError (mkSrcSpan loc loc)
+ defaultUserStyle msg
loop chan hProcess t p exitcode
EOF ->
loop chan hProcess (t-1) p exitcode
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index df31fda16c..072fb840a4 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -390,7 +390,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
-- Print one-line size info
; let cs = coreBindsStats tidy_binds
; when (dopt Opt_D_dump_core_stats dflags)
- (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
+ (log_action dflags dflags Nothing SevDump noSrcSpan
+ defaultDumpStyle
(text "Tidy size (terms,types,coercions)"
<+> ppr (moduleName mod) <> colon
<+> int (cs_tm cs)
View Lorry Controller Status