module GHC.Types.Error
(
Messages
, WarningMessages
, ErrorMessages
, mkMessages
, emptyMessages
, isEmptyMessages
, addMessage
, unionMessages
, MsgEnvelope (..)
, WarnMsg
, SDoc
, DecoratedSDoc (unDecorated)
, Severity (..)
, RenderableDiagnostic (..)
, pprMessageBag
, mkDecorated
, mkLocMessage
, mkLocMessageAnn
, getSeverityColour
, getCaretDiagnostic
, makeIntoWarning
, mkMsgEnvelope
, mkPlainMsgEnvelope
, mkErr
, mkLongMsgEnvelope
, mkWarnMsg
, mkPlainWarnMsg
, mkLongWarnMsg
, isErrorMessage
, isWarningMessage
, getErrorMessages
, getWarningMessages
, partitionMessages
, errorsFound
)
where
import GHC.Prelude
import GHC.Driver.Flags
import GHC.Data.Bag
import GHC.Utils.Outputable as Outputable
import qualified GHC.Utils.Ppr.Colour as Col
import GHC.Types.SrcLoc as SrcLoc
import GHC.Data.FastString (unpackFS)
import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)
import GHC.Utils.Json
import System.IO.Error ( catchIOError )
newtype Messages e = Messages (Bag (MsgEnvelope e))
instance Functor Messages where
fmap f (Messages xs) = Messages (mapBag (fmap f) xs)
emptyMessages :: Messages e
emptyMessages = Messages emptyBag
mkMessages :: Bag (MsgEnvelope e) -> Messages e
mkMessages = Messages
isEmptyMessages :: Messages e -> Bool
isEmptyMessages (Messages msgs) = isEmptyBag msgs
addMessage :: MsgEnvelope e -> Messages e -> Messages e
addMessage x (Messages xs) = Messages (x `consBag` xs)
unionMessages :: Messages e -> Messages e -> Messages e
unionMessages (Messages msgs1) (Messages msgs2) = Messages (msgs1 `unionBags` msgs2)
type WarningMessages = Bag (MsgEnvelope DecoratedSDoc)
type ErrorMessages = Bag (MsgEnvelope DecoratedSDoc)
type WarnMsg = MsgEnvelope DecoratedSDoc
newtype DecoratedSDoc = Decorated { unDecorated :: [SDoc] }
mkDecorated :: [SDoc] -> DecoratedSDoc
mkDecorated = Decorated
class RenderableDiagnostic a where
renderDiagnostic :: a -> DecoratedSDoc
data MsgEnvelope e = MsgEnvelope
{ errMsgSpan :: SrcSpan
, errMsgContext :: PrintUnqualified
, errMsgDiagnostic :: e
, errMsgSeverity :: Severity
, errMsgReason :: WarnReason
} deriving Functor
instance RenderableDiagnostic DecoratedSDoc where
renderDiagnostic = id
data Severity
= SevOutput
| SevFatal
| SevInteractive
| SevDump
| SevInfo
| SevWarning
| SevError
deriving (Eq, Show)
instance ToJson Severity where
json s = JSString (show s)
instance Show (MsgEnvelope DecoratedSDoc) where
show = showMsgEnvelope
showMsgEnvelope :: RenderableDiagnostic a => MsgEnvelope a -> String
showMsgEnvelope err =
renderWithContext defaultSDocContext (vcat (unDecorated . renderDiagnostic $ errMsgDiagnostic err))
pprMessageBag :: Bag SDoc -> SDoc
pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))
mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage = mkLocMessageAnn Nothing
mkLocMessageAnn
:: Maybe String
-> Severity
-> SrcSpan
-> SDoc
-> SDoc
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
optAnn = case ann of
Nothing -> text ""
Just i -> text " [" <> coloured sevColour (text i) <> text "]"
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 SDoc
getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty
getCaretDiagnostic severity (RealSrcSpan span _) =
caretDiagnostic <$> getSrcLine (srcSpanFile span) row
where
getSrcLine fn i =
getLine i (unpackFS fn)
`catchIOError` \_ ->
pure Nothing
getLine i fn = do
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
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
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 -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning reason err = err
{ errMsgSeverity = SevWarning
, errMsgReason = reason }
mk_err_msg
:: Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mk_err_msg sev locn print_unqual err
= MsgEnvelope { errMsgSpan = locn
, errMsgContext = print_unqual
, errMsgDiagnostic = err
, errMsgSeverity = sev
, errMsgReason = NoReason }
mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErr = mk_err_msg SevError
mkLongMsgEnvelope, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc
mkMsgEnvelope, mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkLongMsgEnvelope locn unqual msg extra = mk_err_msg SevError locn unqual (mkDecorated [msg,extra])
mkMsgEnvelope locn unqual msg = mk_err_msg SevError locn unqual (mkDecorated [msg])
mkPlainMsgEnvelope locn msg = mk_err_msg SevError locn alwaysQualify (mkDecorated [msg])
mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual (mkDecorated [msg,extra])
mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual (mkDecorated [msg])
mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify (mkDecorated [msg])
isErrorMessage :: MsgEnvelope e -> Bool
isErrorMessage = (== SevError) . errMsgSeverity
isWarningMessage :: MsgEnvelope e -> Bool
isWarningMessage = not . isErrorMessage
errorsFound :: Messages e -> Bool
errorsFound (Messages msgs) = any isErrorMessage msgs
getWarningMessages :: Messages e -> Bag (MsgEnvelope e)
getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs
getErrorMessages :: Messages e -> Bag (MsgEnvelope e)
getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs
partitionMessages :: Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
partitionMessages (Messages xs) = partitionBag isWarningMessage xs