Give parsing plugins access to errorswip/T20803

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

18 files changed, 226 insertions, 22 deletions

diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 62187d573f..d0fde311e4 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -443,8 +443,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"
@@ -453,7 +451,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,
@@ -489,9 +486,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
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index a2cced7294..97ceef7fce 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -49,6 +49,12 @@ Compiler
   defaults for ambiguous variables that would otherwise cause errors
   just like the built-in defaulting mechanism.
 
+- ``GHC.Plugins.parsedResultAction`` now takes and returns a tuple of warnings
+  and errors encountered by the parser before they're shown to the user, as
+  long as none of the errors prevented the AST from being built. This means
+  plugins can remove, modify, or add any of these, or simply pass them through
+  unchanged.
+
 - The way GHC checks for representation polymorphism has been overhauled:
   all the checks are now done during typechecking. The error messages
   now contain more detailed information about the specific check that was performed.
@@ -357,4 +363,4 @@ Compiler
 
 - GHC no longer carries ``Derived`` constraints. Accordingly, several functions
   in the plugin architecture that previously passed or received three sets of
-  constraints (givens, deriveds, and wanteds) now work with two such sets.
\ No newline at end of file
+  constraints (givens, deriveds, and wanteds) now work with two such sets.
diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst
index a727d3ee60..4a987bca87 100644
--- a/docs/users_guide/extending_ghc.rst
+++ b/docs/users_guide/extending_ghc.rst
@@ -755,7 +755,8 @@ in the source code as well as the original syntax tree of the compiled module.
 ::
 
     parsed :: [CommandLineOption] -> ModSummary -> HsParsedModule
-                -> Hsc HsParsedModule
+                -> (Messages PsWarning, Messages PsError)
+                -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError)
 
 The ``ModSummary`` contains useful
 meta-information about the compiled module. The ``HsParsedModule`` contains the
@@ -763,6 +764,14 @@ lexical and syntactical information we mentioned before. The result that you
 return will change the result of the parsing. If you don't want to change the
 result, just return the ``HsParsedModule`` that you received as the argument.
 
+If the parser encounters any errors that prevent an AST from being constructed,
+the plugin will not be run, but other kinds of errors, as well as warnings,
+will be given to the plugin via the ``Messages`` tuple. This allows you to
+modify, remove, and add warnings or errors before they are displayed to the
+user, although in most cases, you will likely want to return the tuple
+unmodified. The parsing pass will fail if the returned ``Messages PsError``
+collection is not empty after all parsing plugins have been run.
+
 Type checked representation
 ^^^^^^^^^^^^^^^^^^^^^^^^^^^
 
@@ -874,7 +883,7 @@ displayed.
     import Control.Monad.IO.Class
     import GHC.Driver.Session (getDynFlags)
     import GHC.Driver.Plugins
-    import GHC.Driver.Types
+    import GHC.Plugins
     import GHC.Tc.Types
     import Language.Haskell.Syntax.Extension
     import GHC.Hs.Decls
@@ -893,11 +902,15 @@ displayed.
       , interfaceLoadAction = interfaceLoadPlugin
       }
 
-    parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
-    parsedPlugin _ _ pm
-      = do dflags <- getDynFlags
+    parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
+                 -> (Messages PsWarning, Messages PsError)
+                 -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError))
+    parsedPlugin _ _ pm msgs@(warns, errs)
+         = do dflags <- getDynFlags
            liftIO $ putStrLn $ "parsePlugin: \n" ++ (showSDoc dflags $ ppr $ hpm_module pm)
-           return pm
+           liftIO $ putStrLn $ "parsePlugin warnings: \n" ++ (showSDoc dflags $ ppr warns)
+           liftIO $ putStrLn $ "parsePlugin errors: \n" ++ (showSDoc dflags $ ppr errs)
+           return (pm, msgs)
 
     renamedAction :: [CommandLineOption] -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
     renamedAction _ tc gr = do
