Commit c2783ccf authored by lazac's avatar lazac Committed by Ben Gamari
Browse files

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
parent 72725668
...@@ -77,6 +77,7 @@ import Hooks ...@@ -77,6 +77,7 @@ import Hooks
import FieldLabel import FieldLabel
import RnModIface import RnModIface
import UniqDSet import UniqDSet
import Plugins
import Control.Monad import Control.Monad
import Control.Exception import Control.Exception
...@@ -510,7 +511,9 @@ loadInterface doc_str mod from ...@@ -510,7 +511,9 @@ loadInterface doc_str mod from
(length new_eps_insts) (length new_eps_insts)
(length new_eps_rules) } (length new_eps_rules) }
; return (Succeeded final_iface) ; -- invoke plugins
res <- withPlugins dflags interfaceLoadAction final_iface
; return (Succeeded res)
}}}} }}}}
......
...@@ -85,6 +85,7 @@ module HscMain ...@@ -85,6 +85,7 @@ module HscMain
import GhcPrelude import GhcPrelude
import Data.Data hiding (Fixity, TyCon) import Data.Data hiding (Fixity, TyCon)
import Data.Maybe ( isJust, fromMaybe )
import DynFlags (addPluginModuleName) import DynFlags (addPluginModuleName)
import Id import Id
import GHCi ( addSptEntry ) import GHCi ( addSptEntry )
...@@ -142,6 +143,8 @@ import Fingerprint ( Fingerprint ) ...@@ -142,6 +143,8 @@ import Fingerprint ( Fingerprint )
import Hooks import Hooks
import TcEnv import TcEnv
import PrelNames import PrelNames
import Plugins
import DynamicLoading ( initializePlugins )
import DynFlags import DynFlags
import ErrUtils import ErrUtils
...@@ -169,7 +172,6 @@ import System.IO (fixIO) ...@@ -169,7 +172,6 @@ import System.IO (fixIO)
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as S import qualified Data.Set as S
import Data.Set (Set) import Data.Set (Set)
import DynamicLoading (initializePlugins)
#include "HsVersions.h" #include "HsVersions.h"
...@@ -375,7 +377,7 @@ hscParse' mod_summary ...@@ -375,7 +377,7 @@ hscParse' mod_summary
-- filter them out: -- filter them out:
srcs2 <- liftIO $ filterM doesFileExist srcs1 srcs2 <- liftIO $ filterM doesFileExist srcs1
return HsParsedModule { let res = HsParsedModule {
hpm_module = rdr_module, hpm_module = rdr_module,
hpm_src_files = srcs2, hpm_src_files = srcs2,
hpm_annotations hpm_annotations
...@@ -384,6 +386,11 @@ hscParse' mod_summary ...@@ -384,6 +386,11 @@ hscParse' mod_summary
:(annotations_comments pst))) :(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 -- 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 -- can become a Nothing and decide whether this should instead throw an
-- exception/signal an error. -- exception/signal an error.
...@@ -395,13 +402,7 @@ type RenamedStuff = ...@@ -395,13 +402,7 @@ type RenamedStuff =
-- | If the renamed source has been kept, extract it. Dump it if requested. -- | If the renamed source has been kept, extract it. Dump it if requested.
extract_renamed_stuff :: TcGblEnv -> Hsc (TcGblEnv, RenamedStuff) extract_renamed_stuff :: TcGblEnv -> Hsc (TcGblEnv, RenamedStuff)
extract_renamed_stuff tc_result = do extract_renamed_stuff tc_result = do
let rn_info = get_renamed_stuff tc_result
-- 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)
dflags <- getDynFlags dflags <- getDynFlags
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $ liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $
...@@ -409,15 +410,20 @@ extract_renamed_stuff tc_result = do ...@@ -409,15 +410,20 @@ extract_renamed_stuff tc_result = do
return (tc_result, rn_info) 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 -- | Rename and typecheck a module, additionally returning the renamed syntax
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff) -> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
tc_result <- hscTypecheck True mod_summary (Just rdr_module) tc_result <- hscTypecheck True mod_summary (Just rdr_module)
extract_renamed_stuff tc_result extract_renamed_stuff tc_result
hscTypecheck :: Bool -- ^ Keep renamed source? hscTypecheck :: Bool -- ^ Keep renamed source?
-> ModSummary -> Maybe HsParsedModule -> ModSummary -> Maybe HsParsedModule
...@@ -460,39 +466,65 @@ tcRnModule' :: ModSummary -> Bool -> HsParsedModule ...@@ -460,39 +466,65 @@ tcRnModule' :: ModSummary -> Bool -> HsParsedModule
-> Hsc TcGblEnv -> Hsc TcGblEnv
tcRnModule' sum save_rn_syntax mod = do tcRnModule' sum save_rn_syntax mod = do
hsc_env <- getHscEnv 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" #-} tcg_res <- {-# SCC "Typecheck-Rename" #-}
ioMsgMaybe $ 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] -- See Note [Safe Haskell Overlapping Instances Implementation]
-- although this is used for more than just that failure case. -- although this is used for more than just that failure case.
(tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res) (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
dflags <- getDynFlags
let allSafeOK = safeInferred dflags && tcSafeOK let allSafeOK = safeInferred dflags && tcSafeOK
-- end of the safe haskell line, how to respond to user? -- end of the safe haskell line, how to respond to user?
if not (safeHaskellOn dflags) || (safeInferOn dflags && not allSafeOK) res <- if not (safeHaskellOn dflags)
-- if safe Haskell off or safe infer failed, mark unsafe || (safeInferOn dflags && not allSafeOK)
then markUnsafeInfer tcg_res whyUnsafe -- 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 -- module (could be) safe, throw warning if needed
tcg_res' <- hscCheckSafeImports tcg_res else do
safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res') tcg_res' <- hscCheckSafeImports tcg_res
when safe $ do safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
case wopt Opt_WarnSafe dflags of when safe $ do
True -> (logWarnings $ unitBag $ case wopt Opt_WarnSafe dflags of
makeIntoWarning (Reason Opt_WarnSafe) $ True -> (logWarnings $ unitBag $
mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ makeIntoWarning (Reason Opt_WarnSafe) $
errSafe tcg_res') mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
False | safeHaskell dflags == Sf_Trustworthy && errSafe tcg_res')
wopt Opt_WarnTrustworthySafe dflags -> False | safeHaskell dflags == Sf_Trustworthy &&
(logWarnings $ unitBag $ wopt Opt_WarnTrustworthySafe dflags ->
makeIntoWarning (Reason Opt_WarnTrustworthySafe) $ (logWarnings $ unitBag $
mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $ makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
errTwthySafe tcg_res') mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
False -> return () errTwthySafe tcg_res')
return 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 where
pprMod t = ppr $ moduleName $ tcg_mod t pprMod t = ppr $ moduleName $ tcg_mod t
errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!" errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
......
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Plugins ( module Plugins (
FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction, FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction
Plugin(..), CommandLineOption, LoadedPlugin(..), lpModuleName, , Plugin(..), CommandLineOption, LoadedPlugin(..), lpModuleName
defaultPlugin, withPlugins, withPlugins_ , defaultPlugin, withPlugins, withPlugins_
, PluginRecompile(..) , PluginRecompile(..)
, purePlugin, impurePlugin, flagRecompile , purePlugin, impurePlugin, flagRecompile
) where ) where
import GhcPrelude import GhcPrelude
import CoreMonad ( CoreToDo, CoreM ) import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM )
import qualified TcRnTypes (TcPlugin) import qualified TcRnTypes
import TcRnTypes ( TcGblEnv, IfM, TcM )
import HsSyn
import DynFlags import DynFlags
import HscTypes
import GhcMonad import GhcMonad
import DriverPhases import DriverPhases
import Module ( ModuleName, Module(moduleName)) import Module ( ModuleName, Module(moduleName))
import Avail
import Fingerprint import Fingerprint
import Data.List import Data.List
import Outputable (Outputable(..), text, (<+>)) import Outputable (Outputable(..), text, (<+>))
...@@ -50,14 +54,55 @@ data Plugin = Plugin { ...@@ -50,14 +54,55 @@ data Plugin = Plugin {
-- behaviour of the constraint solver. -- behaviour of the constraint solver.
, pluginRecompile :: [CommandLineOption] -> IO PluginRecompile , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
-- ^ Specify how the plugin should affect recompilation. -- ^ 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. -- | A plugin with its arguments. The result of loading the plugin.
data LoadedPlugin = LoadedPlugin { data LoadedPlugin = LoadedPlugin {
lpPlugin :: Plugin lpPlugin :: Plugin
-- ^ the actual callable plugin -- ^ the actual callable plugin
, lpModule :: Module , lpModule :: Module
-- ^ The module the plugin is defined in -- ^ the module containing the plugin
, lpArguments :: [CommandLineOption] , lpArguments :: [CommandLineOption]
-- ^ command line arguments for the plugin -- ^ command line arguments for the plugin
} }
...@@ -101,14 +146,22 @@ flagRecompile = ...@@ -101,14 +146,22 @@ flagRecompile =
-- you should base all your plugin definitions on this default value. -- you should base all your plugin definitions on this default value.
defaultPlugin :: Plugin defaultPlugin :: Plugin
defaultPlugin = Plugin { defaultPlugin = Plugin {
installCoreToDos = const return installCoreToDos = const return
, tcPlugin = const Nothing , tcPlugin = const Nothing
, pluginRecompile = impurePlugin , pluginRecompile = impurePlugin
, renamedResultAction = Nothing
, parsedResultAction = \_ _ -> return
, typeCheckResultAction = \_ _ -> return
, spliceRunAction = \_ -> return
, interfaceLoadAction = \_ -> return
} }
type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a
type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m () 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. -- | Perform an operation by using all of the plugins in turn.
withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a
withPlugins df transformation input withPlugins df transformation input
......
-- 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
...@@ -112,6 +112,7 @@ import DynFlags ...@@ -112,6 +112,7 @@ import DynFlags
import Panic import Panic
import Lexeme import Lexeme
import qualified EnumSet import qualified EnumSet
import Plugins
import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types -- THSyntax gives access to internal functions and data types
...@@ -735,10 +736,13 @@ runMeta' show_code ppr_hs run_and_convert expr ...@@ -735,10 +736,13 @@ runMeta' show_code ppr_hs run_and_convert expr
-- in type-correct programs. -- in type-correct programs.
; failIfErrsM ; failIfErrsM
-- run plugins
; hsc_env <- getTopEnv
; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr
-- Desugar -- Desugar
; ds_expr <- initDsTc (dsLExpr expr) ; ds_expr <- initDsTc (dsLExpr expr')
-- Compile and link it; might fail if linking fails -- Compile and link it; might fail if linking fails
; hsc_env <- getTopEnv
; src_span <- getSrcSpanM ; src_span <- getSrcSpanM
; traceTc "About to run (desugared)" (ppr ds_expr) ; traceTc "About to run (desugared)" (ppr ds_expr)
; either_hval <- tryM $ liftIO $ ; either_hval <- tryM $ liftIO $
......
...@@ -600,6 +600,209 @@ the plugin to create equality axioms for use in evidence terms, but GHC ...@@ -600,6 +600,209 @@ the plugin to create equality axioms for use in evidence terms, but GHC
does not check their consistency, and inconsistent axiom sets may lead does not check their consistency, and inconsistent axiom sets may lead
to segfaults or other runtime misbehaviour. to segfaults or other runtime misbehaviour.
.. _source-plugins:
Source plugins
~~~~~~~~~~~~~~
In additional to core and type checker plugins, you can install plugins that can
access different representations of the source code. The main purpose of these
plugins is to make it easier to implement development tools.
There are several different access points that you can use for defining plugins
that access the representations. All these fields receive the list of
``CommandLineOption`` strings that are passed to the compiler using the
``-fplugin-opt`` flags.
::
plugin :: Plugin
plugin = defaultPlugin {
parsedResultAction = parsed
, typeCheckResultAction = typechecked
, spliceRunAction = spliceRun
, interfaceLoadAction = interfaceLoad
, renamedResultAction = renamed
}
Parsed representation
^^^^^^^^^^^^^^^^^^^^^
When you want to define a plugin that uses the syntax tree of the source code,
you would like to override the ``parsedResultAction`` field. This access point
enables you to get access to information about the lexical tokens and comments
in the source code as well as the original syntax tree of the compiled module.
::
parsed :: [CommandLineOption] -> ModSummary -> HsParsedModule
-> Hsc HsParsedModule
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.
Type checked representation
^^^^^^^^^^^^^^^^^^^^^^^^^^^
When you want to define a plugin that needs semantic information about the
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``
::
typechecked :: [CommandLineOption] -> ModSummary -> TcGblEnv -> Hsc 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
syntax tree (for example, imports) are not found in the typechecked one.
The ``renamedResultAction`` is set to ``Nothing`` by default.
::
rename :: Maybe ([CommandLineOption] -> ModSummary -> Hsc ())
Evaluated code
^^^^^^^^^^^^^^
When the compiler type checks the source code, :ref:`template-haskell` Splices
and :ref:`th-quasiquotation` will be replaced by the syntax tree fragments
generated from them. However for tools that operate on the source code the
code generator is usually more interesting than the generated code. For this
reason we included ``spliceRunAction``. This field is invoked on each expression
before they are evaluated. The input is type checked, so semantic information is
available for these syntax tree fragments. If you return a different expression
you can change the code that is generated.
::
spliceRun :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
However take care that the generated definitions are still in the input of
``typeCheckResultAction``. If your don't take care to filter the typechecked
input, the behavior of your tool might be inconsistent.
Interface files
^^^^^^^^^^^^^^^
Sometimes when you are writing a tool, knowing the source code is not enough,
you also have to know details about the modules that you import. In this case we
suggest using the ``interfaceLoadAction``. This will be called each time when
the code of an already compiled module is loaded. It will be invoked for modules
from installed packages and even modules that are installed with GHC. It will
NOT be invoked with your own modules.
::
interfaceLoad :: forall lcl . [CommandLineOption] -> ModIface
-> IfM lcl ModIface
In the ``ModIface`` datatype you can find lots of useful information, including
the exported definitions and type class instances.
Source plugin example
^^^^^^^^^^^^^^^^^^^^^
In this example, we inspect all available details of the compiled source code.
We don't change any of the representation, but write out the details to the
standard output. The pretty printed representation of the parsed, renamed and
type checked syntax tree will be in the output as well as the evaluated splices
and quasi quotes. The name of the interfaces that are loaded will also be
displayed.
::
module SourcePlugin where
import Control.Monad.IO.Class
import Plugins
import HscTypes
import TcRnTypes
import HsExtension
import HsExpr
import Outputable
import HsDoc
plugin :: Plugin
plugin = defaultPlugin { parsedResultAction = parsedPlugin
, renamedResultAction = Just renamedAction
, typeCheckResultAction = typecheckPlugin
, spliceRunAction = metaPlugin
, interfaceLoadAction = interfaceLoadPlugin
}