From f07c7766663fa52a037aaf941fd0d34523ff2f2f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jakob=20Br=C3=BCnker?= <jakob.bruenker@gmail.com>
Date: Fri, 18 Mar 2022 17:56:07 +0100
Subject: Give parsing plugins access to errors

Previously, when the parser produced non-fatal errors (i.e. it produced
errors but the 'PState' is 'POk'), compilation would be aborted before
the 'parsedResultAction' of any plugin was invoked. This commit changes
that, so that such that 'parsedResultAction' gets collections of
warnings and errors as argument, and must return them after potentially
modifying them.

Closes #20803
---
 compiler/GHC/Driver/Main.hs    | 13 ++++++++-----
 compiler/GHC/Driver/Plugins.hs | 13 ++++++++++---
 compiler/GHC/Plugins.hs        |  8 ++++++++
 3 files changed, 26 insertions(+), 8 deletions(-)

(limited to 'compiler/GHC')

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 4c17228852..3fa3d581ce 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -450,8 +450,6 @@ hscParse' mod_summary
         PFailed pst ->
             handleWarningsThrowErrors (getPsMessages pst)
         POk pst rdr_module -> do
-            let (warns, errs) = getPsMessages pst
-            logDiagnostics (GhcPsMessage <$> warns)
             liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"
                         FormatHaskell (ppr rdr_module)
             liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"
@@ -460,7 +458,6 @@ hscParse' mod_summary
                                                    rdr_module)
             liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics"
                         FormatText (ppSourceStats False rdr_module)
-            when (not $ isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)
 
             -- To get the list of extra source files, we take the list
             -- that the parser gave us,
@@ -496,9 +493,15 @@ hscParse' mod_summary
 
             -- apply parse transformation of plugins
             let applyPluginAction p opts
-                  = parsedResultAction p opts mod_summary
+                  = uncurry (parsedResultAction p opts mod_summary)
             hsc_env <- getHscEnv
-            withPlugins (hsc_plugins hsc_env) applyPluginAction res
+            (transformed, (warns, errs)) <-
+              withPlugins (hsc_plugins hsc_env) applyPluginAction (res, getPsMessages pst)
+
+            logDiagnostics (GhcPsMessage <$> warns)
+            unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)
+
+            return transformed
 
 checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))
 checkBidirectionFormatChars start_loc sb
diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs
index 9afb556311..64e82c42b6 100644
--- a/compiler/GHC/Driver/Plugins.hs
+++ b/compiler/GHC/Driver/Plugins.hs
@@ -63,12 +63,15 @@ import GHC.Unit.Module
 import GHC.Unit.Module.ModIface
 import GHC.Unit.Module.ModSummary
 
+import GHC.Parser.Errors.Types (PsWarning, PsError)
+
 import qualified GHC.Tc.Types
 import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports  )
 import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR )
 
 import GHC.Core.Opt.Monad ( CoreToDo, CoreM )
 import GHC.Hs
+import GHC.Types.Error (Messages)
 import GHC.Utils.Fingerprint
 import GHC.Utils.Outputable (Outputable(..), text, (<+>))
 
@@ -119,9 +122,13 @@ data Plugin = Plugin {
   , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
     -- ^ Specify how the plugin should affect recompilation.
   , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule
-                            -> Hsc HsParsedModule
+                       -> (Messages PsWarning, Messages PsError)
+                       -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError))
     -- ^ Modify the module when it is parsed. This is called by
-    -- "GHC.Driver.Main" when the parsing is successful.
+    -- "GHC.Driver.Main" when the parser has produced no or only non-fatal
+    -- errors.
+    -- Compilation will fail if the messages produced by this function contain
+    -- any errors.
   , renamedResultAction :: [CommandLineOption] -> TcGblEnv
                                 -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
     -- ^ Modify each group after it is renamed. This is called after each
@@ -230,7 +237,7 @@ defaultPlugin = Plugin {
       , driverPlugin          = const return
       , pluginRecompile       = impurePlugin
       , renamedResultAction   = \_ env grp -> return (env, grp)
-      , parsedResultAction    = \_ _ -> return
+      , parsedResultAction    = \_ _ mod msgs -> return (mod, msgs)
       , typeCheckResultAction = \_ _ -> return
       , spliceRunAction       = \_ -> return
       , interfaceLoadAction   = \_ -> return
diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs
index 95ae21aba7..2de8d8d370 100644
--- a/compiler/GHC/Plugins.hs
+++ b/compiler/GHC/Plugins.hs
@@ -58,6 +58,9 @@ module GHC.Plugins
    , module GHC.Unit.Module.ModIface
    , module GHC.Types.Meta
    , module GHC.Types.SourceError
+   , module GHC.Parser.Errors.Types
+   , module GHC.Types.Error
+   , module GHC.Hs
    , -- * Getting 'Name's
      thNameToGhcName
    )
@@ -140,6 +143,11 @@ import GHC.Tc.Utils.Env ( lookupGlobal )
 
 import GHC.Tc.Errors.Hole.FitTypes
 
+-- For parse result plugins
+import GHC.Parser.Errors.Types ( PsWarning, PsError )
+import GHC.Types.Error         ( Messages )
+import GHC.Hs                  ( HsParsedModule )
+
 import qualified Language.Haskell.TH as TH
 
 {- This instance is defined outside GHC.Core.Opt.Monad so that
-- 
cgit v1.2.1