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

13 files changed, 170 insertions, 7 deletions

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 a56fc3cf4f..8cb2d87c85 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