summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/HsToCore/Errors/Ppr.hs4
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs76
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs6
-rw-r--r--compiler/GHC/Types/Error.hs7
-rw-r--r--compiler/GHC/Types/Hint.hs59
-rw-r--r--compiler/GHC/Types/Hint/Ppr.hs18
6 files changed, 117 insertions, 53 deletions
diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs
index b0d2b16409..6c65b14e20 100644
--- a/compiler/GHC/HsToCore/Errors/Ppr.hs
+++ b/compiler/GHC/HsToCore/Errors/Ppr.hs
@@ -282,7 +282,9 @@ instance Diagnostic DsMessage where
-> case (bounds, usingNegLiterals) of
(Just (MinBound minB, MaxBound _), NotUsingNegLiterals)
| minB == -i -- Note [Suggest NegativeLiterals]
- , i > 0 -> [SuggestExtension LangExt.NegativeLiterals]
+ , i > 0
+ -> [ suggestExtensionWithInfo (text "If you are trying to write a large negative literal")
+ LangExt.NegativeLiterals ]
_ -> noHints
DsRedundantBangPatterns{} -> noHints
DsOverlappingPatterns{} -> noHints
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 048605a225..2cc8b4a113 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -183,15 +183,7 @@ instance Diagnostic PsMessage where
PsErrOverloadedRecordUpdateNoQualifiedFields
-> mkSimpleDecorated $ text "Fields cannot be qualified when OverloadedRecordUpdate is enabled"
PsErrExplicitForall is_unicode
- -> mkSimpleDecorated $ vcat
- [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"
- , text "Perhaps you intended to use RankNTypes or a similar language"
- , text "extension to enable explicit-forall syntax:" <+>
- forallSym is_unicode <+> text "<tvs>. <type>"
- ]
- where
- forallSym True = text "∀"
- forallSym False = text "forall"
+ -> mkSimpleDecorated $ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"
PsErrIllegalQualifiedDo qdoDoc
-> mkSimpleDecorated $
text "Illegal qualified" <+> quotes qdoDoc <+> text "block"
@@ -358,12 +350,7 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $
text "Malformed head of type or class declaration:" <+> ppr ty
PsErrIllegalWhereInDataDecl
- -> mkSimpleDecorated $
- vcat
- [ text "Illegal keyword 'where' in data declaration"
- , text "Perhaps you intended to use GADTs or a similar language"
- , text "extension to enable syntax: data T where"
- ]
+ -> mkSimpleDecorated $ text "Illegal keyword 'where' in data declaration"
PsErrIllegalDataTypeContext c
-> mkSimpleDecorated $
text "Illegal datatype context:"
@@ -607,18 +594,18 @@ instance Diagnostic PsMessage where
PsWarnStarIsType -> [SuggestUseTypeFromDataKind]
PsWarnUnrecognisedPragma -> noHints
PsWarnImportPreQualified -> [ SuggestQualifiedAfterModuleName
- , SuggestExtension LangExt.ImportQualifiedPost]
+ , suggestExtension LangExt.ImportQualifiedPost]
PsErrLexer{} -> noHints
PsErrCmmLexer -> noHints
PsErrCmmParser{} -> noHints
PsErrParse token PsErrParseDetails{..} -> case token of
"" -> []
- "$" | not ped_th_enabled -> [SuggestExtension LangExt.TemplateHaskell] -- #7396
- "<-" | ped_mdo_in_last_100 -> [SuggestExtension LangExt.RecursiveDo]
+ "$" | not ped_th_enabled -> [suggestExtension LangExt.TemplateHaskell] -- #7396
+ "<-" | ped_mdo_in_last_100 -> [suggestExtension LangExt.RecursiveDo]
| otherwise -> [SuggestMissingDo]
"=" | ped_do_in_last_100 -> [SuggestLetInDo] -- #15849
_ | not ped_pat_syn_enabled
- , ped_pattern_parsed -> [SuggestExtension LangExt.PatternSynonyms] -- #12429
+ , ped_pattern_parsed -> [suggestExtension LangExt.PatternSynonyms] -- #12429
| otherwise -> []
PsErrTypeAppWithoutSpace{} -> noHints
PsErrLazyPatWithoutSpace{} -> noHints
@@ -628,18 +615,21 @@ instance Diagnostic PsMessage where
PsErrSpaceInSCC -> noHints
PsErrEmptyDoubleQuotes th_on | th_on -> [SuggestThQuotationSyntax]
| otherwise -> noHints
- PsErrLambdaCase{} -> [SuggestExtension LangExt.LambdaCase]
+ PsErrLambdaCase{} -> [suggestExtension LangExt.LambdaCase]
PsErrEmptyLambda{} -> noHints
- PsErrLinearFunction{} -> [SuggestExtension LangExt.LinearTypes]
- PsErrMultiWayIf{} -> [SuggestExtension LangExt.MultiWayIf]
- PsErrOverloadedRecordUpdateNotEnabled{} -> [SuggestExtension LangExt.OverloadedRecordUpdate]
- PsErrNumUnderscores{} -> [SuggestExtension LangExt.NumericUnderscores]
- PsErrIllegalBangPattern{} -> [SuggestExtension LangExt.BangPatterns]
+ PsErrLinearFunction{} -> [suggestExtension LangExt.LinearTypes]
+ PsErrMultiWayIf{} -> [suggestExtension LangExt.MultiWayIf]
+ PsErrOverloadedRecordUpdateNotEnabled{} -> [suggestExtension LangExt.OverloadedRecordUpdate]
+ PsErrNumUnderscores{} -> [suggestExtension LangExt.NumericUnderscores]
+ PsErrIllegalBangPattern{} -> [suggestExtension LangExt.BangPatterns]
PsErrOverloadedRecordDotInvalid{} -> noHints
- PsErrIllegalPatSynExport -> [SuggestExtension LangExt.PatternSynonyms]
+ PsErrIllegalPatSynExport -> [suggestExtension LangExt.PatternSynonyms]
PsErrOverloadedRecordUpdateNoQualifiedFields -> noHints
- PsErrExplicitForall{} -> noHints
- PsErrIllegalQualifiedDo{} -> [SuggestExtension LangExt.QualifiedDo]
+ PsErrExplicitForall is_unicode ->
+ let info = text "or a similar language extension to enable explicit-forall syntax:" <+>
+ forallSym is_unicode <+> text "<tvs>. <type>"
+ in [ suggestExtensionWithInfo info LangExt.RankNTypes ]
+ PsErrIllegalQualifiedDo{} -> [suggestExtension LangExt.QualifiedDo]
PsErrQualifiedDoInCmd{} -> noHints
PsErrRecordSyntaxInPatSynDecl{} -> noHints
PsErrEmptyWhereInPatSynDecl{} -> noHints
@@ -647,9 +637,9 @@ instance Diagnostic PsMessage where
PsErrNoSingleWhereBindInPatSynDecl{} -> noHints
PsErrDeclSpliceNotAtTopLevel{} -> noHints
PsErrMultipleNamesInStandaloneKindSignature{} -> noHints
- PsErrIllegalExplicitNamespace -> [SuggestExtension LangExt.ExplicitNamespaces]
+ PsErrIllegalExplicitNamespace -> [suggestExtension LangExt.ExplicitNamespaces]
PsErrUnallowedPragma{} -> noHints
- PsErrImportPostQualified -> [SuggestExtension LangExt.ImportQualifiedPost]
+ PsErrImportPostQualified -> [suggestExtension LangExt.ImportQualifiedPost]
PsErrImportQualifiedTwice -> noHints
PsErrIllegalImportBundleForm -> noHints
PsErrInvalidRuleActivationMarker -> noHints
@@ -692,20 +682,22 @@ instance Diagnostic PsMessage where
PsErrIfInFunAppExpr{} -> suggestParensAndBlockArgs
PsErrProcInFunAppExpr{} -> suggestParensAndBlockArgs
PsErrMalformedTyOrClDecl{} -> noHints
- PsErrIllegalWhereInDataDecl -> noHints
- PsErrIllegalDataTypeContext{} -> [SuggestExtension LangExt.DatatypeContexts]
+ PsErrIllegalWhereInDataDecl ->
+ [ suggestExtensionWithInfo (text "or a similar language extension to enable syntax: data T where")
+ LangExt.GADTs ]
+ PsErrIllegalDataTypeContext{} -> [suggestExtension LangExt.DatatypeContexts]
PsErrPrimStringInvalidChar -> noHints
PsErrSuffixAT -> noHints
PsErrPrecedenceOutOfRange{} -> noHints
- PsErrSemiColonsInCondExpr{} -> [SuggestExtension LangExt.DoAndIfThenElse]
- PsErrSemiColonsInCondCmd{} -> [SuggestExtension LangExt.DoAndIfThenElse]
+ PsErrSemiColonsInCondExpr{} -> [suggestExtension LangExt.DoAndIfThenElse]
+ PsErrSemiColonsInCondCmd{} -> [suggestExtension LangExt.DoAndIfThenElse]
PsErrAtInPatPos -> noHints
PsErrParseErrorOnInput{} -> noHints
PsErrMalformedDecl{} -> noHints
PsErrUnexpectedTypeAppInDecl{} -> noHints
PsErrNotADataCon{} -> noHints
PsErrInferredTypeVarNotAllowed -> noHints
- PsErrIllegalTraditionalRecordSyntax{} -> [SuggestExtension LangExt.TraditionalRecordSyntax]
+ PsErrIllegalTraditionalRecordSyntax{} -> [suggestExtension LangExt.TraditionalRecordSyntax]
PsErrParseErrorInCmd{} -> noHints
PsErrInPat _ details -> case details of
PEIP_RecPattern args YesPatIsRecursive ctx
@@ -714,18 +706,18 @@ instance Diagnostic PsMessage where
PEIP_OtherPatDetails ctx -> catMaybes [sug_missingdo ctx]
_ -> []
where
- sug_recdo = Just (SuggestExtension LangExt.RecursiveDo)
+ sug_recdo = Just (suggestExtension LangExt.RecursiveDo)
sug_missingdo (ParseContext _ YesIncompleteDoBlock) = Just SuggestMissingDo
sug_missingdo _ = Nothing
PsErrParseRightOpSectionInPat{} -> noHints
PsErrIllegalRoleName _ nearby -> [SuggestRoles nearby]
PsErrInvalidTypeSignature lhs ->
if | foreign_RDR `looks_like` lhs
- -> [SuggestExtension LangExt.ForeignFunctionInterface]
+ -> [suggestExtension LangExt.ForeignFunctionInterface]
| default_RDR `looks_like` lhs
- -> [SuggestExtension LangExt.DefaultSignatures]
+ -> [suggestExtension LangExt.DefaultSignatures]
| pattern_RDR `looks_like` lhs
- -> [SuggestExtension LangExt.PatternSynonyms]
+ -> [suggestExtension LangExt.PatternSynonyms]
| otherwise
-> [SuggestTypeSignatureForm]
where
@@ -782,7 +774,7 @@ psHeaderMessageHints = \case
suggestParensAndBlockArgs :: [GhcHint]
suggestParensAndBlockArgs =
- [SuggestParentheses, SuggestExtension LangExt.BlockArguments]
+ [SuggestParentheses, suggestExtension LangExt.BlockArguments]
pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc
pp_unexpected_fun_app e a =
@@ -791,3 +783,7 @@ pp_unexpected_fun_app e a =
parse_error_in_pat :: SDoc
parse_error_in_pat = text "Parse error in pattern:"
+
+forallSym :: Bool -> SDoc
+forallSym True = text "∀"
+forallSym False = text "forall"
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 97d0a40413..73ef9d9470 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -171,13 +171,13 @@ instance Diagnostic TcRnMessage where
TcRnEmptyRecordUpdate{}
-> noHints
TcRnIllegalFieldPunning{}
- -> [SuggestExtension LangExt.NamedFieldPuns]
+ -> [suggestExtension LangExt.NamedFieldPuns]
TcRnIllegalWildcardsInRecord{}
- -> [SuggestExtension LangExt.RecordWildCards]
+ -> [suggestExtension LangExt.RecordWildCards]
TcRnDuplicateFieldName{}
-> noHints
TcRnIllegalViewPattern{}
- -> [SuggestExtension LangExt.ViewPatterns]
+ -> [suggestExtension LangExt.ViewPatterns]
TcRnCharLiteralOutOfRange{}
-> noHints
TcRnIllegalWildcardsInConstructor{}
diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs
index bb27b568bb..b1814e8fb1 100644
--- a/compiler/GHC/Types/Error.hs
+++ b/compiler/GHC/Types/Error.hs
@@ -33,6 +33,13 @@ module GHC.Types.Error
-- * Hints and refactoring actions
, GhcHint (..)
+ , LanguageExtensionHint(..)
+ , suggestExtension
+ , suggestExtensionWithInfo
+ , suggestExtensions
+ , suggestExtensionsWithInfo
+ , suggestAnyExtension
+ , suggestAnyExtensionWithInfo
, noHints
-- * Rendering Messages
diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs
index e1ed317753..364bad8355 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -1,8 +1,15 @@
{-# LANGUAGE ExistentialQuantification #-}
module GHC.Types.Hint (
- GhcHint(..),
- InstantiationSuggestion(..)
+ GhcHint(..)
+ , InstantiationSuggestion(..)
+ , LanguageExtensionHint(..)
+ , suggestExtension
+ , suggestExtensionWithInfo
+ , suggestExtensions
+ , suggestExtensionsWithInfo
+ , suggestAnyExtension
+ , suggestAnyExtensionWithInfo
) where
import GHC.Prelude
@@ -19,6 +26,52 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr
-- This {-# SOURCE #-} import should be removable once
-- 'Language.Haskell.Syntax.Bind' no longer depends on 'GHC.Tc.Types.Evidence'.
+
+data LanguageExtensionHint
+ = -- | Suggest to enable the input extension. If the input 'SDoc'
+ -- is not empty, it will contain some extra information about the
+ -- why the extension is required, but it's totally irrelevant/redundant
+ -- for IDEs and other tools.
+ SuggestSingleExtension !SDoc !LangExt.Extension
+ -- | Suggest to enable the input extensions. The list
+ -- is to be intended as /disjuctive/ i.e. the user is
+ -- suggested to enable /any/ of the extensions listed. If
+ -- the input 'SDoc' is not empty, it will contain some extra
+ -- information about the why the extensions are required, but
+ -- it's totally irrelevant/redundant for IDEs and other tools.
+ | SuggestAnyExtension !SDoc [LangExt.Extension]
+ -- | Suggest to enable the input extensions. The list
+ -- is to be intended as /conjunctive/ i.e. the user is
+ -- suggested to enable /all/ the extensions listed. If
+ -- the input 'SDoc' is not empty, it will contain some extra
+ -- information about the why the extensions are required, but
+ -- it's totally irrelevant/redundant for IDEs and other tools.
+ | SuggestExtensions !SDoc [LangExt.Extension]
+
+-- | Suggests a single extension without extra user info.
+suggestExtension :: LangExt.Extension -> GhcHint
+suggestExtension ext = SuggestExtension (SuggestSingleExtension empty ext)
+
+-- | Like 'suggestExtension' but allows supplying extra info for the user.
+suggestExtensionWithInfo :: SDoc -> LangExt.Extension -> GhcHint
+suggestExtensionWithInfo extraInfo ext = SuggestExtension (SuggestSingleExtension extraInfo ext)
+
+-- | Suggests to enable /every/ extension in the list.
+suggestExtensions :: [LangExt.Extension] -> GhcHint
+suggestExtensions exts = SuggestExtension (SuggestExtensions empty exts)
+
+-- | Like 'suggestExtensions' but allows supplying extra info for the user.
+suggestExtensionsWithInfo :: SDoc -> [LangExt.Extension] -> GhcHint
+suggestExtensionsWithInfo extraInfo exts = SuggestExtension (SuggestExtensions extraInfo exts)
+
+-- | Suggests to enable /any/ extension in the list.
+suggestAnyExtension :: [LangExt.Extension] -> GhcHint
+suggestAnyExtension exts = SuggestExtension (SuggestAnyExtension empty exts)
+
+-- | Like 'suggestAnyExtension' but allows supplying extra info for the user.
+suggestAnyExtensionWithInfo :: SDoc -> [LangExt.Extension] -> GhcHint
+suggestAnyExtensionWithInfo extraInfo exts = SuggestExtension (SuggestAnyExtension extraInfo exts)
+
-- | A type for hints emitted by GHC.
-- A /hint/ suggests a possible way to deal with a particular warning or error.
data GhcHint
@@ -39,7 +92,7 @@ data GhcHint
parser/should_fail/T18251e, ... (and many more)
-}
- | SuggestExtension !LangExt.Extension
+ | SuggestExtension !LanguageExtensionHint
{-| Suggests that a monadic code block is probably missing a \"do\" keyword.
Example:
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index 24e0da427d..abb30d55d8 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -15,17 +15,23 @@ import GHC.Types.Hint
import GHC.Hs.Expr () -- instance Outputable
import GHC.Types.Id
import GHC.Utils.Outputable
-import qualified GHC.LanguageExtensions as LangExt
+
+import Data.List (intersperse)
instance Outputable GhcHint where
ppr = \case
UnknownHint m
-> ppr m
- SuggestExtension ext
- -> case ext of
- LangExt.NegativeLiterals
- -> text "If you are trying to write a large negative literal, use NegativeLiterals"
- _ -> text "Perhaps you intended to use" <+> ppr ext
+ SuggestExtension extHint
+ -> case extHint of
+ SuggestSingleExtension extraUserInfo ext ->
+ (text "Perhaps you intended to use" <+> ppr ext) $$ extraUserInfo
+ SuggestAnyExtension extraUserInfo exts ->
+ let header = text "Enable any of the following extensions:"
+ in header <+> hsep (intersperse (char ',') (map ppr exts)) $$ extraUserInfo
+ SuggestExtensions extraUserInfo exts ->
+ let header = text "Enable all of the following extensions:"
+ in header <+> hsep (intersperse (char ',') (map ppr exts)) $$ extraUserInfo
SuggestMissingDo
-> text "Possibly caused by a missing 'do'?"
SuggestLetInDo
View Lorry Controller Status