@@ -945,6 +958,10 @@ output:
     module A where
     a = ()
     $(return [])
+    parsePlugin warnings:
+
+    parsePlugin errors:
+
     typeCheckPlugin (rn): a = ()
     interface loaded: Language.Haskell.TH.Lib.Internal
     meta: return []
diff --git a/testsuite/tests/plugins/Makefile b/testsuite/tests/plugins/Makefile
index 7ee0ccbfb7..442e69cd92 100644
--- a/testsuite/tests/plugins/Makefile
+++ b/testsuite/tests/plugins/Makefile
@@ -182,3 +182,10 @@ plugins-order-pragma:
 	"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins-order-pragma.hs -package-db plugin-recomp/pkg.plugins01/local.package.conf -fplugin ImpurePlugin
 	./plugins-order-pragma
 
+.PHONY: T20803a
+T20803a:
+	"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 T20803a.hs -package-db T20803-plugin/pkg.T20803a/local.package.conf
+
+.PHONY: T20803b
+T20803b:
+	"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 T20803b.hs -package-db T20803-plugin/pkg.T20803b/local.package.conf
diff --git a/testsuite/tests/plugins/T20803-plugin/AddErrorPlugin.hs b/testsuite/tests/plugins/T20803-plugin/AddErrorPlugin.hs
new file mode 100644
index 0000000000..e055204acf
--- /dev/null
+++ b/testsuite/tests/plugins/T20803-plugin/AddErrorPlugin.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE GADTs #-}
+
+module AddErrorPlugin where
+
+import GHC.Plugins
+import GHC.Types.Error
+import GHC.Hs
+import GHC.Data.Bag
+import GHC.Parser.Errors.Types
+
+import System.IO
+
+-- Tests whether it's possible to add a parse error
+plugin :: Plugin
+plugin = defaultPlugin {parsedResultAction = parsedAction}
+
+parsedAction :: [CommandLineOption] -> ModSummary -> HsParsedModule
+             -> (Messages PsWarning, Messages PsError)
+             -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError))
+parsedAction _ _ pm (warns, _) = do
+  liftIO $ putStrLn "parsePlugin"
+  -- TODO: Remove #20791
+  liftIO $ hFlush stdout
+  pure (pm, (warns, mkMessages $ unitBag err))
+  where
+    err = MsgEnvelope
+      { errMsgSpan = UnhelpfulSpan UnhelpfulNoLocationInfo
+      , errMsgContext = alwaysQualify
+      , errMsgDiagnostic = PsErrEmptyLambda
+      , errMsgSeverity = SevError
+      }
diff --git a/testsuite/tests/plugins/T20803-plugin/FixErrorsPlugin.hs b/testsuite/tests/plugins/T20803-plugin/FixErrorsPlugin.hs
new file mode 100644
index 0000000000..1cf44edd8a
--- /dev/null
+++ b/testsuite/tests/plugins/T20803-plugin/FixErrorsPlugin.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE GADTs #-}
+
+module FixErrorsPlugin where
+
+import GHC.Plugins
+import GHC.Types.Error
+import GHC.Hs
+import GHC.Data.Bag
+import GHC.Parser.Errors.Types
+
+import System.IO
+import Data.Type.Equality as Eq
+import Data.Data
+import Data.Maybe
+
+-- Tests whether it's possible to remove a parse error and fix the erroneous AST
+plugin :: Plugin
+plugin = defaultPlugin {parsedResultAction = parsedAction}
+
+-- Replace every hole (and other unbound vars) with the given expression
+replaceHoles :: forall a . Data a => HsExpr GhcPs -> a -> a
+replaceHoles new = gmapT \case
+  (d :: d) -> replaceHoles new d `fromMaybe` tryHole
+    where
+      tryHole :: Maybe d
+      tryHole = eqT @d @(HsExpr GhcPs) >>= \case
+        Eq.Refl | HsUnboundVar _ _ <- d -> Just new
+        _                               -> Nothing
+
+parsedAction :: [CommandLineOption] -> ModSummary -> HsParsedModule
+             -> (Messages PsWarning, Messages PsError)
+             -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError))
+parsedAction _ _ (HsParsedModule lmod srcFiles) (warns, errs) = do
+  liftIO $ putStrLn "parsePlugin"
+  liftIO $ putStrLn $ showPprUnsafe newModule
+  -- TODO: Remove #20791
+  liftIO $ hFlush stdout
+  pure (HsParsedModule newModule srcFiles, (warns, otherErrs))
+
+  where
+    PsErrBangPatWithoutSpace (L _ holeExpr) = errMsgDiagnostic noSpaceBang
+    (bagToList -> [noSpaceBang], mkMessages -> otherErrs) =
+      partitionBag (isNoSpaceBang . errMsgDiagnostic) . getMessages $ errs
+
+    isNoSpaceBang (PsErrBangPatWithoutSpace _) = True
+    isNoSpaceBang _ = False
+
+    newModule = replaceHoles holeExpr <$> lmod
diff --git a/testsuite/tests/plugins/T20803-plugin/Makefile b/testsuite/tests/plugins/T20803-plugin/Makefile
new file mode 100644
index 0000000000..9d5468b812
--- /dev/null
+++ b/testsuite/tests/plugins/T20803-plugin/Makefile
@@ -0,0 +1,20 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+clean.%:
+	rm -rf pkg.$*
+
+HERE := $(abspath .)
+$(eval $(call canonicalise,HERE))
+
+package.%:
+	$(MAKE) -s --no-print-directory clean.$*
+	mkdir pkg.$*
+	"$(TEST_HC)" -outputdir pkg.$* --make -v0 -o pkg.$*/setup Setup.hs
+
+	"$(GHC_PKG)" init pkg.$*/local.package.conf
+
+	pkg.$*/setup configure --distdir pkg.$*/dist -v0 $(CABAL_PLUGIN_BUILD) --prefix="$(HERE)/pkg.$*/install" --with-compiler="$(TEST_HC)" --with-hc-pkg="$(GHC_PKG)" --package-db=pkg.$*/local.package.conf $(if $(findstring YES,$(HAVE_PROFILING)), --enable-library-profiling)
+	pkg.$*/setup build     --distdir pkg.$*/dist -v0
+	pkg.$*/setup install   --distdir pkg.$*/dist -v0
diff --git a/testsuite/tests/plugins/T20803-plugin/Setup.hs b/testsuite/tests/plugins/T20803-plugin/Setup.hs
new file mode 100644
index 0000000000..e8ef27dbba
--- /dev/null
+++ b/testsuite/tests/plugins/T20803-plugin/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
diff --git a/testsuite/tests/plugins/T20803-plugin/T20803-plugin.cabal b/testsuite/tests/plugins/T20803-plugin/T20803-plugin.cabal
new file mode 100644
index 0000000000..48dc1fa489
--- /dev/null
+++ b/testsuite/tests/plugins/T20803-plugin/T20803-plugin.cabal
@@ -0,0 +1,13 @@
+Name:           T20803-plugin
+Version:        0.1
+Synopsis:       For testing
+Build-Type:     Simple
+Cabal-Version:  >= 1.10
+
+Library
+    Extensions:     CPP
+    Default-language: GHC2021
+    Build-Depends: base, ghc
+    Exposed-Modules:
+        FixErrorsPlugin
+        AddErrorPlugin
diff --git a/testsuite/tests/plugins/T20803a.hs b/testsuite/tests/plugins/T20803a.hs
new file mode 100644
index 0000000000..aa1afb8e32
--- /dev/null
+++ b/testsuite/tests/plugins/T20803a.hs
@@ -0,0 +1,6 @@
+module Main where
+
+main = do
+  putStrLn "Program Started"
+  putStrLn !"message"
+  putStrLn "Program Ended"
diff --git a/testsuite/tests/plugins/T20803a.stderr b/testsuite/tests/plugins/T20803a.stderr
new file mode 100644
index 0000000000..828a882f24
--- /dev/null
+++ b/testsuite/tests/plugins/T20803a.stderr
@@ -0,0 +1,6 @@
+parsePlugin
+module Main where
+main
+  = do putStrLn "Program Started"
+       putStrLn "message"
+       putStrLn "Program Ended"
diff --git a/testsuite/tests/plugins/T20803b.hs b/testsuite/tests/plugins/T20803b.hs
new file mode 100644
index 0000000000..46d214c2e6
--- /dev/null
+++ b/testsuite/tests/plugins/T20803b.hs
@@ -0,0 +1,6 @@
+module Main where
+
+main = do
+  putStrLn "Program Started"
+  putStrLn "message"
+  putStrLn "Program Ended"
diff --git a/testsuite/tests/plugins/T20803b.stderr b/testsuite/tests/plugins/T20803b.stderr
new file mode 100644
index 0000000000..3bb08f7756
--- /dev/null
+++ b/testsuite/tests/plugins/T20803b.stderr
@@ -0,0 +1,3 @@
+parsePlugin
+
+<no location info>: A lambda requires at least one parameter
diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T
index 3fda3755ae..d2681ac658 100644
--- a/testsuite/tests/plugins/all.T
+++ b/testsuite/tests/plugins/all.T
@@ -277,3 +277,15 @@ test('plugins-order-pragma',
       pre_cmd('$MAKE -s --no-print-directory -C plugin-recomp package.plugins01 TOP={top}')
       ],
      makefile_test, [])
