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`.

5 files changed, 39 insertions, 59 deletions

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)