diff options
author | Jakob Brünker <jakob.bruenker@gmail.com> | 2022-03-18 17:56:07 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-03-30 03:10:33 -0400 |
commit | f07c7766663fa52a037aaf941fd0d34523ff2f2f (patch) | |
tree | de3288beb918e3fbe0d053ffc9bbadaed9f38477 | |
parent | dda46e2da13268c239db3290720b014cef00c01d (diff) | |
download | haskell-f07c7766663fa52a037aaf941fd0d34523ff2f2f.tar.gz |
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
-rw-r--r-- | compiler/GHC/Driver/Main.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/Driver/Plugins.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/Plugins.hs | 8 | ||||
-rw-r--r-- | docs/users_guide/9.4.1-notes.rst | 8 | ||||
-rw-r--r-- | docs/users_guide/extending_ghc.rst | 29 | ||||
-rw-r--r-- | testsuite/tests/plugins/Makefile | 7 | ||||
-rw-r--r-- | testsuite/tests/plugins/T20803-plugin/AddErrorPlugin.hs | 34 | ||||
-rw-r--r-- | testsuite/tests/plugins/T20803-plugin/FixErrorsPlugin.hs | 51 | ||||
-rw-r--r-- | testsuite/tests/plugins/T20803-plugin/Makefile | 20 | ||||
-rw-r--r-- | testsuite/tests/plugins/T20803-plugin/Setup.hs | 3 | ||||
-rw-r--r-- | testsuite/tests/plugins/T20803-plugin/T20803-plugin.cabal | 13 | ||||
-rw-r--r-- | testsuite/tests/plugins/T20803a.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/plugins/T20803a.stderr | 6 | ||||
-rw-r--r-- | testsuite/tests/plugins/T20803b.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/plugins/T20803b.stderr | 3 | ||||
-rw-r--r-- | testsuite/tests/plugins/all.T | 12 | ||||
-rw-r--r-- | testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs | 9 | ||||
-rw-r--r-- | testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs | 7 |
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 |