+
+test('T20803a',
+     [extra_files(['T20803-plugin/']),
+      pre_cmd('$MAKE -s --no-print-directory -C T20803-plugin package.T20803a TOP={top}')],
+     compile,
+     ['-package-db T20803-plugin/pkg.T20803a/local.package.conf -fplugin FixErrorsPlugin -package T20803-plugin ' + config.plugin_way_flags])
+
+test('T20803b',
+     [extra_files(['T20803-plugin/']),
+      pre_cmd('$MAKE -s --no-print-directory -C T20803-plugin package.T20803b TOP={top}')],
+     compile_fail,
+     ['-package-db T20803-plugin/pkg.T20803b/local.package.conf -fplugin AddErrorPlugin -package T20803-plugin ' + config.plugin_way_flags])
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
index dfbed9e490..d638bd6a48 100644
--- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
+++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
@@ -28,10 +28,11 @@ plugin = defaultPlugin { parsedResultAction = parsedPlugin
                        }
 
 parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
-                  -> Hsc HsParsedModule
-parsedPlugin [name, "parse"] _ pm
-  = return $ pm { hpm_module = removeParsedBinding name (hpm_module pm) }
-parsedPlugin _ _ pm = return pm
+             -> (Messages PsWarning, Messages PsError)
+             -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError))
+parsedPlugin [name, "parse"] _ pm msgs
+  = return (pm { hpm_module = removeParsedBinding name (hpm_module pm) }, msgs)
+parsedPlugin _ _ pm msgs = return (pm, msgs)
 
 removeParsedBinding :: String -> Located HsModule
                          -> Located HsModule
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs
index bb0458bf3e..172a052817 100644
--- a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs
+++ b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs
@@ -26,12 +26,13 @@ plugin = defaultPlugin { parsedResultAction = parsedPlugin
                        }
 
 parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
-                  -> Hsc HsParsedModule
-parsedPlugin opts _ pm
+             -> (Messages PsWarning, Messages PsError)
+             -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError))
+parsedPlugin opts _ pm msgs
   = do liftIO $ putStrLn $ "parsePlugin(" ++ intercalate "," opts ++ ")"
        -- TODO: Remove #20791
        liftIO $ hFlush stdout
-       return pm
+       return (pm, msgs)
 
 renamedAction :: [CommandLineOption]
                     -> TcGblEnv -> HsGroup GhcRn