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

7 files changed, 64 insertions, 53 deletions

diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index cf8e911369..a8a33bfaad 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -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.
diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs
index 0ad46bdb99..0e2ab32015 100644
--- a/compiler/main/Plugins.hs
+++ b/compiler/main/Plugins.hs
@@ -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
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index b073b50353..1cc3ef33dd 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -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) )
diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst
index 3cceead1f4..5b1a6cc93b 100644
--- a/docs/users_guide/extending_ghc.rst
+++ b/docs/users_guide/extending_ghc.rst
@@ -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
diff --git a/testsuite/tests/plugins/plugins09.stdout b/testsuite/tests/plugins/plugins09.stdout
index 5e212f3e2f..885850e598 100644
--- a/testsuite/tests/plugins/plugins09.stdout
+++ b/testsuite/tests/plugins/plugins09.stdout
@@ -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
diff --git a/testsuite/tests/plugins/plugins11.stdout b/testsuite/tests/plugins/plugins11.stdout
index ff31aa3c8c..8e0dca4335 100644
--- a/testsuite/tests/plugins/plugins11.stdout
+++ b/testsuite/tests/plugins/plugins11.stdout
@@ -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
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs
index 85fc870604..b9bdaeb37a 100644
--- a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs
+++ b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs
@@ -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