never executed always true always false
1 {-# LANGUAGE RecordWildCards #-}
2 {-# LANGUAGE MultiWayIf #-}
3 {-# LANGUAGE LambdaCase #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE FlexibleContexts #-}
6
7 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic PsMessage
8
9 module GHC.Parser.Errors.Ppr where
10
11 import GHC.Prelude
12 import GHC.Driver.Flags
13 import GHC.Parser.Errors.Basic
14 import GHC.Parser.Errors.Types
15 import GHC.Parser.Types
16 import GHC.Types.Basic
17 import GHC.Types.Error
18 import GHC.Types.Hint.Ppr (perhapsAsPat)
19 import GHC.Types.SrcLoc
20 import GHC.Types.Name.Reader (opIsAt, starInfo, rdrNameOcc, mkUnqual)
21 import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)
22 import GHC.Utils.Outputable
23 import GHC.Utils.Misc
24 import GHC.Data.FastString
25 import GHC.Data.Maybe (catMaybes)
26 import GHC.Hs.Expr (prependQualified,HsExpr(..))
27 import GHC.Hs.Type (pprLHsContext)
28 import GHC.Builtin.Names (allNameStrings)
29 import GHC.Builtin.Types (filterCTuple)
30 import qualified GHC.LanguageExtensions as LangExt
31 import Data.List.NonEmpty (NonEmpty((:|)))
32
33
34 instance Diagnostic PsMessage where
35 diagnosticMessage = \case
36 PsUnknownMessage m
37 -> diagnosticMessage m
38
39 PsHeaderMessage m
40 -> psHeaderMessageDiagnostic m
41
42 PsWarnHaddockInvalidPos
43 -> mkSimpleDecorated $ text "A Haddock comment cannot appear in this position and will be ignored."
44 PsWarnHaddockIgnoreMulti
45 -> mkSimpleDecorated $
46 text "Multiple Haddock comments for a single entity are not allowed." $$
47 text "The extraneous comment will be ignored."
48 PsWarnBidirectionalFormatChars ((loc,_,desc) :| xs)
49 -> mkSimpleDecorated $
50 text "A unicode bidirectional formatting character" <+> parens (text desc)
51 $$ text "was found at offset" <+> ppr (bufPos (psBufPos loc)) <+> text "in the file"
52 $$ (case xs of
53 [] -> empty
54 xs -> text "along with further bidirectional formatting characters at" <+> pprChars xs
55 where
56 pprChars [] = empty
57 pprChars ((loc,_,desc):xs) = text "offset" <+> ppr (bufPos (psBufPos loc)) <> text ":" <+> text desc
58 $$ pprChars xs
59 )
60 $$ text "Bidirectional formatting characters may be rendered misleadingly in certain editors"
61
62 PsWarnTab tc
63 -> mkSimpleDecorated $
64 text "Tab character found here"
65 <> (if tc == 1
66 then text ""
67 else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location"))
68 <> text "."
69 PsWarnTransitionalLayout reason
70 -> mkSimpleDecorated $
71 text "transitional layout will not be accepted in the future:"
72 $$ text (case reason of
73 TransLayout_Where -> "`where' clause at the same depth as implicit layout block"
74 TransLayout_Pipe -> "`|' at the same depth as implicit layout block"
75 )
76 PsWarnOperatorWhitespaceExtConflict sym
77 -> let mk_prefix_msg extension_name syntax_meaning =
78 text "The prefix use of a" <+> quotes (pprOperatorWhitespaceSymbol sym)
79 <+> text "would denote" <+> text syntax_meaning
80 $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.")
81 in mkSimpleDecorated $
82 case sym of
83 OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "LinearTypes" "a multiplicity annotation"
84 OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "TemplateHaskell" "an untyped splice"
85 OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "TemplateHaskell" "a typed splice"
86 PsWarnOperatorWhitespace sym occ_type
87 -> let mk_msg occ_type_str =
88 text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)
89 <+> text "might be repurposed as special syntax"
90 $$ nest 2 (text "by a future language extension.")
91 in mkSimpleDecorated $
92 case occ_type of
93 OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix"
94 OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"
95 OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"
96 PsWarnStarBinder
97 -> mkSimpleDecorated $
98 text "Found binding occurrence of" <+> quotes (text "*")
99 <+> text "yet StarIsType is enabled."
100 PsWarnStarIsType
101 -> mkSimpleDecorated $
102 text "Using" <+> quotes (text "*")
103 <+> text "(or its Unicode variant) to mean"
104 <+> quotes (text "Data.Kind.Type")
105 $$ text "relies on the StarIsType extension, which will become"
106 $$ text "deprecated in the future."
107 PsWarnUnrecognisedPragma
108 -> mkSimpleDecorated $ text "Unrecognised pragma"
109 PsWarnImportPreQualified
110 -> mkSimpleDecorated $
111 text "Found" <+> quotes (text "qualified")
112 <+> text "in prepositive position"
113
114 PsErrLexer err kind
115 -> mkSimpleDecorated $ hcat
116 [ text $ case err of
117 LexError -> "lexical error"
118 LexUnknownPragma -> "unknown pragma"
119 LexErrorInPragma -> "lexical error in pragma"
120 LexNumEscapeRange -> "numeric escape sequence out of range"
121 LexStringCharLit -> "lexical error in string/character literal"
122 LexStringCharLitEOF -> "unexpected end-of-file in string/character literal"
123 LexUnterminatedComment -> "unterminated `{-'"
124 LexUnterminatedOptions -> "unterminated OPTIONS pragma"
125 LexUnterminatedQQ -> "unterminated quasiquotation"
126
127 , text $ case kind of
128 LexErrKind_EOF -> " at end of input"
129 LexErrKind_UTF8 -> " (UTF-8 decoding error)"
130 LexErrKind_Char c -> " at character " ++ show c
131 ]
132 PsErrParse token _details
133 | null token
134 -> mkSimpleDecorated $ text "parse error (possibly incorrect indentation or mismatched brackets)"
135 | otherwise
136 -> mkSimpleDecorated $ text "parse error on input" <+> quotes (text token)
137 PsErrCmmLexer
138 -> mkSimpleDecorated $ text "Cmm lexical error"
139 PsErrCmmParser cmm_err -> mkSimpleDecorated $ case cmm_err of
140 CmmUnknownPrimitive name -> text "unknown primitive" <+> ftext name
141 CmmUnknownMacro fun -> text "unknown macro" <+> ftext fun
142 CmmUnknownCConv cconv -> text "unknown calling convention:" <+> text cconv
143 CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety
144 CmmUnrecognisedHint hint -> text "unrecognised hint:" <+> text hint
145
146 PsErrTypeAppWithoutSpace v e
147 -> mkSimpleDecorated $
148 sep [ text "@-pattern in expression context:"
149 , nest 4 (pprPrefixOcc v <> text "@" <> ppr e)
150 ]
151 $$ text "Type application syntax requires a space before '@'"
152 PsErrLazyPatWithoutSpace e
153 -> mkSimpleDecorated $
154 sep [ text "Lazy pattern in expression context:"
155 , nest 4 (text "~" <> ppr e)
156 ]
157 $$ text "Did you mean to add a space after the '~'?"
158 PsErrBangPatWithoutSpace e
159 -> mkSimpleDecorated $
160 sep [ text "Bang pattern in expression context:"
161 , nest 4 (text "!" <> ppr e)
162 ]
163 $$ text "Did you mean to add a space after the '!'?"
164 PsErrInvalidInfixHole
165 -> mkSimpleDecorated $ text "Invalid infix hole, expected an infix operator"
166 PsErrExpectedHyphen
167 -> mkSimpleDecorated $ text "Expected a hyphen"
168 PsErrSpaceInSCC
169 -> mkSimpleDecorated $ text "Spaces are not allowed in SCCs"
170 PsErrEmptyDoubleQuotes _th_on
171 -> mkSimpleDecorated $ vcat msg
172 where
173 msg = [ text "Parser error on `''`"
174 , text "Character literals may not be empty"
175 ]
176 PsErrLambdaCase
177 -> mkSimpleDecorated $ text "Illegal lambda-case"
178 PsErrEmptyLambda
179 -> mkSimpleDecorated $ text "A lambda requires at least one parameter"
180 PsErrLinearFunction
181 -> mkSimpleDecorated $ text "Illegal use of linear functions"
182 PsErrOverloadedRecordUpdateNotEnabled
183 -> mkSimpleDecorated $ text "Illegal overloaded record update"
184 PsErrMultiWayIf
185 -> mkSimpleDecorated $ text "Illegal multi-way if-expression"
186 PsErrNumUnderscores reason
187 -> mkSimpleDecorated $
188 text $ case reason of
189 NumUnderscore_Integral -> "Illegal underscores in integer literals"
190 NumUnderscore_Float -> "Illegal underscores in floating literals"
191 PsErrIllegalBangPattern e
192 -> mkSimpleDecorated $ text "Illegal bang-pattern" $$ ppr e
193 PsErrOverloadedRecordDotInvalid
194 -> mkSimpleDecorated $
195 text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)"
196 PsErrIllegalPatSynExport
197 -> mkSimpleDecorated $ text "Illegal export form"
198 PsErrOverloadedRecordUpdateNoQualifiedFields
199 -> mkSimpleDecorated $ text "Fields cannot be qualified when OverloadedRecordUpdate is enabled"
200 PsErrExplicitForall is_unicode
201 -> mkSimpleDecorated $ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"
202 PsErrIllegalQualifiedDo qdoDoc
203 -> mkSimpleDecorated $
204 text "Illegal qualified" <+> quotes qdoDoc <+> text "block"
205 PsErrQualifiedDoInCmd m
206 -> mkSimpleDecorated $
207 hang (text "Parse error in command:") 2 $
208 text "Found a qualified" <+> ppr m <> text ".do block in a command, but"
209 $$ text "qualified 'do' is not supported in commands."
210 PsErrRecordSyntaxInPatSynDecl pat
211 -> mkSimpleDecorated $
212 text "record syntax not supported for pattern synonym declarations:"
213 $$ ppr pat
214 PsErrEmptyWhereInPatSynDecl patsyn_name
215 -> mkSimpleDecorated $
216 text "pattern synonym 'where' clause cannot be empty"
217 $$ text "In the pattern synonym declaration for: "
218 <+> ppr (patsyn_name)
219 PsErrInvalidWhereBindInPatSynDecl patsyn_name decl
220 -> mkSimpleDecorated $
221 text "pattern synonym 'where' clause must bind the pattern synonym's name"
222 <+> quotes (ppr patsyn_name) $$ ppr decl
223 PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl
224 -> mkSimpleDecorated $
225 text "pattern synonym 'where' clause must contain a single binding:"
226 $$ ppr decl
227 PsErrDeclSpliceNotAtTopLevel d
228 -> mkSimpleDecorated $
229 hang (text "Declaration splices are allowed only"
230 <+> text "at the top level:")
231 2 (ppr d)
232 PsErrMultipleNamesInStandaloneKindSignature vs
233 -> mkSimpleDecorated $
234 vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")
235 2 (pprWithCommas ppr vs)
236 , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details."
237 ]
238 PsErrIllegalExplicitNamespace
239 -> mkSimpleDecorated $
240 text "Illegal keyword 'type'"
241
242 PsErrUnallowedPragma prag
243 -> mkSimpleDecorated $
244 hang (text "A pragma is not allowed in this position:") 2
245 (ppr prag)
246 PsErrImportPostQualified
247 -> mkSimpleDecorated $
248 text "Found" <+> quotes (text "qualified")
249 <+> text "in postpositive position. "
250 PsErrImportQualifiedTwice
251 -> mkSimpleDecorated $ text "Multiple occurrences of 'qualified'"
252 PsErrIllegalImportBundleForm
253 -> mkSimpleDecorated $
254 text "Illegal import form, this syntax can only be used to bundle"
255 $+$ text "pattern synonyms with types in module exports."
256 PsErrInvalidRuleActivationMarker
257 -> mkSimpleDecorated $ text "Invalid rule activation marker"
258
259 PsErrMissingBlock
260 -> mkSimpleDecorated $ text "Missing block"
261 PsErrUnsupportedBoxedSumExpr s
262 -> mkSimpleDecorated $
263 hang (text "Boxed sums not supported:") 2
264 (pprSumOrTuple Boxed s)
265 PsErrUnsupportedBoxedSumPat s
266 -> mkSimpleDecorated $
267 hang (text "Boxed sums not supported:") 2
268 (pprSumOrTuple Boxed s)
269 PsErrUnexpectedQualifiedConstructor v
270 -> mkSimpleDecorated $
271 hang (text "Expected an unqualified type constructor:") 2
272 (ppr v)
273 PsErrTupleSectionInPat
274 -> mkSimpleDecorated $ text "Tuple section in pattern context"
275 PsErrOpFewArgs (StarIsType star_is_type) op
276 -> mkSimpleDecorated $
277 text "Operator applied to too few arguments:" <+> ppr op
278 $$ starInfo star_is_type op
279 PsErrVarForTyCon name
280 -> mkSimpleDecorated $
281 text "Expecting a type constructor but found a variable,"
282 <+> quotes (ppr name) <> text "."
283 $$ if isSymOcc $ rdrNameOcc name
284 then text "If" <+> quotes (ppr name) <+> text "is a type constructor"
285 <+> text "then enable ExplicitNamespaces and use the 'type' keyword."
286 else empty
287 PsErrMalformedEntityString
288 -> mkSimpleDecorated $ text "Malformed entity string"
289 PsErrDotsInRecordUpdate
290 -> mkSimpleDecorated $ text "You cannot use `..' in a record update"
291 PsErrInvalidDataCon t
292 -> mkSimpleDecorated $
293 hang (text "Cannot parse data constructor in a data/newtype declaration:") 2
294 (ppr t)
295 PsErrInvalidInfixDataCon lhs tc rhs
296 -> mkSimpleDecorated $
297 hang (text "Cannot parse an infix data constructor in a data/newtype declaration:") 2
298 (ppr lhs <+> ppr tc <+> ppr rhs)
299 PsErrUnpackDataCon
300 -> mkSimpleDecorated $ text "{-# UNPACK #-} cannot be applied to a data constructor."
301 PsErrUnexpectedKindAppInDataCon lhs ki
302 -> mkSimpleDecorated $
303 hang (text "Unexpected kind application in a data/newtype declaration:") 2
304 (ppr lhs <+> text "@" <> ppr ki)
305 PsErrInvalidRecordCon p
306 -> mkSimpleDecorated $ text "Not a record constructor:" <+> ppr p
307 PsErrIllegalUnboxedStringInPat lit
308 -> mkSimpleDecorated $ text "Illegal unboxed string literal in pattern:" $$ ppr lit
309 PsErrDoNotationInPat
310 -> mkSimpleDecorated $ text "do-notation in pattern"
311 PsErrIfThenElseInPat
312 -> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern"
313 PsErrLambdaCaseInPat
314 -> mkSimpleDecorated $ text "(\\case ...)-syntax in pattern"
315 PsErrCaseInPat
316 -> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern"
317 PsErrLetInPat
318 -> mkSimpleDecorated $ text "(let ... in ...)-syntax in pattern"
319 PsErrLambdaInPat
320 -> mkSimpleDecorated $
321 text "Lambda-syntax in pattern."
322 $$ text "Pattern matching on functions is not possible."
323 PsErrArrowExprInPat e
324 -> mkSimpleDecorated $ text "Expression syntax in pattern:" <+> ppr e
325 PsErrArrowCmdInPat c
326 -> mkSimpleDecorated $ text "Command syntax in pattern:" <+> ppr c
327 PsErrArrowCmdInExpr c
328 -> mkSimpleDecorated $
329 vcat
330 [ text "Arrow command found where an expression was expected:"
331 , nest 2 (ppr c)
332 ]
333 PsErrViewPatInExpr a b
334 -> mkSimpleDecorated $
335 sep [ text "View pattern in expression context:"
336 , nest 4 (ppr a <+> text "->" <+> ppr b)
337 ]
338 PsErrLambdaCmdInFunAppCmd a
339 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda command") a
340 PsErrCaseCmdInFunAppCmd a
341 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a
342 PsErrIfCmdInFunAppCmd a
343 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a
344 PsErrLetCmdInFunAppCmd a
345 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let command") a
346 PsErrDoCmdInFunAppCmd a
347 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "do command") a
348 PsErrDoInFunAppExpr m a
349 -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "do block")) a
350 PsErrMDoInFunAppExpr m a
351 -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "mdo block")) a
352 PsErrLambdaInFunAppExpr a
353 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda expression") a
354 PsErrCaseInFunAppExpr a
355 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a
356 PsErrLambdaCaseInFunAppExpr a
357 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda-case expression") a
358 PsErrLetInFunAppExpr a
359 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a
360 PsErrIfInFunAppExpr a
361 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if expression") a
362 PsErrProcInFunAppExpr a
363 -> mkSimpleDecorated $ pp_unexpected_fun_app (text "proc expression") a
364 PsErrMalformedTyOrClDecl ty
365 -> mkSimpleDecorated $
366 text "Malformed head of type or class declaration:" <+> ppr ty
367 PsErrIllegalWhereInDataDecl
368 -> mkSimpleDecorated $ text "Illegal keyword 'where' in data declaration"
369 PsErrIllegalDataTypeContext c
370 -> mkSimpleDecorated $
371 text "Illegal datatype context:"
372 <+> pprLHsContext (Just c)
373 PsErrPrimStringInvalidChar
374 -> mkSimpleDecorated $ text "primitive string literal must contain only characters <= \'\\xFF\'"
375 PsErrSuffixAT
376 -> mkSimpleDecorated $
377 text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."
378 PsErrPrecedenceOutOfRange i
379 -> mkSimpleDecorated $ text "Precedence out of range: " <> int i
380 PsErrSemiColonsInCondExpr c st t se e
381 -> mkSimpleDecorated $
382 text "Unexpected semi-colons in conditional:"
383 $$ nest 4 expr
384 where
385 pprOptSemi True = semi
386 pprOptSemi False = empty
387 expr = text "if" <+> ppr c <> pprOptSemi st <+>
388 text "then" <+> ppr t <> pprOptSemi se <+>
389 text "else" <+> ppr e
390 PsErrSemiColonsInCondCmd c st t se e
391 -> mkSimpleDecorated $
392 text "Unexpected semi-colons in conditional:"
393 $$ nest 4 expr
394 where
395 pprOptSemi True = semi
396 pprOptSemi False = empty
397 expr = text "if" <+> ppr c <> pprOptSemi st <+>
398 text "then" <+> ppr t <> pprOptSemi se <+>
399 text "else" <+> ppr e
400 PsErrAtInPatPos
401 -> mkSimpleDecorated $
402 text "Found a binding for the"
403 <+> quotes (text "@")
404 <+> text "operator in a pattern position."
405 $$ perhapsAsPat
406 PsErrParseErrorOnInput occ
407 -> mkSimpleDecorated $ text "parse error on input" <+> ftext (occNameFS occ)
408 PsErrMalformedDecl what for
409 -> mkSimpleDecorated $
410 text "Malformed" <+> what
411 <+> text "declaration for" <+> quotes (ppr for)
412 PsErrUnexpectedTypeAppInDecl ki what for
413 -> mkSimpleDecorated $
414 vcat [ text "Unexpected type application"
415 <+> text "@" <> ppr ki
416 , text "In the" <+> what
417 <+> text "declaration for"
418 <+> quotes (ppr for)
419 ]
420 PsErrNotADataCon name
421 -> mkSimpleDecorated $ text "Not a data constructor:" <+> quotes (ppr name)
422 PsErrInferredTypeVarNotAllowed
423 -> mkSimpleDecorated $ text "Inferred type variables are not allowed here"
424 PsErrIllegalTraditionalRecordSyntax s
425 -> mkSimpleDecorated $
426 text "Illegal record syntax:" <+> s
427 PsErrParseErrorInCmd s
428 -> mkSimpleDecorated $ hang (text "Parse error in command:") 2 s
429 PsErrInPat s details
430 -> let msg = parse_error_in_pat
431 body = case details of
432 PEIP_NegApp -> text "-" <> ppr s
433 PEIP_TypeArgs peipd_tyargs
434 | not (null peipd_tyargs) -> ppr s <+> vcat [
435 hsep [text "@" <> ppr t | t <- peipd_tyargs]
436 , text "Type applications in patterns are only allowed on data constructors."
437 ]
438 | otherwise -> ppr s
439 PEIP_OtherPatDetails (ParseContext (Just fun) _)
440 -> ppr s <+> text "In a function binding for the"
441 <+> quotes (ppr fun)
442 <+> text "operator."
443 $$ if opIsAt fun
444 then perhapsAsPat
445 else empty
446 _ -> ppr s
447 in mkSimpleDecorated $ msg <+> body
448 PsErrParseRightOpSectionInPat infixOcc s
449 -> mkSimpleDecorated $ parse_error_in_pat <+> pprInfixOcc infixOcc <> ppr s
450 PsErrIllegalRoleName role _nearby
451 -> mkSimpleDecorated $
452 text "Illegal role name" <+> quotes (ppr role)
453 PsErrInvalidTypeSignature lhs
454 -> mkSimpleDecorated $
455 text "Invalid type signature:"
456 <+> ppr lhs
457 <+> text ":: ..."
458 PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where
459 -> mkSimpleDecorated $
460 vcat [ text "Unexpected type" <+> quotes (ppr t)
461 , text "In the" <+> what
462 <+> text "declaration for" <+> quotes tc'
463 , vcat[ (text "A" <+> what
464 <+> text "declaration should have form")
465 , nest 2
466 (what
467 <+> tc'
468 <+> hsep (map text (takeList tparms allNameStrings))
469 <+> equals_or_where) ] ]
470 where
471 -- Avoid printing a constraint tuple in the error message. Print
472 -- a plain old tuple instead (since that's what the user probably
473 -- wrote). See #14907
474 tc' = ppr $ filterCTuple tc
475 PsErrInvalidPackageName pkg
476 -> mkSimpleDecorated $ vcat
477 [ text "Parse error" <> colon <+> quotes (ftext pkg)
478 , text "Version number or non-alphanumeric" <+>
479 text "character in package name"
480 ]
481
482 PsErrIllegalGadtRecordMultiplicity arr
483 -> mkSimpleDecorated $ vcat
484 [ text "Parse error" <> colon <+> quotes (ppr arr)
485 , text "Record constructors in GADTs must use an ordinary, non-linear arrow."
486 ]
487 PsErrInvalidCApiImport {} -> mkSimpleDecorated $ vcat [ text "Wrapper stubs can't be used with CApiFFI."]
488
489 diagnosticReason = \case
490 PsUnknownMessage m -> diagnosticReason m
491 PsHeaderMessage m -> psHeaderMessageReason m
492 PsWarnBidirectionalFormatChars{} -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters
493 PsWarnTab{} -> WarningWithFlag Opt_WarnTabs
494 PsWarnTransitionalLayout{} -> WarningWithFlag Opt_WarnAlternativeLayoutRuleTransitional
495 PsWarnOperatorWhitespaceExtConflict{} -> WarningWithFlag Opt_WarnOperatorWhitespaceExtConflict
496 PsWarnOperatorWhitespace{} -> WarningWithFlag Opt_WarnOperatorWhitespace
497 PsWarnHaddockInvalidPos -> WarningWithFlag Opt_WarnInvalidHaddock
498 PsWarnHaddockIgnoreMulti -> WarningWithFlag Opt_WarnInvalidHaddock
499 PsWarnStarBinder -> WarningWithFlag Opt_WarnStarBinder
500 PsWarnStarIsType -> WarningWithFlag Opt_WarnStarIsType
501 PsWarnUnrecognisedPragma -> WarningWithFlag Opt_WarnUnrecognisedPragmas
502 PsWarnImportPreQualified -> WarningWithFlag Opt_WarnPrepositiveQualifiedModule
503 PsErrLexer{} -> ErrorWithoutFlag
504 PsErrCmmLexer -> ErrorWithoutFlag
505 PsErrCmmParser{} -> ErrorWithoutFlag
506 PsErrParse{} -> ErrorWithoutFlag
507 PsErrTypeAppWithoutSpace{} -> ErrorWithoutFlag
508 PsErrLazyPatWithoutSpace{} -> ErrorWithoutFlag
509 PsErrBangPatWithoutSpace{} -> ErrorWithoutFlag
510 PsErrInvalidInfixHole -> ErrorWithoutFlag
511 PsErrExpectedHyphen -> ErrorWithoutFlag
512 PsErrSpaceInSCC -> ErrorWithoutFlag
513 PsErrEmptyDoubleQuotes{} -> ErrorWithoutFlag
514 PsErrLambdaCase{} -> ErrorWithoutFlag
515 PsErrEmptyLambda{} -> ErrorWithoutFlag
516 PsErrLinearFunction{} -> ErrorWithoutFlag
517 PsErrMultiWayIf{} -> ErrorWithoutFlag
518 PsErrOverloadedRecordUpdateNotEnabled{} -> ErrorWithoutFlag
519 PsErrNumUnderscores{} -> ErrorWithoutFlag
520 PsErrIllegalBangPattern{} -> ErrorWithoutFlag
521 PsErrOverloadedRecordDotInvalid{} -> ErrorWithoutFlag
522 PsErrIllegalPatSynExport -> ErrorWithoutFlag
523 PsErrOverloadedRecordUpdateNoQualifiedFields -> ErrorWithoutFlag
524 PsErrExplicitForall{} -> ErrorWithoutFlag
525 PsErrIllegalQualifiedDo{} -> ErrorWithoutFlag
526 PsErrQualifiedDoInCmd{} -> ErrorWithoutFlag
527 PsErrRecordSyntaxInPatSynDecl{} -> ErrorWithoutFlag
528 PsErrEmptyWhereInPatSynDecl{} -> ErrorWithoutFlag
529 PsErrInvalidWhereBindInPatSynDecl{} -> ErrorWithoutFlag
530 PsErrNoSingleWhereBindInPatSynDecl{} -> ErrorWithoutFlag
531 PsErrDeclSpliceNotAtTopLevel{} -> ErrorWithoutFlag
532 PsErrMultipleNamesInStandaloneKindSignature{} -> ErrorWithoutFlag
533 PsErrIllegalExplicitNamespace -> ErrorWithoutFlag
534 PsErrUnallowedPragma{} -> ErrorWithoutFlag
535 PsErrImportPostQualified -> ErrorWithoutFlag
536 PsErrImportQualifiedTwice -> ErrorWithoutFlag
537 PsErrIllegalImportBundleForm -> ErrorWithoutFlag
538 PsErrInvalidRuleActivationMarker -> ErrorWithoutFlag
539 PsErrMissingBlock -> ErrorWithoutFlag
540 PsErrUnsupportedBoxedSumExpr{} -> ErrorWithoutFlag
541 PsErrUnsupportedBoxedSumPat{} -> ErrorWithoutFlag
542 PsErrUnexpectedQualifiedConstructor{} -> ErrorWithoutFlag
543 PsErrTupleSectionInPat{} -> ErrorWithoutFlag
544 PsErrOpFewArgs{} -> ErrorWithoutFlag
545 PsErrVarForTyCon{} -> ErrorWithoutFlag
546 PsErrMalformedEntityString -> ErrorWithoutFlag
547 PsErrDotsInRecordUpdate -> ErrorWithoutFlag
548 PsErrInvalidDataCon{} -> ErrorWithoutFlag
549 PsErrInvalidInfixDataCon{} -> ErrorWithoutFlag
550 PsErrUnpackDataCon -> ErrorWithoutFlag
551 PsErrUnexpectedKindAppInDataCon{} -> ErrorWithoutFlag
552 PsErrInvalidRecordCon{} -> ErrorWithoutFlag
553 PsErrIllegalUnboxedStringInPat{} -> ErrorWithoutFlag
554 PsErrDoNotationInPat{} -> ErrorWithoutFlag
555 PsErrIfThenElseInPat -> ErrorWithoutFlag
556 PsErrLambdaCaseInPat -> ErrorWithoutFlag
557 PsErrCaseInPat -> ErrorWithoutFlag
558 PsErrLetInPat -> ErrorWithoutFlag
559 PsErrLambdaInPat -> ErrorWithoutFlag
560 PsErrArrowExprInPat{} -> ErrorWithoutFlag
561 PsErrArrowCmdInPat{} -> ErrorWithoutFlag
562 PsErrArrowCmdInExpr{} -> ErrorWithoutFlag
563 PsErrViewPatInExpr{} -> ErrorWithoutFlag
564 PsErrLambdaCmdInFunAppCmd{} -> ErrorWithoutFlag
565 PsErrCaseCmdInFunAppCmd{} -> ErrorWithoutFlag
566 PsErrIfCmdInFunAppCmd{} -> ErrorWithoutFlag
567 PsErrLetCmdInFunAppCmd{} -> ErrorWithoutFlag
568 PsErrDoCmdInFunAppCmd{} -> ErrorWithoutFlag
569 PsErrDoInFunAppExpr{} -> ErrorWithoutFlag
570 PsErrMDoInFunAppExpr{} -> ErrorWithoutFlag
571 PsErrLambdaInFunAppExpr{} -> ErrorWithoutFlag
572 PsErrCaseInFunAppExpr{} -> ErrorWithoutFlag
573 PsErrLambdaCaseInFunAppExpr{} -> ErrorWithoutFlag
574 PsErrLetInFunAppExpr{} -> ErrorWithoutFlag
575 PsErrIfInFunAppExpr{} -> ErrorWithoutFlag
576 PsErrProcInFunAppExpr{} -> ErrorWithoutFlag
577 PsErrMalformedTyOrClDecl{} -> ErrorWithoutFlag
578 PsErrIllegalWhereInDataDecl -> ErrorWithoutFlag
579 PsErrIllegalDataTypeContext{} -> ErrorWithoutFlag
580 PsErrPrimStringInvalidChar -> ErrorWithoutFlag
581 PsErrSuffixAT -> ErrorWithoutFlag
582 PsErrPrecedenceOutOfRange{} -> ErrorWithoutFlag
583 PsErrSemiColonsInCondExpr{} -> ErrorWithoutFlag
584 PsErrSemiColonsInCondCmd{} -> ErrorWithoutFlag
585 PsErrAtInPatPos -> ErrorWithoutFlag
586 PsErrParseErrorOnInput{} -> ErrorWithoutFlag
587 PsErrMalformedDecl{} -> ErrorWithoutFlag
588 PsErrUnexpectedTypeAppInDecl{} -> ErrorWithoutFlag
589 PsErrNotADataCon{} -> ErrorWithoutFlag
590 PsErrInferredTypeVarNotAllowed -> ErrorWithoutFlag
591 PsErrIllegalTraditionalRecordSyntax{} -> ErrorWithoutFlag
592 PsErrParseErrorInCmd{} -> ErrorWithoutFlag
593 PsErrInPat{} -> ErrorWithoutFlag
594 PsErrIllegalRoleName{} -> ErrorWithoutFlag
595 PsErrInvalidTypeSignature{} -> ErrorWithoutFlag
596 PsErrUnexpectedTypeInDecl{} -> ErrorWithoutFlag
597 PsErrInvalidPackageName{} -> ErrorWithoutFlag
598 PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag
599 PsErrIllegalGadtRecordMultiplicity{} -> ErrorWithoutFlag
600 PsErrInvalidCApiImport {} -> ErrorWithoutFlag
601
602 diagnosticHints = \case
603 PsUnknownMessage m -> diagnosticHints m
604 PsHeaderMessage m -> psHeaderMessageHints m
605 PsWarnBidirectionalFormatChars{} -> noHints
606 PsWarnTab{} -> [SuggestUseSpaces]
607 PsWarnTransitionalLayout{} -> noHints
608 PsWarnOperatorWhitespaceExtConflict sym -> [SuggestUseWhitespaceAfter sym]
609 PsWarnOperatorWhitespace sym occ -> [SuggestUseWhitespaceAround (unpackFS sym) occ]
610 PsWarnHaddockInvalidPos -> noHints
611 PsWarnHaddockIgnoreMulti -> noHints
612 PsWarnStarBinder -> [SuggestQualifyStarOperator]
613 PsWarnStarIsType -> [SuggestUseTypeFromDataKind]
614 PsWarnUnrecognisedPragma -> noHints
615 PsWarnImportPreQualified -> [ SuggestQualifiedAfterModuleName
616 , suggestExtension LangExt.ImportQualifiedPost]
617 PsErrLexer{} -> noHints
618 PsErrCmmLexer -> noHints
619 PsErrCmmParser{} -> noHints
620 PsErrParse token PsErrParseDetails{..} -> case token of
621 "" -> []
622 "$" | not ped_th_enabled -> [suggestExtension LangExt.TemplateHaskell] -- #7396
623 "$$" | not ped_th_enabled -> [suggestExtension LangExt.TemplateHaskell] -- #20157
624 "<-" | ped_mdo_in_last_100 -> [suggestExtension LangExt.RecursiveDo]
625 | otherwise -> [SuggestMissingDo]
626 "=" | ped_do_in_last_100 -> [SuggestLetInDo] -- #15849
627 _ | not ped_pat_syn_enabled
628 , ped_pattern_parsed -> [suggestExtension LangExt.PatternSynonyms] -- #12429
629 | otherwise -> []
630 PsErrTypeAppWithoutSpace{} -> noHints
631 PsErrLazyPatWithoutSpace{} -> noHints
632 PsErrBangPatWithoutSpace{} -> noHints
633 PsErrInvalidInfixHole -> noHints
634 PsErrExpectedHyphen -> noHints
635 PsErrSpaceInSCC -> noHints
636 PsErrEmptyDoubleQuotes th_on | th_on -> [SuggestThQuotationSyntax]
637 | otherwise -> noHints
638 PsErrLambdaCase{} -> [suggestExtension LangExt.LambdaCase]
639 PsErrEmptyLambda{} -> noHints
640 PsErrLinearFunction{} -> [suggestExtension LangExt.LinearTypes]
641 PsErrMultiWayIf{} -> [suggestExtension LangExt.MultiWayIf]
642 PsErrOverloadedRecordUpdateNotEnabled{} -> [suggestExtension LangExt.OverloadedRecordUpdate]
643 PsErrNumUnderscores{} -> [suggestExtension LangExt.NumericUnderscores]
644 PsErrIllegalBangPattern{} -> [suggestExtension LangExt.BangPatterns]
645 PsErrOverloadedRecordDotInvalid{} -> noHints
646 PsErrIllegalPatSynExport -> [suggestExtension LangExt.PatternSynonyms]
647 PsErrOverloadedRecordUpdateNoQualifiedFields -> noHints
648 PsErrExplicitForall is_unicode ->
649 let info = text "or a similar language extension to enable explicit-forall syntax:" <+>
650 forallSym is_unicode <+> text "<tvs>. <type>"
651 in [ suggestExtensionWithInfo info LangExt.RankNTypes ]
652 PsErrIllegalQualifiedDo{} -> [suggestExtension LangExt.QualifiedDo]
653 PsErrQualifiedDoInCmd{} -> noHints
654 PsErrRecordSyntaxInPatSynDecl{} -> noHints
655 PsErrEmptyWhereInPatSynDecl{} -> noHints
656 PsErrInvalidWhereBindInPatSynDecl{} -> noHints
657 PsErrNoSingleWhereBindInPatSynDecl{} -> noHints
658 PsErrDeclSpliceNotAtTopLevel{} -> noHints
659 PsErrMultipleNamesInStandaloneKindSignature{} -> noHints
660 PsErrIllegalExplicitNamespace -> [suggestExtension LangExt.ExplicitNamespaces]
661 PsErrUnallowedPragma{} -> noHints
662 PsErrImportPostQualified -> [suggestExtension LangExt.ImportQualifiedPost]
663 PsErrImportQualifiedTwice -> noHints
664 PsErrIllegalImportBundleForm -> noHints
665 PsErrInvalidRuleActivationMarker -> noHints
666 PsErrMissingBlock -> noHints
667 PsErrUnsupportedBoxedSumExpr{} -> noHints
668 PsErrUnsupportedBoxedSumPat{} -> noHints
669 PsErrUnexpectedQualifiedConstructor{} -> noHints
670 PsErrTupleSectionInPat{} -> noHints
671 PsErrOpFewArgs{} -> noHints
672 PsErrVarForTyCon{} -> noHints
673 PsErrMalformedEntityString -> noHints
674 PsErrDotsInRecordUpdate -> noHints
675 PsErrInvalidDataCon{} -> noHints
676 PsErrInvalidInfixDataCon{} -> noHints
677 PsErrUnpackDataCon -> noHints
678 PsErrUnexpectedKindAppInDataCon{} -> noHints
679 PsErrInvalidRecordCon{} -> noHints
680 PsErrIllegalUnboxedStringInPat{} -> noHints
681 PsErrDoNotationInPat{} -> noHints
682 PsErrIfThenElseInPat -> noHints
683 PsErrLambdaCaseInPat -> noHints
684 PsErrCaseInPat -> noHints
685 PsErrLetInPat -> noHints
686 PsErrLambdaInPat -> noHints
687 PsErrArrowExprInPat{} -> noHints
688 PsErrArrowCmdInPat{} -> noHints
689 PsErrArrowCmdInExpr{} -> noHints
690 PsErrViewPatInExpr{} -> noHints
691 PsErrLambdaCmdInFunAppCmd{} -> suggestParensAndBlockArgs
692 PsErrCaseCmdInFunAppCmd{} -> suggestParensAndBlockArgs
693 PsErrIfCmdInFunAppCmd{} -> suggestParensAndBlockArgs
694 PsErrLetCmdInFunAppCmd{} -> suggestParensAndBlockArgs
695 PsErrDoCmdInFunAppCmd{} -> suggestParensAndBlockArgs
696 PsErrDoInFunAppExpr{} -> suggestParensAndBlockArgs
697 PsErrMDoInFunAppExpr{} -> suggestParensAndBlockArgs
698 PsErrLambdaInFunAppExpr{} -> suggestParensAndBlockArgs
699 PsErrCaseInFunAppExpr{} -> suggestParensAndBlockArgs
700 PsErrLambdaCaseInFunAppExpr{} -> suggestParensAndBlockArgs
701 PsErrLetInFunAppExpr{} -> suggestParensAndBlockArgs
702 PsErrIfInFunAppExpr{} -> suggestParensAndBlockArgs
703 PsErrProcInFunAppExpr{} -> suggestParensAndBlockArgs
704 PsErrMalformedTyOrClDecl{} -> noHints
705 PsErrIllegalWhereInDataDecl ->
706 [ suggestExtensionWithInfo (text "or a similar language extension to enable syntax: data T where")
707 LangExt.GADTs ]
708 PsErrIllegalDataTypeContext{} -> [suggestExtension LangExt.DatatypeContexts]
709 PsErrPrimStringInvalidChar -> noHints
710 PsErrSuffixAT -> noHints
711 PsErrPrecedenceOutOfRange{} -> noHints
712 PsErrSemiColonsInCondExpr{} -> [suggestExtension LangExt.DoAndIfThenElse]
713 PsErrSemiColonsInCondCmd{} -> [suggestExtension LangExt.DoAndIfThenElse]
714 PsErrAtInPatPos -> noHints
715 PsErrParseErrorOnInput{} -> noHints
716 PsErrMalformedDecl{} -> noHints
717 PsErrUnexpectedTypeAppInDecl{} -> noHints
718 PsErrNotADataCon{} -> noHints
719 PsErrInferredTypeVarNotAllowed -> noHints
720 PsErrIllegalTraditionalRecordSyntax{} -> [suggestExtension LangExt.TraditionalRecordSyntax]
721 PsErrParseErrorInCmd{} -> noHints
722 PsErrInPat _ details -> case details of
723 PEIP_RecPattern args YesPatIsRecursive ctx
724 | length args /= 0 -> catMaybes [sug_recdo, sug_missingdo ctx]
725 | otherwise -> catMaybes [sug_missingdo ctx]
726 PEIP_OtherPatDetails ctx -> catMaybes [sug_missingdo ctx]
727 _ -> []
728 where
729 sug_recdo = Just (suggestExtension LangExt.RecursiveDo)
730 sug_missingdo (ParseContext _ YesIncompleteDoBlock) = Just SuggestMissingDo
731 sug_missingdo _ = Nothing
732 PsErrParseRightOpSectionInPat{} -> noHints
733 PsErrIllegalRoleName _ nearby -> [SuggestRoles nearby]
734 PsErrInvalidTypeSignature lhs ->
735 if | foreign_RDR `looks_like` lhs
736 -> [suggestExtension LangExt.ForeignFunctionInterface]
737 | default_RDR `looks_like` lhs
738 -> [suggestExtension LangExt.DefaultSignatures]
739 | pattern_RDR `looks_like` lhs
740 -> [suggestExtension LangExt.PatternSynonyms]
741 | otherwise
742 -> [SuggestTypeSignatureForm]
743 where
744 -- A common error is to forget the ForeignFunctionInterface flag
745 -- so check for that, and suggest. cf #3805
746 -- Sadly 'foreign import' still barfs 'parse error' because
747 -- 'import' is a keyword
748 -- looks_like :: RdrName -> LHsExpr GhcPsErr -> Bool -- AZ
749 looks_like s (L _ (HsVar _ (L _ v))) = v == s
750 looks_like s (L _ (HsApp _ lhs _)) = looks_like s lhs
751 looks_like _ _ = False
752
753 foreign_RDR = mkUnqual varName (fsLit "foreign")
754 default_RDR = mkUnqual varName (fsLit "default")
755 pattern_RDR = mkUnqual varName (fsLit "pattern")
756 PsErrUnexpectedTypeInDecl{} -> noHints
757 PsErrInvalidPackageName{} -> noHints
758 PsErrIllegalGadtRecordMultiplicity{} -> noHints
759 PsErrInvalidCApiImport {} -> noHints
760
761 psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc
762 psHeaderMessageDiagnostic = \case
763 PsErrParseLanguagePragma
764 -> mkSimpleDecorated $
765 vcat [ text "Cannot parse LANGUAGE pragma"
766 , text "Expecting comma-separated list of language options,"
767 , text "each starting with a capital letter"
768 , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]
769 PsErrUnsupportedExt unsup _
770 -> mkSimpleDecorated $ text "Unsupported extension: " <> text unsup
771 PsErrParseOptionsPragma str
772 -> mkSimpleDecorated $
773 vcat [ text "Error while parsing OPTIONS_GHC pragma."
774 , text "Expecting whitespace-separated list of GHC options."
775 , text " E.g. {-# OPTIONS_GHC -Wall -O2 #-}"
776 , text ("Input was: " ++ show str) ]
777 PsErrUnknownOptionsPragma flag
778 -> mkSimpleDecorated $ text "Unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
779
780 psHeaderMessageReason :: PsHeaderMessage -> DiagnosticReason
781 psHeaderMessageReason = \case
782 PsErrParseLanguagePragma
783 -> ErrorWithoutFlag
784 PsErrUnsupportedExt{}
785 -> ErrorWithoutFlag
786 PsErrParseOptionsPragma{}
787 -> ErrorWithoutFlag
788 PsErrUnknownOptionsPragma{}
789 -> ErrorWithoutFlag
790
791 psHeaderMessageHints :: PsHeaderMessage -> [GhcHint]
792 psHeaderMessageHints = \case
793 PsErrParseLanguagePragma
794 -> noHints
795 PsErrUnsupportedExt unsup supported
796 -> if null suggestions
797 then noHints
798 -- FIXME(adn) To fix the compiler crash in #19923 we just rewrap this into an
799 -- UnknownHint, but we should have here a proper hint, but that would require
800 -- changing 'supportedExtensions' to emit a list of 'Extension'.
801 else [UnknownHint $ text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)]
802 where
803 suggestions :: [String]
804 suggestions = fuzzyMatch unsup supported
805 PsErrParseOptionsPragma{}
806 -> noHints
807 PsErrUnknownOptionsPragma{}
808 -> noHints
809
810
811 suggestParensAndBlockArgs :: [GhcHint]
812 suggestParensAndBlockArgs =
813 [SuggestParentheses, suggestExtension LangExt.BlockArguments]
814
815 pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc
816 pp_unexpected_fun_app e a =
817 text "Unexpected " <> e <> text " in function application:"
818 $$ nest 4 (ppr a)
819
820 parse_error_in_pat :: SDoc
821 parse_error_in_pat = text "Parse error in pattern:"
822
823 forallSym :: Bool -> SDoc
824 forallSym True = text "∀"
825 forallSym False = text "forall"