diff options
| -rw-r--r-- | compiler/GHC/Driver/Main.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Driver/Plugins.hs | 22 | ||||
| -rw-r--r-- | docs/users_guide/9.4.1-notes.rst | 11 | ||||
| -rw-r--r-- | docs/users_guide/extending_ghc.rst | 45 | ||||
| -rw-r--r-- | testsuite/tests/plugins/T20803-plugin/AddErrorPlugin.hs | 9 | ||||
| -rw-r--r-- | testsuite/tests/plugins/T20803-plugin/FixErrorsPlugin.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs | 11 | ||||
| -rw-r--r-- | testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs | 9 |
8 files changed, 69 insertions, 56 deletions
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 3fa3d581ce..7fd07d31cf 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -493,10 +493,11 @@ hscParse' mod_summary -- apply parse transformation of plugins let applyPluginAction p opts - = uncurry (parsedResultAction p opts mod_summary) + = parsedResultAction p opts mod_summary hsc_env <- getHscEnv - (transformed, (warns, errs)) <- - withPlugins (hsc_plugins hsc_env) applyPluginAction (res, getPsMessages pst) + (ParsedResult transformed (PsMessages warns errs)) <- + withPlugins (hsc_plugins hsc_env) applyPluginAction + (ParsedResult res (uncurry PsMessages $ getPsMessages pst)) logDiagnostics (GhcPsMessage <$> warns) unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs) diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs index 64e82c42b6..67d8422562 100644 --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -12,6 +12,8 @@ module GHC.Driver.Plugins ( , Plugin(..) , defaultPlugin , CommandLineOption + , PsMessages(..) + , ParsedResult(..) -- ** Recompilation checking , purePlugin, impurePlugin, flagRecompile , PluginRecompile(..) @@ -89,6 +91,19 @@ import GHC.Types.Unique.DFM -- are given to you as this type type CommandLineOption = String +-- | Errors and warnings produced by the parser +data PsMessages = PsMessages { psWarnings :: Messages PsWarning + , psErrors :: Messages PsError + } + +-- | Result of running the parser and the parser plugin +data ParsedResult = ParsedResult + { -- | Parsed module, potentially modified by a plugin + parsedResultModule :: HsParsedModule + , -- | Warnings and errors from parser, potentially modified by a plugin + parsedResultMessages :: PsMessages + } + -- | 'Plugin' is the compiler plugin data type. Try to avoid -- constructing one of these directly, and just modify some fields of -- 'defaultPlugin' instead: this is to try and preserve source-code @@ -121,9 +136,8 @@ data Plugin = Plugin { , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile -- ^ Specify how the plugin should affect recompilation. - , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule - -> (Messages PsWarning, Messages PsError) - -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError)) + , parsedResultAction :: [CommandLineOption] -> ModSummary + -> ParsedResult -> Hsc ParsedResult -- ^ Modify the module when it is parsed. This is called by -- "GHC.Driver.Main" when the parser has produced no or only non-fatal -- errors. @@ -237,7 +251,7 @@ defaultPlugin = Plugin { , driverPlugin = const return , pluginRecompile = impurePlugin , renamedResultAction = \_ env grp -> return (env, grp) - , parsedResultAction = \_ _ mod msgs -> return (mod, msgs) + , parsedResultAction = \_ _ -> return , typeCheckResultAction = \_ _ -> return , spliceRunAction = \_ -> return , interfaceLoadAction = \_ -> return diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst index 3ccbf4c3ec..a77b6b451b 100644 --- a/docs/users_guide/9.4.1-notes.rst +++ b/docs/users_guide/9.4.1-notes.rst @@ -64,11 +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. +- ``GHC.Plugins.parsedResultAction`` now takes and returns a value of type + ``ParsedResult``, containing the ``HsParsedModule`` as well as ``PsMessages``, + which contains 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 diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst index 4a987bca87..b2b555c005 100644 --- a/docs/users_guide/extending_ghc.rst +++ b/docs/users_guide/extending_ghc.rst @@ -754,23 +754,24 @@ in the source code as well as the original syntax tree of the compiled module. :: - parsed :: [CommandLineOption] -> ModSummary -> HsParsedModule - -> (Messages PsWarning, Messages PsError) - -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError) + parsed :: [CommandLineOption] -> ModSummary + -> ParsedResult -> Hsc ParsedResult The ``ModSummary`` contains useful -meta-information about the compiled module. The ``HsParsedModule`` contains the -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. +meta-information about the compiled module. The ``ParsedResult`` contains a +``HsParsedModule``, which contains the 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 +``ParsedResult`` 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. +will be given to the plugin via the ``PsMessages`` value of the +``ParsedResult``. 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 messages unmodified. The parsing pass will fail if the +``Messages PsError`` collection inside the return ``ParsedResult`` is not empty +after all parsing plugins have been run. Type checked representation ^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -892,6 +893,7 @@ displayed. import GHC.Types.Avail import GHC.Utils.Outputable import GHC.Hs.Doc + import GHC plugin :: Plugin plugin = defaultPlugin @@ -902,15 +904,14 @@ displayed. , interfaceLoadAction = interfaceLoadPlugin } - parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule - -> (Messages PsWarning, Messages PsError) - -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError)) - parsedPlugin _ _ pm msgs@(warns, errs) + parsedPlugin :: [CommandLineOption] -> ModSummary + -> ParsedResult -> Hsc ParsedResult + parsedPlugin _ _ parsed@(ParsedResult pm msgs) = do dflags <- getDynFlags - liftIO $ putStrLn $ "parsePlugin: \n" ++ (showSDoc dflags $ ppr $ hpm_module pm) - liftIO $ putStrLn $ "parsePlugin warnings: \n" ++ (showSDoc dflags $ ppr warns) - liftIO $ putStrLn $ "parsePlugin errors: \n" ++ (showSDoc dflags $ ppr errs) - return (pm, msgs) + liftIO $ putStrLn $ "parsePlugin: \n" ++ (showSDoc dflags $ ppr $ hpm_module pm) + liftIO $ putStrLn $ "parsePlugin warnings: \n" ++ (showSDoc dflags $ ppr $ psWarnings msgs) + liftIO $ putStrLn $ "parsePlugin errors: \n" ++ (showSDoc dflags $ ppr $ psErrors msgs) + return parsed renamedAction :: [CommandLineOption] -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) renamedAction _ tc gr = do @@ -1320,10 +1321,10 @@ Defaulting plugins have a single access point in the `GHC.Tc.Types` module , deProposalCts :: [Ct] -- ^ The constraints against which defaults are checked. } - + type DefaultingPluginResult = [DefaultingProposal] type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult - + -- | A plugin for controlling defaulting. data DefaultingPlugin = forall s. DefaultingPlugin { dePluginInit :: TcPluginM s diff --git a/testsuite/tests/plugins/T20803-plugin/AddErrorPlugin.hs b/testsuite/tests/plugins/T20803-plugin/AddErrorPlugin.hs index e055204acf..74738a75f1 100644 --- a/testsuite/tests/plugins/T20803-plugin/AddErrorPlugin.hs +++ b/testsuite/tests/plugins/T20803-plugin/AddErrorPlugin.hs @@ -17,14 +17,13 @@ import System.IO plugin :: Plugin plugin = defaultPlugin {parsedResultAction = parsedAction} -parsedAction :: [CommandLineOption] -> ModSummary -> HsParsedModule - -> (Messages PsWarning, Messages PsError) - -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError)) -parsedAction _ _ pm (warns, _) = do +parsedAction :: [CommandLineOption] -> ModSummary + -> ParsedResult -> Hsc ParsedResult +parsedAction _ _ (ParsedResult pm msgs) = do liftIO $ putStrLn "parsePlugin" -- TODO: Remove #20791 liftIO $ hFlush stdout - pure (pm, (warns, mkMessages $ unitBag err)) + pure (ParsedResult pm msgs{psErrors = mkMessages $ unitBag err}) where err = MsgEnvelope { errMsgSpan = UnhelpfulSpan UnhelpfulNoLocationInfo diff --git a/testsuite/tests/plugins/T20803-plugin/FixErrorsPlugin.hs b/testsuite/tests/plugins/T20803-plugin/FixErrorsPlugin.hs index 1cf44edd8a..b8c761a82e 100644 --- a/testsuite/tests/plugins/T20803-plugin/FixErrorsPlugin.hs +++ b/testsuite/tests/plugins/T20803-plugin/FixErrorsPlugin.hs @@ -30,20 +30,19 @@ replaceHoles new = gmapT \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 +parsedAction :: [CommandLineOption] -> ModSummary + -> ParsedResult -> Hsc ParsedResult +parsedAction _ _ (ParsedResult (HsParsedModule lmod srcFiles) msgs) = do liftIO $ putStrLn "parsePlugin" liftIO $ putStrLn $ showPprUnsafe newModule -- TODO: Remove #20791 liftIO $ hFlush stdout - pure (HsParsedModule newModule srcFiles, (warns, otherErrs)) + pure (ParsedResult (HsParsedModule newModule srcFiles) msgs{psErrors = otherErrs}) where PsErrBangPatWithoutSpace (L _ holeExpr) = errMsgDiagnostic noSpaceBang (bagToList -> [noSpaceBang], mkMessages -> otherErrs) = - partitionBag (isNoSpaceBang . errMsgDiagnostic) . getMessages $ errs + partitionBag (isNoSpaceBang . errMsgDiagnostic) . getMessages $ psErrors msgs isNoSpaceBang (PsErrBangPatWithoutSpace _) = True isNoSpaceBang _ = False diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index 8cb2d87c85..24ed240cfc 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -27,12 +27,11 @@ plugin = defaultPlugin { parsedResultAction = parsedPlugin , interfaceLoadAction = interfaceLoadPlugin' } -parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule - -> (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) +parsedPlugin :: [CommandLineOption] -> ModSummary + -> ParsedResult -> Hsc ParsedResult +parsedPlugin [name, "parse"] _ (ParsedResult pm msgs) + = return (ParsedResult pm { hpm_module = removeParsedBinding name (hpm_module pm) } msgs) +parsedPlugin _ _ parsed = return parsed 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 172a052817..e918b02cc9 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs @@ -25,14 +25,13 @@ plugin = defaultPlugin { parsedResultAction = parsedPlugin , renamedResultAction = renamedAction } -parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule - -> (Messages PsWarning, Messages PsError) - -> Hsc (HsParsedModule, (Messages PsWarning, Messages PsError)) -parsedPlugin opts _ pm msgs +parsedPlugin :: [CommandLineOption] -> ModSummary + -> ParsedResult -> Hsc ParsedResult +parsedPlugin opts _ parsed = do liftIO $ putStrLn $ "parsePlugin(" ++ intercalate "," opts ++ ")" -- TODO: Remove #20791 liftIO $ hFlush stdout - return (pm, msgs) + return parsed renamedAction :: [CommandLineOption] -> TcGblEnv -> HsGroup GhcRn |