Extensible Hints for diagnostic messageswip/adinapoli-hints-design

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

26 files changed, 314 insertions, 143 deletions

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=<MyStr>"
---      replacing <MyStr> 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=<MyStr>"
+--      replacing <MyStr> 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=<T12955>"
-     replacing <T12955> as necessary.)
+    Suggested fix:
+      Try passing -instantiated-with="T12955=<T12955>"
+      replacing <T12955> 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