diff options
Diffstat (limited to 'compiler/GHC/Utils/Error.hs')
| -rw-r--r-- | compiler/GHC/Utils/Error.hs | 264 |
1 files changed, 51 insertions, 213 deletions
diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 1bd3e57f56..2db4672f07 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -58,24 +58,27 @@ module GHC.Utils.Error ( debugTraceMsg, ghcExit, prettyPrintGhcErrors, - traceCmd + traceCmd, + + -- * Compilation errors and warnings + printOrThrowWarnings, handleFlagWarnings, shouldPrintWarning ) where #include "HsVersions.h" 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 qualified GHC.Utils.Ppr.Colour as Col +import GHC.Types.SourceError +import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc -import GHC.Driver.Session -import GHC.Driver.Ppr -import GHC.Data.FastString (unpackFS) -import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) -import GHC.Utils.Json import System.Directory import System.Exit ( ExitCode(..), exitWith ) @@ -91,12 +94,9 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Catch as MC (handle) import System.IO -import System.IO.Error ( catchIOError ) import GHC.Conc ( getAllocationCounter ) import System.CPUTime -------------------------- -type MsgDoc = SDoc ------------------------- data Validity @@ -126,209 +126,6 @@ orValid _ v = v -- ----------------------------------------------------------------------------- -- Basic error messages: just render a message with a source location. -type Messages = (WarningMessages, ErrorMessages) -type WarningMessages = Bag WarnMsg -type ErrorMessages = Bag ErrMsg - -unionMessages :: Messages -> Messages -> Messages -unionMessages (warns1, errs1) (warns2, errs2) = - (warns1 `unionBags` warns2, errs1 `unionBags` errs2) - -data ErrMsg = ErrMsg { - errMsgSpan :: SrcSpan, - errMsgContext :: PrintUnqualified, - errMsgDoc :: ErrDoc, - -- | This has the same text as errDocImportant . errMsgDoc. - errMsgShortString :: String, - errMsgSeverity :: Severity, - errMsgReason :: WarnReason - } - -- The SrcSpan is used for sorting errors into line-number order - - --- | Categorise error msgs by their importance. This is so each section can --- be rendered visually distinct. See Note [Error report] for where these come --- from. -data ErrDoc = ErrDoc { - -- | Primary error msg. - errDocImportant :: [MsgDoc], - -- | Context e.g. \"In the second argument of ...\". - errDocContext :: [MsgDoc], - -- | Supplementary information, e.g. \"Relevant bindings include ...\". - errDocSupplementary :: [MsgDoc] - } - -errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc -errDoc = ErrDoc - -mapErrDoc :: (MsgDoc -> MsgDoc) -> ErrDoc -> ErrDoc -mapErrDoc f (ErrDoc a b c) = ErrDoc (map f a) (map f b) (map f c) - -type WarnMsg = ErrMsg - -data Severity - = SevOutput - | SevFatal - | SevInteractive - - | SevDump - -- ^ Log message intended for compiler developers - -- No file\/line\/column stuff - - | SevInfo - -- ^ Log messages intended for end users. - -- No file\/line\/column stuff. - - | SevWarning - | SevError - -- ^ SevWarning and SevError are used for warnings and errors - -- o The message has a file\/line\/column heading, - -- plus "warning:" or "error:", - -- added by mkLocMessags - -- o Output is intended for end users - deriving Show - - -instance ToJson Severity where - json s = JSString (show s) - -instance Show ErrMsg where - show em = errMsgShortString em - -pprMessageBag :: Bag MsgDoc -> SDoc -pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) - --- | Make an unannotated error message with location info. -mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc -mkLocMessage = mkLocMessageAnn Nothing - --- | Make a possibly annotated error message with location info. -mkLocMessageAnn - :: Maybe String -- ^ optional annotation - -> Severity -- ^ severity - -> SrcSpan -- ^ location - -> MsgDoc -- ^ message - -> 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>". -mkLocMessageAnn ann severity locn msg - = sdocOption sdocColScheme $ \col_scheme -> - let locn' = sdocOption sdocErrorSpans $ \case - True -> ppr locn - False -> ppr (srcSpanStart locn) - - sevColour = getSeverityColour severity col_scheme - - -- Add optional information - optAnn = case ann of - Nothing -> text "" - Just i -> text " [" <> coloured sevColour (text i) <> text "]" - - -- Add prefixes, like Foo.hs:34: warning: - -- <the warning message> - header = locn' <> colon <+> - coloured sevColour sevText <> optAnn - - in coloured (Col.sMessage col_scheme) - (hang (coloured (Col.sHeader col_scheme) header) 4 - msg) - - where - sevText = - case severity of - SevWarning -> text "warning:" - SevError -> text "error:" - SevFatal -> text "fatal:" - _ -> empty - -getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour -getSeverityColour SevWarning = Col.sWarning -getSeverityColour SevError = Col.sError -getSeverityColour SevFatal = Col.sFatal -getSeverityColour _ = const mempty - -getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc -getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty -getCaretDiagnostic severity (RealSrcSpan span _) = do - caretDiagnostic <$> getSrcLine (srcSpanFile span) row - - where - getSrcLine fn i = - getLine i (unpackFS fn) - `catchIOError` \_ -> - pure Nothing - - getLine i fn = do - -- StringBuffer has advantages over readFile: - -- (a) no lazy IO, otherwise IO exceptions may occur in pure code - -- (b) always UTF-8, rather than some system-dependent encoding - -- (Haskell source code must be UTF-8 anyway) - content <- hGetStringBuffer fn - case atLine i content of - Just at_line -> pure $ - case lines (fix <$> lexemeToString at_line (len at_line)) of - srcLine : _ -> Just srcLine - _ -> Nothing - _ -> pure Nothing - - -- allow user to visibly see that their code is incorrectly encoded - -- (StringBuffer.nextChar uses \0 to represent undecodable characters) - fix '\0' = '\xfffd' - fix c = c - - row = srcSpanStartLine span - rowStr = show row - multiline = row /= srcSpanEndLine span - - caretDiagnostic Nothing = empty - caretDiagnostic (Just srcLineWithNewline) = - sdocOption sdocColScheme$ \col_scheme -> - let sevColour = getSeverityColour severity col_scheme - marginColour = Col.sMargin col_scheme - in - coloured marginColour (text marginSpace) <> - text ("\n") <> - coloured marginColour (text marginRow) <> - text (" " ++ srcLinePre) <> - coloured sevColour (text srcLineSpan) <> - text (srcLinePost ++ "\n") <> - coloured marginColour (text marginSpace) <> - coloured sevColour (text (" " ++ caretLine)) - - where - - -- expand tabs in a device-independent manner #13664 - expandTabs tabWidth i s = - case s of - "" -> "" - '\t' : cs -> replicate effectiveWidth ' ' ++ - expandTabs tabWidth (i + effectiveWidth) cs - c : cs -> c : expandTabs tabWidth (i + 1) cs - where effectiveWidth = tabWidth - i `mod` tabWidth - - srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline) - - start = srcSpanStartCol span - 1 - end | multiline = length srcLine - | otherwise = srcSpanEndCol span - 1 - width = max 1 (end - start) - - marginWidth = length rowStr - marginSpace = replicate marginWidth ' ' ++ " |" - marginRow = rowStr ++ " |" - - (srcLinePre, srcLineRest) = splitAt start srcLine - (srcLineSpan, srcLinePost) = splitAt width srcLineRest - - caretEllipsis | multiline = "..." - | otherwise = "" - caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis - -makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg -makeIntoWarning reason err = err - { errMsgSeverity = SevWarning - , errMsgReason = reason } -- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. @@ -993,3 +790,44 @@ 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 + |