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

7 files changed, 78 insertions, 58 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