1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
|
{-# LANGUAGE LambdaCase #-}
module GHC.Types.Error
( Messages
, WarningMessages
, ErrorMessages
, ErrMsg (..)
, WarnMsg
, ErrDoc (..)
, MsgDoc
, Severity (..)
, unionMessages
, errDoc
, mapErrDoc
, pprMessageBag
, mkLocMessage
, mkLocMessageAnn
, getSeverityColour
, getCaretDiagnostic
, makeIntoWarning
-- * Constructing individual errors
, mkErrMsg
, mkPlainErrMsg
, mkErrDoc
, mkLongErrMsg
, mkWarnMsg
, mkPlainWarnMsg
, mkLongWarnMsg
)
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 )
type Messages = (WarningMessages, ErrorMessages)
type WarningMessages = Bag WarnMsg
type ErrorMessages = Bag ErrMsg
type MsgDoc = SDoc
type WarnMsg = ErrMsg
-- | The main 'GHC' error type.
data ErrMsg = ErrMsg
{ errMsgSpan :: SrcSpan
-- ^ The SrcSpan is used for sorting errors into line-number order
, errMsgContext :: PrintUnqualified
, errMsgDoc :: ErrDoc
, errMsgSeverity :: Severity
, errMsgReason :: WarnReason
}
-- | 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]
}
unionMessages :: Messages -> Messages -> Messages
unionMessages (warns1, errs1) (warns2, errs2) =
(warns1 `unionBags` warns2, errs1 `unionBags` errs2)
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)
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 = showErrMsg
-- | Shows an 'ErrMsg'.
showErrMsg :: ErrMsg -> String
showErrMsg err =
renderWithContext defaultSDocContext (vcat (errDocImportant $ errMsgDoc err))
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 _) =
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 }
--
-- Creating ErrMsg(s)
--
mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mk_err_msg sev locn print_unqual err
= ErrMsg { errMsgSpan = locn
, errMsgContext = print_unqual
, errMsgDoc = err
, errMsgSeverity = sev
, errMsgReason = NoReason }
mkErrDoc :: SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg
mkErrDoc = mk_err_msg SevError
mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
-- ^ A long (multi-line) error message
mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg
-- ^ A short (one-line) error message
mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg
-- ^ Variant that doesn't care about qualified/unqualified names
mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual (ErrDoc [msg] [] [extra])
mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual (ErrDoc [msg] [] [])
mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify (ErrDoc [msg] [] [])
mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual (ErrDoc [msg] [] [extra])
mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual (ErrDoc [msg] [] [])
mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify (ErrDoc [msg] [] [])
|