Commit 1a79270c authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari

Run the renamed source plugin after each HsGroup

This allows modification of each `HsGroup` after it has been renamed.

The old behaviour of keeping the renamed source until later can be
recovered if desired by using the `keepRenamedSource` plugin but it
shouldn't really be necessary as it can be inspected in the `TcGblEnv`.

Reviewers: nboldi, bgamari, alpmestan

Reviewed By: nboldi, alpmestan

Subscribers: alpmestan, rwbarton, thomie, carter

GHC Trac Issues: #15315

Differential Revision: https://phabricator.haskell.org/D4947
parent 305da44c
......@@ -85,7 +85,6 @@ module HscMain
import GhcPrelude
import Data.Data hiding (Fixity, TyCon)
import Data.Maybe ( isJust )
import DynFlags (addPluginModuleName)
import Id
import GHCi ( addSptEntry )
......@@ -455,14 +454,10 @@ tcRnModule' sum save_rn_syntax mod = do
hsc_env <- getHscEnv
dflags <- getDynFlags
-- check if plugins need the renamed syntax
let plugin_needs_rn = any (isJust . renamedResultAction . lpPlugin)
(plugins dflags)
tcg_res <- {-# SCC "Typecheck-Rename" #-}
ioMsgMaybe $
tcRnModule hsc_env sum
(save_rn_syntax || plugin_needs_rn) mod
save_rn_syntax mod
-- See Note [Safe Haskell Overlapping Instances Implementation]
-- although this is used for more than just that failure case.
......
......@@ -3,7 +3,7 @@
module Plugins (
FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction
, Plugin(..), CommandLineOption, LoadedPlugin(..), lpModuleName
, defaultPlugin, withPlugins, withPlugins_
, defaultPlugin, keepRenamedSource, withPlugins, withPlugins_
, PluginRecompile(..)
, purePlugin, impurePlugin, flagRecompile
) where
......@@ -12,14 +12,13 @@ import GhcPrelude
import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM )
import qualified TcRnTypes
import TcRnTypes ( TcGblEnv, IfM, TcM )
import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports )
import HsSyn
import DynFlags
import HscTypes
import GhcMonad
import DriverPhases
import Module ( ModuleName, Module(moduleName))
import Avail
import Fingerprint
import Data.List
import Outputable (Outputable(..), text, (<+>))
......@@ -58,10 +57,10 @@ data Plugin = Plugin {
-> Hsc HsParsedModule
-- ^ Modify the module when it is parsed. This is called by
-- HscMain when the parsing is successful.
, renamedResultAction :: Maybe ([CommandLineOption] -> ModSummary
-> RenamedSource -> TcM ())
-- ^ Installs a read-only pass that receives the renamed syntax tree as an
-- argument when type checking is successful.
, renamedResultAction :: [CommandLineOption] -> TcGblEnv
-> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
-- ^ Modify each group after it is renamed. This is called after each
-- `HsGroup` has been renamed.
, typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv
-> TcM TcGblEnv
-- ^ Modify the module when it is type checked. This is called add the
......@@ -82,8 +81,7 @@ data Plugin = Plugin {
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- The `Plugin` datatype have been extended by fields that allow access to the
-- different inner representations that are generated during the compilation
-- process. These fields are `parsedResultAction`, `needsRenamedSyntax` (for
-- controlling when renamed representation is kept during typechecking),
-- process. These fields are `parsedResultAction`, `renamedResultAction`,
-- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`.
--
-- The main purpose of these plugins is to help tool developers. They allow
......@@ -149,19 +147,32 @@ defaultPlugin = Plugin {
installCoreToDos = const return
, tcPlugin = const Nothing
, pluginRecompile = impurePlugin
, renamedResultAction = Nothing
, renamedResultAction = \_ env grp -> return (env, grp)
, parsedResultAction = \_ _ -> return
, typeCheckResultAction = \_ _ -> return
, spliceRunAction = \_ -> return
, interfaceLoadAction = \_ -> return
}
-- | A renamer plugin which mades the renamed source available in
-- a typechecker plugin.
keepRenamedSource :: [CommandLineOption] -> TcGblEnv
-> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
keepRenamedSource _ gbl_env group =
return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env)
, tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group)
where
update_exports Nothing = Just []
update_exports m = m
update Nothing = Just emptyRnGroup
update m = m
type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a
type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m ()
type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn]
, Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString )
-- | Perform an operation by using all of the plugins in turn.
withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a
withPlugins df transformation input
......
......@@ -290,7 +290,6 @@ tcRnModuleTcRnM hsc_env mod_sum
-- add extra source files to tcg_dependent_files
addDependentFiles src_files ;
runRenamerPlugin mod_sum hsc_env tcg_env ;
tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env ;
-- Dump output and return
......@@ -1305,6 +1304,8 @@ rnTopSrcDecls group
traceRn "rn12" empty ;
(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
traceRn "rn13" empty ;
(tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ;
traceRn "rn13-plugin" empty ;
-- save the renamed syntax, if we want it
let { tcg_env'
......@@ -2756,16 +2757,15 @@ getTcPlugins :: DynFlags -> [TcPlugin]
getTcPlugins dflags = catMaybes $ map get_plugin (plugins dflags)
where get_plugin p = tcPlugin (lpPlugin p) (lpArguments p)
runRenamerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM ()
runRenamerPlugin mod_sum hsc_env gbl_env = do
let dflags = hsc_dflags hsc_env
case getRenamedStuff gbl_env of
Just rn ->
withPlugins_ dflags
(\p opts -> (fromMaybe (\_ _ _ -> return ())
(renamedResultAction p)) opts mod_sum)
rn
Nothing -> return ()
runRenamerPlugin :: TcGblEnv
-> HsGroup GhcRn
-> TcM (TcGblEnv, HsGroup GhcRn)
runRenamerPlugin gbl_env hs_group = do
dflags <- getDynFlags
withPlugins dflags
(\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g))
(gbl_env, hs_group)
-- XXX: should this really be a Maybe X? Check under which circumstances this
-- can become a Nothing and decide whether this should instead throw an
......@@ -2784,10 +2784,14 @@ getRenamedStuff tc_result
runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv
runTypecheckerPlugin sum hsc_env gbl_env = do
let dflags = hsc_dflags hsc_env
unsafeText = "Use of plugins makes the module unsafe"
pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan
(Outputable.text unsafeText) )
mark_unsafe = recordUnsafeInfer pluginUnsafe
withPlugins dflags
(\p opts env -> mark_unsafe >> typeCheckResultAction p opts sum env)
(\p opts env -> mark_plugin_unsafe dflags
>> typeCheckResultAction p opts sum env)
gbl_env
mark_plugin_unsafe :: DynFlags -> TcM ()
mark_plugin_unsafe dflags = recordUnsafeInfer pluginUnsafe
where
unsafeText = "Use of plugins makes the module unsafe"
pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan
(Outputable.text unsafeText) )
......@@ -652,21 +652,22 @@ source code, use the ``typeCheckResultAction`` field. For example, if your
plugin have to decide if two names are referencing the same definition or it has
to check the type of a function it is using semantic information. In this case
you need to access the renamed or type checked version of the syntax tree with
``typeCheckResultAction``
``typeCheckResultAction`` or ``renamedResultAction``.
::
typechecked :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
By overriding the ``renamedResultAction`` field with a ``Just`` function, you
can request the compiler to keep the renamed syntax tree and give it to your
processing function. This is important because some parts of the renamed
renamed :: [CommandLineOption] -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)
By overriding the ``renamedResultAction`` field we can modify each ``HsGroup``
after it has been renamed. A source file is seperated into groups depending on
the location of template haskell splices so the contents of these groups may
not be intuitive. In order to save the entire renamed AST for inspection
at the end of typechecking you can set ``renamedResultAction`` to ``keepRenamedSource``
which is provided by the ``Plugins`` module.
This is important because some parts of the renamed
syntax tree (for example, imports) are not found in the typechecked one.
The ``renamedResultAction`` is set to ``Nothing`` by default.
::
rename :: Maybe ([CommandLineOption] -> ModSummary -> TcM ())
Evaluated code
......
......@@ -2,8 +2,8 @@ parsePlugin(a,b)
interfacePlugin: Prelude
interfacePlugin: GHC.Float
interfacePlugin: GHC.Base
interfacePlugin: GHC.Types
typeCheckPlugin (rn)
interfacePlugin: GHC.Types
typeCheckPlugin (tc)
interfacePlugin: GHC.Integer.Type
interfacePlugin: GHC.Natural
......@@ -2,8 +2,8 @@ parsePlugin()
interfacePlugin: Prelude
interfacePlugin: GHC.Float
interfacePlugin: GHC.Base
interfacePlugin: GHC.Types
typeCheckPlugin (rn)
interfacePlugin: GHC.Types
typeCheckPlugin (tc)
interfacePlugin: GHC.Integer.Type
interfacePlugin: GHC.Natural
......@@ -19,7 +19,7 @@ plugin = defaultPlugin { parsedResultAction = parsedPlugin
, typeCheckResultAction = typecheckPlugin
, spliceRunAction = metaPlugin'
, interfaceLoadAction = interfaceLoadPlugin'
, renamedResultAction = Just renamedAction
, renamedResultAction = renamedAction
}
parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
......@@ -28,12 +28,12 @@ parsedPlugin opts _ pm
= do liftIO $ putStrLn $ "parsePlugin(" ++ intercalate "," opts ++ ")"
return pm
renamedAction :: [CommandLineOption] -> ModSummary
-> ( HsGroup GhcRn, [LImportDecl GhcRn]
, Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString )
-> TcM ()
renamedAction _ _ ( gr, _, _, _ )
= liftIO $ putStrLn "typeCheckPlugin (rn)"
renamedAction :: [CommandLineOption]
-> TcGblEnv -> HsGroup GhcRn
-> TcM (TcGblEnv, HsGroup GhcRn)
renamedAction _ env grp
= do liftIO $ putStrLn "typeCheckPlugin (rn)"
return (env, grp)
typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typecheckPlugin _ _ tc
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment