Extended the plugin system to run plugins on more representations

Extend GHC plugins to access parsed, type checked representation,
interfaces that are loaded. And splices that are evaluated. The goal is
to enable development tools to access the GHC representation in the
pre-existing build environment.

See the full proposal here:
https://ghc.haskell.org/trac/ghc/wiki/ExtendedPluginsProposal

Reviewers: goldfire, bgamari, ezyang, angerman, mpickering

Reviewed By: mpickering

Subscribers: ezyang, angerman, mpickering, ulysses4ever, rwbarton, thomie, carter

GHC Trac Issues: #14709

Differential Revision: https://phabricator.haskell.org/D4342

5 files changed, 176 insertions, 47 deletions

diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 02e7d50969..cc4a4241d5 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -77,6 +77,7 @@ import Hooks
 import FieldLabel
 import RnModIface
 import UniqDSet
+import Plugins
 
 import Control.Monad
 import Control.Exception
@@ -510,7 +511,9 @@ loadInterface doc_str mod from
                                                    (length new_eps_insts)
                                                    (length new_eps_rules) }
 
-        ; return (Succeeded final_iface)
+        ; -- invoke plugins
+          res <- withPlugins dflags interfaceLoadAction final_iface
+        ; return (Succeeded res)
     }}}}
 
 
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 21224ebc45..516cf0e586 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -85,6 +85,7 @@ module HscMain
 import GhcPrelude
 
 import Data.Data hiding (Fixity, TyCon)
+import Data.Maybe       ( isJust, fromMaybe )
 import DynFlags         (addPluginModuleName)
 import Id
 import GHCi             ( addSptEntry )
@@ -142,6 +143,8 @@ import Fingerprint      ( Fingerprint )
 import Hooks
 import TcEnv
 import PrelNames
+import Plugins
+import DynamicLoading   ( initializePlugins )
 
 import DynFlags
 import ErrUtils
@@ -169,7 +172,6 @@ import System.IO (fixIO)
 import qualified Data.Map as Map
 import qualified Data.Set as S
 import Data.Set (Set)
-import DynamicLoading (initializePlugins)
 
 #include "HsVersions.h"
 
@@ -375,7 +377,7 @@ hscParse' mod_summary
             -- filter them out:
             srcs2 <- liftIO $ filterM doesFileExist srcs1
 
-            return HsParsedModule {
+            let res = HsParsedModule {
                       hpm_module    = rdr_module,
                       hpm_src_files = srcs2,
                       hpm_annotations
@@ -384,6 +386,11 @@ hscParse' mod_summary
                                                  :(annotations_comments pst)))
                    }
 
+            -- apply parse transformation of plugins
+            let applyPluginAction p opts
+                  = parsedResultAction p opts mod_summary
+            withPlugins dflags applyPluginAction res
+
 -- 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
 -- exception/signal an error.
@@ -395,13 +402,7 @@ type RenamedStuff =
 -- | If the renamed source has been kept, extract it. Dump it if requested.
 extract_renamed_stuff :: TcGblEnv -> Hsc (TcGblEnv, RenamedStuff)
 extract_renamed_stuff tc_result = do
-
-    -- This 'do' is in the Maybe monad!
-    let rn_info = do decl <- tcg_rn_decls tc_result
-                     let imports = tcg_rn_imports tc_result
-                         exports = tcg_rn_exports tc_result
-                         doc_hdr = tcg_doc_hdr tc_result
-                     return (decl,imports,exports,doc_hdr)
+    let rn_info = get_renamed_stuff tc_result
 
     dflags <- getDynFlags
     liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $
@@ -409,15 +410,20 @@ extract_renamed_stuff tc_result = do
 
     return (tc_result, rn_info)
 
