summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Driver/Main.hs13
-rw-r--r--compiler/GHC/Driver/Plugins.hs13
-rw-r--r--compiler/GHC/Plugins.hs8
-rw-r--r--docs/users_guide/9.4.1-notes.rst8
-rw-r--r--docs/users_guide/extending_ghc.rst29
-rw-r--r--testsuite/tests/plugins/Makefile7
-rw-r--r--testsuite/tests/plugins/T20803-plugin/AddErrorPlugin.hs34
-rw-r--r--testsuite/tests/plugins/T20803-plugin/FixErrorsPlugin.hs51
-rw-r--r--testsuite/tests/plugins/T20803-plugin/Makefile20
-rw-r--r--testsuite/tests/plugins/T20803-plugin/Setup.hs3
-rw-r--r--testsuite/tests/plugins/T20803-plugin/T20803-plugin.cabal13
-rw-r--r--testsuite/tests/plugins/T20803a.hs6
-rw-r--r--testsuite/tests/plugins/T20803a.stderr6
-rw-r--r--testsuite/tests/plugins/T20803b.hs6
-rw-r--r--testsuite/tests/plugins/T20803b.stderr3
-rw-r--r--testsuite/tests/plugins/all.T12
-rw-r--r--testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs9
-rw-r--r--testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs7
18 files changed, 226 insertions, 22 deletions
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
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 39ab943356..3ccbf4c3ec 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -64,6 +64,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.
@@ -375,4 +381,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 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
View Lorry Controller Status