From 60b3ec36bfe1539cec62f28587c8bc4f04f78df5 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Tue, 20 Apr 2021 11:03:01 +0200 Subject: Extensible Hints for diagnostic messages This commit extends the GHC diagnostic hierarchy with a `GhcHint` type, modelling helpful suggestions emitted by GHC which can be used to deal with a particular warning or error. As a direct consequence of this, the `Diagnostic` typeclass has been extended with a `diagnosticHints` method, which returns a `[GhcHint]`. This means that now we can clearly separate out the printing of the diagnostic message with the suggested fixes. This is done by extending the `printMessages` function in `GHC.Driver.Errors`. On top of that, the old `PsHint` type has been superseded by the new `GhcHint` type, which de-duplicates some hints in favour of a general `SuggestExtension` constructor that takes a `GHC.LanguageExtensions.Extension`. --- compiler/GHC/Driver/Errors.hs | 16 ++- compiler/GHC/Driver/Errors/Ppr.hs | 60 +++++++--- compiler/GHC/Driver/Errors/Types.hs | 23 +--- compiler/GHC/Driver/Main.hs | 26 ++--- compiler/GHC/Driver/Make.hs | 7 +- compiler/GHC/Driver/MakeFile.hs | 2 +- compiler/GHC/Driver/Pipeline.hs | 2 +- compiler/GHC/HsToCore/Errors/Ppr.hs | 2 +- compiler/GHC/HsToCore/Monad.hs | 4 +- compiler/GHC/Iface/Rename.hs | 2 +- compiler/GHC/Parser.y | 1 + compiler/GHC/Parser/Errors.hs | 16 +-- compiler/GHC/Parser/Errors/Ppr.hs | 57 ++++----- compiler/GHC/Parser/Header.hs | 4 +- compiler/GHC/Parser/Lexer.x | 9 +- compiler/GHC/Parser/PostProcess.hs | 12 +- compiler/GHC/Tc/Errors/Ppr.hs | 15 +++ compiler/GHC/Tc/Module.hs | 4 +- compiler/GHC/Tc/Utils/Monad.hs | 6 +- compiler/GHC/Types/Error.hs | 43 +++++-- compiler/GHC/Types/Hint.hs | 130 +++++++++++++++++++++ compiler/GHC/Utils/Error.hs | 1 + compiler/ghc.cabal.in | 1 + testsuite/tests/driver/T12955.stderr | 8 +- .../tests/parser/should_run/CountAstDeps.stdout | 3 +- .../tests/parser/should_run/CountParserDeps.stdout | 3 +- 26 files changed, 314 insertions(+), 143 deletions(-) create mode 100644 compiler/GHC/Types/Hint.hs diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index 7afb0f3b26..f980502f5d 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -14,7 +14,7 @@ import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.Error import GHC.Utils.Error -import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle ) +import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext, text, withPprStyle, mkErrStyle ) import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine @@ -23,12 +23,21 @@ printMessages logger dflags msgs = sequence_ [ let style = mkErrStyle unqual ctx = initSDocContext dflags style in putLogMsg logger dflags (MCDiagnostic sev . diagnosticReason $ dia) s $ - withPprStyle style (formatBulleted ctx (diagnosticMessage dia)) + withPprStyle style (messageWithHints ctx dia) | MsgEnvelope { errMsgSpan = s, errMsgDiagnostic = dia, errMsgSeverity = sev, errMsgContext = unqual } <- sortMsgBag (Just dflags) (getMessages msgs) ] + where + messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc + messageWithHints ctx e = + let main_msg = formatBulleted ctx $ diagnosticMessage e + in case diagnosticHints e of + [] -> main_msg + [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h) + hs -> main_msg $$ hang (text "Suggested fixes:") 2 + (formatBulleted ctx . mkDecorated . map ppr $ hs) handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO () handleFlagWarnings logger dflags warns = do @@ -37,8 +46,7 @@ handleFlagWarnings logger dflags warns = do bag = listToBag [ mkPlainMsgEnvelope dflags loc $ GhcDriverMessage $ DriverUnknownMessage $ - mkPlainDiagnostic reason $ - text warn + mkPlainDiagnostic reason noHints $ text warn | CmdLine.Warn reason (L loc warn) <- warns ] printOrThrowDiagnostics logger dflags (mkMessages bag) diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs index 74c3d4bf21..853d83b76b 100644 --- a/compiler/GHC/Driver/Errors/Ppr.hs +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage} @@ -15,6 +16,7 @@ import GHC.Types.Error import GHC.Unit.Types import GHC.Utils.Outputable import GHC.Unit.Module +import GHC.Types.Hint -- -- Suggestions @@ -51,6 +53,18 @@ instance Diagnostic GhcMessage where GhcUnknownMessage m -> diagnosticReason m + diagnosticHints = \case + GhcPsMessage m + -> diagnosticHints m + GhcTcRnMessage m + -> diagnosticHints m + GhcDsMessage m + -> diagnosticHints m + GhcDriverMessage m + -> diagnosticHints m + GhcUnknownMessage m + -> diagnosticHints m + instance Diagnostic DriverMessage where diagnosticMessage = \case DriverUnknownMessage m @@ -99,22 +113,8 @@ instance Diagnostic DriverMessage where $$ text "Saw :" <+> quotes (ppr actual) $$ text "Expected:" <+> quotes (ppr expected) - DriverUnexpectedSignature pi_mod_name buildingCabalPackage suggestions - -> let suggested_instantiated_with = - hcat (punctuate comma $ - [ ppr k <> text "=" <> ppr v - | InstantiationSuggestion k v <- suggestions - ]) - msg = text "Unexpected signature:" <+> quotes (ppr pi_mod_name) - $$ if buildingCabalPackage == YesBuildingCabalPackage - then parens (text "Try adding" <+> quotes (ppr pi_mod_name) - <+> text "to the" - <+> quotes (text "signatures") - <+> text "field in your Cabal file.") - else parens (text "Try passing -instantiated-with=\"" <> - suggested_instantiated_with <> text "\"" $$ - text "replacing <" <> ppr pi_mod_name <> text "> as necessary.") - in mkSimpleDecorated msg + DriverUnexpectedSignature pi_mod_name _buildingCabalPackage _instantiations + -> mkSimpleDecorated $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) DriverFileNotFound hsFilePath -> mkSimpleDecorated (text "Can't find" <+> text hsFilePath) DriverStaticPointersNotSupported @@ -147,3 +147,31 @@ instance Diagnostic DriverMessage where -> WarningWithoutFlag DriverBackpackModuleNotFound{} -> ErrorWithoutFlag + + diagnosticHints = \case + DriverUnknownMessage m + -> diagnosticHints m + DriverPsHeaderMessage _desc hints + -> hints + DriverMissingHomeModules{} + -> noHints + DriverUnusedPackages{} + -> noHints + DriverUnnecessarySourceImports{} + -> noHints + DriverDuplicatedModuleDeclaration{} + -> noHints + DriverModuleNotFound{} + -> noHints + DriverFileModuleNameMismatch{} + -> noHints + DriverUnexpectedSignature pi_mod_name buildingCabalPackage instantiations + -> if buildingCabalPackage == YesBuildingCabalPackage + then [SuggestAddSignatureCabalFile pi_mod_name] + else [SuggestSignatureInstantiations pi_mod_name (suggestInstantiatedWith pi_mod_name instantiations)] + DriverFileNotFound{} + -> noHints + DriverStaticPointersNotSupported + -> noHints + DriverBackpackModuleNotFound{} + -> noHints diff --git a/compiler/GHC/Driver/Errors/Types.hs b/compiler/GHC/Driver/Errors/Types.hs index 6f1684d789..2519d5597c 100644 --- a/compiler/GHC/Driver/Errors/Types.hs +++ b/compiler/GHC/Driver/Errors/Types.hs @@ -4,7 +4,6 @@ module GHC.Driver.Errors.Types ( GhcMessage(..) , DriverMessage(..), DriverMessages , BuildingCabalPackage(..) - , InstantiationSuggestion(..) , WarningMessages , ErrorMessages , WarnMsg @@ -26,7 +25,7 @@ import GHC.Driver.Session import GHC.Types.Error import GHC.Unit.Module -import GHC.Parser.Errors ( PsErrorDesc, PsHint ) +import GHC.Parser.Errors ( PsErrorDesc ) import GHC.Parser.Errors.Types ( PsMessage ) import GHC.Tc.Errors.Types ( TcRnMessage ) import GHC.HsToCore.Errors.Types ( DsMessage ) @@ -116,12 +115,11 @@ type DriverMessages = Messages DriverMessage -- | A message from the driver. data DriverMessage where - -- | Simply wraps a generic 'DiagnosticMessage'. + -- | Simply wraps a generic 'Diagnostic' message @a@. DriverUnknownMessage :: (Diagnostic a, Typeable a) => a -> DriverMessage - -- | A parse error in parsing a Haskell file header during dependency -- analysis - DriverPsHeaderMessage :: !PsErrorDesc -> ![PsHint] -> DriverMessage + DriverPsHeaderMessage :: !PsErrorDesc -> ![GhcHint] -> DriverMessage {-| DriverMissingHomeModules is a warning (controlled with -Wmissing-home-modules) that arises when running GHC in --make mode when some modules needed for compilation @@ -189,7 +187,7 @@ data DriverMessage where Test cases: driver/T12955 -} - DriverUnexpectedSignature :: !ModuleName -> !BuildingCabalPackage -> [InstantiationSuggestion] -> DriverMessage + DriverUnexpectedSignature :: !ModuleName -> !BuildingCabalPackage -> GenInstantiations UnitId -> DriverMessage {-| DriverFileNotFound occurs when the input file (e.g. given on the command line) can't be found. @@ -211,19 +209,6 @@ data DriverMessage where -} DriverBackpackModuleNotFound :: !ModuleName -> DriverMessage --- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated --- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way --- to instantiate a particular signature, where the first argument is --- the signature name and the second is the module where the signature --- was defined. --- Example: --- --- src/MyStr.hsig:2:11: error: --- Unexpected signature: ‘MyStr’ --- (Try passing -instantiated-with="MyStr=" --- replacing as necessary.) -data InstantiationSuggestion = InstantiationSuggestion !ModuleName !Module - -- | Pass to a 'DriverMessage' the information whether or not the -- '-fbuilding-cabal-package' flag is set. data BuildingCabalPackage diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 2d3e1e3925..8c09f4434c 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -570,7 +570,7 @@ tcRnModule' sum save_rn_syntax mod = do logDiagnostics $ singleMessage $ mkPlainMsgEnvelope dflags (getLoc (hpm_module mod)) $ GhcDriverMessage $ DriverUnknownMessage $ - mkPlainDiagnostic reason warnMissingSafeHaskellMode + mkPlainDiagnostic reason noHints warnMissingSafeHaskellMode tcg_res <- {-# SCC "Typecheck-Rename" #-} ioMsgMaybe $ hoistTcRnMessage $ @@ -600,14 +600,14 @@ tcRnModule' sum save_rn_syntax mod = do | otherwise -> (logDiagnostics $ singleMessage $ mkPlainMsgEnvelope dflags (warnSafeOnLoc dflags) $ GhcDriverMessage $ DriverUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnSafe) $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnSafe) noHints $ errSafe tcg_res') False | safeHaskell dflags == Sf_Trustworthy && wopt Opt_WarnTrustworthySafe dflags -> (logDiagnostics $ singleMessage $ mkPlainMsgEnvelope dflags (trustworthyOnLoc dflags) $ GhcDriverMessage $ DriverUnknownMessage $ - mkPlainDiagnostic (WarningWithFlag Opt_WarnTrustworthySafe) $ + mkPlainDiagnostic (WarningWithFlag Opt_WarnTrustworthySafe) noHints $ errTwthySafe tcg_res') False -> return () return tcg_res' @@ -1201,7 +1201,7 @@ hscCheckSafeImports tcg_env = do warnRules df (L loc (HsRule { rd_name = n })) = mkPlainMsgEnvelope df (locA loc) $ DriverUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag $ + mkPlainDiagnostic WarningWithoutFlag noHints $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -1279,7 +1279,7 @@ checkSafeImports tcg_env | imv_is_safe v1 /= imv_is_safe v2 = throwOneError $ mkPlainErrorMsgEnvelope (imv_span v1) $ - GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ + GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ text "Module" <+> ppr (imv_name v1) <+> (text $ "is imported both as a safe and unsafe import!") | otherwise @@ -1349,7 +1349,7 @@ hscCheckSafe' m l = do -- can't load iface to check trust! Nothing -> throwOneError $ mkPlainErrorMsgEnvelope l $ - GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ + GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ text "Can't load the interface file for" <+> ppr m <> text ", to check that it can be safely imported" @@ -1384,7 +1384,7 @@ hscCheckSafe' m l = do inferredImportWarn dflags = singleMessage $ mkMsgEnvelope dflags l (pkgQual state) $ GhcDriverMessage $ DriverUnknownMessage - $ mkPlainDiagnostic (WarningWithFlag Opt_WarnInferredSafeImports) + $ mkPlainDiagnostic (WarningWithFlag Opt_WarnInferredSafeImports) noHints $ sep [ text "Importing Safe-Inferred module " <> ppr (moduleName m) @@ -1393,7 +1393,7 @@ hscCheckSafe' m l = do pkgTrustErr = singleMessage $ mkErrorMsgEnvelope l (pkgQual state) $ GhcDriverMessage $ DriverUnknownMessage - $ mkPlainError + $ mkPlainError noHints $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The package (" @@ -1403,7 +1403,7 @@ hscCheckSafe' m l = do modTrustErr = singleMessage $ mkErrorMsgEnvelope l (pkgQual state) $ GhcDriverMessage $ DriverUnknownMessage - $ mkPlainError + $ mkPlainError noHints $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -1453,7 +1453,7 @@ checkPkgTrust pkgs = do $ mkErrorMsgEnvelope noSrcSpan (pkgQual state) $ GhcDriverMessage $ DriverUnknownMessage - $ mkPlainError + $ mkPlainError noHints $ pprWithUnitState state $ text "The package (" <> ppr pkg @@ -1481,7 +1481,7 @@ markUnsafeInfer tcg_env whyUnsafe = do (logDiagnostics $ singleMessage $ mkPlainMsgEnvelope dflags (warnUnsafeOnLoc dflags) $ GhcDriverMessage $ DriverUnknownMessage $ - mkPlainDiagnostic reason $ + mkPlainDiagnostic reason noHints $ whyUnsafe' dflags) liftIO $ writeIORef (tcg_safe_infer tcg_env) False @@ -2079,7 +2079,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do [L _ i] -> return i _ -> liftIO $ throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ - GhcPsMessage $ PsUnknownMessage $ mkPlainError $ + GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -2110,7 +2110,7 @@ hscParseExpr expr = do Just (L _ (BodyStmt _ expr _ _)) -> return expr _ -> throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan $ - GhcPsMessage $ PsUnknownMessage $ mkPlainError $ + GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $ text "not an expression:" <+> quotes (text expr) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index f153e96e37..e73b3fb39d 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -58,7 +58,6 @@ import GHC.Driver.Backend import GHC.Driver.Monad import GHC.Driver.Env import GHC.Driver.Errors -import GHC.Driver.Errors.Ppr import GHC.Driver.Errors.Types import GHC.Driver.Main @@ -2708,9 +2707,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) $ DriverFileModuleNameMismatch pi_mod_name wanted_mod when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $ - let suggestions = suggestInstantiatedWith pi_mod_name (homeUnitInstantiations home_unit) + let instantiations = homeUnitInstantiations home_unit in throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc - $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) suggestions + $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary { nms_src_fn = src_fn @@ -2861,7 +2860,7 @@ withDeferredDiagnostics f = do noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err - = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ + = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ cannotFindModule hsc_env wanted_mod err noHsFileErr :: SrcSpan -> String -> DriverMessages diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index 890054efd4..81336912de 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -307,7 +307,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do fail -> throwOneError $ mkPlainErrorMsgEnvelope srcloc $ - GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ + GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ cannotFindModule hsc_env imp fail ----------------------------- diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 9a5fa6819e..2ad69bc4a2 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -152,7 +152,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = handler (ProgramError msg) = return $ Left $ singleMessage $ mkPlainErrorMsgEnvelope srcspan $ - DriverUnknownMessage $ mkPlainError $ text msg + DriverUnknownMessage $ mkPlainError noHints $ text msg handler ex = throwGhcExceptionIO ex to_driver_messages :: Messages GhcMessage -> Messages DriverMessage diff --git a/compiler/GHC/HsToCore/Errors/Ppr.hs b/compiler/GHC/HsToCore/Errors/Ppr.hs index f453a82743..b8d2a0a86c 100644 --- a/compiler/GHC/HsToCore/Errors/Ppr.hs +++ b/compiler/GHC/HsToCore/Errors/Ppr.hs @@ -1,4 +1,3 @@ - {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic DsMessage module GHC.HsToCore.Errors.Ppr where @@ -9,3 +8,4 @@ import GHC.HsToCore.Errors.Types instance Diagnostic DsMessage where diagnosticMessage (DsUnknownMessage m) = diagnosticMessage m diagnosticReason (DsUnknownMessage m) = diagnosticReason m + diagnosticHints (DsUnknownMessage m) = diagnosticHints m diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 9bc893f814..691f78b4ef 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -474,7 +474,7 @@ diagnosticDs reason warn ; dflags <- getDynFlags ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) $ DsUnknownMessage $ - mkPlainDiagnostic reason warn + mkPlainDiagnostic reason noHints warn ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags @@ -489,7 +489,7 @@ errDs err ; loc <- getSrcSpanDs ; let msg = mkErrorMsgEnvelope loc (ds_unqual env) $ DsUnknownMessage $ - mkPlainError err + mkPlainError noHints err ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Issue an error, but return the expression for (), so that we can continue diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index 18ad1a55ce..04b227c50e 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -76,7 +76,7 @@ failWithRn doc = do -- TODO: maybe associate this with a source location? let msg = mkPlainErrorMsgEnvelope noSrcSpan $ TcRnUnknownMessage $ - mkPlainError doc + mkPlainError noHints doc writeTcRef errs_var (msg `addMessage` errs) failM diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index f9f7acc0fa..44ca8fa042 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -69,6 +69,7 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString) import GHC.Types.SrcLoc import GHC.Types.Basic +import GHC.Types.Error ( GhcHint(..) ) import GHC.Types.Fixity import GHC.Types.ForeignCall import GHC.Types.SourceFile diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs index 570385c773..7a9c154ed8 100644 --- a/compiler/GHC/Parser/Errors.hs +++ b/compiler/GHC/Parser/Errors.hs @@ -9,12 +9,12 @@ module GHC.Parser.Errors , LexErr(..) , CmmParserError(..) , LexErrKind(..) - , PsHint(..) , StarIsType (..) ) where import GHC.Prelude +import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Types.Name.Reader (RdrName) import GHC.Types.Name.Occurrence (OccName) @@ -27,7 +27,6 @@ import GHC.Hs.Type import GHC.Hs.Lit import GHC.Hs.Decls import GHC.Core.Coercion.Axiom (Role) -import GHC.Utils.Outputable (SDoc) import GHC.Data.FastString import GHC.Unit.Module.Name @@ -82,7 +81,7 @@ data TransLayoutReason data PsError = PsError { errDesc :: !PsErrorDesc -- ^ Error description - , errHints :: ![PsHint] -- ^ Hints + , errHints :: ![GhcHint] -- ^ Hints , errLoc :: !SrcSpan -- ^ Error position } @@ -396,17 +395,6 @@ data NumUnderscoreReason | NumUnderscore_Float deriving (Show,Eq,Ord) -data PsHint - = SuggestTH - | SuggestRecursiveDo - | SuggestDo - | SuggestMissingDo - | SuggestLetInDo - | SuggestPatternSynonyms - | SuggestInfixBindMaybeAtPat !RdrName - | TypeApplicationsInPatternsOnlyDataCons -- ^ Type applications in patterns are only allowed on data constructors - - data LexErrKind = LexErrKind_EOF -- ^ End of input | LexErrKind_UTF8 -- ^ UTF-8 decoding error diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 8decaddfbe..4cc8da75f4 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -18,8 +18,9 @@ import GHC.Parser.Errors.Types import GHC.Parser.Types import GHC.Types.Basic import GHC.Types.Error +import GHC.Types.Hint (perhapsAsPat) import GHC.Types.SrcLoc -import GHC.Types.Name.Reader (starInfo, rdrNameOcc, opIsAt, mkUnqual) +import GHC.Types.Name.Reader (starInfo, rdrNameOcc, mkUnqual) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) import GHC.Utils.Outputable import GHC.Utils.Misc @@ -34,12 +35,23 @@ import GHC.Utils.Error (diagReasonSeverity) instance Diagnostic PsMessage where diagnosticMessage (PsUnknownMessage m) = diagnosticMessage m diagnosticReason (PsUnknownMessage m) = diagnosticReason m - -mk_parser_err :: SrcSpan -> SDoc -> MsgEnvelope PsMessage -mk_parser_err span doc = MsgEnvelope + -- FIXME(adinapoli) Fix it properly for #18516. + -- The reason why we temporarily set 'diagnosticHints' to be + -- the empty list is because currently the parser types does + -- not integrate tightly with the new diagnostic infrastructure + -- and as such hints and bundled together with the rendereded + -- diagnostic, and the same 'PsErrorDesc' is sometimes emitted + -- twice but with a different hint, which makes it hard to + -- untangle the two. Therefore, to smooth out the integration, + -- we provisionally tuck the hints directly into a 'PsUnknownMessage' + -- and we rendered them inside 'diagnosticMessage'. + diagnosticHints (PsUnknownMessage _m) = [] + +mk_parser_err :: [GhcHint] -> SrcSpan -> SDoc -> MsgEnvelope PsMessage +mk_parser_err hints span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = PsUnknownMessage $ DiagnosticMessage (mkDecorated [doc]) ErrorWithoutFlag + , errMsgDiagnostic = PsUnknownMessage $ mkPlainError hints doc , errMsgSeverity = SevError } @@ -47,7 +59,7 @@ mk_parser_warn :: DynFlags -> WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope PsMe mk_parser_warn df flag span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = PsUnknownMessage $ DiagnosticMessage (mkDecorated [doc]) reason + , errMsgDiagnostic = PsUnknownMessage $ mkPlainDiagnostic reason noHints doc , errMsgSeverity = diagReasonSeverity df reason } where @@ -141,12 +153,12 @@ mkParserWarn df = \case OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" mkParserErr :: PsError -> MsgEnvelope PsMessage -mkParserErr err = mk_parser_err (errLoc err) $ +mkParserErr err = mk_parser_err (errHints err) (errLoc err) $ pprPsError (errDesc err) (errHints err) --- | Render a 'PsErrorDesc' into an 'SDoc', with its 'PsHint's. -pprPsError :: PsErrorDesc -> [PsHint] -> SDoc -pprPsError desc hints = vcat (pp_err desc : map pp_hint hints) +-- | Render a 'PsErrorDesc' into an 'SDoc', with its 'Hint's. +pprPsError :: PsErrorDesc -> [GhcHint] -> SDoc +pprPsError desc hints = vcat (pp_err desc : map ppr hints) pp_err :: PsErrorDesc -> SDoc pp_err = \case @@ -384,7 +396,7 @@ pp_err = \case -> text "Found a binding for the" <+> quotes (text "@") <+> text "operator in a pattern position." - $$ perhaps_as_pat + $$ perhapsAsPat PsErrLambdaCmdInFunAppCmd a -> pp_unexpected_fun_app (text "lambda command") a @@ -613,26 +625,3 @@ pp_unexpected_fun_app e a = $$ nest 4 (ppr a) $$ text "You could write it with parentheses" $$ text "Or perhaps you meant to enable BlockArguments?" - -pp_hint :: PsHint -> SDoc -pp_hint = \case - SuggestTH -> text "Perhaps you intended to use TemplateHaskell" - SuggestDo -> text "Perhaps this statement should be within a 'do' block?" - SuggestMissingDo -> text "Possibly caused by a missing 'do'?" - SuggestRecursiveDo -> text "Perhaps you intended to use RecursiveDo" - SuggestLetInDo -> text "Perhaps you need a 'let' in a 'do' block?" - $$ text "e.g. 'let x = 5' instead of 'x = 5'" - SuggestPatternSynonyms -> text "Perhaps you intended to use PatternSynonyms" - - SuggestInfixBindMaybeAtPat fun - -> text "In a function binding for the" - <+> quotes (ppr fun) - <+> text "operator." - $$ if opIsAt fun - then perhaps_as_pat - else empty - TypeApplicationsInPatternsOnlyDataCons -> - text "Type applications in patterns are only allowed on data constructors." - -perhaps_as_pat :: SDoc -perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index bb0aee09be..7a60830d34 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -425,7 +425,7 @@ checkProcessArgsResult flags liftIO $ throwErrors $ foldMap (singleMessage . mkMsg) flags where mkMsg (L loc flag) = mkPlainErrorMsgEnvelope loc $ - GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ + GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag @@ -469,5 +469,5 @@ optionsParseError str loc = throwErr :: SrcSpan -> SDoc -> a -- #15053 throwErr loc doc = - let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage $ PsUnknownMessage $ mkPlainError doc + let msg = mkPlainErrorMsgEnvelope loc $ GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints doc in throw $ mkSrcErr $ singleMessage msg diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index 2864e2998e..dc13d44493 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -109,6 +109,7 @@ import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair ) +import GHC.Types.Error ( GhcHint(..) ) import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..)) @@ -3044,11 +3045,11 @@ srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options sug c s = if c then Just s else Nothing - sug_th = sug (not th_enabled && token == "$") SuggestTH -- #7396 - sug_rdo = sug (token == "<-" && mdoInLast100) SuggestRecursiveDo - sug_do = sug (token == "<-" && not mdoInLast100) SuggestDo + sug_th = sug (not th_enabled && token == "$") (SuggestExtension LangExt.TemplateHaskell) -- #7396 + sug_rdo = sug (token == "<-" && mdoInLast100) (SuggestExtension LangExt.RecursiveDo) + sug_do = sug (token == "<-" && not mdoInLast100) SuggestMissingDo sug_let = sug (token == "=" && doInLast100) SuggestLetInDo -- #15849 - sug_pat = sug (not ps_enabled && pattern_ == "pattern ") SuggestPatternSynonyms -- #12429 + sug_pat = sug (not ps_enabled && pattern_ == "pattern ") (SuggestExtension LangExt.PatternSynonyms) -- #12429 suggests | null token = [] | otherwise = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat] diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 2eba1fa9e2..62d6c6b834 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -118,6 +118,7 @@ import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Unit.Module (ModuleName) import GHC.Types.Basic +import GHC.Types.Error ( GhcHint(..) ) import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Parser.Types @@ -145,6 +146,7 @@ import GHC.Driver.Flags ( WarningFlag(..) ) import qualified Data.Semigroup as Semi import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import qualified GHC.LanguageExtensions as LangExt import Control.Monad import Text.ParserCombinators.ReadP as ReadP @@ -1073,7 +1075,7 @@ checkImportDecl mPre mPost = do checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs) checkPattern = runPV . checkLPat -checkPattern_hints :: [PsHint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) +checkPattern_hints :: [GhcHint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs) checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat) checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs) @@ -1091,7 +1093,7 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args add_hint TypeApplicationsInPatternsOnlyDataCons $ patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs]) | not (null args) && patIsRec c = - add_hint SuggestRecursiveDo $ + add_hint (SuggestExtension LangExt.RecursiveDo) $ patFail (locA l) (ppr e) checkPat loc (L _ (PatBuilderAppType f _ t)) tyargs args = checkPat loc f (t : tyargs) args @@ -2715,7 +2717,7 @@ failOpFewArgs (L loc op) = data PV_Context = PV_Context { pv_options :: ParserOpts - , pv_hints :: [PsHint] -- See Note [Parser-Validator Hint] + , pv_hints :: [GhcHint] -- See Note [Parser-Validator Hint] } data PV_Accum = @@ -2765,7 +2767,7 @@ instance Monad PV where runPV :: PV a -> P a runPV = runPV_hints [] -runPV_hints :: [PsHint] -> PV a -> P a +runPV_hints :: [GhcHint] -> PV a -> P a runPV_hints hints m = P $ \s -> let @@ -2786,7 +2788,7 @@ runPV_hints hints m = PV_Ok acc' a -> POk (mkPState acc') a PV_Failed acc' -> PFailed (mkPState acc') -add_hint :: PsHint -> PV a -> PV a +add_hint :: GhcHint -> PV a -> PV a add_hint hint m = let modifyHint ctx = ctx{pv_hints = pv_hints ctx ++ [hint]} in PV (\ctx acc -> unPV m (modifyHint ctx) acc) diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index ffabf0f69c..650befdd8f 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -31,6 +31,7 @@ instance Diagnostic TcRnMessage where -> mkDecorated [ text "The import item" <+> quotes (ppr ie) <+> text "does not have an explicit import list" ] + diagnosticReason = \case TcRnUnknownMessage m -> diagnosticReason m @@ -45,6 +46,20 @@ instance Diagnostic TcRnMessage where TcRnMissingImportList{} -> WarningWithFlag Opt_WarnMissingImportList + diagnosticHints = \case + TcRnUnknownMessage m + -> diagnosticHints m + TcRnImplicitLift{} + -> noHints + TcRnUnusedPatternBinds{} + -> noHints + TcRnDodgyImports{} + -> noHints + TcRnDodgyExports{} + -> noHints + TcRnMissingImportList{} + -> noHints + dodgy_msg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc dodgy_msg kind tc ie = sep [ text "The" <+> kind <+> text "item" diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 50b832ed49..450e97819a 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -214,7 +214,7 @@ tcRnModule hsc_env mod_sum save_rn_syntax logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env err_msg = mkPlainErrorMsgEnvelope loc $ - TcRnUnknownMessage $ mkPlainError $ + TcRnUnknownMessage $ mkPlainError noHints $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod pair :: (Module, SrcSpan) @@ -3152,5 +3152,5 @@ mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $ singleMessage $ mkPlainMsgEnvelope dflags noSrcSpan $ TcRnUnknownMessage $ - mkPlainDiagnostic WarningWithoutFlag $ + mkPlainDiagnostic WarningWithoutFlag noHints $ Outputable.text unsafeText diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 730e666a2a..2d9298e12b 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -1038,7 +1038,7 @@ mkLongErrAt loc msg extra let msg' = pprWithUnitState unit_state msg in return $ mkErrorMsgEnvelope loc printer $ TcRnUnknownMessage - $ mkDecoratedError [msg', extra] } + $ mkDecoratedError noHints [msg', extra] } mkTcRnMessage :: DiagnosticReason -> SrcSpan @@ -1058,7 +1058,7 @@ mkTcRnMessage reason loc important context extra in return $ mkMsgEnvelope dflags loc printer $ TcRnUnknownMessage - $ mkDecoratedDiagnostic reason errDocs } + $ mkDecoratedDiagnostic reason noHints errDocs } addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic @@ -1585,7 +1585,7 @@ add_diagnostic_at reason loc msg extra_info dflags <- getDynFlags ; let { dia = mkMsgEnvelope dflags loc printer $ TcRnUnknownMessage $ - mkDecoratedDiagnostic reason [msg, extra_info] } ; + mkDecoratedDiagnostic reason noHints [msg, extra_info] } ; reportDiagnostic dia } diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 0ec3e8756c..a97c690260 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} @@ -24,12 +25,16 @@ module GHC.Types.Error , Diagnostic (..) , DiagnosticMessage (..) , DiagnosticReason (..) - , mkDiagnosticMessage + , DiagnosticHint (..) , mkPlainDiagnostic , mkPlainError , mkDecoratedDiagnostic , mkDecoratedError + -- * Hints and refactoring actions + , GhcHint (..) + , noHints + -- * Rendering Messages , SDoc @@ -67,6 +72,7 @@ import GHC.Utils.Json import Data.Bifunctor import Data.Foldable ( fold ) +import GHC.Types.Hint {- Note [Messages] @@ -202,6 +208,13 @@ constraint. class Diagnostic a where diagnosticMessage :: a -> DecoratedSDoc diagnosticReason :: a -> DiagnosticReason + diagnosticHints :: a -> [GhcHint] + +-- | A generic 'Hint' message, to be used with 'DiagnosticMessage'. +data DiagnosticHint = DiagnosticHint !SDoc + +instance Outputable DiagnosticHint where + ppr (DiagnosticHint msg) = msg -- | A generic 'Diagnostic' message, without any further classification or -- provenance: By looking at a 'DiagnosticMessage' we don't know neither @@ -211,30 +224,36 @@ class Diagnostic a where data DiagnosticMessage = DiagnosticMessage { diagMessage :: !DecoratedSDoc , diagReason :: !DiagnosticReason + , diagHints :: [GhcHint] } instance Diagnostic DiagnosticMessage where diagnosticMessage = diagMessage diagnosticReason = diagReason + diagnosticHints = diagHints --- | Create a 'DiagnosticMessage' with a 'DiagnosticReason' -mkDiagnosticMessage :: DecoratedSDoc -> DiagnosticReason -> DiagnosticMessage -mkDiagnosticMessage = DiagnosticMessage +-- | Helper function to use when no hints can be provided. Currently this function +-- can be used to construct plain 'DiagnosticMessage' and add hints to them, but +-- once #18516 will be fully executed, the main usage of this function would be in +-- the implementation of the 'diagnosticHints' typeclass method, to report the fact +-- that a particular 'Diagnostic' has no hints. +noHints :: [GhcHint] +noHints = mempty -mkPlainDiagnostic :: DiagnosticReason -> SDoc -> DiagnosticMessage -mkPlainDiagnostic rea doc = DiagnosticMessage (mkSimpleDecorated doc) rea +mkPlainDiagnostic :: DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage +mkPlainDiagnostic rea hints doc = DiagnosticMessage (mkSimpleDecorated doc) rea hints -- | Create an error 'DiagnosticMessage' holding just a single 'SDoc' -mkPlainError :: SDoc -> DiagnosticMessage -mkPlainError doc = DiagnosticMessage (mkSimpleDecorated doc) ErrorWithoutFlag +mkPlainError :: [GhcHint] -> SDoc -> DiagnosticMessage +mkPlainError hints doc = DiagnosticMessage (mkSimpleDecorated doc) ErrorWithoutFlag hints -- | Create a 'DiagnosticMessage' from a list of bulleted SDocs and a 'DiagnosticReason' -mkDecoratedDiagnostic :: DiagnosticReason -> [SDoc] -> DiagnosticMessage -mkDecoratedDiagnostic rea docs = DiagnosticMessage (mkDecorated docs) rea +mkDecoratedDiagnostic :: DiagnosticReason -> [GhcHint] -> [SDoc] -> DiagnosticMessage +mkDecoratedDiagnostic rea hints docs = DiagnosticMessage (mkDecorated docs) rea hints -- | Create an error 'DiagnosticMessage' from a list of bulleted SDocs -mkDecoratedError :: [SDoc] -> DiagnosticMessage -mkDecoratedError docs = DiagnosticMessage (mkDecorated docs) ErrorWithoutFlag +mkDecoratedError :: [GhcHint] -> [SDoc] -> DiagnosticMessage +mkDecoratedError hints docs = DiagnosticMessage (mkDecorated docs) ErrorWithoutFlag hints -- | The reason /why/ a 'Diagnostic' was emitted in the first place. -- Diagnostic messages are born within GHC with a very precise reason, which diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs new file mode 100644 index 0000000000..23e00acfd8 --- /dev/null +++ b/compiler/GHC/Types/Hint.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +module GHC.Types.Hint where + +import GHC.Prelude + +import GHC.Utils.Outputable +import GHC.Types.Name.Reader +import GHC.LanguageExtensions +import Data.Typeable +import GHC.Unit.Module (ModuleName, Module) + +-- | A type for hints emitted by GHC. +-- A /hint/ suggests a possible way to deal with a particular warning or error. +data GhcHint + = + {-| An \"unknown\" hint. This type constructor allows arbitrary + -- hints to be embedded. The typical use case would be GHC plugins + -- willing to emit hints alongside their custom diagnostics. + -} + forall a. (Outputable a, Typeable a) => UnknownHint a + {-| Suggests adding a particular language extension. GHC will do its best trying + to guess when the user is using the syntax of a particular language extension + without having the relevant extension enabled. + + Example: If the user uses the keyword \"mdo\" (and we are in a monadic block), but + the relevant extension is not enabled, GHC will emit a 'SuggestExtension RecursiveDo'. + + Test case(s): parser/should_fail/T12429, parser/should_fail/T8501c, + parser/should_fail/T18251e, ... (and many more) + + -} + | SuggestExtension !Extension + {-| Suggests that a monadic code block is probably missing a \"do\" keyword. + + Example: + main = + putStrLn "hello" + putStrLn "world" + + Test case(s): parser/should_fail/T8501a, parser/should_fail/readFail007, + parser/should_fail/InfixAppPatErr, parser/should_fail/T984 + -} + | SuggestMissingDo + {-| Suggests that a \"let\" expression is needed in a \"do\" block. + + Test cases: None (that explicitly test this particular hint is emitted). + -} + | SuggestLetInDo + -- FIXME(adn) This is not a hint but was migrated from the old \"PsHint\" type. + -- It will be removed in a further refactoring as part of #18516. + | SuggestInfixBindMaybeAtPat !RdrName + -- FIXME(adn) This is not a hint but was migrated from the old \"PsHint\" type. + -- It will be removed in a further refactoring as part of #18516. + | TypeApplicationsInPatternsOnlyDataCons + {-| Suggests to add an \".hsig\" signature file to the Cabal manifest. + + Triggered by: 'GHC.Driver.Errors.Types.DriverUnexpectedSignature', if Cabal + is being used. + + Example: See comment of 'DriverUnexpectedSignature'. + + Test case(s): driver/T12955 + + -} + | SuggestAddSignatureCabalFile !ModuleName + {-| Suggests to explicitly list the instantiations for the signatures in + the GHC invocation command. + + Triggered by: 'GHC.Driver.Errors.Types.DriverUnexpectedSignature', if Cabal + is /not/ being used. + + Example: See comment of 'DriverUnexpectedSignature'. + + Test case(s): driver/T12955 + -} + | SuggestSignatureInstantiations !ModuleName [InstantiationSuggestion] + + +instance Outputable GhcHint where + ppr = \case + UnknownHint m + -> ppr m + SuggestExtension ext + -> text "Perhaps you intended to use" <+> ppr ext + SuggestMissingDo + -> text "Possibly caused by a missing 'do'?" + SuggestLetInDo + -> text "Perhaps you need a 'let' in a 'do' block?" + $$ text "e.g. 'let x = 5' instead of 'x = 5'" + SuggestInfixBindMaybeAtPat fun + -> text "In a function binding for the" + <+> quotes (ppr fun) + <+> text "operator." + $$ if opIsAt fun + then perhapsAsPat + else empty + TypeApplicationsInPatternsOnlyDataCons + -> text "Type applications in patterns are only allowed on data constructors." + SuggestAddSignatureCabalFile pi_mod_name + -> text "Try adding" <+> quotes (ppr pi_mod_name) + <+> text "to the" + <+> quotes (text "signatures") + <+> text "field in your Cabal file." + SuggestSignatureInstantiations pi_mod_name suggestions + -> let suggested_instantiated_with = + hcat (punctuate comma $ + [ ppr k <> text "=" <> ppr v + | InstantiationSuggestion k v <- suggestions + ]) + in text "Try passing -instantiated-with=\"" <> + suggested_instantiated_with <> text "\"" $$ + text "replacing <" <> ppr pi_mod_name <> text "> as necessary." + +perhapsAsPat :: SDoc +perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" + + +-- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated +-- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way +-- to instantiate a particular signature, where the first argument is +-- the signature name and the second is the module where the signature +-- was defined. +-- Example: +-- +-- src/MyStr.hsig:2:11: error: +-- Unexpected signature: ‘MyStr’ +-- (Try passing -instantiated-with="MyStr=" +-- replacing as necessary.) +data InstantiationSuggestion = InstantiationSuggestion !ModuleName !Module diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index a5eccbd7de..43692af28a 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -39,6 +39,7 @@ module GHC.Utils.Error ( mkPlainDiagnostic, mkDecoratedError, mkDecoratedDiagnostic, + noHints, -- * Utilities doIfSet, doIfSet_dyn, diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 1b7c8d4eb4..0d6e92cf6e 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -640,6 +640,7 @@ Library GHC.Types.Fixity.Env GHC.Types.ForeignCall GHC.Types.ForeignStubs + GHC.Types.Hint GHC.Types.HpcInfo GHC.Types.Id GHC.Types.IPE diff --git a/testsuite/tests/driver/T12955.stderr b/testsuite/tests/driver/T12955.stderr index acf4000608..baa6fc6064 100644 --- a/testsuite/tests/driver/T12955.stderr +++ b/testsuite/tests/driver/T12955.stderr @@ -1,9 +1,11 @@ T12955.hsig:1:11: error: Unexpected signature: ‘T12955’ - (Try passing -instantiated-with="T12955=" - replacing as necessary.) + Suggested fix: + Try passing -instantiated-with="T12955=" + replacing as necessary. T12955.hsig:1:11: error: Unexpected signature: ‘T12955’ - (Try adding ‘T12955’ to the ‘signatures’ field in your Cabal file.) + Suggested fix: + Try adding ‘T12955’ to the ‘signatures’ field in your Cabal file. diff --git a/testsuite/tests/parser/should_run/CountAstDeps.stdout b/testsuite/tests/parser/should_run/CountAstDeps.stdout index 3980993668..242076d90c 100644 --- a/testsuite/tests/parser/should_run/CountAstDeps.stdout +++ b/testsuite/tests/parser/should_run/CountAstDeps.stdout @@ -1,4 +1,4 @@ -Found 256 Language.Haskell.Syntax module dependencies +Found 257 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -167,6 +167,7 @@ GHC.Types.Fixity GHC.Types.Fixity.Env GHC.Types.ForeignCall GHC.Types.ForeignStubs +GHC.Types.Hint GHC.Types.HpcInfo GHC.Types.IPE GHC.Types.Id diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout index 887161fd5e..c08cd67a52 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.stdout +++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout @@ -1,4 +1,4 @@ -Found 262 GHC.Parser module dependencies +Found 263 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -173,6 +173,7 @@ GHC.Types.Fixity GHC.Types.Fixity.Env GHC.Types.ForeignCall GHC.Types.ForeignStubs +GHC.Types.Hint GHC.Types.HpcInfo GHC.Types.IPE GHC.Types.Id -- cgit v1.2.1