+-- | Extract the renamed information from TcGblEnv.
+get_renamed_stuff :: TcGblEnv -> RenamedStuff
+get_renamed_stuff tc_result
+  = fmap (\decls -> ( decls, tcg_rn_imports tc_result
+                    , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )
+         (tcg_rn_decls tc_result)
 
 -- -----------------------------------------------------------------------------
 -- | Rename and typecheck a module, additionally returning the renamed syntax
 hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
                    -> IO (TcGblEnv, RenamedStuff)
 hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
-    tc_result <- hscTypecheck True mod_summary (Just rdr_module)
-    extract_renamed_stuff tc_result
-
+      tc_result <- hscTypecheck True mod_summary (Just rdr_module)
+      extract_renamed_stuff tc_result
 
 hscTypecheck :: Bool -- ^ Keep renamed source?
              -> ModSummary -> Maybe HsParsedModule
@@ -460,39 +466,65 @@ tcRnModule' :: ModSummary -> Bool -> HsParsedModule
             -> Hsc TcGblEnv
 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 (ms_hsc_src sum) save_rn_syntax mod
+                   tcRnModule hsc_env (ms_hsc_src sum)
+                     (save_rn_syntax || plugin_needs_rn) mod
 
     -- See Note [Safe Haskell Overlapping Instances Implementation]
     -- although this is used for more than just that failure case.
     (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
-    dflags   <- getDynFlags
     let allSafeOK = safeInferred dflags && tcSafeOK
 
     -- end of the safe haskell line, how to respond to user?
-    if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK)
-        -- if safe Haskell off or safe infer failed, mark unsafe
-        then markUnsafeInfer tcg_res whyUnsafe
-
-        -- module (could be) safe, throw warning if needed
-        else do
-            tcg_res' <- hscCheckSafeImports tcg_res
-            safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
-            when safe $ do
-              case wopt Opt_WarnSafe dflags of
-                True -> (logWarnings $ unitBag $
-                         makeIntoWarning (Reason Opt_WarnSafe) $
-                         mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
-                         errSafe tcg_res')
-                False | safeHaskell dflags == Sf_Trustworthy &&
-                        wopt Opt_WarnTrustworthySafe dflags ->
-                        (logWarnings $ unitBag $
-                         makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
-                         mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
-                         errTwthySafe tcg_res')
-                False -> return ()
-            return tcg_res'
+    res <- if not (safeHaskellOn dflags)
+                || (safeInferOn dflags && not allSafeOK)
+             -- if safe Haskell off or safe infer failed, mark unsafe
+             then markUnsafeInfer tcg_res whyUnsafe
+
+             -- module (could be) safe, throw warning if needed
+             else do
+                 tcg_res' <- hscCheckSafeImports tcg_res
+                 safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
+                 when safe $ do
+                   case wopt Opt_WarnSafe dflags of
+                     True -> (logWarnings $ unitBag $
+                              makeIntoWarning (Reason Opt_WarnSafe) $
+                              mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
+                              errSafe tcg_res')
+                     False | safeHaskell dflags == Sf_Trustworthy &&
+                             wopt Opt_WarnTrustworthySafe dflags ->
+                             (logWarnings $ unitBag $
+                              makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
+                              mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
+                              errTwthySafe tcg_res')
+                     False -> return ()
+                 return tcg_res'
+
+    -- apply plugins to the type checking result
+    let unsafeText = "Use of plugins makes the module unsafe"
+        pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan
+                                   (Outputable.text unsafeText) )
+
+    case get_renamed_stuff res of
+      Just rn ->
+        withPlugins_ dflags
+                     (\p opts -> (fromMaybe (\_ _ _ -> return ())
+                                            (renamedResultAction p)) opts sum)
+                     rn
+      Nothing -> return ()
+
+    res' <- withPlugins dflags
+                        (\p opts -> typeCheckResultAction p opts sum
+                                      >=> flip markUnsafeInfer pluginUnsafe)
+                        res
+    return res'
   where
     pprMod t  = ppr $ moduleName $ tcg_mod t
     errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs
index 85c5d07882..34f3298b0d 100644
--- a/compiler/main/Plugins.hs
+++ b/compiler/main/Plugins.hs
@@ -1,21 +1,25 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE CPP #-}
 module Plugins (
-    FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction,
-    Plugin(..), CommandLineOption, LoadedPlugin(..), lpModuleName,
-    defaultPlugin, withPlugins, withPlugins_
+      FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction
+    , Plugin(..), CommandLineOption, LoadedPlugin(..), lpModuleName
+    , defaultPlugin, withPlugins, withPlugins_
     , PluginRecompile(..)
     , purePlugin, impurePlugin, flagRecompile
     ) where
 
 import GhcPrelude
 
-import CoreMonad ( CoreToDo, CoreM )
-import qualified TcRnTypes (TcPlugin)
+import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM )
+import qualified TcRnTypes
+import TcRnTypes ( TcGblEnv, IfM, TcM )
+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, (<+>))
@@ -50,14 +54,55 @@ data Plugin = Plugin {
     -- behaviour of the constraint solver.
   , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
     -- ^ Specify how the plugin should affect recompilation.
+  , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule
+                            -> Hsc HsParsedModule
+    -- ^ Modify the module when it is parsed. This is called by
+    -- HscMain when the parsing is successful.
+  , renamedResultAction :: Maybe ([CommandLineOption] -> ModSummary
+                                    -> RenamedSource -> Hsc ())
+    -- ^ Installs a read-only pass that receives the renamed syntax tree as an
+    -- argument when type checking is successful.
+  , typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv
+                               -> Hsc TcGblEnv
+    -- ^ Modify the module when it is type checked. This is called by
+    -- HscMain when the type checking is successful.
+  , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc
+                         -> TcM (LHsExpr GhcTc)
+    -- ^ Modify the TH splice or quasiqoute before it is run.
+  , interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface
+                                          -> IfM lcl ModIface
+    -- ^ Modify an interface that have been loaded. This is called by
+    -- LoadIface when an interface is successfully loaded. Not applied to
+    -- the loading of the plugin interface. Tools that rely on information from
+    -- modules other than the currently compiled one should implement this
+    -- function.
   }
 
+-- Note [Source plugins]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- 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),
+-- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`.
+--
+-- The main purpose of these plugins is to help tool developers. They allow
+-- development tools to extract the information about the source code of a big
+-- Haskell project during the normal build procedure. In this case the plugin
+-- acts as the tools access point to the compiler that can be controlled by
+-- compiler flags. This is important because the manipulation of compiler flags
+-- is supported by most build environment.
+--
+-- For the full discussion, check the full proposal at:
+-- https://ghc.haskell.org/trac/ghc/wiki/ExtendedPluginsProposal
+
+
 -- | A plugin with its arguments. The result of loading the plugin.
 data LoadedPlugin = LoadedPlugin {
     lpPlugin :: Plugin
     -- ^ the actual callable plugin
   , lpModule :: Module
-    -- ^ The module the plugin is defined in
+    -- ^ the module containing the plugin
   , lpArguments :: [CommandLineOption]
     -- ^ command line arguments for the plugin
   }
@@ -101,14 +146,22 @@ flagRecompile =
 -- you should base all your plugin definitions on this default value.
 defaultPlugin :: Plugin
 defaultPlugin = Plugin {
-        installCoreToDos = const return
-      , tcPlugin         = const Nothing
+        installCoreToDos      = const return
+      , tcPlugin              = const Nothing
       , pluginRecompile  = impurePlugin
+      , renamedResultAction   = Nothing
+      , parsedResultAction    = \_ _ -> return
+      , typeCheckResultAction = \_ _ -> return
+      , spliceRunAction       = \_ -> return
+      , interfaceLoadAction   = \_ -> return
     }
 
 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/simplCore/CoreMonad.hs-boot b/compiler/simplCore/CoreMonad.hs-boot
new file mode 100644
index 0000000000..206675e5e2
--- /dev/null
+++ b/compiler/simplCore/CoreMonad.hs-boot
@@ -0,0 +1,37 @@
+-- Created this hs-boot file to remove circular dependencies from the use of
+-- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core
+-- transformations.
+-- However CoreMonad does much more than defining these, and because Plugins are
+-- activated in various modules, the imports become circular. To solve this I
+-- extracted CoreToDo and CoreM into this file.
+-- I needed to write the whole definition of these types, otherwise it created
+-- a data-newtype conflict.
+
+module CoreMonad ( CoreToDo, CoreM ) where
+
+import GhcPrelude
+
+import IOEnv ( IOEnv )
+import UniqSupply ( UniqSupply )
+
+newtype CoreState = CoreState {
+        cs_uniq_supply :: UniqSupply
+}
+
+type CoreIOEnv = IOEnv CoreReader
+
+data CoreReader
+
+newtype CoreWriter = CoreWriter {
+        cw_simpl_count :: SimplCount
+}
+
+data SimplCount
+
+newtype CoreM a
+          = CoreM { unCoreM :: CoreState
+                                 -> CoreIOEnv (a, CoreState, CoreWriter) }
+
+instance Monad CoreM
+
+data CoreToDo
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 2738929aa5..5bef07f369 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -112,6 +112,7 @@ import DynFlags
 import Panic
 import Lexeme
 import qualified EnumSet
+import Plugins
 
 import qualified Language.Haskell.TH as TH
 -- THSyntax gives access to internal functions and data types
@@ -735,10 +736,13 @@ runMeta' show_code ppr_hs run_and_convert expr
         -- in type-correct programs.
         ; failIfErrsM
 
+        -- run plugins
+        ; hsc_env <- getTopEnv
+        ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr
+
         -- Desugar
-        ; ds_expr <- initDsTc (dsLExpr expr)
+        ; ds_expr <- initDsTc (dsLExpr expr')
         -- Compile and link it; might fail if linking fails
-        ; hsc_env <- getTopEnv
         ; src_span <- getSrcSpanM
         ; traceTc "About to run (desugared)" (ppr ds_expr)
         ; either_hval <- tryM $ liftIO $